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 = 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 (,)

aW1wb3J0IFN5c3RlbS5FeGl0CmltcG9ydCBHcmFwaGljcy5VSS5HTFVUCmltcG9ydCBDb250cm9sLk1vbmFkCmltcG9ydCBDb250cm9sLkFwcGxpY2F0aXZlCmltcG9ydCBDb250cm9sLkFycm93CmltcG9ydCBDb250cm9sLkNvbmN1cnJlbnQKaW1wb3J0IEdyYXBoaWNzLlJlbmRlcmluZy5PcGVuR0wgCmltcG9ydCBEYXRhLklPUmVmCmltcG9ydCBEYXRhLkxpc3QKaW1wb3J0IERhdGEuTWF5YmUKaW5pdGlhbCA9ICgoMCwwKSwoMC4wMDUsLTAuMDMpLCgwLDApLChbKC0wLjQsLTAuOSksKC0wLjQsLTAuODUpLCgwLjQsLTAuODUpLCgwLjQsLTAuOSksKC0wLjQsLTAuOSldLCgwLDApKSxsaWZ0TTIgKCwpIFstMC45LC0wLjcuLjAuOV0gWzAuNSwwLjcsMC45XSkKd3MgPSBkemlwIFsoLTEsLTEpLCgtMSwxKSwoMSwxKSwoMSwtMSldIDsgciA9IDAuMSA6OiBHTGZsb2F0Cm1haW4gPSBpbml0aWFsV2luZG93U2l6ZSAkPSBTaXplIDc3NyA3NzcgPj4gaW5pdGlhbFdpbmRvd1Bvc2l0aW9uICQ9IFBvc2l0aW9uIDEwMCAxMDAgPj4gaW5pdGlhbERpc3BsYXlNb2RlICQ9IFtEb3VibGVCdWZmZXJlZF0gPj4gY3JlYXRlV2luZG93ICJ1cnN1bGEiID4+IAoJbmV3SU9SZWYgaW5pdGlhbCA+Pj0gXGlvciAtPiBrZXlib2FyZE1vdXNlQ2FsbGJhY2sgJD0gSnVzdCAoa2JkIGlvcikgPj4gZGlzcGxheUNhbGxiYWNrICQ9IGRsYXkgaW9yID4+IGlkbGVDYWxsYmFjayAkPSBKdXN0IChhbmltZSBpb3IpID4+IG1haW5Mb29wCmRsYXkgaW9yID0gY2xlYXJDb2xvciAkPSBDb2xvcjQgMSAxIDEgMSA+PiBjbGVhciBbQ29sb3JCdWZmZXJdID4+IHJlYWRJT1JlZiBpb3IgPj49IGRyYXdEb3h5cSA+PiBzd2FwQnVmZmVycwprYmQgXyAoQ2hhciAncScpIERvd24gXyBfID0gZXhpdFdpdGggRXhpdFN1Y2Nlc3MJCQkKa2JkIHMgKENoYXIgeCkgRG93biBfIF8gICA9IG1vZGlmeUlPUmVmJyBzICQgXChhLGIsdCwoZCxlKSxjcykgLT4gKGEsYix0LChkLChpZiB4ID09ICdbJyB0aGVuIC0wLjA1IGVsc2UgaWYgeCA9PSAnXScgdGhlbiAwLjA1IGVsc2UgZnN0IGUsMCkpLGNzKQprYmQgXyBfIF8gXyBfID0gcmV0dXJuICgpCmRyYXcgYyA9IHJlbmRlclByaW1pdGl2ZSBjIC4gbWFwTV8gKHZlcnRleCAuIHVuY3VycnkgVmVydGV4MikKdG91Y2ggeHkgcyB4eScgPSBndWFyZCAoKHh5ID09PT0geHknKSA8PSByK3IgJiYgKHMgLiouICh4eS4tLnh5JykpIDw9IDApID4+IEp1c3QgKHh5Li0ueHknKQpkcmF3RG94eXEgKCh4LHkpLF8sKHQsXyksKGJkLF8pLGNzKSA9IGN1cnJlbnRDb2xvciAkPSBDb2xvcjQgMC4zIDAuNCAwLjggMCA+PiBtYXBNXyAobWFwTV8gKGRyYXcgTGluZUxvb3ApIC4gc3RhKSBjcyA+PiAKCWN1cnJlbnRDb2xvciAkPSBDb2xvcjQgMC43IDAuMSAwLjIgMSA+PiBtYXBNXyAoZHJhdyBMaW5lU3RyaXApIHN3YSA+PiBjdXJyZW50Q29sb3IgJD0gQ29sb3I0IDAgMCAwIDEgPj4gZHJhdyBQb2x5Z29uIGJkICB3aGVyZQoJc3dhID0gW1soeCx5KSwoeCArIHIvMS44KmNvcyAodGgrcGkvNCkseSArIHIvMS44KnNpbiAodGgrcGkvNCkpLCh4ICsgci8xLjIqY29zIHRoLHkgKyByLzEuMipzaW4gdGgpXSB8IHRoIDwtIFt0LHQrcGkvMi4udCsxLjYqcGldXQoJc3RhICh4LHkpID0gW1soeCx5K3IvMiksKHgtci8yLHktci8yKSwoeCtyLzIseS1yLzIpXSxbKHgrci8yLHkrci8yLTAuMDMpLCh4LXIvMix5K3IvMi0wLjAzKSwoeCx5LXIvMi0wLjAzKV1dCmZyYW1lICh4eSx2LCh0dCx0ciksKGIscyksY3MpID0gaWYgc25kIHh5IDw9IHItMC45OSB8fCBudWxsIGNzIHRoZW4gZXJyb3IgIkdBTUUgT1ZFUiIgZWxzZSAoeHkuKy52Jyx2JywodHQrdHInLHRyJyksKGInLHMnKSxjcycpIHdoZXJlIAoJdicgPSBsaXN0eSB2IChcdXMgLT4gclYgKDIqbmVndiB2IC4+LiBmb2xkbDEnICguKy4pIHVzICsgdHIvMTEpICQgbmVndiB2KSAkIG1hcE1heWJlIChjdXRTZWN0IHh5IHYpICh3cyArKyBkemlwIGInKSArKyBtYXBNYXliZSAodG91Y2ggeHkgdikgY3MKCXMnID0gMC45MyAqLiBpZiBhbnkgKCgxPD0pIC4gKCpzaWdudW0gKGZzdCBzKSkgLiBmc3QpIGIgdGhlbiBuZWd2IHMgZWxzZSBzCgliJyA9IG1hcCAoLisucycpIGIgOyBjcycgPSBmaWx0ZXIgKGlzTm90aGluZyAuIHRvdWNoIHh5IHYpIGNzCgl0cicgPSBpZiB2IC49LiB2JyB0aGVuIHRyIGVsc2UgKHYnIC4+LiB2KS8xOQpsaXN0eSBkIGYgeCA9IGlmIG51bGwgeCB0aGVuIGQgZWxzZSBmIHgKclYgdCAoeCx5KSA9ICh4KmNvcyB0IC0geSpzaW4gdCx5KmNvcyB0ICsgeCpzaW4gdCkKYW5pbWUgaW9yID0gbW9kaWZ5SU9SZWYnIGlvciBmcmFtZSA+PiB0aHJlYWREZWxheSAzMDAwMCA+PiBwb3N0UmVkaXNwbGF5IE5vdGhpbmcKY3V0U2VjdCB4eSBzIGNAKHUsdikgPSBndWFyZCAoeHkgLi8gbCA8PSByICYmIHcgYG9uY3V0YCBjICYmIChzIC4qLiAoeHkuLS53KSkgPD0gMCkgPj4gSnVzdCAoeHkuLS53KSB3aGVyZSAKCWwgPSBsbiB1ICh1Li0udikgOyB3ID0geHkgLi18IGwKb25jdXQgdSAodix3KSA9IDAgPD0gKHUuLS52KSAuKi4gKHcuLS51KSAmJiAwIDw9ICh1Li0udykgLiouICh1Li0udykgJiYgKCh1Li0udykgLjw+LiAodi4tLncpKSAjIDAKbG4geHkgdyA9IChzbmQgdywtZnN0IHcsdy48Pi54eSkKKHgseSkgLi18IChhLGIsYykgPSAoKGJeMip4IC0gYSpjIC0gYSpiKnkpLyhhXjIgKyBiXjIpLC0oYipjICsgYSpiKnggLSBhXjIqeSkvKGFeMiArIGJeMikpCnAgLi8gbG4gPSBwID09PT0gcCAuLXwgbG4gOyBwb3AgZiAoYSxiKSAoYyxkKSA9IChmIGEgYyxmIGIgZCkJCQooLisuKSA9IHBvcCAoKykgOyAoLi0uKSA9IHBvcCAoLSkgIDsgKC49LikgPSAodW5jdXJyeSAoJiYpIC4pIC4gcG9wICgjKSAKKCouKSA9IHRtYXAgLiAoKikgOyAoLiouKSA9ICh1bmN1cnJ5ICgrKSAuKSAuIHBvcCAoKikKKC48Pi4pID0gKHVuY3VycnkgKC0pIC4pIC4gKC4gdW5jdXJyeSAoZmxpcCAoLCkpKSAuIHBvcCAoKikgOyB2IC4+LiB1ID0gYXRhbjIgKHYgLjw+LiB1KSAodiAuKi4gdSkgCm5vcm0gPSBzcXJ0IC4gam9pbiAoLiouKSA7IGEgPT09PSBiID0gbm9ybSAkIGEuLS5iIDsgbmVndiA9IHRtYXAgbmVnYXRlCmluZml4IDQgIywqLiA7IGluZml4IDMgLisuLD09PT0gOyBpbmZpeCA4IC4+Lgp4ICMgeSA9IGFicyAoeC15KSA8IDAuMDAwMDEgOyB0bWFwID0gam9pbiAoKioqKQpkemlwV2l0aCA9ICg8Kj4gZHJvcCAxKSAuIHppcFdpdGggOyBkemlwID0gZHppcFdpdGggKCwp