# Haskell Quiz/Happy Numbers/Solution Dolio

### From HaskellWiki

(Solution) |
m |
||

(6 intermediate revisions by 4 users not shown) | |||

Line 1: | Line 1: | ||

+ | [[Category:Haskell Quiz solutions|Happy Numbers]] |
||

+ | |||

The important thing to know is that there is only one eventual infinite cycle other than 1 => 1, namely: |
The important thing to know is that there is only one eventual infinite cycle other than 1 => 1, namely: |
||

Line 12: | Line 14: | ||

import Control.Arrow |
import Control.Arrow |
||

import Memoizing |
import Memoizing |
||

+ | import Data.Ord (comparing) |
||

square x = x * x |
square x = x * x |
||

− | |||

− | comparing f a b = compare (f a) (f b) |
||

digits = unfoldr mdiv |
digits = unfoldr mdiv |
||

Line 34: | Line 35: | ||

</haskell> |
</haskell> |
||

− | I arbitrarily picked 4 to terminate the unhappiness search. happy returns both the happy/unhappy status of the given number, and what order happiness it has (as defined on the rubyquiz page). happiest find the highest order happy number between 1 and n. |
+ | I arbitrarily picked 4 to terminate the unhappiness search. happy returns both the happy/unhappy status of the given number, and what order happiness it has (as defined on the rubyquiz page). happiest finds the highest order happy number between 1 and n. |

The rest is a fairly reusable (for this sort of problem) module for dynamic programming (influenced by the memoizing recursion article on the old wiki; the original mailing list post by Chris Okasaki that inspired it all is here: http://www.haskell.org//pipermail/haskell-cafe/2005-July/010714.html): |
The rest is a fairly reusable (for this sort of problem) module for dynamic programming (influenced by the memoizing recursion article on the old wiki; the original mailing list post by Chris Okasaki that inspired it all is here: http://www.haskell.org//pipermail/haskell-cafe/2005-July/010714.html): |
||

Line 73: | Line 74: | ||

memoized = flip lookup m |
memoized = flip lookup m |
||

− | -- little-endian Patricia trees |
+ | -- little-endian bit tries |

− | data Patricia v = Nil | Node v (Patricia v) (Patricia v) |
+ | data BTrie v = Nil | Node v (BTrie v) (BTrie v) |

build n m f = Node (f n) (build n m' f) (build (setBit n m) m' f) |
build n m f = Node (f n) (build n m' f) (build (setBit n m) m' f) |
||

where m' = m+1 |
where m' = m+1 |
||

− | lookupP k (Node v l r) |
+ | lookupBT k (Node v l r) |

| k == 0 = v |
| k == 0 = v |
||

− | | not m = lookupP d l |
+ | | not m = lookupBT d l |

− | | m = lookupP d r |
+ | | m = lookupBT d r |

where |
where |
||

d = shiftR k 1 |
d = shiftR k 1 |
||

m = testBit k 0 |
m = testBit k 0 |
||

− | -- Patricia trees can be defined as DPMaps for keys of type (Bits k) => k, |
+ | -- The bit tries can be defined as DPMaps for keys of type (Bits k) => k, |

-- however, I have defined them only for Int and Integer to save space |
-- however, I have defined them only for Int and Integer to save space |
||

-- (one has to declare them all individually, |
-- (one has to declare them all individually, |
||

-- |
-- |
||

− | -- Bits k => DPMap (Patricia v) k v |
+ | -- Bits k => DPMap (BTrie v) k v |

-- |
-- |
||

-- won't work) |
-- won't work) |
||

− | instance DPMap (Patricia v) Int v where |
+ | instance DPMap (BTrie v) Int v where |

fromFunction = build 0 0 |
fromFunction = build 0 0 |
||

− | lookup = lookupP |
+ | lookup = lookupBT |

-- DPMap instances for up to 4-tuples. In general, a map (k1,k2) -> v |
-- DPMap instances for up to 4-tuples. In general, a map (k1,k2) -> v |
||

-- is a map k1 -> (k2 -> v) and so on |
-- is a map k1 -> (k2 -> v) and so on |
||

− | instance DPMap (Patricia v) Integer v where |
+ | instance DPMap (BTrie v) Integer v where |

fromFunction = build 0 0 |
fromFunction = build 0 0 |
||

− | lookup = lookupP |
+ | lookup = lookupBT |

instance (DPMap m1 k1 m2, DPMap m2 k2 v) => DPMap m1 (k1,k2) v where |
instance (DPMap m1 k1 m2, DPMap m2 k2 v) => DPMap m1 (k1,k2) v where |
||

Line 123: | Line 124: | ||

lookup (i,j,k,l) = lookup l . lookup k . lookup j . lookup i |
lookup (i,j,k,l) = lookup l . lookup k . lookup j . lookup i |
||

</haskell> |
</haskell> |
||

+ | |||

+ | == See also == |
||

+ | |||

+ | * [[Memoization]] |

## Latest revision as of 18:53, 21 February 2010

The important thing to know is that there is only one eventual infinite cycle other than 1 => 1, namely:

- 4 => 16 => 37 => 58 => 89 => 145 => 42 => 20 => 4

Every positive integer is either happy, or eventually reaches that cycle, so one can arbitrarily choose one of those numbers to terminate a search and decide that a number is unhappy.

This is an easy job for memoizing/dynamic programming. The code specific to the problem looks like so:

module Main where import Data.List import Control.Arrow import Memoizing import Data.Ord (comparing) square x = x * x digits = unfoldr mdiv where mdiv 0 = Nothing mdiv n = Just (m, d) where (d, m) = divMod n 10 happy :: Integer -> (Bool, Integer) happy = dpm happy' where happy' f 1 = (True, -1) happy' f 4 = (False, -1) happy' f n = second (+1) . f . sum . map square . digits $ n happiest n = head . sortBy (flip . comparing $ snd . snd) . filter (fst . snd) . map (\n -> (n, happy n)) $ [1..n]

I arbitrarily picked 4 to terminate the unhappiness search. happy returns both the happy/unhappy status of the given number, and what order happiness it has (as defined on the rubyquiz page). happiest finds the highest order happy number between 1 and n.

The rest is a fairly reusable (for this sort of problem) module for dynamic programming (influenced by the memoizing recursion article on the old wiki; the original mailing list post by Chris Okasaki that inspired it all is here: http://www.haskell.org//pipermail/haskell-cafe/2005-July/010714.html):

{-# OPTIONS -fglasgow-exts -fallow-overlapping-instances #-} module Memoizing(dp, dpm) where import Data.Array import Data.Bits import Prelude hiding (lookup) tabulate :: (Ix a) => (a,a) -> (a -> b) -> Array a b tabulate bounds f = array bounds [(i,f i) | i <- range bounds] -- Array-based, bounded dynamic programming. dp will take an upper and lower -- bound, and memoize a function between those bounds dp :: (Ix a) => (a,a) -> ((a->b) -> a -> b) -> a -> b dp bounds f = (memo!) where memo = tabulate bounds (f (memo!)) -- A type class for a memoizing map -- m is the map type -- k is the key type -- v is the value type -- fromFunction should build up a (possibly infinite) map for all keys, where -- any key is mapped to the value of the function at that key. class DPMap m k v | k v -> m where fromFunction :: (k -> v) -> m lookup :: k -> m -> v -- dpm uses the above DPMap class to memoize functions with a potentially -- unbounded domain dpm :: (DPMap m k v) => ((k -> v) -> k -> v) -> k -> v dpm f = memoized where m = fromFunction (f memoized) memoized = flip lookup m -- little-endian bit tries data BTrie v = Nil | Node v (BTrie v) (BTrie v) build n m f = Node (f n) (build n m' f) (build (setBit n m) m' f) where m' = m+1 lookupBT k (Node v l r) | k == 0 = v | not m = lookupBT d l | m = lookupBT d r where d = shiftR k 1 m = testBit k 0 -- The bit tries can be defined as DPMaps for keys of type (Bits k) => k, -- however, I have defined them only for Int and Integer to save space -- (one has to declare them all individually, -- -- Bits k => DPMap (BTrie v) k v -- -- won't work) instance DPMap (BTrie v) Int v where fromFunction = build 0 0 lookup = lookupBT -- DPMap instances for up to 4-tuples. In general, a map (k1,k2) -> v -- is a map k1 -> (k2 -> v) and so on instance DPMap (BTrie v) Integer v where fromFunction = build 0 0 lookup = lookupBT instance (DPMap m1 k1 m2, DPMap m2 k2 v) => DPMap m1 (k1,k2) v where fromFunction f = fromFunction (\i -> fromFunction (\j -> f (i,j))) lookup (i,j) = lookup j . lookup i instance (DPMap m1 k1 m2, DPMap m2 k2 m3, DPMap m3 k3 v) => DPMap m1 (k1,k2,k3) v where fromFunction f = fromFunction (\i -> fromFunction (\j -> fromFunction (\k -> f (i,j,k)))) lookup (i,j,k) = lookup k . lookup j . lookup i instance (DPMap m1 k1 m2, DPMap m2 k2 m3, DPMap m3 k3 m4, DPMap m4 k4 v) => DPMap m1 (k1,k2,k3,k4) v where fromFunction f = fromFunction (\i -> fromFunction (\j -> fromFunction (\k -> fromFunction (\l -> f (i,j,k,l))))) lookup (i,j,k,l) = lookup l . lookup k . lookup j . lookup i