Difference between revisions of "Haskell Quiz/Happy Numbers/Solution Dolio"
m (category) 
m 

(5 intermediate revisions by 4 users not shown)  
Line 1:  Line 1:  
−  [[Category: 
+  [[Category:Haskell Quiz solutionsHappy 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 14:  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 36:  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 
+  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/haskellcafe/2005July/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/haskellcafe/2005July/010714.html): 

Line 75:  Line 74:  
memoized = flip lookup m 
memoized = flip lookup m 

−   littleendian 
+   littleendian bit tries 
−  data 
+  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 

−  +  lookupBT k (Node v l r) 

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

−   not m = 
+   not m = lookupBT d l 
−   m = 
+   m = lookupBT d r 
where 
where 

d = shiftR k 1 
d = shiftR k 1 

m = testBit k 0 
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 
 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 ( 
+   Bits k => DPMap (BTrie v) k v 
 
 

 won't work) 
 won't work) 

−  instance DPMap ( 
+  instance DPMap (BTrie v) Int v where 
fromFunction = build 0 0 
fromFunction = build 0 0 

−  lookup = 
+  lookup = lookupBT 
 DPMap instances for up to 4tuples. In general, a map (k1,k2) > v 
 DPMap instances for up to 4tuples. 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 ( 
+  instance DPMap (BTrie v) Integer v where 
fromFunction = build 0 0 
fromFunction = build 0 0 

−  lookup = 
+  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 125:  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/haskellcafe/2005July/010714.html):
{# OPTIONS fglasgowexts fallowoverlappinginstances #}
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]
 Arraybased, 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
 littleendian 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 4tuples. 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