home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Small IO Examples / Hanoi.icl < prev    next >
Encoding:
Text File  |  1997-04-25  |  6.2 KB  |  217 lines  |  [TEXT/3PRM]
  1. module Hanoi
  2.  
  3. /*    The Towers of Hanoi (graphical version).
  4.     This program requires the 0.8 I/O library.
  5.     Run the program using the "No Console" option (Application options).
  6. */
  7.  
  8. import StdEnv
  9. import deltaEventIO, deltaMenu, deltaDialog, deltaTimer, deltaWindow, deltaPicture
  10.  
  11. ::    Tower    :== [Int]
  12. ::    Moves    :== [Int]
  13. ::    Towers
  14.     =    {    moves    :: !Moves
  15.         ,    tower1    :: !Tower
  16.         ,    tower2    :: !Tower
  17.         ,    tower3    :: !Tower
  18.         }
  19. ::    *IO        :==    IOState *Towers
  20.  
  21. FileID        :== 1
  22. RunID        :== 11
  23. HaltID        :== 12
  24. ContID        :== 13
  25. SpeedID        :== 14
  26. VerSID            :== 141
  27. SlowID            :== 142
  28. NormID            :== 143
  29. FastID            :== 144
  30. VerFID            :== 145
  31. QuitID        :== 15
  32.  
  33. TimerID        :== 1
  34.  
  35. WindowID    :== 1
  36. PicDomain    :== ((50,0),(480,180))
  37. Speed1        :== TicksPerSecond / 2
  38. Speed2        :== TicksPerSecond / 3
  39. Speed3        :== TicksPerSecond / 6
  40. Speed4        :== TicksPerSecond / 12
  41. Speed5        :== 0
  42.  
  43. MinDisks    :== 2
  44. MaxDisks    :== 12
  45. XOffs        :==    inc MaxDisks * 10
  46.  
  47. //    Starting the program
  48.  
  49. Start :: *World -> *World
  50. Start world
  51. #    (events,world)    = OpenEvents world
  52.     (_,events)        = StartIO [menus,windows,timers] (InitTowers 0) [] events
  53.     world            = CloseEvents events world
  54. =    world
  55. where
  56.     menus            = MenuSystem
  57.                         [    PullDownMenu FileID "File" Able
  58.                                 [    SubMenuItem RunID   "Run (nr disks)"   Able
  59.                                         [    MenuItem (1000+i) (toString i) NoKey Able (Run i) \\ i<-[MinDisks..MaxDisks]    ]
  60.                                 ,    MenuItem    HaltID  "Halt"        (Key '.') Unable Halt
  61.                                 ,    MenuItem    ContID    "Continue"    (Key ',') Unable Continue
  62.                                 ,    SubMenuItem SpeedID "Speed" Able 
  63.                                         [    MenuRadioItems NormID
  64.                                                 [    MenuRadioItem VerSID "Very Slow" (Key 'A') Able (SetSpeed Speed1)
  65.                                                 ,    MenuRadioItem SlowID "Slow"      (Key 'S') Able (SetSpeed Speed2)
  66.                                                 ,    MenuRadioItem NormID "Normal"    (Key 'D') Able (SetSpeed Speed3)
  67.                                                 ,    MenuRadioItem FastID "Fast"      (Key 'F') Able (SetSpeed Speed4)
  68.                                                 ,    MenuRadioItem VerFID "Very Fast" (Key 'G') Able (SetSpeed Speed5)
  69.                                                 ]
  70.                                         ]
  71.                                 ,    MenuItem QuitID "Quit" (Key 'Q') Able Quit
  72.                                 ]
  73.                         ]
  74.     
  75.     windows            = WindowSystem
  76.                         [    FixedWindow WindowID (0,0) "Hanoi" PicDomain Update 
  77.                                 [GoAway    Quit]
  78.                         ]
  79.     
  80.     timers            = TimerSystem
  81.                         [    Timer TimerID Unable Speed3 StepHanoi
  82.                         ]
  83.  
  84.  
  85. InitTowers :: Int -> *Towers
  86. InitTowers nr_disks
  87. =    {moves=Hanoi nr_disks 1 2 3, tower1=[1..nr_disks], tower2=[], tower3=[]}
  88. where
  89.     Hanoi :: Int Int Int Int -> Moves        // The function that calculates the list of disk moves
  90.     Hanoi n start end via
  91.     |    n==0        = []
  92.     |    otherwise    = Hanoi m start via end ++ [start,end : Hanoi m via end start]
  93.     where
  94.         m            = n-1
  95.  
  96.  
  97. //    The function for the Run command
  98.  
  99. Run :: Int *Towers IO -> (*Towers,IO)
  100. Run nr_disks _ io
  101. #    io        = EnableMenuItems    [HaltID]                    io
  102.     io        = DisableMenuItems    [RunID,ContID]                io
  103.     io        = EnableTimer        TimerID                        io
  104. =    DrawInActiveWindowFrame Update (InitTowers nr_disks)    io
  105.  
  106.  
  107. //    The function for the Halt command
  108.  
  109. Halt :: *Towers IO -> (*Towers,IO)
  110. Halt towers io
  111. #    io        = DisableMenuItems    [HaltID]        io
  112.     io        = EnableMenuItems    [RunID,ContID]    io
  113.     io        = DisableTimer        TimerID            io
  114. =    (towers,io)
  115.  
  116.  
  117. //    The function for the Continue command
  118.  
  119. Continue :: !*Towers IO -> (!*Towers,IO)
  120. Continue towers io
  121. #    io        = EnableMenuItems    [HaltID]        io
  122.     io        = DisableMenuItems    [RunID,ContID]    io
  123.     io        = EnableTimer        TimerID            io
  124. =    (towers,io)
  125.  
  126.  
  127. //    The function for the Quit command
  128.  
  129. Quit :: *Towers IO -> (*Towers,IO)
  130. Quit towers io
  131. =    (towers,QuitIO io)
  132.  
  133.  
  134. //    Set the speed of a (possibly running) Hanoi simulation
  135.  
  136. SetSpeed :: Int *Towers IO -> (*Towers,IO)
  137. SetSpeed speed towers io
  138. =    (towers, SetTimerInterval TimerID speed io)
  139.  
  140.  
  141. //    The timer function: take a move from the list of all moves and show it in the window
  142.  
  143. StepHanoi :: TimerState *Towers IO -> (*Towers,IO)
  144. StepHanoi _ towers=:{moves=[]} io
  145. #    io                = DisableMenuItems    [HaltID]    io
  146.     io                = EnableMenuItems    [RunID]        io
  147.     io                = DisableTimer        TimerID        io
  148. =    (towers, io)
  149. StepHanoi _ towers io
  150. #    (drawfs,towers)    = ChangeTowers towers
  151.     io                = DrawInActiveWindow drawfs io
  152. =    (towers,io)
  153. where
  154.     ChangeTowers :: Towers -> ([DrawFunction],*Towers)
  155.     ChangeTowers towers=:{moves=[1,2:moves],tower1=[f1:r1],tower2=t2}
  156.     =    (DrawMove 1 2 f1 (length r1) (length t2),{towers & moves=moves,tower1=r1,tower2=[f1:t2]})
  157.     ChangeTowers towers=:{moves=[1,3:moves],tower1=[f1:r1],tower3=t3}
  158.     =    (DrawMove 1 3 f1 (length r1) (length t3),{towers & moves=moves,tower1=r1,tower3=[f1:t3]})
  159.     ChangeTowers towers=:{moves=[2,1:moves],tower2=[f2:r2],tower1=t1}
  160.     =    (DrawMove 2 1 f2 (length r2) (length t1),{towers & moves=moves,tower2=r2,tower1=[f2:t1]})
  161.     ChangeTowers towers=:{moves=[2,3:moves],tower2=[f2:r2],tower3=t3}
  162.     =    (DrawMove 2 3 f2 (length r2) (length t3),{towers & moves=moves,tower2=r2,tower3=[f2:t3]})
  163.     ChangeTowers towers=:{moves=[3,1:moves],tower3=[f3:r3],tower1=t1}
  164.     =    (DrawMove 3 1 f3 (length r3) (length t1),{towers & moves=moves,tower3=r3,tower1=[f3:t1]})
  165.     ChangeTowers towers=:{moves=[3,2:moves],tower3=[f3:r3],tower2=t2}
  166.     =    (DrawMove 3 2 f3 (length r3) (length t2),{towers & moves=moves,tower3=r3,tower2=[f3:t2]})
  167.     
  168.     DrawMove :: Int Int Int Int Int -> [DrawFunction]
  169.     DrawMove start end disk lenfr lento
  170.     =    [    EraseDisk    ((fx-w,fy),(fx+w,fy+10))
  171.         ,    DrawDisk    ((tx-w,ty),(tx+w,ty+10))
  172.         ]
  173.     where
  174.         tx    = end  *XOffs;        ty    = 10+10*(MaxDisks-lento) 
  175.         fx    = start*XOffs;        fy    = 10+10*(MaxDisks-lenfr) 
  176.         w    = disk *5
  177.  
  178. EraseDisk :: Rectangle -> DrawFunction
  179. EraseDisk rectangle = EraseRectangle rectangle
  180.  
  181. DrawDisk :: Rectangle -> DrawFunction
  182. DrawDisk rectangle
  183. =    seq
  184.     [    SetPenColour    (RGB 0.5 0.6 0.7)
  185.     ,    FillRectangle    rectangle
  186.     ,    SetPenColour    BlackColour
  187.     ,    DrawRectangle    rectangle
  188.     ]
  189.  
  190.  
  191. //    The update function: erase the window and redraw the towers
  192.  
  193. Update :: UpdateArea *Towers -> (*Towers, [DrawFunction])
  194. Update _ towers=:{tower1,tower2,tower3}
  195. =    (    towers
  196.     ,    [    EraseRectangle PicDomain
  197.         ,    DrawTower 1 (MaxDisks-length tower1) tower1
  198.         ,    DrawTower 2 (MaxDisks-length tower2) tower2
  199.         ,    DrawTower 3 (MaxDisks-length tower3) tower3
  200.         ]
  201.     )
  202. where
  203.     DrawTower :: Int Int Tower Picture -> Picture
  204.     DrawTower nr i [f:r] pic
  205.     =    DrawTower nr (i+1) r disk
  206.     where
  207.         disk    = DrawDisk ((x-w,y),(x+w,y+10)) pic
  208.         x        = nr*XOffs
  209.         w        = f *5
  210.         y        = 20+10*i
  211.     DrawTower nr _ _ pic
  212.     |    nr==1    = DrawString "from"    (MovePenTo (  XOffs-14,y) pic)
  213.     |    nr==2    = DrawString "to"    (MovePenTo (2*XOffs-6, y) pic)
  214.     |    nr==3    = DrawString "via"    (MovePenTo (3*XOffs-9, y) pic)
  215.     where
  216.         y        = 35+10*MaxDisks
  217.