[htoolkit-cvs] gio/src/examples/life Life.hs,NONE,1.1 Main.hs,NONE,1.1

[<kr_...@us...>]

Update of /cvsroot/htoolkit/gio/src/examples/life
In directory sc8-pr-cvs1:/tmp/cvs-serv5220

Added Files:
	Life.hs Main.hs 
Log Message:
Add Life example


--- NEW FILE: Life.hs ---
module Life where

import Graphics.UI.GIO
import Control.Monad(when)

type Generation	= [[LifeCell]]
type CellSize	= Int
type ClickPoint	= Point

data LifeCell
   = LifeCell
	{ cx	:: !Int
	, cy	:: !Int
	, age	:: !Int
	} deriving Show

colours :: [Color]
colours = [red,magenta,green,yellow,cyan,blue]

ageToColour :: Int -> Color
ageToColour age
	| age<=0	= colours !! 0
	| age>=5	= colours !! 5
	| otherwise	= colours !! age

makeGeneration :: Generation
makeGeneration = []

makeLifeCell :: ClickPoint -> CellSize -> LifeCell
makeLifeCell (Point x y) size = LifeCell{cx=x `div` size, cy=y `div` size, age=0}

newLifeCell :: Int -> Int -> LifeCell
newLifeCell x y = LifeCell{cx=x,cy=y,age=0}


--	Rendering of LifeCells.

drawCells :: (LifeCell -> Canvas -> IO ()) -> Generation -> Canvas -> IO ()
drawCells f gen can = mapM_ (mapM_ (flip f can)) gen

drawCell :: CellSize -> LifeCell -> Canvas -> IO ()
drawCell size (LifeCell {cx=cx,cy=cy,age=age}) can = do
	setCanvasPen can [color =: ageToColour age]
	fillRect (Rect px py (px+size) (py+size)) can
	where
		px	= cx*size
		py	= cy*size

eraseCell :: CellSize -> LifeCell -> Canvas -> IO ()
eraseCell size (LifeCell {cx=cx,cy=cy}) can = do
	setCanvasPen can [color =: black]
	fillRect (Rect px py (px+size) (py+size)) can
	where
		px	= cx*size
		py	= cy*size


{-	Insert a LifeCell to a Generation.
	In a Generation LifeCells are ordered by increasing x-coordinate first, and by increasing y-coordinate second.
-}
insertCell :: LifeCell -> Generation -> Generation
insertCell c1@(LifeCell{cx=x1}) gen@(cs@(LifeCell{cx=x2,cy=y2}:x2ys) : cs_xs)
	| x2<x1			= cs : insertCell c1 cs_xs
	| x2==x1		= insertCelly c1 cs : cs_xs
	| otherwise		= [c1]:gen
	where
		insertCelly :: LifeCell -> [LifeCell] -> [LifeCell]
		insertCelly c1@(LifeCell {cy=y1}) g@(c2@(LifeCell {cx=x2,cy=y2}):x2ys)
			| y2<y1		= c2	: insertCelly c1 x2ys
			| y2==y1	= c1	: x2ys
			| otherwise	= c1	: g
		insertCelly c1 _ = [c1]
insertCell c1 [] = [[c1]]

{-	Remove a LifeCell from a Generation.
-}
removeCell :: LifeCell -> Generation -> Generation
removeCell c1@(LifeCell {cx=x1,cy=y1}) gen@(cs@((LifeCell {cx=x2,cy=y2}):x2ys):cs_xs)
	| x2<x1		= cs:removeCell c1 cs_xs
	| x2>x1		= gen
	| otherwise	=
		let cs1 = removeCelly c1 cs
		in if null cs1 then cs_xs
		   else cs1 : cs_xs
	where
		removeCelly :: LifeCell -> [LifeCell] -> [LifeCell]
		removeCelly c1@(LifeCell {cy=y1}) cs@(c2@(LifeCell {cx=x2,cy=y2}):x2ys)
			| y2<y1		= c2 : removeCelly c1 x2ys
			| y2==y1	= x2ys
			| otherwise	= cs
		removeCelly _ _ = []
removeCell c ([]:cs_xs) = removeCell c cs_xs
removeCell c _ = []

{-	Calculate the new Generation (first tuple result) and the Generation of LifeCells that die (second tuple result).
-}
lifeGame :: Generation -> (Generation,Generation)
lifeGame gen =
	let 
		(next,_,die) = nextGen gen gen
		next1 = celebrateSurvival next gen
	in 
		(next1,die)
	where
		nextGen :: Generation -> Generation -> (Generation,Generation,Generation)
		nextGen ((c@(LifeCell{cx=cx,cy=cy}):cs_x):cs_xs) gen
			| neighbours34 (neighbours c gen) = (insertCell c gennext1,new,diednext)
			| otherwise			  = (gennext1,new,insertCell c diednext)
			where
				(gennext,newbornsnext,diednext)	= nextGen (cs_x:cs_xs) gen1
				(gennext1,new)			= newBorns c newbornsnext gennext gen
				gen1				= shiftGeneration (cs_x:cs_xs) gen

				neighbours34 [_,_,_]	=  True
				neighbours34 [_,_,_,_] 	=  True
				neighbours34 _		=  False

				newBorns :: LifeCell -> Generation -> Generation -> Generation -> (Generation,Generation)
				newBorns c newbornsnext gennext gen =
					newBorns1 (newBornNeighbours c gen) newbornsnext gennext gen
					where
						newBorns1 (c@(LifeCell {cx=x1,cy=y1}):cs) newbornsnext gennext gen
							| neighbours3 (neighbours c gen) = (insertCell c gennext1,insertCell c newbornsnext1)
							| otherwise			 = next_genANDnewborns
							where
								(gennext1,newbornsnext1)	= next_genANDnewborns
								next_genANDnewborns		= newBorns1 cs newbornsnext gennext gen

								neighbours3 :: [LifeCell] -> Bool
								neighbours3 [_,_,_]	= True
								neighbours3 _ 		= False
						newBorns1 [] newbornsnext gennext _ = (gennext,newbornsnext)

						--	newBornNeighbours c gen -> dead neighbours of c in gen in decreasing order.

						newBornNeighbours :: LifeCell -> Generation -> [LifeCell]
						newBornNeighbours (LifeCell {cx=cx,cy=cy}) gen =
							newBornNeighbours1 (cx-1) (cx+1) (cy-1) gen []
							where
								newBornNeighbours1:: Int -> Int -> Int -> Generation -> [LifeCell] -> [LifeCell]
								newBornNeighbours1 x xn y (cs@((LifeCell {cx=x2}):_):cs_xs) newborns
									| x>xn		= newborns
									| x2<x		= newBornNeighbours1 x xn y cs_xs newborns
									| x2==x		= newBornNeighbours2 x y (y+2) cs (newBornNeighbours1 (x+1) xn y cs_xs newborns)
									| otherwise	= (newLifeCell x y:newLifeCell x (y+1):newLifeCell x (y+2):newBornNeighbours1 (x+1) xn y cs_xs newborns)
								newBornNeighbours1 x xn y [] newborns
									| x>xn		= newborns
									| otherwise	= (newLifeCell x y:newLifeCell x (y+1):newLifeCell x (y+2):newBornNeighbours1 (x+1) xn y [] newborns)

								newBornNeighbours2:: Int -> Int -> Int -> [LifeCell] -> [LifeCell] -> [LifeCell]
								newBornNeighbours2 x y yn (c@(LifeCell {cx=x2,cy=y2}):cs) cs_xs
									| y>yn		= cs_xs
									| y2<y		= newBornNeighbours2 x y yn cs cs_xs
									| y2==y		= newBornNeighbours2 x (y+1) yn cs cs_xs
									| otherwise	= (newLifeCell x y:newBornNeighbours2 x (y+1) yn cs cs_xs)
								newBornNeighbours2 x y yn [] cs_xs
									| y>yn		= cs_xs
									| otherwise	= newLifeCell x y:newBornNeighbours2 x (y+1) yn [] cs_xs

				shiftGeneration :: Generation -> Generation -> Generation
				shiftGeneration (   (c@(LifeCell {cx=cx,cy=cy}):_):_) gen = shiftGeneration1 c{cx=cx-2,cy=cy-2} gen
				shiftGeneration ([]:(c@(LifeCell {cx=cx,cy=cy}):_):_) gen = shiftGeneration1 c{cx=cx-2,cy=cy-2} gen
				shiftGeneration partial_gen           gen = gen

				shiftGeneration1:: LifeCell -> Generation -> Generation
				shiftGeneration1 c@(LifeCell {cx=x1,cy=y1}) gen@((c2@(LifeCell {cx=x2,cy=y2}):cs_x):cs_xs)
					| x2<x1			= shiftGeneration1 c cs_xs
					| x2==x1 && y2<y1	= shiftGeneration1 c (cs_x:cs_xs)
					| otherwise		= gen
				shiftGeneration1 c ([]:cs_xs) = shiftGeneration1 c cs_xs
				shiftGeneration1 c _ = []

				--	neighbours c gen -> neighbours of c in gen in decreasing order.

				neighbours :: LifeCell -> Generation -> [LifeCell]
				neighbours (LifeCell {cx=x,cy=y}) gen =
					neighbours1 (x-1) (x+1) (y-1) gen []
					where
						neighbours1:: Int -> Int -> Int -> Generation -> [LifeCell] -> [LifeCell]
						neighbours1 x xn y (cs@((LifeCell {cx=x2,cy=y2}):_):cs_xs) neighbours
							| x2<x		= neighbours1 x xn y cs_xs neighbours
							| x2<=xn	= neighbours2 y (y+2) cs (neighbours1 (x+1) xn y cs_xs neighbours)
							| otherwise	= neighbours
						neighbours1 _ _ _ [] neighbours = neighbours

						neighbours2:: Int -> Int -> [LifeCell] -> [LifeCell] -> [LifeCell]
						neighbours2 y yn (c@(LifeCell {cx=x2,cy=y2}):cs) cs_xs
							| y2<y		= neighbours2 y yn cs cs_xs
							| y2<=yn	= (c:neighbours2 (y+1) yn cs cs_xs)
							| otherwise	= cs_xs
						neighbours2 _ _ [] cs_xs = cs_xs

		nextGen ([]:cs_xs) gen = nextGen cs_xs gen
		nextGen _ _ = ([],[],[])
	
		celebrateSurvival :: Generation -> Generation -> Generation
		celebrateSurvival new old = map (map (celebrate old)) new
			where
				celebrate :: Generation -> LifeCell -> LifeCell
				celebrate old newcell
					| found		= newcell{age=age+1}
					| otherwise	= newcell{age=age}
					where
						(found,age)	= getCellAge newcell old

				getCellAge :: LifeCell -> Generation -> (Bool,Int)
				getCellAge c1@(LifeCell {cx=x1}) (xs@((LifeCell {cx=x2}):_):xss)
					| x1<x2		= (False,0)
					| x1>x2		= getCellAge  c1 xss
					| otherwise	= getCellAge' c1 xs
				getCellAge _ _ = (False,0)

				getCellAge' :: LifeCell -> [LifeCell] -> (Bool,Int)
				getCellAge' c1@(LifeCell {cy=y1}) (LifeCell{cy=y2,age=age}:xs)
					| y1<y2		= (False,0)
					| y1>y2		= getCellAge' c1 xs
					| otherwise	= (True,age)
				getCellAge' _ _ = (False,0)

--- NEW FILE: Main.hs ---
module Main where

import Graphics.UI.GIO
import Life
import Data.Char(ord,chr)
import Data.IORef

data Life = Life
   	{ gen       :: Generation
	, cellSize :: CellSize
	} deriving Show

initialLife = Life
	{ gen       = makeGeneration
	, cellSize = startCellSize
	}

main :: IO ()
main = start "Life" "1.0" SDI [] $ do
		ref <- newIORef initialLife

		let mydomain@(Size dw dh) = getViewDomain startCellSize
		    myorigin = Point (dw `div` 2) (dh `div` 2)
		w <- window [domain =: mydomain, origin =: myorigin, bgcolor =: black]
		set w [on mouse =: onMouse w ref, on paint =: onPaint ref]
		set w [origin =: myorigin]

		mfile <- menu  [title =: "File"] mainMenu
		menuitem [title =: "About LifeGameExample...", on command =: onAbout] mfile
		menuline mfile
		menuitem [title =: "Exit", on command =: halt] mfile

		mopts  <- menu [title =: "Options"] mainMenu
		msizes <- menu [title =: "Cell Size"] mopts
		rg <- menuRadioGroup [] msizes
		sequence [menuRadioItem [ title =: mkTitle size
		                                        , on command =: onNewSize size w ref] rg
				| size <- [1..8]]
		set rg [selected =: 7]

		mcmd <- menu [title =: "Commands"] mainMenu
		merase <- menuitem [title =: "Erase Cells", accel =: KeyChar '\^E'] mcmd
		mplay  <- menuitem [title =: "Play",           accel =: KeyChar '\^P'] mcmd
		mhalt  <- menuitem [title =: "Halt",            accel =: KeyChar '\^H', enabled =: False] mcmd
		mstep  <- menuitem [title =: "Step",           accel =: KeyChar '\^S'] mcmd

		t <- timer [enabled =: False, interval =: 40, on command =: onTimer w ref]

		set merase [on command =: onErase w ref]
		set mplay [on command =: onPlay mplay mstep  mhalt t]
		set mhalt [on command =: onHalt mplay mstep  mhalt t]
		set mstep [on command =: onTimer w ref]
		where
			mkTitle size	= show size ++ " * " ++ show size

			onTimer w ref = do
				life <- readIORef ref
				let size = cellSize life
				let (next,died) = lifeGame (gen life)
				let render can = drawCells (drawCell size) next can >> drawCells (eraseCell size) died can
				writeIORef ref (life{gen=next})
				drawInWindow UnBuffered w render

			onAbout = do
				logo <- readBitmap "../images/logo.bmp" []
				runAboutDialog "Life" "1.0"
				                       "(C) Krasimir Angelov, 2003"
				                       "The Life is an example program\nfreely distributed with HToolkit"
				                       [] [] [] logo Nothing

			onMouse w ref (MouseLeftDown pos mods)
				| mods == justControl = do
					life <- readIORef ref
					let cell = makeLifeCell pos (cellSize life)
					writeIORef ref (life{gen=removeCell cell (gen life)})
					drawInWindow UnBuffered w (eraseCell (cellSize life) cell)
				| mods == noModifiers = do
					life <- readIORef ref
					let cell = makeLifeCell pos (cellSize life)
					writeIORef ref (life{gen=insertCell cell (gen life)})
					drawInWindow UnBuffered w (drawCell (cellSize life) cell)
			onMouse w ref (MouseDrag pos mods) = do
					life <- readIORef ref
					let cell = makeLifeCell pos (cellSize life)
					writeIORef ref (life{gen=insertCell cell (gen life)})
					drawInWindow UnBuffered w (drawCell (cellSize life) cell)
			onMouse w ref _ = return ()

			onPaint ref can _ _ = do
				life <- readIORef ref
				drawCells (drawCell (cellSize life)) (gen life) can

			-- onErase sets the current generation to empty and clears the window.
			onErase :: Window -> IORef Life -> IO ()
			onErase w ref = do
				life <- readIORef ref
				writeIORef ref (life{gen=makeGeneration})
				repaint w

			-- play starts the computation of successive generations given the current set of life cells.
			onPlay :: MenuItem -> MenuItem -> MenuItem -> Timer -> IO ()
			onPlay mplay mstep  mhalt timer = do
				set mplay   [enabled =: False]
				set mstep   [enabled =: False]
				set mhalt    [enabled =: True ]
				set timer     [enabled =: True ]

			-- onHalt stops the computation of successive generations, but does not change the current generation.
			onHalt :: MenuItem -> MenuItem -> MenuItem -> Timer -> IO ()
			onHalt mplay mstep  mhalt timer = do
				set mplay   [enabled =: True]
				set mstep   [enabled =: True]
				set mhalt    [enabled =: False]
				set timer     [enabled =: False]

			-- onNewSize changes the size in which life cells are rendered and redraws the window.
			onNewSize :: Int -> Window -> IORef Life -> IO ()
			onNewSize newSize w ref = do
				life <- readIORef ref
				oldOrigin <- get w origin
				let oldSize = cellSize life
				    newOrigin = Point ((px oldOrigin) `div` oldSize*newSize) ((py oldOrigin) `div` oldSize*newSize)
				set w [domain =: getViewDomain newSize, origin =: newOrigin]
				writeIORef ref (life{cellSize=newSize})

	-- Given the size in which to render life cells, getViewDomain calculates the corresponding ViewDomain:
			getViewDomain :: CellSize -> Size
			getViewDomain size =
				let Size w h = universe
				in Size (w*size) (h*size)

--	Program constants.

universe	= Size 2000 2000
startCellSize	= 8