Friday, 30 November 2007

Solve Ball Clock Puzzle in Python and Haskell

Let's solve the Ball Clock puzzle. After reading the puzzle, I spend some time thinking about it. I quickly find that instead of running the full simulation until the clock returns to its original state, I can reuse the result of first 12 hour. What can we do to the first 12 hour result? We can build a table that tell which ball goes to which position after another 12 hour circle. Now we can run the simulation at 12 hour circle, more fast. But wait, can we do better? After some thinking, I finally find that actually We can find every ball's own circle (How many days does a ball return to its original position) and we get a list of circles. What's next? Right, find the Least Common Multiplier of all balls' circles. So here we have the Python version:

`def run_12h(balls): hour = [] five_min = []   min = []   for i in xrange(12*60):       ball, balls = balls[0], balls[1:]       if len(min) < 4:           min.append(ball)       else:           min.reverse()           balls.extend(min)           min = []           if len(five_min) < 11:               five_min.append(ball)           else:               five_min.reverse()               balls.extend(five_min)               five_min = []               if len(hour) < 11:                   hour.append(ball)               else:                   hour.reverse()                   balls.extend(hour)                   hour = []                   balls.append(ball)   return ballsdef shift_table(balls):   table = balls[:]   for i, ball in enumerate(balls):       table[ball] = i   return tabledef circle(table):   def lookup(i):       old = i       count = 1       while(table[old] != i):           count += 1           old = table[old]       return count   return map(lookup, range(len(table)))def gcd(x, y):   if y == 0:       return x   else:       return gcd(y, x % y)def lcm(x, y):   return x*y/gcd(x,y)def solve(n):   return reduce(lcm, circle(shift_table(run_12h(range(n)))))/2if __name__ == '__main__':   print map(solve, range(27, 128))`

It takes me about five minutes to hack the above Python code. As you may note, it is heavily influenced by the FP style. As a consequence, it gave me the correct answer the first time I run it:) I think the code is quite straight forward, So I just give some brief explanation. The run_12h function takes a ball clock and run it through 12 hour and then return the state. The shift_table function takes a state and builds a lookup table. (eg. The state tells us the 9th ball goes to 1 position, the 11th ball goes to 2 position, but what we really want is where does the 1st ball go, where does the 2nd ball go. It is just a reverse table of the state) The circle function takes a table and return a list of circles.

Now let's see my first Haskell program. I planed to translation the Python code to Haskell function by function. So let's start from the easy one.

`shiftTable :: [Int] -> Array Int IntshiftTable pattern = array (0, length pattern - 1) (zip pattern [0..])circle :: (Num t, Ix i) => i -> Array i i -> tcircle i table = snd \$ until ((i==) . (table!) . fst) ((table!) *** (+1)) (i, 1)`

Then comes the hardest part. The run_12h function. I spend about three hours trying to translate the Python function into Haskell and finally I gave up. It's too ugly:(. Then another two hours, I came up with the following code:

`data BC = BC {track::[Int], hour::[Int], fiveMin::[Int], min::[Int]} deriving ShowrunMinute :: BC -> BCrunMinute (BC track h fm min) = let newTrack = tail track                                   ball = head track in                               if length min < 4 then                                   BC newTrack h fm (ball:min)                               else adjustFiveMin (BC (newTrack ++ min) h fm []) balladjustHour :: BC -> Int -> BCadjustHour (BC t h _ _) ball = if length h < 11 then                                  BC t (ball:h) [] []                              else BC (t ++ h ++ [ball]) [] [] []adjustFiveMin :: BC -> Int -> BCadjustFiveMin (BC t h fm _) ball = if length fm < 11 then                                      BC t h (ball:fm) []                                  else adjustHour (BC (t ++ fm) h [] []) ballrun12Hour :: Int -> [Int]run12Hour n = track \$ foldr (\$) (BC [0..n-1] [] [] []) (replicate (12 * 60) runMinute)`

Although not quite beautiful, I can't find better ways. Any ideas?

OK, the final part, We almost succeed!

`solve :: Int -> Intsolve n = foldl1' lcm (map ((flip circle) . shiftTable . run12Hour \$ n) [0..n-1]) `div` 2`

That's it, but we are not at the end. Here comes a second question: If given a Ball Clock, can you tell at least how many minutes has passed? Think a moment. The solution is first run the clock to the nearest 12 hour, then use the result to find how many days have passed. Finally substract the minutes and you got the answer.

Until now, I realize that it's much easier to extend the Haskell version to solve the second question. I must say that I didn't intend to. (I even didn't know the second question when I wrote the program) It really really really is that Haskell force you think carefully at every step you solving the problem and makes it quite hard to write ugly code! Though learning Haskell does take some effort so as writing programs in Haskell, but now I'm quite convinced that "Learning Haskell at least makes you a better programmer in any other languages!".

Let's solve the second question then.

`circle' :: (Num t, Ix i) => i -> i -> Array i i -> tcircle' start stop table = snd \$ until ((stop==) . (table!) . fst) ((table!) *** (+1)) (start, 1)runTo12 :: BC -> (BC, Int)runTo12 bc = until (is12 . fst) (runMinute *** (+1)) (bc, 0) where   is12 (BC _ [] [] []) = True   is12 (BC _ _ _ _) = FalsehowManyMin :: BC -> InthowManyMin bc = let (target, min) = first (elems . shiftTable . track) \$ runTo12 bc                   table = shiftTable \$ run12Hour \$ length target in               (foldl1' lcm \$ map (\$table) \$ zipWith circle' [0..] target) * 12 * 60 - min`

As a plus, we can redefine circle and solve in a much simpler way:

`circle1 :: (Num t, Ix i) => i -> Array i i -> tcircle1 i table = circle' i i tablesolve1 :: Int -> Intsolve1 n = (howManyMin \$ BC [0..n-1] [] [] []) `div` (24 * 60)`

That's the end. I must tell that it takes me quite a bit time to write this, because I just start to blog and English is not my native. So, any feedback is greatly appreciated.

Logan Capaldo said...

If there was an untilM :: (Monad m) => (a -> m Bool) -> (a -> m a) -> a -> m a
function I would write circle like:

counting :: (Num n, MonadWriter (Sum n) m) => (a -> b) -> a -> m b

counting f a = tell (Sum 1) >> (return (f a))

circle :: (Num t, Ix i) => i -> Array i i -> t

circle i table = getSum . snd . runWriter \$ untilM (return . (i ==) . (table!))
(counting (table!)) i

Vineet said...

I tried to improve on the parts of the post you said you weren't so happy with. The biggest improvement I got was by using guards instead of if/then/else. Adding a Ball type helps make the function type signatures more meaningful, I think. I also used the field labels a bit more, but I don't think that really made as much of a difference in readibility as I'd hoped:

import Prelude hiding(min)
import Control.Arrow
import Data.List
import Array

type Ball = Int
data BC = BC {track, hour, fiveMin, min::[Ball]} deriving Show

runMinute :: BC -> BC
runMinute bc@(BC {track=(ball:rest), min=m})
| length m < 4 = bc {track=rest, min=(ball:m)}
| otherwise = adjustFiveMin (bc {track=(rest++m),min=[]}) ball

adjustHour :: BC -> Ball -> BC
| length h < 11 = bc {hour=(ball:h)}
| otherwise = bc {track=(t ++ h ++ [ball]), hour=[]}

adjustFiveMin :: BC -> Ball -> BC
adjustFiveMin bc@(BC {track = t, fiveMin = fm}) ball
| length fm < 11 = bc {fiveMin = (ball:fm)}
| otherwise = adjustHour bc {track = (t++fm), fiveMin=[]} ball

run12Hour :: Int -> [Ball]
run12Hour n = track \$ foldr1 (.) (replicate (12*60) runMinute) (BC [0..n-1] [] [] [])

I started playing around with making BC an instance of Enum, but without a predefined value for the total number of balls, it was pretty clumsy. I originally started out using an infinite track. It worked fine, but it didn't really turn out to be all that interesting.

numBalls = 27

bcToEnum :: Int -> BC
bcToEnum 0 = BC [0..numBalls] [] [] []
bcToEnum n = runMinute (bcToEnum (n-1))

bcFromEnum (BC t h fm m) = 60*(length h) + 5*(length fm) + length m

bcEnumFrom :: BC -> [BC]
bcEnumFrom = iterate runMinute

instance Enum BC where
succ = runMinute
toEnum = bcToEnum
enumFrom = bcEnumFrom

garfield said...

vineet, I'd use pattern matching and guard more often, thx.

logan capaldo, I'll play more with monad, or maybe learn some category theory...(actually I've read some, but my math is quite poor...)

very popular to u! ........................................