Menu
▾
▴
[htoolkit-cvs] gio/src/examples/life Life.hs,NONE,1.1 Main.hs,NONE,1.1
|
From: <kr_...@us...> - 2003-07-13 10:32:19
|
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
|
