Just a game

game.hs

import System.Exit
import Graphics.UI.GLUT
import Control.Monad
import Control.Applicative
import Control.Arrow
import Control.Concurrent
import Graphics.Rendering.OpenGL 
import Data.IORef
import Data.List
import Data.Maybe
initial = ((0,0),(0.005,-0.03),(0,0),([(-0.4,-0.9),(-0.4,-0.85),(0.4,-0.85),(0.4,-0.9),(-0.4,-0.9)],(0,0)),liftM2 (,) [-0.9,-0.7..0.9] [0.5,0.7,0.9])
ws = dzip [(-1,-1),(-1,1),(1,1),(1,-1)] ; r = 0.1 :: GLfloat
main = getArgsAndInitialize >> initialWindowSize $= Size 777 777 >> initialWindowPosition $= Position 100 100 >> initialDisplayMode $= [DoubleBuffered] >> createWindow "ursula" >> 
	newIORef initial >>= \ior -> keyboardMouseCallback $= Just (kbd ior) >> displayCallback $= dlay ior >> idleCallback $= Just (anime ior) >> mainLoop
dlay ior = clearColor $= Color4 1 1 1 1 >> clear [ColorBuffer] >> readIORef ior >>= drawDoxyq >> swapBuffers
kbd _ (Char 'q') Down _ _ = exitWith ExitSuccess			
kbd s (Char x) Down _ _   = modifyIORef' s $ \(a,b,t,(d,e),cs) -> (a,b,t,(d,(if x == '[' then -0.05 else if x == ']' then 0.05 else fst e,0)),cs)
kbd _ _ _ _ _ = return ()
draw c = renderPrimitive c . mapM_ (vertex . uncurry Vertex2)
touch xy s xy' = guard ((xy ==== xy') <= r+r && (s .*. (xy.-.xy')) <= 0) >> Just (xy.-.xy')
drawDoxyq ((x,y),_,(t,_),(bd,_),cs) = currentColor $= Color4 0.3 0.4 0.8 0 >> mapM_ (mapM_ (draw LineLoop) . sta) cs >> 
	currentColor $= Color4 0.7 0.1 0.2 1 >> mapM_ (draw LineStrip) swa >> currentColor $= Color4 0 0 0 1 >> draw Polygon bd  where
	swa = [[(x,y),(x + r/1.8*cos (th+pi/4),y + r/1.8*sin (th+pi/4)),(x + r/1.2*cos th,y + r/1.2*sin th)] | th <- [t,t+pi/2..t+1.6*pi]]
	sta (x,y) = [[(x,y+r/2),(x-r/2,y-r/2),(x+r/2,y-r/2)],[(x+r/2,y+r/2-0.03),(x-r/2,y+r/2-0.03),(x,y-r/2-0.03)]]
frame (xy,v,(tt,tr),(b,s),cs) = if snd xy <= r-0.99 || null cs then error "GAME OVER" else (xy.+.v',v',(tt+tr',tr'),(b',s'),cs') where 
	v' = listy v (\us -> rV (2*negv v .>. foldl1' (.+.) us + tr/11) $ negv v) $ mapMaybe (cutSect xy v) (ws ++ dzip b') ++ mapMaybe (touch xy v) cs
	s' = 0.93 *. if any ((1<=) . (*signum (fst s)) . fst) b then negv s else s
	b' = map (.+.s') b ; cs' = filter (isNothing . touch xy v) cs
	tr' = if v .=. v' then tr else (v' .>. v)/19
listy d f x = if null x then d else f x
rV t (x,y) = (x*cos t - y*sin t,y*cos t + x*sin t)
anime ior = modifyIORef' ior frame >> threadDelay 30000 >> postRedisplay Nothing
cutSect xy s c@(u,v) = guard (xy ./ l <= r && w `oncut` c && (s .*. (xy.-.w)) <= 0) >> Just (xy.-.w) where 
	l = ln u (u.-.v) ; w = xy .-| l
oncut u (v,w) = 0 <= (u.-.v) .*. (w.-.u) && 0 <= (u.-.w) .*. (u.-.w) && ((u.-.w) .<>. (v.-.w)) # 0
ln xy w = (snd w,-fst w,w.<>.xy)
(x,y) .-| (a,b,c) = ((b^2*x - a*c - a*b*y)/(a^2 + b^2),-(b*c + a*b*x - a^2*y)/(a^2 + b^2))
p ./ ln = p ==== p .-| ln ; pop f (a,b) (c,d) = (f a c,f b d)		
(.+.) = pop (+) ; (.-.) = pop (-)  ; (.=.) = (uncurry (&&) .) . pop (#) 
(*.) = tmap . (*) ; (.*.) = (uncurry (+) .) . pop (*)
(.<>.) = (uncurry (-) .) . (. uncurry (flip (,))) . pop (*) ; v .>. u = atan2 (v .<>. u) (v .*. u) 
norm = sqrt . join (.*.) ; a ==== b = norm $ a.-.b ; negv = tmap negate
infix 4 #,*. ; infix 3 .+.,==== ; infix 8 .>.
x # y = abs (x-y) < 0.00001 ; tmap = join (***)
dzipWith = (<*> drop 1) . zipWith ; dzip = dzipWith (,)