{- 02/2003 -}
module Main where

import FunWorlds


scene keyb = 
  NewChannel (show n) $ \nCh->
  let textColor = greenB `Until` ((Observe False nCh) `then_` redB)
  in groupB $ [ translateB (vector3B (-2.5) 2 0) $ 
                scaleB (vector3B 0.3 0.3 0.3) $ 
                coloredTextB textColor ["Towers of Hanoi"]
              , scaleB (vector3B 1 0.5 1) $
                towers nCh n ((-2),[1..n]) (0,[]) (2,[])
              ]
  where 

    -- plain old recursive move and state sequence generation,
    -- combining each move/state-pair into a dynamic scene,
    -- and stringing them all together; here, the result is a
    -- dynamically computed hybrid state machine for the towers.
    -- the nCh is a channel on which termination of the state
    -- machine can be observed
    towers nCh 0 source aux target = 
      fork (groupB [tower p t|(p,t)<-[source,aux,target]])
           (Source trueB nCh)
    towers nCh n source@(ps,ds) aux@(pa,da) target@(pt,dt) = 
      NewChannel (show n++"a") $ \naCh->
      towers naCh (n-1) source target aux 
      `Until` ((Observe False naCh) `then_`
      ((groupB $ [move d (ps,hs') (pt,ht)]
              ++ [tower p t|(p,t)<-[source',aux',target]])
      `Until` ((time .>. waiting) `then_` 
      (towers nCh (n-1) aux' source' target') )))
      where
        (top,(d:ds')) = splitAt (fromInteger (n-1)) ds
        hs'           = length ds'
        ht            = length dt
        source'       = (ps,ds')
        aux'          = (pa,top++da)
        target'       = (pt,d:dt)

    -- tower at x-position p, with disks ds
    tower p ds = translateB (vector3B p (yBase $ length ds) 0) $ 
                 groupB [ disk n (vector3B 0 (fromInteger (-y)) 0)
                        | (n,y) <- zip ds [1..]] 

    -- disk of size n, at position v
    disk n v = translateB v $ 
               rotateB (xAxisRotationB 90) $
               shapeB (coloredAppearanceB blueB) $
               cylinderB r (0.8*r)
               where
                r = (fromInteger n)/15

    -- animation of disk n moving from one stack to another
    move n (from_pos,from_height) (to_pos,to_height) = 
       disk n (vector3B from_pos up 0)  `Until` ((up `close` top) `then_` 
      (disk n (vector3B x top 0)        `Until` ((x `close` to_pos) `then_` 
      (disk n (vector3B to_pos down 0)  `Until` ((down `close` h) `then_` 
      (disk n (vector3B to_pos h 0)))))))
      where
        x    = interp from_pos                    to_pos    (time/3)
        up   = interp ((yBase (from_height+1))-1) top       time
        down = interp top                         h         time
        h    = (yBase (to_height+1))-1 

    yBase height = top+(fromInteger ((fromIntegral $ height)-n))

    n   = 5
    top = 2

    waiting, time, epsilon  :: Beh Double
    waiting = 6
    time    = integral 0.20
    epsilon = 0.01

    close a b = (abs (a-b)) .<. epsilon

    interp a b t = a*(1-t)+b*t

main :: IO ()
main = startB $ \SC{keyCh=keyb}->
                rotateAndScale keyb $ 
                scene keyb