[htoolkit-cvs] gio/src/examples/worm HighScore.hs,NONE,1.1 Main.hs,NONE,1.1 WormShow.hs,NONE,1.1 WormState.hs,NONE,1.1 logo.bmp,NONE,1.1 wormhi,NONE,1.1

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

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

Added Files:
	HighScore.hs Main.hs WormShow.hs WormState.hs logo.bmp wormhi 
Log Message:
Add Worm example`


--- NEW FILE: HighScore.hs ---
module HighScore
	( HiScores, HiScore(..)
	, readHiScores
	, writeHiScores
	, itsAHighScore
	, addScore
	, showHiScores
	) where

import	Graphics.UI.GIO

type HiScores = [HiScore]
data HiScore
   = HiScore
   	{ name	:: !String
	, score	:: !Int
	}
	deriving (Show,Read)

--	Read in the high scores:
readHiScores :: FilePath -> IO HiScores
readHiScores fname = do
	content <- fmap lines (readFile fname)
	return (map read content)

--	Write the high scores:
writeHiScores :: FilePath -> HiScores -> IO ()
writeHiScores fname highs = do
	let content = map show highs
	writeFile fname (unlines content)

-- 	Determine whether, given the number of high scores, a given score is actually a new high score:
itsAHighScore :: Int -> Int -> HiScores -> Bool
itsAHighScore nrOfHiScores score' hiscores
	| score'==0			= False
	| length hiscores<nrOfHiScores	= True
	| otherwise			= any (\hiscore -> score' > score hiscore) hiscores
	

--	Add a HiScore to the current list of high scores:
addScore :: Int -> HiScore -> HiScores -> HiScores
addScore nrOfHighScores hi hiscores =
	take nrOfHighScores (addscore hi hiscores)
	where
		addscore :: HiScore -> HiScores -> HiScores
		addscore hi' hiscores@(hi:his)
			| score hi > score hi'  = hi  : addscore hi' his
			| otherwise		= hi' : hiscores
		addscore hi [] = [hi]

--	Display high scores in a modal dialog to the user:
showHiScores :: String -> HiScores -> IO ()
showHiScores header highs = do
	w <- dialog [title =: "High Scores", resizeable =: False] Nothing
	hdr <- label [title =: header] w
	btnOK <- button [title =: "OK", on command =: dismissWidget w >> return ()] w
	cs <- sequence [label [title =: show hi++". "++take 20 name++" "++show score] w
				| (hi,HiScore{name=name,score=score}) <- zip [1..] highs]
	set w [layout =: padding 10 (padding 15 hdr ^^^ column cs ^^^ padding 15 (hcenter btnOK))]
	runDialog w

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

import Graphics.UI.GIO
import WormShow
import WormState
--import Help
import HighScore
import System.Random
import Data.IORef
import Control.Monad(when)


--	GUI constants.
helpFile	= "WormHelp"
hiScoresFile	= "wormhi"
nrOfHiScores	= 8


--	Start of the program.
main :: IO ()
main = do
	hiscores <- readHiScores hiScoresFile
	start "Worm" "1.0" SDI [] (startWorm hiscores)

startWorm :: HiScores -> IO ()
startWorm best = do
	ref <- newIORef (initState best)
	
	-- Main window
	w <- window [ bgcolor    =: wormBackGroundColour
	            , bkDrawMode =: True
	            , view       =: Size 488 303
	            , on paint   =: onPaint ref
	            , on dismiss =: halt
	            , resizeable =: False
	            ]

	-- File menu
	mfile <- menu [title =: "File"] mainMenu
	mnew  <- menuitem [title =: "New",  accel =: KeyChar '\^N'] mfile
	mplay <- menuitem [title =: "Play",  accel =: KeyChar '\^P'] mfile
	menuline mfile
	mexit <- menuitem [title =: "Exit",  on command =: halt] mfile
	
	-- Options menu
	mopts <- menu [title =: "Options"] mainMenu
	mspeed <- menuRadioGroup [] mopts
	menuRadioItem [title =: "Slow",   on command =: onSetSpeed ref easySpeed  ] mspeed
	menuRadioItem [title =: "Medium", on command =: onSetSpeed ref mediumSpeed] mspeed
	menuRadioItem [title =: "Fast",   on command =: onSetSpeed ref hardSpeed  ] mspeed
	menuline mopts
	menuitem [title =: "High Scores", accel =: KeyChar '\^S', on command =: onShowBest ref] mopts
	
	-- Help menu
	mhelp <- menu [title =: "Help"] mainMenu
	menuitem [title =: "About Worm...",  on command =: onAbout] mhelp
	
	-- Timer
	tm <- timer [enabled =: False]
	set tm [on command =: onTimer ref mnew mopts mplay mexit tm w]
		
	set mplay [on command =: onPlay ref mnew mopts mplay mexit tm w]
	set mnew [on command =: onNew ref w]

onPaint ref can _ _ = do
	state <- readIORef ref
	let (State {gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives}) = state
	drawGame state can

onNew ref w = do
	modifyIORef ref (initState . best)
	repaint w

onPlay ref mnew mopts mplay mexit tm w = do
	state <- readIORef ref
	set mplay [title =: "Stop", on command =: onStop ref mnew mopts mplay mexit tm w]
	set mnew  [enabled =: False]
	set mopts [enabled =: False]
	set mexit [enabled =: False]
	set w  [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
	set tm [enabled =: True, interval =: speed (gamelevel state)]

onStop ref mnew mopts mplay mexit tm w = do
	set mplay [title =: "Play", on command =: onPlay ref mnew mopts mplay mexit tm w]
	set mnew  [enabled =: True]
	set mopts [enabled =: True]
	set mexit [enabled =: True]
	set w  [off keyboard]
	set tm [enabled =: False]
	
onHalt ref mnew mopts mplay mexit tm w = do
	onStop ref mnew mopts mplay mexit tm w 
	onNew ref w
						
onAbout = do
	logo <- readBitmap "logo.bmp" []
	runAboutDialog "Worm" "1.0" "(C) Krasimir Angelov, 2003" "The Worm is an example program\nfreely distributed with HToolkit" [] [] [] logo Nothing
	
onSetSpeed ref speed =
	modifyIORef ref (\state -> state{gamelevel=(gamelevel state){fix=speed,speed=speed}})

onShowBest ref = do
	state <- readIORef ref
	showHiScores "Worm High Scores:" (best state)

onTimer ref mnew mopts mplay mexit tm w = do
	state <- readIORef ref
	let (event,state1) = stepGame state
	writeIORef ref state1
	case event of
		IncreaseLevel -> switchLevel state1
		DecreaseLevel -> switchLevel state1
		Collide	      -> nextLife state
		_             -> drawInWindow UnBuffered w (drawStep state state1)
	where
		switchLevel :: State -> IO ()
		switchLevel state@(State {gamelevel=gamelevel}) = do
			set w [off keyboard]
			set tm [interval =: 80, on command =: betweenLevels nrAnimationSteps (-1)]
			where
				betweenLevels :: Int -> Int -> IO ()
				betweenLevels animationStep step
					| animationStep<=1 = set tm [on command =: betweenLevels 2 1]
					| animationStep<=nrAnimationSteps = do
						drawInWindow UnBuffered w (drawAnimation animationStep step)
						set tm [on command =: betweenLevels (animationStep+step) step]
					| otherwise = do
						set tm [interval =: speed gamelevel, on command =: onTimer ref mnew mopts mplay mexit tm w]
						set w [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
						repaint w

		nextLife :: State -> IO ()
		nextLife state@(State {gamelevel=gamelevel,foodsupply=foodsupply,points=points,best=best,worm=worm,lives=lives})
			| lives>0 =						
				let
					deadWorm :: Worm -> IO ()
					deadWorm (segment:rest) = do
						drawInWindow UnBuffered w (eraseSegment segment)
						set tm [on command =: deadWorm rest]
					deadWorm [] = do
						set tm [interval =: speed gamelevel, on command =: onTimer ref mnew mopts mplay mexit tm w]
						set w  [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
						repaint w
				in do
					set w  [off keyboard]
					set tm [interval =: 100, on command =: deadWorm worm]
			| itsAHighScore nrOfHighScores points best = do
				onHalt ref mnew mopts mplay mexit tm w
				refName <- newIORef ""
				dlg <- dialog [] Nothing
				lbl1 <- label [title =: "Game Over with a new high score!"] dlg
				lbl2 <- label [title =: "Your name:"] dlg
				e <- entry [] dlg
				let onOK refName dlg e = do
					get e title >>= writeIORef refName
					dismissWidget dlg
					return ()
				btnOK <- button [title =: "OK", on command =: onOK refName dlg e] dlg
				set dlg [layout =: padding 5 (lbl1 ^^^ padding 15 (lbl2 ^^^ hfill e) ^^^ hcenter btnOK)]
				runDialog dlg
				name <- readIORef refName
				when (name /= "") $ do
					let best' = addScore nrOfHighScores (HiScore name points) best
					writeHiScores hiScoresFile best'
					modifyIORef ref (\state -> state{best=best'})
			| otherwise = do
				onHalt ref mnew mopts mplay mexit tm w
				messageAlert "Game Over, no high score."

						
onKeyboard ref mnew mopts mplay mexit tm w (KeyDown key _) = do
	modifyIORef ref (\state@(State {dir=dir}) -> case key of
		KeyArrowUp    _ | dir == West  || dir == East  -> state{dir=North}
		KeyArrowDown  _ | dir == West  || dir == East  -> state{dir=South}
		KeyArrowLeft  _ | dir == North || dir == South -> state{dir=West}
		KeyArrowRight _ | dir == North || dir == South -> state{dir=East}
		_               -> state)
	onTimer ref mnew mopts mplay mexit tm w
onKeyboard ref mnew mopts mplay mexit tm w _ = return ()

{-	state <- openWindow undefined window      state
	state <- openMenu   undefined filemenu    state
	state <- openMenu   undefined optionsmenu state
	state <- openTimer  undefined timer       state
	state <- initFoodSupply (mkStdGen 0)      state
	state <- initWindowPicture 		  state
	return state
	where
		[fileID,playID,haltID,quitID,levelID,contID,windowID,timerID] = ids

		initFoodSupply :: StdGen ->  State -> GUI State State
		initFoodSupply seed state@(State {worm=worm,gamelevel=gamelevel}) = do
			let (food,foods) = newFood worm gamelevel (randoms seed)
			return state{food=food,foodsupply=foods}

		initWindowPicture :: State -> GUI State State
		initWindowPicture state = do
			drawInWindow windowID setPenFontSize
			return state
			where
				setPenFontSize :: Draw ()
				setPenFontSize = do
					font <- getPenFont					
					setPenFont font{fontSize=wormFontSize}

		filemenu = Menu "File" 
			(	MenuItem "Play"			[MenuId playID,MenuShortKey 'r',MenuFunction (noLS play)]
			:+:	MenuItem "Halt"			[MenuId haltID,MenuShortKey '.',MenuFunction (noLS halt),MenuSelectState Unable]
			:+:	MenuSeparator			[]
			:+: 	MenuItem "About Worm..."	[MenuFunction (noLS (showAbout "Worm" helpFile))]
			:+:	MenuItem "Help"			[MenuFunction (noLS (showHelp helpFile))]
			:+:	MenuSeparator			[]
			:+:	MenuItem "Quit"			[MenuId quitID,MenuShortKey 'q',MenuFunction (noLS quit)]
			)	[MenuId fileID]
		optionsmenu = Menu "Options"
			( 	RadioMenu
					[ ("Slow"  ,Nothing,Just '1',noLS (setSpeed easySpeed)  )
					, ("Medium",Nothing,Just '2',noLS (setSpeed mediumSpeed))
					, ("Fast"  ,Nothing,Just '3',noLS (setSpeed hardSpeed)  )
					] 1 []
			:+: 	MenuSeparator []
			:+:	MenuItem "High Scores" [MenuShortKey 'h',MenuFunction (noLS showBest)]
			)
			[	MenuId	levelID
			]
		window	= Window "Worm" NilLS
			[ WindowId			windowID
			, WindowClose			(noLS quit)
			, WindowKeyboard		keyFilter Unable (noLS1 makeTurn)
			, WindowPen			[PenBack wormBackGroundColour]
			, WindowViewDomain		zero{corner2=Point2{x=488,y=303}}
			, WindowLook			True (updateWindow (initState best))
			]
		timer	= Timer easySpeed NilLS [TimerId timerID, TimerSelectState Unable, TimerFunction (noLS1 oneStep)]

		--	The update function for the playfield window.
		updateWindow :: State -> SelectState -> UpdateState -> Draw ()
		updateWindow (State {gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives}) _ (UpdateState {updArea=updArea}) = do
			mapM_ unfill updArea
			drawGame gamelevel food points worm lives

		--	The function for the Play command.
		play :: State -> GUI State State
		play state = do
			disableMenus		[levelID]
			disableMenuElements	[playID,quitID]
			enableMenuElements	[haltID]
			setTimerInterval	timerID (speed (gamelevel state))
			enableWindowKeyboard	windowID
			enableTimer		timerID
			drawInWindow		windowID (drawGame initlevel newfood initpoints initworm initlives)
			setWindowCursor		windowID HiddenCursor
			return initstate
			where
				initlevel		= initLevel (fix (gamelevel state))
				initworm		= newWorm initlevel
				(newfood,foods1)	= newFood initworm initlevel (foodsupply state)
				initpoints		= 0
				initlives		= nrOfWorms
				initstate		= state
						{ gamelevel	= initlevel
						, food		= newfood
						, foodsupply	= foods1
						, grow		= 0
						, points	= initpoints
						, dir		= rightKey
						, worm		= initworm
						, lives		= initlives
						}

		--	The functions for the Halt/Continue command(s).
		halt :: State -> GUI State State
		halt state = do
			setWindowCursor		windowID StandardCursor
			disableWindowKeyboard	windowID
			disableTimer		timerID
			enableMenuElements	[quitID]
			closeMenuElements	fileID [haltID]
			openMenuElements fileID 1 undefined continue
			return state
			where
				continue = MenuItem "Continue" [MenuId contID, MenuShortKey '.', MenuFunction (noLS contf)]

				contf :: State -> GUI State State
				contf state = do
					enableWindowKeyboard	windowID
					enableTimer		timerID
					setWindowCursor		windowID HiddenCursor
					disableMenuElements	[quitID]
					closeMenuElements	fileID [contID]
					openMenuElements	fileID 1 undefined hlt
					return	state
					where
						hlt = MenuItem "Halt" [MenuId haltID, MenuShortKey '.', MenuFunction (noLS halt)]

		--	The function for the Quit command: stop the program and write the high scores to file.
		quit :: State -> GUI State State
		quit state@(State {best=best}) = do
			state <- closeProcess state
			liftIO (writeHiScores hiScoresFile best)
			return state

		--	Set a new speed (called when one of the Options commands is chosen).
		setSpeed :: Int -> State -> GUI State State
		setSpeed fix state =
			return state{gamelevel=(gamelevel state){fix=fix,speed=fix}}

		--	Show the high scores.
		showBest :: State -> GUI State State
		showBest state@(State {best=best}) = showHiScores "Worm High Scores:" best state

		--	The MakeTurn function is called when an arrow key is pressed.
		keyFilter :: KeyboardState -> Bool
		keyFilter (SpecialKey key (KeyDown _) _) = key `elem` [downKey,leftKey,rightKey,upKey]
		keyFilter _ = False

		makeTurn :: KeyboardState -> State -> GUI State State
		makeTurn (SpecialKey key _ _) state@(State {dir=dir})
			| (dir==upKey   || dir==downKey)  && (key==leftKey || key==rightKey)	= oneStep 1 state{dir=key}
			| (dir==leftKey || dir==rightKey) && (key==upKey   || key==downKey )	= oneStep 1 state{dir=key}
			| otherwise = return state

		--	The function for the Timer device: do one step of the worm game.
		oneStep :: NrOfIntervals -> State -> GUI State State
		oneStep _ state@(State {gamelevel=gamelevel,food=food,foodsupply=foodsupply,grow=grow,points=points,dir=dir,worm=worm,best=best,lives=lives})
			| newlevel/=curlevel	= switchLevel gamelevel foodsupply points2 points best lives state
			| otherwise		=
				let
					state1 = state{food=food1,foodsupply=foods1,grow=grow1,points=points2,worm=worm1}
				in
					if collide
					then nextLife state1
					else do
						drawInWindow windowID (drawStep scored food food1 points2 (head worm) hd tl)
						return state1
			where
				(hd,tl,worm1)		= stepWorm dir grow worm
				scored			= hd==pos food
				collide			= collision gamelevel worm hd
				(food1,foods1)		= if scored then (newFood worm1 gamelevel foodsupply) else (food,foodsupply)
				grow1			= if scored then (grow+((value food)*3)`div`2) else (max 0 (grow-1))
				points1			= if scored then points+(value food)*(length worm1) `div` 2 else points
				points2			= if collide then max 0 (points1-100) else points1
				curlevel		= points  `div` pointsPerLevel
				newlevel		= points2 `div` pointsPerLevel

				collision :: Level -> Worm -> Segment -> Bool
				collision level worm head
					=  (not (inRectangle head (Rectangle {corner1=Point2{x=1,y=1},corner2=Point2{x=sizeX,y=sizeY}})))
					|| (any (inRectangle head) (obstacles level))
					|| (head `elem` worm)
					where
						inRectangle :: Point2 -> Obstacle -> Bool
						inRectangle (Point2 x y) (Rectangle (Point2 lx ty) (Point2 rx by)) =
							x>=lx && x<=rx && y>=ty && y<=by

				stepWorm :: SpecialKey -> Grow -> Worm -> (Segment,Segment,Worm)
				stepWorm dir 0 worm = (hd,tl,(hd:worm1))
					where
						(tl,worm1) = getAndRemoveLast worm
						hd	   = newHead dir (head worm)

						getAndRemoveLast :: [x] -> (x,[x])
						getAndRemoveLast [x]    = (x,[])
						getAndRemoveLast (x:xs) = (x1,x:xs1)
							where 
								(x1,xs1) = getAndRemoveLast xs
				stepWorm dir _ worm = (hd,zero,hd:worm)
					where
						hd = newHead dir (head worm)

				newHead :: SpecialKey -> Segment -> Segment
				newHead key segment@(Point2 x y)
					| key==upKey	= segment{y=y-1}
					| key==downKey	= segment{y=y+1}
					| key==leftKey	= segment{x=x-1}
					| key==rightKey	= segment{x=x+1}
					| otherwise	= error ("newHead applied to unknown SpecialKey: "++show key)

				switchLevel :: Level -> [Food] -> Points -> Points -> HiScores -> Lives -> State -> GUI State State
				switchLevel curlevel foods newPoints oldPoints high lives state = do
					id <- openId
					nextLevelAnimation id newstate
					where	
						newlevel 		= (if newPoints>oldPoints then increaseLevel else decreaseLevel) curlevel
						initworm 		= newWorm newlevel
						(newfood,foods1)	= newFood initworm newlevel foods
						newstate		= State
							{ gamelevel	= newlevel
							, food		= newfood
							, foodsupply	= foods1
							, grow		= 0
							, points	= newPoints
							, dir		= rightKey
							, worm		= initworm
							, best		= high
							, lives		= if newPoints>oldPoints then lives+1 else lives-1
							}

						nextLevelAnimation :: Id -> State -> GUI State State
						nextLevelAnimation id state = do
							disableWindowKeyboard windowID
							disableTimer	      timerID					
							state <- openTimer (nrAnimationSteps,-1) (Timer (ticksPerSecond `div` 30) NilLS
													[ TimerId	id
													, TimerFunction	betweenLevels
													]) state
							return state
							where
								nrAnimationSteps= 40

								betweenLevels :: NrOfIntervals -> GUIFun (Int,Int) State
								betweenLevels _ ((animationStep,step), state@(State{gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives}))
									| animationStep<=1 = return ((2,1),state)
									| animationStep<=nrAnimationSteps = do
										drawInWindow windowID (drawAnimation animationStep step)
										return ((animationStep+step,step),state)
									| otherwise = do
										drawInWindow windowID (drawGame gamelevel food points worm lives)
										enableTimer  timerID
										closeTimer   id
										enableWindowKeyboard	windowID
										return ((animationStep,step),state)

				nextLife :: State -> GUI State State
				nextLife state@(State {gamelevel=gamelevel,foodsupply=foodsupply,points=points,best=best,worm=worm,lives=lives})
					| lives>0 =						
						let
							(newfood,foods1)= newFood newworm gamelevel foodsupply
							newworm			= newWorm gamelevel

							deadWormAlert :: Id -> Worm -> State -> GUI State State
							deadWormAlert id worm state = do
								disableTimer		timerID
								disableWindowKeyboard	windowID
								state <- openTimer worm (Timer (ticksPerSecond `div` 30) NilLS [TimerId id,TimerFunction deadWorm]) state
								return state
								where
									deadWorm :: NrOfIntervals -> GUIFun Worm State
									deadWorm _ (segment:rest,state) = do
										drawInWindow windowID (eraseSegment segment)
										return (rest,state)
									deadWorm _ (segments,state@(State {gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives})) = do
										drawInWindow windowID (drawGame gamelevel food points worm lives)
										enableTimer  timerID
										closeTimer   id
										enableWindowKeyboard windowID
										return (segments,state)
						in do
							id <- openId
							deadWormAlert id worm state{ food = newfood
										   , foodsupply = foods1
										   , grow       = 0
										   , dir        = rightKey
										   , worm       = newworm
										   , lives      = lives-1
			   							   }
					| otherwise =
						let
							dialog [overId,okId,editId]
								= Dialog "Game Over"
									(	TextControl	  "Game Over with a new high score!"	[ControlPos (Left,zero)]
									:+:	TextControl	  "Your name:"							[ControlPos (Left,zero)]
									:+:	EditControl   "" (PixelWidth (hmm 45.0)) 1			[ControlId	editId]
									:+:	ButtonControl "OK"									[ControlPos (Center,zero),ControlFunction (noLS overOK)]
									)
									[	WindowId		overId
									,	WindowOk		okId
									,	WindowItemSpace	(hmm 6.0) (vmm 6.0)
									]
								where
									overOK :: State -> GUI State State
									overOK state = do										
										(_, mb_name) <- getControlText editId
										state <- (case mb_name of
												Nothing -> error "OK button could not retrieved."
												Just name -> addscore name state)
										closeWindow overId state
										where
											addscore :: String -> State -> GUI State State
											addscore name state@(State {points=points,best=curBest})
												| null name = return state
												| otherwise = do
													let newBest = addScore nrOfHiScores (HiScore{name=name,score=points}) curBest
													return state{best=newBest}
						in do
							enableMenus [levelID]
							enableMenuElements [playID,quitID]
							disableMenuElements [haltID]
							disableTimer	timerID
							disableWindowKeyboard	windowID
							setWindowCursor	 windowID StandardCursor
							(if (itsAHighScore nrOfHiScores points best)
							 then do
								ids <- openIds 3
								openModalDialog undefined (dialog ids) state
								return state
							 else return state)
					| otherwise = do
						openModalDialog undefined (Notice ["Game Over, no high score."] (NoticeButton "OK" return) []) state
						return state
-}
--- NEW FILE: WormShow.hs ---
module WormShow
	( drawGame
	, drawStep
	, drawAnimation
	, eraseSegment
	, wormBackGroundColour
	, nrAnimationSteps
	) where

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

--	The drawing constants.
wormBackGroundColour	= lightyellow
wormFontSize		= 12 :: Int
pointsPos		= Point 72  15
lifesPos		= Point 255  5
levelPos		= Point 465 15
cornerX			= 15 :: Int
cornerY			= 23 :: Int
segSize			= 4  :: Int
cellSize		= 10 :: Int
nrAnimationSteps        = 40 :: Int

--	Draw the game.
drawGame :: State -> Canvas -> IO ()
drawGame (State {gamelevel=Level {level=level,obstacles=obstacles},food=food,points=points,worm=worm,lives=lives}) can = do
	drawBorders             can
	drawObstacles obstacles can
	drawPoints    points    can
	drawWorm      worm      can
	drawFood      food      can
	drawLevel     level     can
	drawLives     lives     can
	where
		drawObstacles :: [Obstacle] -> Canvas -> IO ()
		drawObstacles [] can = return ()
		drawObstacles obstacles can = do
			setCanvasPen can [color =: purple]
			mapM_ drawObstacle obstacles
			setCanvasPen can [color =: black]
			where
				drawObstacle :: Obstacle -> IO ()
				drawObstacle (Rect ltx lty rbx rby) =
					fillRect (Rect lx ty rx by) can
					where
						lx = cornerX+cellSize*ltx-2
						ty = cornerY+cellSize*lty-2
						rx = cornerX+cellSize*rbx+2
						by = cornerY+cellSize*rby+2

		drawPoints :: Points -> Canvas -> IO ()
		drawPoints points can = do
			setCanvasPen can [color =: magenta]
			drawString pointsPos{px=(px pointsPos) - 57} "Points: " can
			setCanvasPen can [color =: black]
			drawString pointsPos (show points) can

		drawWorm :: Worm -> Canvas -> IO ()
		drawWorm [] can = return ()
		drawWorm (head:rest) can = do
			mapM_ (\s -> drawSegment red s can) rest
			drawSegment lightgreen head can
			setCanvasPen can [color =: black]

		drawLevel :: Int -> Canvas -> IO ()
		drawLevel level can = do
			setCanvasPen can [color =: magenta]
			drawString levelPos{px=px levelPos-50} "Level: " can
			setCanvasPen can [color =: black]
			drawString levelPos (show level) can

		drawLives :: Lives -> Canvas -> IO ()
		drawLives lives can
			| lives /= 0 = drawLittleWorms lives can
			| otherwise  = do
				setCanvasPen can [color =: magenta]
				drawString (Point (lx-63) (ly+10)) "No more worms!" can
				setCanvasPen can [color =: black]
			where
				Point lx ly = lifesPos

				drawLittleWorms :: Lives -> Canvas -> IO ()
				drawLittleWorms lives can
					| lives>0 = do
						drawLittleWorm   lives can
						drawLittleWorms (lives-1) can
					| otherwise = do
						setCanvasPen can [color =: magenta]
						drawString (Point (lx-63) (ly+10)) "Worms:" can
						setCanvasPen can [color =: black]
					where
						drawLittleWorm :: Int -> Canvas -> IO ()
						drawLittleWorm n can = do
							setCanvasPen can [thickness=:5, color =: red]
							drawLine (Point x y) (Point (x+9) y) can
							setCanvasPen can [color =: lightgreen]
							drawLine (Point (x+9) y) (Point (x+14) y) can
							setCanvasPen can [thickness=:1, color =: black]
							where
								x	   	  = lx+20*((n-1) `div` 2)
								y		  = ly+ 7*((n-1) `mod` 2)


drawBorders :: Canvas -> IO ()
drawBorders can = do
	setCanvasPen can [color=:black, thickness=:3]
	drawRect (Rect (cornerX-3) (cornerY-3) (cornerX+sizeX*cellSize+11) (cornerY+sizeY*cellSize+11)) can
	setCanvasPen can [thickness=:1]

drawSegment :: Color -> Segment -> Canvas -> IO ()
drawSegment c (Point x y) can = do
	setCanvasPen can [color=:c]
	fillCircle (Point (cornerX+cellSize*x) (cornerY+cellSize*y)) segSize can

eraseSegment :: Segment -> Canvas -> IO ()
eraseSegment segment = drawSegment wormBackGroundColour segment

drawFood :: Food -> Canvas -> IO ()
drawFood (Food _ (Point x y)) can = do
	setCanvasPen can [color=:magenta]
	fillRect (Rect x1 y1 (x1+6) (y1+6)) can
	setCanvasPen can [color=:black]
	where
		x1	= cornerX+cellSize*x-3
		y1	= cornerY+cellSize*y-3
		
eraseFood :: Food -> Canvas -> IO ()
eraseFood (Food _ (Point x y)) can = do
	setCanvasPen can [color=:yellow]
	fillRect (Rect x1 y1 (x1+6) (y1+6)) can
	setCanvasPen can [color=:black]
	where
		x1	= cornerX+cellSize*x-3
		y1	= cornerY+cellSize*y-3
	

--	Show a step of the worm.
drawStep :: State -> State -> Canvas -> IO ()
drawStep (State{food=oldfood,worm=oldworm}) (State{food=newfood,worm=newworm,points=points}) can = do
	eraseFood  oldfood can
	drawFood   newfood can
	drawString pointsPos (show points) can
	drawSegment  red (head oldworm) can
	drawSegment  lightgreen (head newworm) can
	when (length oldworm == length newworm) (drawSegment wormBackGroundColour (last oldworm) can)
	setCanvasPen can [color=:black]


--	Close the Playfield between two levels.
drawAnimation :: Int -> Int -> Canvas -> IO ()
drawAnimation 40 1 can = drawBorders  can
drawAnimation n step can
	| step<0 = do
		setCanvasPen can [color=:wormBackGroundColour]
		fillRect (Rect l b x y) can
		fillRect (Rect r t x y) can
		setCanvasPen can [color=:black, thickness=:3]
		drawRect (Rect l t r b) can
	| otherwise = do
		setCanvasPen can [color=:wormBackGroundColour]
		fillRect (Rect l b x     (y-4)) can
		fillRect (Rect r t (x-4) y    ) can
		setCanvasPen can [color=:black, thickness=:3]
		drawRect (Rect l t r b) can
	where
		l	= cornerX-3
		t	= cornerY-3
		r	= l+w*n
		b	= t+h*n 
		x	= r-step*w
		y	= b-step*h 
		w	= (48+sizeX*cellSize) `div` nrAnimationSteps
		h	= (48+sizeY*cellSize) `div` nrAnimationSteps

--- NEW FILE: WormState.hs ---
module WormState
	( -- data structures
	  State(..)
	, Direction(..)
	, Level(..)
	, Food(..)
	, GameEvent(..)
	
	  -- type aliases
	, Grow, Obstacle, Segment, Worm, Points, Lives
	
	  -- constants
	, sizeX, sizeY

	, nrOfWorms, nrOfLevels, nrOfHighScores
	, pointsPerLevel
	, startLevel
	, easySpeed, mediumSpeed, hardSpeed
	, accelation
	
	, initState
	, stepGame
	) where

import	Graphics.UI.GIO
import	HighScore
import  Random


--	The worm data types.

data State
   = State
	{ gamelevel	:: Level
	, food		:: Food
	, foodsupply	:: [Food]
	, grow		:: Grow
	, points	:: Points
	, dir		:: Direction
	, worm		:: Worm
	, best		:: HiScores
	, lives		:: Lives
	}
data Direction
   = North | West | East | South deriving Eq
data Level
   = Level
	{ fix		:: Int
	, speed		:: Int
	, level		:: Int
	, obstacles	:: [Obstacle]
	}
data Food = Food Int Point
type Grow		= Int
type Obstacle 		= Rect
type Segment		= Point
type Worm		= [Segment]
type Points		= Int
type Lives		= Int

data GameEvent
   = Scored | Collide | IncreaseLevel | DecreaseLevel | None deriving Show

sizeX			= 45 :: Int
sizeY			= 26 :: Int

nrOfWorms		= 4   :: Int
nrOfLevels		= 8   :: Int
nrOfHighScores		= 10  :: Int
pointsPerLevel		= 500 :: Int
startLevel		= 0   :: Int

easySpeed		= 300 :: Int
mediumSpeed		= 200 :: Int
hardSpeed		= 100 :: Int
accelation		= 100 :: Int


--	Initial State.
initState :: HiScores -> State
initState best =
	State
	  { gamelevel	= initlevel
	  , food	= food
	  , foodsupply	= foodsupply
	  , grow	= 0
	  , points	= 0
	  , dir		= East
	  , worm	= initworm
	  , best	= best
	  , lives	= nrOfWorms
	  }
	where
		(food,foodsupply) = newFood initworm initlevel (randoms (mkStdGen 0))
		initlevel	  = initLevel easySpeed
		initworm	  = newWorm initlevel

stepGame :: State -> (GameEvent,State)
stepGame state@(State { gamelevel=curlevel
	              , food=food@(Food value pos)
	              , foodsupply=foodsupply
	              , grow=grow
	              , points=points
	              , dir=dir
	              , worm=worm
	              , best=best
	              , lives=lives
	              })
	| levelpoints > levelpoints1 = 
		let
			newlevel            = decreaseLevel curlevel
			(food1,foodsupply1) = newFood worm1 newlevel foodsupply
			initworm            = newWorm newlevel
		in (DecreaseLevel,state
			{ food=food1
			, foodsupply=foodsupply1
			, grow=0
			, points=points1
			, worm=initworm
			, gamelevel=newlevel
			, dir=East
			, lives=lives-1
			})
	| levelpoints1 > levelpoints =
		let
			newlevel            = increaseLevel curlevel
			(food1,foodsupply1) = newFood worm1 newlevel foodsupply
			initworm            = newWorm newlevel
		in (IncreaseLevel,state
			{ food=food1
			, foodsupply=foodsupply1
			, grow=0
			, points=points1
			, worm=initworm
			, gamelevel=newlevel
			, dir=East
			, lives=lives+1
			})
	| scored    = 
		let
			(food1,foodsupply1) = newFood worm1 curlevel foodsupply
		in (Scored,state
			{ food=food1
			, foodsupply=foodsupply1
			, grow=grow1
			, points=points1
			, worm=worm1
			})
	| collide= (Collide,state
			{ grow=0
			, points=points1
			, worm=newWorm curlevel
			, dir=East
			, lives=lives-1
			})
	| otherwise = (None,state
			{ grow=grow1
			, worm=worm1
			})
	where
		levelpoints  = points  `div` pointsPerLevel
		levelpoints1 = points1 `div` pointsPerLevel
		
		hd    = newHead dir (head worm)
		
		worm1   | grow == 0 = hd : init worm
		        | otherwise = hd : worm
		
		grow1   | scored = grow+(value*3) `div` 2
		        | otherwise = max 0 (grow-1)
		
		points1 | scored    = points+value*(length worm1) `div` 2
		        | collide   = max 0 (points-100)
		        | otherwise = points
		   	      
		collide =  (not (pointInRect hd (Rect 1 1 sizeX sizeY)))
			|| (any (pointInRect hd) (obstacles curlevel))
		        || (hd `elem` worm)
		        
		scored = hd == pos

		newHead :: Direction -> Segment -> Segment
		newHead North (Point x y) = Point x (y-1)
		newHead South (Point x y) = Point x (y+1)
		newHead West  (Point x y) = Point (x-1) y
		newHead East  (Point x y) = Point (x+1) y
		
					
--	Make a new initial worm.
newWorm :: Level -> Worm
newWorm Level{level=level} =
	[Point x y | x<-[5,4..1]]
	where
		y = startHeights !! (level `mod` nrOfLevels)

startHeights :: [Int]
startHeights = [13,5,13,13,13,1,1,14]


--	Construct the next level.
initLevel :: Int -> Level
initLevel fix =
	Level {fix=fix,speed=fix,level=startLevel,obstacles=sampleObstacles!!startLevel}

decreaseLevel :: Level -> Level
decreaseLevel curlevel@(Level {speed=speed,level=level}) =
	let
		newLevel = level-1
	  	newSpeed = if level `mod` nrOfLevels==0 && level/=0 then speed+accelation else speed
	in
		curlevel
		  { fix		= newSpeed
		  , speed	= newSpeed
		  , level	= newLevel
		  , obstacles	= sampleObstacles !! (newLevel `mod` nrOfLevels)
	  	  }

increaseLevel :: Level -> Level
increaseLevel curlevel@(Level {speed=speed,level=level}) =
	let
		newLevel = level+1
		newSpeed = if level `mod` nrOfLevels==0 && level/=0 then speed-accelation else speed
	in
		curlevel
		  { fix		= newSpeed
		  , speed	= newSpeed
		  , level	= newLevel
		  , obstacles	= sampleObstacles !! (newLevel `mod` nrOfLevels)
	  	  }

sampleObstacles :: [[Obstacle]]
sampleObstacles =
		[ []
	    	, [Rect 12 11 34 16]
	    	, [Rect 12  1 34  3, Rect 12 24 34 26]
		, [Rect  7  7 38  9, Rect  7 17 38 19]
		, [Rect  1  1 18 10, Rect 28 17 45 26]
		, [Rect 14  3 15 24, Rect 30  3 31 24]
		, [Rect  3 13 43 14, Rect 22  3 24 24]
		, [Rect  3  3 20 12, Rect 26 15 43 24]
		]

--	Generate a food supply.
instance Random Food where  
	random seed = (Food value pos, seed3)
		where
			(random1,seed1)	= random seed
			(random2,seed2)	= random seed1
			(random3,seed3)	= random seed2
			foodx		= (incMod random2 (sizeX-2))+1
			foody		= (incMod random3 (sizeY-2))+1
			pos		= Point foodx foody
			value		= incMod random1 9

			incMod a b	= (a `mod` b)+1

	randomR _ seed = random seed

--	Think of some new random food.
newFood :: Worm -> Level -> [Food] -> (Food, [Food])
newFood worm level@(Level {obstacles=obstacles}) (food@(Food _ pos):foods)
	| pos `elem` worm || any (pointInRect pos) obstacles = newFood worm level foods
	| otherwise					     = (food, foods)

--- NEW FILE: logo.bmp ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: wormhi ---
HiScore {name = "Krasimir Angelov", score = 200000}
HiScore {name = "Ivanka Ivanova", score = 190000}
HiScore {name = "Krasimir Angelov", score = 57}