home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Life / LifeGameExample.icl < prev   
Encoding:
Text File  |  1997-04-28  |  4.5 KB  |  140 lines  |  [TEXT/3PRM]
  1. module LifeGameExample
  2.  
  3. //    This is the version of the LifeGame program written in Clean 1.2 for I/O system 0.8
  4.  
  5. import StdEnv, deltaEventIO, deltaMenu, deltaWindow, deltaTimer
  6. import Life
  7.  
  8. ::    *State    =    {gen::Generation, size::CellSize}
  9. ::    *IO        :==    IOState State
  10.  
  11. Start :: *World -> *World
  12. Start world 
  13. #    (events,world)    = OpenEvents world
  14.     (_,events)        = StartIO [window, timer, menus] start_state init_io events
  15.     world            = CloseEvents events world
  16. =    world
  17. where
  18.     start_state        = {gen=MakeGeneration, size=StartCellSize}
  19.     init_io            = [\s io->(s,DrawInWindow WindowID [SetBackColour BlackColour] io)]
  20.     
  21.     window            = WindowSystem
  22.                         [    ScrollWindow WindowID (0,0) "Life" 
  23.                             (ScrollBar (Thumb 0) (Scroll StartCellSize))
  24.                             (ScrollBar (Thumb 0) (Scroll StartCellSize)) 
  25.                             picturedomain (100,100) (RectangleSize picturedomain) UpdateWindow
  26.                             [    GoAway    Quit
  27.                             ,    Mouse    Able Track
  28.                             ]
  29.                         ]
  30.     picturedomain    = GetPictureDomain StartCellSize
  31.     timer            = TimerSystem [Timer TimerID Unable 0 (\_ ->Step)]
  32.     menus            = MenuSystem 
  33.                         [    PullDownMenu FileMenuID "File" Able
  34.                             [    MenuItem QuitID "Quit" (Key 'Q') Able Quit
  35.                             ]
  36.                         ,    PullDownMenu OptionsMenuID "Options" Able
  37.                             [    MenuItem EraseID "Erase All Cells" (Key 'E') Able Erase
  38.                               ,    SubMenuItem CellSizeID "Cell Size" Able 
  39.                                   [    MenuRadioItems Size8ID
  40.                                     [    MenuRadioItem Size1ID  "1 * 1" (Key '1') Able (ChangeSize 1)
  41.                                     ,    MenuRadioItem Size2ID  "2 * 2" (Key '2') Able (ChangeSize 2)
  42.                                     ,    MenuRadioItem Size4ID  "4 * 4" (Key '3') Able (ChangeSize 4)
  43.                                     ,    MenuRadioItem Size8ID  "8 * 8" (Key '4') Able (ChangeSize 8)
  44.                                     ,    MenuRadioItem Size16ID "16*16" (Key '5') Able (ChangeSize 16)
  45.                                     ]
  46.                                   ]
  47.                             ]
  48.                         ,     PullDownMenu CommandsMenuID "Commands" Able
  49.                             [    MenuItem PlayID "Play" (Key 'P') Able Play
  50.                             ,    MenuItem HaltID "Halt" (Key 'H') Unable Halt
  51.                             ,    MenuItem StepID "Step" (Key 'S') Able Step
  52.                             ]
  53.                         ]
  54.  
  55. Quit :: State IO -> (State, IO)
  56. Quit state io = (state, QuitIO io)
  57.  
  58. Play :: State IO -> (State, IO)
  59. Play state io
  60. #    io    = DisableActiveMouse                        io
  61.     io    = DisableMenuItems    [PlayID,StepID,EraseID]    io
  62.     io    = EnableMenuItems    [HaltID]                io
  63.     io    = EnableTimer        TimerID                    io
  64. =    (state, io)
  65.  
  66. Halt :: State IO -> (State, IO)
  67. Halt state io
  68. #    io    = EnableActiveMouse                            io
  69.     io    = DisableMenuItems    [HaltID]                io
  70.     io    = EnableMenuItems    [PlayID,StepID,EraseID]    io
  71.     io    = DisableTimer        TimerID                    io
  72. =    (state, io)
  73.  
  74. Step :: State IO -> (State, IO)
  75. Step state=:{gen,size} io
  76. =    ({state & gen = next}, DrawInActiveWindow (DrawCells (EraseCell size) died ++ DrawCells (DrawCell size) next) io)
  77. where
  78.     (next,died)    = LifeGame gen
  79.  
  80. Erase :: State IO -> (State, IO)
  81. Erase state=:{size} io
  82. =    ({state & gen = MakeGeneration}, DrawInActiveWindow [EraseRectangle (GetPictureDomain size)] io)
  83.  
  84. ChangeSize :: Int State IO -> (State, IO)
  85. ChangeSize newSize state=:{gen,size=oldSize} io
  86. #    state            = {state & gen=MakeGeneration,size=newSize}
  87.     (((x,y),_),io)    = ActiveWindowGetFrame io
  88.     (state,io)        = ChangeActivePictureDomain (GetPictureDomain newSize) state io
  89.     (state,io)        = ChangeActiveScrollBar     (ChangeHBar (x/oldSize*newSize) newSize) state io
  90.     (state,io)        = ChangeActiveScrollBar     (ChangeVBar (y/oldSize*newSize) newSize) state io
  91.     state            = {state & gen=gen}
  92.     io                = DrawInActiveWindow        [EraseRectangle (GetPictureDomain newSize):DrawCells (DrawCell newSize) gen] io
  93. =    (state,io)
  94.  
  95. UpdateWindow :: UpdateArea State -> (State,[DrawFunction])
  96. UpdateWindow _ state=:{gen,size} = (state,DrawCells (DrawCell size) gen)
  97.  
  98. Track :: MouseState State IO -> (State, IO)
  99. Track (_,ButtonUp,_) state io = (state, io)
  100. Track (pos,_,(_,_,command,_)) state=:{gen,size} io
  101. |    command
  102. =    ({state & gen = RemoveCell cell gen}, DrawInActiveWindow [EraseCell size cell] io)
  103. =    ({state & gen = InsertCell cell gen}, DrawInActiveWindow [DrawCell  size cell] io)
  104. where
  105.     cell    = MakeLifeCell pos size
  106.  
  107. GetPictureDomain :: CellSize -> PictureDomain
  108. GetPictureDomain size
  109. =    ((size*left,size*top),(size*right,size*bottom))
  110. where
  111.     ((left,top),(right,bottom))    = Universe
  112.  
  113. RectangleSize :: Rectangle -> (Int,Int)
  114. RectangleSize ((left,top),(right,bottom)) = (abs (right-left),abs (bottom-top))
  115.  
  116.  
  117. //    Program constants.
  118.  
  119. FileMenuID        :== 1
  120. QuitID                 :== 11
  121. OptionsMenuID     :== 2
  122. EraseID                :== 21
  123. CellSizeID             :== 22
  124. Size1ID                    :== 221
  125. Size2ID                    :== 222
  126. Size4ID                    :== 223
  127. Size8ID                    :== 224
  128. Size16ID                :== 225
  129. CommandsMenuID     :== 3
  130. PlayID                :== 31
  131. HaltID                :== 32
  132. StepID                :== 33
  133.  
  134. WindowID        :== 1
  135. Universe        :==    ((-1000,-1000),(1000,1000))
  136.  
  137. TimerID            :== 1
  138.  
  139. StartCellSize    :== 8
  140.