Shu-thing-1.0.20071203: Shu-thing.hs
{-# OPTIONS_GHC -fbang-patterns #-}
module Main (main)
where
import Control.Exception (Exception(ExitException), catch, throwIO)
import Control.Monad (zipWithM_)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
import Data.List (nub)
import Data.Maybe (isJust, fromJust)
import Graphics.UI.GLUT (DisplayMode(RGBMode, DoubleBuffered),
getArgsAndInitialize, initialDisplayMode, initialWindowSize, mainLoop,
createWindow, destroyWindow, swapBuffers, Menu(..), MenuItem(MenuEntry),
attachMenu, Font(renderString), StrokeFont(Roman), Flavour(Wireframe),
Object(Tetrahedron, Teapot, Octahedron, Icosahedron, Dodecahedron),
renderObject, MouseButton(LeftButton,RightButton), Key(SpecialKey, Char), KeyState(..),
SpecialKey(KeyUp, KeyRight, KeyLeft, KeyDown), displayCallback,
keyboardMouseCallback, TimerCallback, addTimerCallback, MatrixComponent(..),
MatrixMode(Projection, Modelview), Position(..), Size(..), Vector3(..),
loadIdentity, matrixMode, preservingMatrix, viewport,
ClearBuffer(DepthBuffer, ColorBuffer), clear, HasSetter(..), lookAt,
perspective, Color(color), Color3(..), Vertex3(..))
import Prelude hiding (catch)
import System.Exit (ExitCode(ExitSuccess))
main :: IO ()
main = do
keystate <- newIORef []
cp <- newIORef $ openingProc keystate
initialWindowSize $= Size 1200 800
initialDisplayMode $= [RGBMode,DoubleBuffered]
getArgsAndInitialize
wnd <- createWindow "Shu-thing"
displayCallback $= dispProc cp
keyboardMouseCallback $= Just (keyProc keystate)
addTimerCallback 24 $ timerProc $ dispProc cp
attachMenu LeftButton (Menu [
MenuEntry "&Exit" exitLoop])
attachMenu RightButton (Menu [
MenuEntry "&Exit" exitLoop])
initMatrix
mainLoop
destroyWindow wnd
`catch` (\_ -> return ())
exitLoop :: IO a
exitLoop = throwIO $ ExitException ExitSuccess
initMatrix :: IO ()
initMatrix = do
viewport $= (Position 0 0,Size 1200 800)
matrixMode $= Projection
loadIdentity
perspective 30.0 (4/3) 600 1400
lookAt (Vertex3 0 0 (927 :: Double)) (Vertex3 0 0 (0 :: Double)) (Vector3 0 1 (0 :: Double))
dispProc :: IORef (IO Scene) -> IO ()
dispProc !cp = do
m <- readIORef cp
Scene next <- m
writeIORef cp next
data Scene = Scene (IO Scene)
openingProc :: IORef [Key] -> IO Scene
openingProc !ks = do
keystate <- readIORef ks
clear [ColorBuffer,DepthBuffer]
matrixMode $= Modelview 0
loadIdentity
color $ Color3 (1.0 :: Double) 1.0 1.0
preservingMatrix $ do
translate $ Vector3 (-250 :: Double) 0 0
scale (0.8 :: Double) 0.8 0.8
renderString Roman "shu-thing"
preservingMatrix $ do
translate $ Vector3 (-180 :: Double) (-100) 0
scale (0.4 :: Double) 0.4 0.4
renderString Roman "Press Z key"
swapBuffers
if Char 'z' `elem` keystate then do
gs <- newIORef initialGameState
return $ Scene $ mainProc gs ks
else return $ Scene $ openingProc ks
endingProc :: IORef [Key] -> IORef Double -> IO Scene
endingProc !ks !ctr= do
keystate <- readIORef ks
counter <- readIORef ctr
modifyIORef ctr $ min 2420 . (+1.5)
clear [ColorBuffer,DepthBuffer]
matrixMode $= Modelview 0
loadIdentity
color $ Color3 (1.0 :: Double) 1.0 1.0
zipWithM_ (\str pos -> preservingMatrix $ do
translate $ Vector3 (-180 :: Double) (-240+counter-pos) 0
scale (0.3 :: Double) 0.3 0.3
renderString Roman str)
stuffRoll [0,60..]
swapBuffers
if Char 'x' `elem` keystate then do
return $ Scene $ openingProc ks
else return $ Scene $ endingProc ks ctr
where
stuffRoll = [
"",
"Game Design",
" T. Muranushi",
"",
"Main Programmer",
" H. Tanaka",
"",
"Enemy Algorithm",
" M. Takayuki",
"",
"Graphics Designer",
" Euclid",
"",
"Monad Designer",
" tanakh",
"",
"Lazy Evaluator",
" GHC 6.8",
"",
"Cast",
" Player Dodecahedron",
" Bullet Tetrahedron",
" Enemy Octahedron",
" Boss Teapot",
"",
"Special thanks to",
" Simon Marlow",
" Haskell B. Curry",
"",
"Presented by",
" team combat",
"",
"WE LOVE HASKELL!",
"",
" press x key"]
mainProc :: IORef GameState -> IORef [Key] -> IO Scene
mainProc !gs !ks = do
keystate <- readIORef ks
modifyIORef gs $ updateGameState keystate
gamestate <- readIORef gs
clear [ColorBuffer,DepthBuffer]
matrixMode $= Modelview 0
loadIdentity
renderGameState gamestate
swapBuffers
if (isGameover gamestate) then return $ Scene $ openingProc ks else
if (isClear gamestate) then do
counter <- newIORef (0.0 :: Double)
return $ Scene $ endingProc ks counter else
return $ Scene $ mainProc gs ks
timerProc :: IO a -> TimerCallback
timerProc m = m >> addTimerCallback 16 (timerProc m)
keyProc :: IORef [Key] -> Key -> KeyState -> t -> t1 -> IO ()
keyProc keystate !key !ks _ _ =
case (key,ks) of
(Char 'q',_) -> exitLoop
(Char 'c',_) -> exitLoop
(_,Down) -> modifyIORef keystate $ nub . (++[key])
(_,Up) -> modifyIORef keystate $ filter (/=key)
bosstime, bosstime2 :: Int
bosstime = 6600
bosstime2 = 7200
data GameObject = Player {position :: !Point,shotEnergy :: !Double,hp :: !Double}|
Bullet {position :: !Point} |
EnemyMaker {timer :: !Int,deathtimer :: !Int}|
Enemy {position :: !Point,hp :: !Double,anime :: !Int,enemySpec :: !EnemySpec} |
Explosion {position :: !Point,hp :: !Double,size :: !Double}|
EnemyBullet {position :: !Point,velocity :: !Point} |
GameoverSignal |
ClearSignal
deriving (Eq)
data EnemySpec = EnemySpec {ways :: !Int,spread :: !Double,speed :: !Double,freq :: !Int,endurance :: !Double,boss :: !Bool}
deriving (Eq)
updateObject :: GameState -> [Key] -> GameObject -> [GameObject]
updateObject _ !ks (!Player{position=pos,shotEnergy=sen,hp=oldhp})
= [(Player{position=newPos,shotEnergy=nsen,hp=newhp})] ++ shots
where
newPos :: Point
newPos = if (oldhp > 0) then (nx,ny) +++ v
else (nx,ny)
newhp = oldhp
(x,y) = pos
nx = if (x < (-310)) then -310 else if (x > 310) then 310 else x
ny = if (y < (-230)) then -230 else if (y > 200) then 200 else y
v = (vx,vy) *++ (5.0 :: Double)
shots = replicate shotn $ Bullet pos
nsen = if (shotn /= 0) then (-1.0) else
if (shotmode == 1 && shotn == 0) then (sen+0.25) else
if(shotmode == 0) then 0.0 else
sen
vx :: Double
vx =
if ((SpecialKey KeyLeft) `elem` ks) then -1 else 0 +
if ((SpecialKey KeyRight) `elem` ks) then 1 else 0
vy =
if ((SpecialKey KeyUp) `elem` ks) then 1 else 0 +
if ((SpecialKey KeyDown) `elem` ks) then -1 else 0
shotmode :: Int
shotmode =
if ((Char 'z') `elem` ks) then 1 else 0
shotn :: Int
shotn = if (oldhp <= 0) then 0 else if (shotmode == 0) then 0 else
if (sen >= 0) then 1 else 0
updateObject _ _ (!Bullet{position=pos}) = replicate n (Bullet newpos) where
newpos = pos +++ (0.0,15.0)
n = if( (\(_,y) -> y > 250) pos)then 0 else 1
updateObject !gs _ (!EnemyMaker{timer=t,deathtimer=dtime}) =
[EnemyMaker{timer=t+1,deathtimer=newdtime}] ++ enemies ++ deatheffects where
enemies = replicate n $ Enemy{position = (320*sin(dt*dt),240),hp=1.0,anime=0,enemySpec = spec}
dt :: Double
dt = fromIntegral t
newdtime = dtime + if (hp p<=0 || (bossExist&&hp b<=0)) then 1 else 0
n = if((t`mod`120==0 && t<=bosstime) || t==bosstime2) then 1 else 0
deatheffects = if(dtime==0) then [] else
if(dtime==120) then [Explosion{position=position deadone,hp=1.0,size=3.0*deathradius}] else
if(dtime==130) then [Explosion{position=position deadone,hp=1.0,size=3.0*deathradius}] else
if(dtime==140) then [Explosion{position=position deadone,hp=1.0,size=3.0*deathradius}] else
if(dtime==240) then [if(hp p<=0) then GameoverSignal else ClearSignal] else
if(dtime>120) then [] else
if(dtime`mod`15/=0)then [] else
[Explosion{position=position deadone +++ ((sin(dt),cos(dt))*++ (16*deathradius)),hp=1.0,size=0.3*deathradius}]
p = findplayer gs
b = fromJust mayb
deadone :: GameObject
deadone = if(hp p<=0) then p else b
deathradius = if(hp p<=0) then 1 else 3
bossExist = isJust mayb
mayb = findBoss gs
spec = if(t==bosstime2) then (EnemySpec{ways=0,spread=0.1,speed=3.0,freq=10,endurance=300.0,boss=True})
else speclist !! (t `div` 600)
speclist = [
EnemySpec {ways=0,spread=0.1,speed=3.0,freq=30,endurance=2.0,boss=False},
EnemySpec {ways=1,spread=0.3,speed=5.0,freq=60,endurance=4.0,boss=False},
EnemySpec {ways=3,spread=0.7,speed=0.2,freq=90,endurance=8.0,boss=False},
EnemySpec {ways=45,spread=0.069,speed=8.0,freq=450,endurance=1.0,boss=False},
EnemySpec {ways=0,spread=0.1,speed=1.0,freq=10,endurance=10.0,boss=False},
EnemySpec {ways=0,spread=0.1,speed=1.0,freq=10,endurance=10.0,boss=False},
EnemySpec {ways=3,spread=0.1,speed=3.0,freq=60,endurance=6.0,boss=False},
EnemySpec {ways=1,spread=0.5,speed=7.0,freq=45,endurance=3.0,boss=False},
EnemySpec {ways=(10),spread=0.3,speed=15.0,freq=115,endurance=5.0,boss=False}
] ++
map (\o -> EnemySpec {ways=o,spread=0.1,speed=4.0,freq=20,endurance=3.0,boss=False}) [0,1 ..]
updateObject !gs _ !oldenemy@(Enemy{position=pos,hp=oldhp,anime=oldanime,enemySpec=spec}) =
replicate n (oldenemy{position=newpos,hp=newhp,anime=newanime,enemySpec=newspec})
++ shots ++ explosions where
newpos = if isBoss then (200 * sin(danime/100),200 + 40 * cos(danime/80))
else pos +++ (0.0,-1.0)
newhp = oldhp
newanime = oldanime + 1
newspec = if(not isBoss) then spec else
if (oldhp>0.75) then EnemySpec{ways=0,spread=0.1,speed=5.0,freq=10,endurance=300.0,boss=True} else
if (oldhp>0.50) then EnemySpec{ways=8,spread=0.15,speed=3.0,freq=30,endurance=300.0,boss=True} else
if (oldhp>0.25) then EnemySpec{ways=2,spread=1.2,speed=15.0,freq=10,endurance=300.0,boss=True} else
if (oldhp>0.05) then EnemySpec{ways=40,spread=0.075,speed=3.0,freq=60,endurance=400.0,boss=True} else
if (oldhp>0.00) then EnemySpec{ways=15,spread=0.2,speed=16.0,freq=20,endurance=900.0,boss=True} else
EnemySpec{ways=(-1),spread=0.1,speed=3.0,freq=10,endurance=300.0,boss=True}
danime :: Double
danime = fromIntegral oldanime
explosions = if(oldhp<=0 && not isBoss) then [Explosion{position=pos,hp=1.0,size=1.0}] else []
shots = if(oldanime`mod` frq /=(frq-1)) then [] else
map (\v -> EnemyBullet{position=pos,velocity=v}) vs
vs = (take (wa+1) $ iterate (vdistr***) centerv) ++
(take wa $ tail $ iterate (vdistrc***) centerv)
centerv = (pp -+- pos) *++ (spd / (distance pp pos))
vdistr :: Point
vdistr = (cos(sprd),sin(sprd))
vdistrc :: Point
vdistrc = (cos(sprd),-sin(sprd))
pp = playerpos gs
n = if( (\(_,y) -> y<(-250)) pos || (not isBoss && oldhp<=0))then 0 else 1
wa = ways spec
spd= speed spec
frq = freq spec
sprd= spread spec
isBoss = boss spec
updateObject _ _ !e@(Explosion{}) = if(hp e>0) then [e{hp=hp e - (0.024/(size e))}] else []
updateObject _ _ !eb@(EnemyBullet{}) = if(outofmap (position eb)) then [] else
[eb{position=position eb+++velocity eb}]
updateObject _ _ go = [go]
watcher :: [GameObject] -> [GameObject]
watcher os = np ++ ne ++ nb ++ neb ++ others
where
ne = foldr ($) enemies $ map enemyDamager bullets
np = foldr ($) players $ map playerDamager ebullets
nb = foldr ($) bullets $ map bulletEraser enemies
neb = foldr ($) ebullets $ map ebEraser players
bulletEraser :: GameObject -> [GameObject] -> [GameObject]
bulletEraser e = filter (\b -> (distance2 (position b) (position e)) > hitr(e))
enemyDamager :: GameObject -> [GameObject] -> [GameObject]
enemyDamager b = map (\e ->
if ((distance2 (position b) (position e)) > hitr(e))
then e
else (\d -> d{hp=hp d-(1.0 / (endurance (enemySpec d)))}) e)
hitr e = if(boss $ enemySpec e) then sq 100 else sq 32
playerDamager :: GameObject -> [GameObject] -> [GameObject]
playerDamager eb = map (\p ->
if((distance2 (position p) (position eb)) > 70)
then p
else (\q -> q{hp=hp q-0.3}) p)
ebEraser p = filter (\eb -> (distance2 (position eb) (position p)) > 70)
(enemies,bullets,ebullets,players,others) = foldl f ([],[],[],[],[]) os
f (e,b,eb,p,x) o = case o of
Enemy{} -> (o:e,b,eb,p,x)
Bullet{} -> (e,o:b,eb,p,x)
EnemyBullet{} -> (e,b,o:eb,p,x)
Player{} -> (e,b,eb,o:p,x)
_ -> (e,b,eb,p,o:x)
renderGameObject :: GameObject -> IO ()
renderGameObject !Player{position=pos,hp=h} = preservingMatrix $ do
let (x,y) = pos
color (Color3 (1.0 :: Double) h h)
translate (Vector3 x y 0)
scale (10 :: Double) 10 10
rotate (x) (Vector3 0 1 0)
rotate (30 :: Double) (Vector3 0 0 1)
renderObject Wireframe Dodecahedron
renderGameObject !Bullet{position=pos} = preservingMatrix $ do
let (x,y) = pos
color (Color3 (0.6 :: Double) 0.6 1.0)
translate (Vector3 x y 0)
scale (4 :: Double) 18 8
rotate (45 :: Double) (Vector3 0 1 0)
rotate (90 :: Double) (Vector3 1 0 0)
renderObject Wireframe Tetrahedron
renderGameObject !Enemy{position=pos,anime=a,hp=h,enemySpec=EnemySpec{boss=False}} = preservingMatrix $ do
let (x,y) = pos
color (Color3 (cos rho) (sin rho) (0.0 :: Double))
translate (Vector3 x y 0)
rotate (2*(theta :: Double)) (Vector3 0 1.0 0)
scale (32 :: Double) 32 8
renderObject Wireframe Octahedron where
theta = fromIntegral a
rho = h * 3.14 / 2
renderGameObject !Enemy{position=pos,anime=a,hp=h,enemySpec=EnemySpec{boss=True}} = preservingMatrix $ do
let (x,y) = pos
color (Color3 (cos rho) (sin rho) (0.0 :: Double))
translate (Vector3 x y 0)
rotate (2*(theta :: Double)) (Vector3 0 1.0 0)
scale (120 :: Double) 120 120
renderObject Wireframe (Teapot 1.0) where
theta = fromIntegral a
rho = h * 3.14 / 2
renderGameObject !Explosion{position=pos,hp=h,size=s}= preservingMatrix $ do
let (x,y) = pos
color (Color3 h 0.0 0.0)
translate (Vector3 x y 0)
rotate (720*h) (Vector3 0 1.0 0)
rotate (540*h) (Vector3 1.0 0 0)
scale r r r
renderObject Wireframe Icosahedron where
r = s*(100 - h*h*80)
renderGameObject !EnemyBullet{position=pos} = preservingMatrix $ do
let (x,y) = pos
color (Color3 (1.0 :: Double) 1.0 1.0)
translate (Vector3 x y 0)
scale (5 :: Double) 5 5
rotate (45 :: Double) (Vector3 0 0 (1.0 :: Double))
renderObject Wireframe Tetrahedron
renderGameObject _ = return ()
data GameState = GameState {objects :: [GameObject]}
initialGameState :: GameState
initialGameState = GameState{objects=
[(Player{position=(0.0,0.0),shotEnergy=0.0,hp=1.0}),(EnemyMaker{timer=0,deathtimer=0})]}
renderGameState :: GameState -> IO ()
renderGameState !GameState{objects=os} = mapM_ renderGameObject os
updateGameState :: [Key] -> GameState -> GameState
updateGameState !ks !gs@(GameState { objects=os }) = newgs where
newgs = GameState{objects = watcher $ concatMap (updateObject gs ks) os}
playerpos :: GameState -> Point
playerpos = position . findplayer
findplayer :: GameState -> GameObject
findplayer !GameState{objects=os} = player where
[player] = filter (\o -> case o of
Player{} -> True
_ -> False) os
findBoss :: GameState -> Maybe GameObject
findBoss GameState{objects=os} = if (length bosses==0) then Nothing
else Just (head bosses) where
bosses = filter(\o -> case o of
Enemy{} -> boss( enemySpec o)
_ -> False) os
isGameover :: GameState -> Bool
isGameover GameState{objects=os} = (GameoverSignal `elem` os)
isClear :: GameState -> Bool
isClear GameState{objects=os} = (ClearSignal `elem` os)
type Point = (Double,Double)
(+++) :: (Double, Double) -> (Double, Double) -> (Double, Double)
(ax,ay) +++ (bx,by) = (ax+bx, ay+by)
(-+-) :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
(!ax,!ay) -+- (!bx,!by) = (ax-bx,ay-by)
(*++) :: (Num t) => (t, t) -> t -> (t, t)
(!ax,!ay) *++ (!s) = (ax*s,ay*s)
(***) :: (Num t) => (t, t) -> (t, t) -> (t, t)
(!ax,!ay) *** (!bx,!by) = (ax*bx-ay*by,ay*bx+ax*by)
sq :: Double -> Double
sq !x = x*x
distance, distance2 :: Point -> Point -> Double
distance a b= sqrt $ distance2 a b
distance2 !(ax,ay) !(bx,by) = sq(ax-bx) + sq(ay-by)
outofmap :: Point -> Bool
outofmap !(x,y) = (not $ abs x < 320) || (not $ abs y < 240)