module Test where

import Debug.Trace
import Array
import Control.Arrow ((***))
import AFRP
import AFRPEvent
import AFRPGeometry
import AFRPUtilities
import AFRPForceable
import Animate
import Parser
import Command
import WorldGeometry
import PhysicalDimensions
import Colors
import IdentityList

import qualified Graphics.HGL as HGL


test = animate 50 "test window" worldSizeX worldSizeY
               (drawObjects)
               (const [])
               (parseWinInput >>> mainLoop)

mainLoop :: SF GameInput (IL ObsObjState)
mainLoop = proc gi -> do 
    rec oos <- compute objs0 -< (gi, oos)
    returnA -< fmap ooObsObjState oos

objs0 = listToIL [ball0 ,barr0,barr1, barr3,diam0] 
  where
    ball0 = ball ballP0 ballRadius
    barr0 = oscillate (barrier barrWid barrLen) 
                      barrP0  
                      (Point2 0 $ worldYMax - barrLen)
                      (Point2 0 $ worldYMin + barrLen)
    barr1 = oscillate (barrier barrLen barrWid) 
                      barrP0  
                      (Point2 (worldXMax - barrLen) (worldYMax / 2))
                      (Point2 (worldXMin + barrLen) (worldYMax / 2))
    barr3 = oscillate (barrier barrWid barrLen) 
                      barrP0  
                      (Point2 (worldXMax - barrWid) (worldYMax - barrLen))
                      (Point2 (worldXMin + barrLen) (worldYMin + barrLen))
    diam0 = wrap (diamond diamWid diamLen) diamV0 (Point2 0 0)

compute :: IL Object -> SF (GameInput, IL ObjOut) (IL ObjOut)
compute objs = dpSwitch route objs (checkup >>> notYet) (\sfs f -> compute $ f sfs)


checkup :: SF (a, IL ObjOut) (Event (IL Object -> IL Object))
checkup = proc (_,oos) -> do
    let
      es :: [Event (IL Object -> IL Object)]
      es = [ooKillReq oo `tag` (deleteIL k) | (k, oo) <- assocsIL oos]
    returnA -< foldl (mergeBy (.)) noEvent es


route :: (GameInput, IL ObjOut) -> IL sf -> IL (ObjIn, sf)
route (gi, oos) objs = mapIL routeAux objs where
    routeAux (k, obj) =
	(ObjIn {oiHit = foldl (mergeBy $ (^+^) |*| max) noEvent $ lookupAll k hs,
		oiGameInput = gi},
	 obj)
    hs = hits (assocsIL (fmap ooObsObjState oos))

(f |*| g) (x1, y1) (x2, y2) = (f x1 x2, g y1 y2)
lookupAll k [] = []
lookupAll k ((i,v):vs) = if k == i then Event v:lookupAll k vs else lookupAll k vs

hits :: [(ILKey, ObsObjState)] -> [(ILKey, Correction)]
hits kooss = map fromEvent $ filter isEvent (hitsAux kooss) where
    hitsAux [] = []
    hitsAux ((koos):kooss) =
	[ koos `colliding` koos' | (koos') <- kooss]
	++ hitsAux kooss

--
-- Corrective velocity vector, and size of puncture for an object which has been hit.
--
type Correction = ((Velocity, Velocity), Length)	

--
-- Objects
--
type Object = SF ObjIn ObjOut

data ObjIn = ObjIn {
    oiHit :: Event Correction,
    oiGameInput :: GameInput
}

data ObjOut = ObjOut {
    ooObsObjState :: !ObsObjState,
    ooKillReq :: Event (),
    ooSpawnReq :: Event [Object]
}

data ObsObjState = 
    OOSBall {
        oosPos :: !Position2,
        oosVel :: !Velocity2,
        oosRadius :: !Length
    }
  | OOSBarrier {
        oosPos :: !Position2,
        oosVel :: !Velocity2,
        oosWidth :: !Length,
        oosHeight :: !Length
    }
  | OOSDiamond {
        oosPos :: !Position2,
        oosVel :: !Velocity2,
        oosWidth :: !Length,
        oosHeight :: !Length
    }

instance Forceable ObsObjState where
    -- If non-strict fields: oosNonStrict1 obj `seq` ... `seq` obj 
    force obj = obj



oscillate :: (Position2 -> Position2 -> Object) -> Position2 -> Position2 -> Position2 -> Object
oscillate obj p0 p1 p2 =  
    switch (obj p0 p1 >>> arr id &&& arr isDone) (\p -> oscillate obj p p2 p1) 
  where
    isDone (ObjOut {ooObsObjState = oos}) = let p = oosPos oos in Event p `gate` eq p p1 
    eq p1@(Point2 x1 y1) p2@(Point2 x2 y2) = abs (x1 - x2) < eps && abs (y1 - y2) < eps
    eps = 0.1



wrap :: (Velocity2 -> Position2 -> Object) -> Velocity2 -> Position2 -> Object
wrap obj v0 p0 = switch (obj v0 p0 >>> arr id &&& arr wrapped) (uncurry $ wrap obj)
  where
    wrapped (ObjOut {ooObsObjState = oos}) = 
        Event (oosVel oos, Point2 x' y') `gate` (x < worldXMin || x > worldXMax || y < worldYMin || y > worldYMax)
      where 
        (Point2 x y) = oosPos oos
        x' = if x < worldXMin then worldXMax else if x > worldXMax then worldXMin else x
        y' = if y < worldYMin then worldYMax else if y > worldYMax then worldYMin else y

--
-- ball object
--
ballP0 :: Position2
ballP0 = Point2 worldXMin worldYMin
ballRadius = 50

ball :: Position2 -> Length -> Object

maxBallA = 300
maxBallV = 300
bound l x = if x < -l then -l else if x > l then l else x 

check maxv v a = if -maxv <= v && v <= maxv || v < -maxv && a > 0 || v > maxv && a < 0 then a else 0 

ball p0 r = proc oi -> do
    let gi = oiGameInput oi
        ((dvx, dvy), puncture) = event ((0,0),0) (id) (oiHit oi)
    Point2 xd yd <- ptrPos -< gi  -- desired position
    rec let ax = check maxBallV (vector2X v) $ bound maxBallA $ 10 * (xd - x) - 5 * vector2X v -- x acceleration
            ay = check maxBallV (vector2Y v) $ bound maxBallA $ 10 * (yd - y) - 5 * vector2Y v -- y acceleration
        v <- integral -< vector2 ax ay  -- velocity
        p@(Point2 x y) <- (p0 .+^) ^<< integral -< v ^+^ (vector2 dvx dvy) -- position
    returnA -< ObjOut (OOSBall p v r) (Event () `gate` (puncture > 30)) noEvent


--
-- barrier object
--
barrP0 :: Position2
barrP0 = Point2 (0) (worldYMax / 2.0)
barrWid = 50
barrLen = 150
maxBarrA = 500
maxBarrV = 500

barrier :: Length -> Length -> Position2 -> Position2 -> Object
barrier w h p0 (Point2 xd yd) = proc oi -> do
    rec let ax = check maxBarrV (vector2X v) $ bound maxBarrA $ 10 * (xd - x) - 5 * vector2X v
            ay = check maxBarrV (vector2Y v) $ bound maxBarrA $ 10 * (yd - y) - 5 * vector2Y v
        v <- integral -< vector2 ax ay
        p@(Point2 x y) <- (p0 .+^) ^<< integral -< v
    returnA -< ObjOut (OOSBarrier p v w h) noEvent noEvent


--
-- diamond object
--
diamWid = 50
diamLen = 75
diamV0 = vector2 100 100
diamond :: Length -> Length -> Velocity2 -> Position2 -> Object
diamond w h v0 p0 = proc oi -> do
    rec vp <- iPre v0 -< v  
        v <- hold v0 -< fmap ((vp ^+^) . uncurry vector2 . fst) (oiHit oi)
        p <- (p0 .+^) ^<< integral -< v 
    returnA -< ObjOut (OOSDiamond p vp w h) noEvent noEvent

--
-- Check if two objects touch each other.
--
intersects :: (ILKey, ObsObjState) -> (ILKey, ObsObjState) -> Event (ILKey, Correction)

--oos1@(OOSBall{}) `intersects` oos2@(OOSBall{}) =
--    if norm ((oosPos oos2) .-. (oosPos oos1)) < (oosRadius oos2 + oosRadius oos1)

(k, oos1@OOSBall{}) `intersects` (_, oos2@OOSBarrier{}) =
    let xdiff = point2X (oosPos oos1) - point2X (oosPos oos2)
        ydiff = point2Y (oosPos oos1) - point2Y (oosPos oos2)
        xinter = abs xdiff - (oosRadius oos1) - (oosWidth oos2 / 2) 
        yinter = abs ydiff - (oosRadius oos1) - (oosHeight oos2 / 2)
        (vx1,vy1) = vector2XY $ oosVel oos1
        (vx2,vy2) = vector2XY $ oosVel oos2
        vx1' = if (xdiff < 0) == (vx1 > 0) then -2*vx1 else 0 
        vy1' = if (ydiff < 0) == (vy1 > 0) then -2*vy1 else 0
        vx2' = if (xdiff < 0) == (vx2 < 0) then vx2 else 0
        vy2' = if (ydiff < 0) == (vy2 < 0) then vy2 else 0
        collision = xinter <= 0 && yinter <= 0
    in if collision then Event (k, ((vx1'+vx2', vy1'+vy2'), abs $ max xinter yinter))
       else noEvent

koos1@(_, OOSBarrier{}) `intersects` koos2@(_, OOSBall{}) = koos2 `intersects` koos1

koos1@(k, oos1@OOSDiamond{}) `intersects` (_, oos2@OOSBarrier{}) =
    let pDm = oosPos oos1;             pBa = oosPos oos2
        wDm = oosWidth oos1 / 2;       wBa = oosWidth oos2 / 2
        hDm = oosHeight oos1 / 2;      hBa = oosHeight oos2 / 2
        d1 = pDm .-^ vector2 wDm 0;    b1 = pBa .-^ vector2 wBa hBa
        d2 = pDm .-^ vector2 (-wDm) 0; b2 = pBa .-^ vector2 wBa (-hBa)
        d3 = pDm .-^ vector2 0 hDm;    b3 = pBa .-^ vector2 (-wBa) hBa
        d4 = pDm .-^ vector2 0 (-hDm);  b4 = pBa .-^ vector2 (-wBa) (-hBa)
        inside (Point2 cx cy) w h (Point2 x y) = abs (cx - x) <= w && abs (cy - y) <= h
        collision = any (inside pDm wDm hDm) [b1,b2,b3,b4] || any (inside pBa wBa hBa) [d1,d2,d3,d4]
        (vx1,vy1) = vector2XY $ oosVel oos1
        (vx2,vy2) = vector2XY $ oosVel oos2
        xdiff = point2X pDm - point2X pBa
        ydiff = point2Y pDm - point2Y pBa
        vx1' = if (xdiff < 0) == (vx1 > 0) then -2*vx1 else 0 
        vy1' = if (ydiff < 0) == (vy1 > 0) then -2*vy1 else 0
    in if collision then Event (k, ((vx1', vy1'), 0))
       else noEvent
       
koos1@(_, oos1@OOSBarrier{}) `intersects` koos2@(_, oos2@OOSDiamond{}) = koos2 `intersects` koos1

_ `intersects` _ = noEvent

--
-- Check if two objects are colliding.
--
colliding :: (ILKey, ObsObjState) -> (ILKey, ObsObjState) -> Event (ILKey, Correction)
koos1 `colliding` koos2 = koos1 `intersects` koos2


drawObjects oos = HGL.overGraphics $ map drawObj (elemsIL oos)

drawObj (OOSBall {oosPos = p, oosRadius = r}) = circle Yellow p r
drawObj (OOSBarrier {oosPos = p, oosWidth = w, oosHeight = h}) = polygon Blue [p1,p2,p3,p4]
  where
    delta = vector2 (w/2) (h/2)
    p1@(x1,y1) = position2ToGPoint $ p .-^ delta
    p2 = (x1, y2)
    p3@(x2,y2) = position2ToGPoint $ p .+^ delta
    p4 = (x2, y1)
drawObj (OOSDiamond {oosPos = p, oosWidth = w, oosHeight = h}) = polygon Green [p1,p2,p3,p4]
  where
    p1 = position2ToGPoint $ p .-^ (vector2 (w/2) 0)
    p3 = position2ToGPoint $ p .-^ (vector2 (-w/2) 0)
    p2 = position2ToGPoint $ p .-^ (vector2 0 (h/2))
    p4 = position2ToGPoint $ p .-^ (vector2 0 (-h/2))


--
-- Drawing Shapes
--
circle :: Color -> Position2 -> Length -> HGL.Graphic
circle c p r = 
    HGL.mkBrush (colorTable ! c) $ \brush ->
    HGL.withBrush brush	        $
    HGL.ellipse gp11 gp22
    where
        d   = vector2 r r
        gp11 = position2ToGPoint (p .-^ d)
	gp22 = position2ToGPoint (p .+^ d)

polygon :: Color -> [HGL.Point] -> HGL.Graphic
polygon c ps =
    HGL.mkBrush (colorTable ! c) $ \brush ->
    HGL.withBrush brush	      $
    HGL.polygon ps