The Little Haskeller

Haskell Scheme Python -Be a programmer for a lifetime

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 = []
if len(five_min) < 11:
five_min = []
if len(hour) < 11:
hour = []
return balls

def shift_table(balls):
table = balls[:]
for i, ball in enumerate(balls):
table[ball] = i
return table

def 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
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)))))/2

if __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 Int
shiftTable pattern = array (0, length pattern - 1) (zip pattern [0..])

circle :: (Num t, Ix i) => i -> Array i i -> t
circle i table = snd $ until ((i==) . (table!) . fst) ((table!) *** (+1)) (i, 1)

The circle function deserves some notes. At first, I wrote it using recursion. Then I find that the control structure is much the same as the buildin until function. But what I really want is how many times the function applies. After a day's thinking, I find that I can use a pair. And at first I wrote the function as a lambda: \(i, n) -> (table ! i, n + 1). It has two problems: too long and not point free. As usual, I put pl \(i, n) -> (table ! i, n + 1) to lambdabot and expect some interesting result. The little cute bot never let me down: (table !) *** (1 +). But the result make me both happy and sad. Happy for it was beautiful and a little shorter and sad for it use Arrow! Oh, my god! I met Arrow when I read about Functional Reactive Programming, but I didn't quite understand it at that time. The only thing I knew is that Arrow is a more generalized computation model than monad. As I even don't quite understand monad, so... But I say to my self, it's time to try again. After some googling, I encounter Playing with Arrows. It is about using Arrow in pure code. After reading this, I know that actually the -> is made an instance of Arrow (Why not? at least the it looks like:), so every function in Haskell is an arrow. And finally I understand why Arrow is a generalized monad, because it can combine computation in a nonlinear way! So I learned a lot on the way:)

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 Show

runMinute :: BC -> BC
runMinute (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 []) ball

adjustHour :: BC -> Int -> BC
adjustHour (BC t h _ _) ball = if length h < 11 then
BC t (ball:h) [] []
else BC (t ++ h ++ [ball]) [] [] []

adjustFiveMin :: BC -> Int -> BC
adjustFiveMin (BC t h fm _) ball = if length fm < 11 then
BC t h (ball:fm) []
else adjustHour (BC (t ++ fm) h [] []) ball

run12Hour :: 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 -> Int
solve 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 -> t
circle' 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 _ _ _ _) = False

howManyMin :: BC -> Int
howManyMin 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 -> t
circle1 i table = circle' i i table

solve1 :: Int -> Int
solve1 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.

Wednesday, 7 November 2007

Syntax highlighting test

Finally I start to blog.

The main reason is that I'm learning Haskell and I need help. I have programmed in Python for about half a year and recently start to learn Scheme and Haskell. I will post code in these languages and if you think there's anything can be improved, just kindly drop me a line. Thanks in advance.

After reading Luke's greate article, I decide write articles in reStructuredText and use Pygments to highlight source code. This very first post is also act as a test that to see if everything works well. So let's have some fun with the factorial function.

From Wang Yin's Schemer page:

(define Y
(lambda (F)
(let ((W (lambda (x)
(F (lambda arg (apply (x x) arg))))))
(W W))))

(define fac
(lambda (fun)
(lambda (n)
(if (= 0 n) 1 (* n (fun (- n 1))))))))

My translation to Python:

Y = lambda F: (lambda x: F(lambda *args: x(x)(*args)))(lambda x: F(lambda *args: x(x)(*args)))
fac = Y(lambda fun: lambda n: n and n*fun(n-1) or 1)

From The Evolution of a Haskell Programmer:

-- a dynamically-typed term language

data Term = Occ Var
| Use Prim
| Lit Integer
| App Term Term
| Abs Var Term
| Rec Var Term

type Var = String
type Prim = String

-- a domain of values, including functions

data Value = Num Integer
| Bool Bool
| Fun (Value -> Value)

instance Show Value where
show (Num n) = show n
show (Bool b) = show b
show (Fun _) = ""

prjFun (Fun f) = f
prjFun _ = error "bad function value"

prjNum (Num n) = n
prjNum _ = error "bad numeric value"

prjBool (Bool b) = b
prjBool _ = error "bad boolean value"

binOp inj f = Fun (\i -> (Fun (\j -> inj (f (prjNum i) (prjNum j)))))

-- environments mapping variables to values

type Env = [(Var, Value)]

getval x env = case lookup x env of
Just v -> v
Nothing -> error ("no value for " ++ x)

-- an environment-based evaluation function

eval env (Occ x) = getval x env
eval env (Use c) = getval c prims
eval env (Lit k) = Num k
eval env (App m n) = prjFun (eval env m) (eval env n)
eval env (Abs x m) = Fun (\v -> eval ((x,v) : env) m)
eval env (Rec x m) = f where f = eval ((x,f) : env) m

-- a (fixed) "environment" of language primitives

times = binOp Num (*)
minus = binOp Num (-)
equal = binOp Bool (==)
cond = Fun (\b -> Fun (\x -> Fun (\y -> if (prjBool b) then x else y)))

prims = [ ("*", times), ("-", minus), ("==", equal), ("if", cond) ]

-- a term representing factorial and a "wrapper" for evaluation

facTerm = Rec "f" (Abs "n"
(App (App (App (Use "if")
(App (App (Use "==") (Occ "n")) (Lit 0))) (Lit 1))
(App (App (Use "*") (Occ "n"))
(App (Occ "f")
(App (App (Use "-") (Occ "n")) (Lit 1))))))

fac n = prjNum (eval [] (App facTerm (Lit n)))

It seems that everything works quite well. Thanks again, Luke! The color schemer is from Emacs color theme test.

I'm currently working on the Ball Clock puzzle. I have worked out the Python version, but write it in Haskell is hard for me (It's my first Haskell program!). As soon as I finish, I'll post them. You may look at the puzzle first. See you next time!