LifeGameExample.icl 7.49 KB
Newer Older
Peter Achten's avatar
Peter Achten committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
module LifeGameExample

//	**************************************************************************************************
//
//	This is the LifeGame program.
//
//	The program has been written in Clean 1.3.2 and uses the Clean Standard Object I/O library 1.2
//	
//	**************************************************************************************************

import StdEnv, StdIO
import Life, Help

::	Life
	=	{	gen	:: !Generation
		,	size:: !CellSize
		}
initialLife
	=	{	gen	= makeGeneration
		,	size= StartCellSize
		}

Start :: *World -> *World
Start world
	= startLife (openIds 6 world)

startLife :: ([Id],*World) -> *World
startLife ([eraseID,playID,haltID,stepID,windowID,timerID],world)
	= startIO SDI initialLife
				  initialise
				  [ProcessClose closeProcess]
				  world
where
//	initialise creates the gui of the life.
	initialise pst
		# (error,pst)	= openTimer undef timer pst
		| error<>NoError
			= abort "LifeGameExample could not open timer."
		# (error,pst)	= openMenu undef file pst
		| error<>NoError
			= abort "LifeGameExample could not open Life menu."
		# (error,pst)	= openMenu undef options pst
		| error<>NoError
			= abort "LifeGameExample could not open Options menu."
		# (error,pst)	= openMenu undef commands pst
		| error<>NoError
			= abort "LifeGameExample could not open Commands menu."
		# (size, pst)	= accPIO getProcessWindowSize pst
		# (error,pst)	= openWindow undef (window size) pst
		| error<>NoError
			= abort "LifeGameExample could not open Life window."
		| otherwise
			= pst
	
//	window defines the window that displays the universe and its inhabitants.
	window size	= Window "Life" NilLS
					[	WindowId			windowID
					,	WindowClose			(noLS closeProcess)
					,	WindowMouse			onlyMouseDown Able (noLS1 track)
					,	WindowViewDomain	(getViewDomain StartCellSize)
					,	WindowViewSize		size
					,	WindowOrigin		zero
					,	WindowHScroll 		(hscroll StartCellSize)
					,	WindowVScroll		(vscroll StartCellSize)
					,	WindowLook			True (look initialLife)
					,	WindowPen			[PenBack Black]
					]
	where
		hscroll dh viewframe {sliderThumb} move
			= case move of
				SliderIncSmall -> sliderThumb+dh
				SliderDecSmall -> sliderThumb-dh
				SliderIncLarge -> sliderThumb+(rectangleSize viewframe).w*9/10
				SliderDecLarge -> sliderThumb-(rectangleSize viewframe).w*9/10
				SliderThumb x  -> x
		vscroll dv viewframe {sliderThumb} move
			= case move of
				SliderIncSmall -> sliderThumb+dv
				SliderDecSmall -> sliderThumb-dv
				SliderIncLarge -> sliderThumb+(rectangleSize viewframe).h*9/10
				SliderDecLarge -> sliderThumb-(rectangleSize viewframe).h*9/10
				SliderThumb y  -> y
	
//	timer defines the timer that calculates subsequent life generations.
	timer	= Timer 0 NilLS
				[	TimerId				timerID
				,	TimerSelectState	Unable
				,	TimerFunction		(noLS1 (\_->step))
				]

//	file defines the "File" menu, containing only the quit command to terminate the program.
	file	= Menu "&File"
				(	MenuItem "&About LifeGameExample..."
										[MenuFunction (noLS (showAbout "Life" "LifeHelp"))]
				:+:	MenuSeparator		[]
				:+:	MenuItem "&Quit"	[MenuShortKey 'q',MenuFunction (noLS closeProcess)]
				)	[]

//	options defines the "Options" menu to set the size of the displayed cells.
	options	= Menu "&Options"
				(	SubMenu "Cell Size" 
		  			(	RadioMenu
		  				[	(title (2^i),Nothing,Just (char i),noLS (newsize (2^i)))
		  				\\	i<-[0..4]
						]	4 []
		  			)	[]
				)	[]
	where
		title size	= toString size +++ " * " +++ toString size
		char  i		= toChar (fromChar '1'+i)
	
//	commands defines the "Commands" menu to run and halt the computations of life generations.
	commands= Menu "&Commands"
				(	MenuItem "&Erase Cells"	[MenuId eraseID,MenuShortKey 'e',MenuFunction (noLS erase)]
		  		:+:	MenuItem "&Play"		[MenuId playID, MenuShortKey 'p',MenuFunction (noLS play)]
				:+:	MenuItem "&Halt"		[MenuId haltID, MenuShortKey 'h',MenuFunction (noLS halt), MenuSelectState Unable]
				:+:	MenuItem "&Step"		[MenuId stepID, MenuShortKey 's',MenuFunction (noLS step)]
				)	[]
	
//	play starts the computation of successive generations given the current set of life cells.
121
	play :: (PSt Life) -> PSt Life
Peter Achten's avatar
Peter Achten committed
122
123
124
125
126
127
128
129
130
	play life
		= appListPIO
			[	disableWindowMouse	windowID
			,	disableMenuElements [eraseID,playID,stepID]
			,	enableMenuElements	[haltID]
			,	enableTimer			timerID
			]	life
	
//	halt stops the computation of successive generations, but does not change the current generation. 
131
	halt :: (PSt Life) -> PSt Life
Peter Achten's avatar
Peter Achten committed
132
133
134
135
136
137
138
139
140
	halt life
		= appListPIO
			[	enableWindowMouse	windowID
			,	disableMenuElements	[haltID]
			,	enableMenuElements	[eraseID,playID,stepID]
			,	disableTimer		timerID
			]	life
	
//	step calculates the next generation and displays it.
141
	step :: (PSt Life) -> PSt Life
Peter Achten's avatar
Peter Achten committed
142
143
144
145
146
147
148
149
150
151
	step life=:{ls=state=:{gen,size},io}
		# state		= {state & gen=next}
		# io		= appWindowPicture windowID render io
		# io		= setWindowLook windowID False (True,look state) io
		= {life & ls=state, io=io}
	where
		(next,died)	= lifeGame gen
		render		= drawCells (drawCell size) next o (drawCells (eraseCell size) died)
	
//	erase sets the current generation to empty and clears the window.
152
	erase :: (PSt Life) -> PSt Life
Peter Achten's avatar
Peter Achten committed
153
154
155
156
157
158
	erase life=:{ls=state,io}
		# state		= {state & gen=makeGeneration}
		# io		= setWindowLook windowID True (True,look state) io
		= {life & ls=state, io=io}
	
//	newsize changes the size in which life cells are rendered and redraws the window.
159
	newsize :: Int (PSt Life) -> PSt Life
Peter Achten's avatar
Peter Achten committed
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
	newsize newSize life=:{ls=state=:{size=oldSize},io}
		# state			= {state & size=newSize}
		# (viewframe,io)= getWindowViewFrame windowID io
  		  oldOrigin		= viewframe.corner1
		  newOrigin		= {x=oldOrigin.x/oldSize*newSize,y=oldOrigin.y/oldSize*newSize}
		# io			= setWindowLook windowID False (True,look {state & gen=makeGeneration}) io
		# io			= setWindowViewDomain windowID (getViewDomain newSize) io
		# io			= moveWindowViewFrame windowID (toVector newOrigin-toVector oldOrigin) io
		# io			= setWindowLook windowID True (True,look state) io
		= {life & ls=state, io=io}
	
//	The window look:
	look :: Life SelectState UpdateState *Picture -> *Picture
	look {gen,size} _ {newFrame} picture
		# picture	= unfill    newFrame			picture
		# picture	= drawCells (drawCell size) gen	picture
		= picture
	
//	The window mouse accepts only MouseDown user actions:
	onlyMouseDown :: MouseState -> Bool
	onlyMouseDown (MouseDown _ _ _) = True
	onlyMouseDown (MouseDrag _ _)	= True
	onlyMouseDown _					= False
	
//	The window mouse action places and removes alive cells:
185
	track :: MouseState (PSt Life) -> PSt Life
Peter Achten's avatar
Peter Achten committed
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
	track mouse life=:{ls=state=:{gen,size},io}
		| modifiers.commandDown
			# state		= {state & gen=removeCell cell gen}
			# io		= appWindowPicture windowID (eraseCell size cell) io
			# io		= setWindowLook windowID False (True,look state) io
			= {life & ls=state, io=io}
		| otherwise
			# state		= {state & gen=insertCell cell gen}
			# io		= appWindowPicture windowID (drawCell size cell) io
			# io		= setWindowLook windowID False (True,look state) io
			= {life & ls=state, io=io}
	where
		(pos,modifiers)	= case mouse of
							(MouseDown pos mods _) -> (pos,mods)
							(MouseDrag pos mods)   -> (pos,mods)
		cell			= makeLifeCell pos size
	
//	Given the size in which to render life cells, getViewDomain calculates the corresponding ViewDomain:
	getViewDomain :: CellSize -> ViewDomain
	getViewDomain size
		= {corner1={x=size*left,y=size*top},corner2={x=size*right,y=size*bottom}}
	where
		{corner1={x=left,y=top},corner2={x=right,y=bottom}}	= Universe


//	Program constants.

Universe		:==	{corner1={x=(-1000),y=(-1000)},corner2={x=1000,y=1000}}
StartCellSize	:== 8