-- <PRE>

module Fal where
import SOEGraphics hiding (Point, Region, Event)
import qualified SOEGraphics as G (Point, Region, Event)

import Draw
import Shape
import Region
import Picture
import Animation(picToGraphic)
import Memo

-- import Drawing (xWin,yWin,intToFloat)
import Win32Misc (timeGetTime)
import Word (word32ToInt)
import Channel

infixl 2 =>>, ->>
infixl 1 `switch`, `stepAccum`, `step`
infixl 0 .|.
infixr 4 <*, >*
infixr 3 &&*
infixr 2 ||*

type Time = Float

type UserAction = G.Event

newtype Behavior1 a
  = Behavior1 ([(UserAction,Time)] -> Time -> a)

inList :: [Int] -> Int -> Bool

inList xs y = elem y xs

result1 :: [Bool]
result1 = map (inList xs) ys

xs = [2,4,6,8,10] :: [Int]
ys = [3,6,9]      :: [Int]

result2 :: [Bool]
result2 = manyInList xs ys

manyInList :: [Int] -> [Int] -> [Bool]
manyInList [] _ = []
manyInList _ [] = []
manyInList (x:xs) (y:ys) =
  if y<x then        manyInList xs (y:ys)
         else (y==x) : manyInList (x:xs) ys

newtype Behavior2 a
  = Behavior2 ([(UserAction,Time)] -> [Time] -> [a])


newtype Behavior3 a
  = Behavior3 ([UserAction] -> [Time] -> [a])

newtype Behavior4 a
  = Behavior4 ([Maybe UserAction] -> [Time] -> [a])

newtype Behavior a
  = Behavior (([Maybe UserAction],[Time]) -> [a])

newtype Event a
  = Event (([Maybe UserAction],[Time]) -> [Maybe a])

-- Event a  =iso=  Behavior (Maybe a)

time :: Behavior Time
time = Behavior (\(_,ts) -> ts)

constB :: a -> Behavior a
constB x = Behavior (\_ -> repeat x)

($*) :: Behavior (a->b) -> Behavior a -> Behavior b
Behavior ff $* Behavior fb
  = Behavior (\uts -> zipWith ($) (ff uts) (fb uts))

lift0 :: a -> Behavior a
lift0 = constB

lift1 :: (a -> b) -> (Behavior a -> Behavior b)
lift1 f b1
  = lift0 f $* b1

lift2 :: (a -> b -> c) -> (Behavior a -> Behavior b -> Behavior c)
lift2 f b1 b2
  = lift1 f b1 $* b2

lift3 :: (a -> b -> c -> d) ->
         (Behavior a -> Behavior b -> Behavior c -> Behavior d)
lift3 f b1 b2 b3
  = lift2 f b1 b2 $* b3

pairB :: Behavior a -> Behavior b -> Behavior (a,b)
pairB = lift2 (,)

fstB :: Behavior (a,b) -> Behavior a
fstB  = lift1 fst
sndB :: Behavior (a,b) -> Behavior b
sndB  = lift1 snd

--- COLORS -----

red, blue, yellow, green, white :: Behavior Color
red    = lift0 Red
blue   = lift0 Blue
yellow = lift0 Yellow
green  = lift0 Green
white  = lift0 White


--- Shapes, Regions, and Pictures

shape :: Behavior Shape -> Behavior Region
shape   = lift1 Shape

region ::Behavior Color -> Behavior Region -> Behavior Picture
region = lift2 Region

wordPic str pos = lift2 Text pos str
showPic n pos = lift2 Text pos (lift1 show n)

ell, rec :: Behavior Float -> Behavior Float -> Behavior Region
ell x y = shape (lift2 Ellipse   x y)
rec x y = shape (lift2 Rectangle x y)


translate :: (Behavior Float, Behavior Float)
             -> Behavior Region -> Behavior Region
translate (Behavior fx, Behavior fy) (Behavior fp)
      = Behavior (\uts -> zipWith3 aux (fx uts) (fy uts) (fp uts))
          where aux x y p = Translate (x,y) p


paint :: Behavior Color -> Behavior Region -> Behavior Picture
paint = lift2 Region

over :: Behavior Picture -> Behavior Picture -> Behavior Picture
over = lift2 Over

--- Lifted OPERATORS ----

(>*),(<*), (>=*), (<=*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(>*) = lift2 (>)
(<*) = lift2 (<)
(<=*) = lift2 (<=)
(>=*) = lift2 (>=)

(&&*),(||*) :: Behavior Bool -> Behavior Bool -> Behavior Bool
(&&*) = lift2 (&&)
(||*) = lift2 (||)

instance Fractional a => Fractional (Behavior a) where
  (/) = lift2 (/)
  fromRational = lift0 . fromRational

instance Num a => Num (Behavior a) where
  (+) = lift2 (+)
  (*) = lift2 (*)
  negate = lift1 negate
  abs = lift1 abs
  signum = lift1 signum
  fromInteger = lift0 . fromInteger

instance Show (Behavior a)  where
  showsPrec n a s = "<< Behavior >>"

instance Eq (Behavior a) where
  a1 == a2 = error "Can't compare behaviors."

instance Floating a => Floating (Behavior a) where
  pi    = lift0 pi
  sqrt  = lift1 sqrt
  exp   = lift1 exp
  log   = lift1 log
  sin   = lift1 sin
  cos   = lift1 cos
  tan   = lift1 tan
  asin  = lift1 asin
  acos  = lift1 acos
  atan  = lift1 atan
  sinh  = lift1 sinh
  cosh  = lift1 cosh
  tanh  = lift1 tanh
  asinh = lift1 asinh
  acosh = lift1 acosh
  atanh = lift1 atanh

--- Simple or Primitive EVENTS

lbp :: Event ()
lbp = Event (\(uas,_) -> map getlbp uas)
      where getlbp (Just (Button _ True True)) = Just ()
            getlbp _                           = Nothing


rbp :: Event ()
rbp = Event (\(uas,_) -> map getrbp uas)
      where getrbp (Just (Button _ False True)) = Just ()
            getrbp _                            = Nothing

key :: Event Char
key = Event (\(uas,_) -> map getkey uas)
      where getkey (Just (Key ch True)) = Just ch
            getkey _                    = Nothing

mm :: Event Vertex
mm = Event (\(uas,_) -> map getmm uas)
     where getmm (Just (MouseMove pt)) = Just (gPtToPt pt)
           getmm _                     = Nothing

gPtToPt :: G.Point -> Vertex
gPtToPt (x,y) = ( pixelToInch (x - 300)
                , pixelToInch (250 - y) )

mouse :: (Behavior Float, Behavior Float)
mouse = (fstB m, sndB m)
          where m = (0,0) `step` mm

---- Behavior and Event Combinators ---

switch :: Behavior a -> Event (Behavior a) -> Behavior a

Behavior fb `switch` Event fe =
  memoB $ Behavior (\uts@(us,ts) -> loop us ts (fe uts) (fb uts))
    where loop (_:us) (_:ts) ~(e:es) (b:bs) =
            b : case e of
                  Nothing             -> loop us ts es bs
                  Just (Behavior fb') -> loop us ts es (fb' (us,ts))

memoB :: Behavior a -> Behavior a
memoB (Behavior fb) = Behavior (memo1 fb)

(=>>) :: Event a -> (a->b) -> Event b
Event fe =>> f = Event (\uts -> map aux (fe uts))
  where aux (Just a) = Just (f a)
        aux Nothing  = Nothing

-- Event fe =>> f = Event (map (map f) . fe)

e ->> v = e =>> \_ -> v


withElem  :: Event a -> [b] -> Event (a,b)
withElem (Event fe) bs = Event (\uts -> loop (fe uts) bs)
  where loop (Just a  : evs) (b:bs) = Just (a,b) : loop evs bs
        loop (Nothing : evs)    bs  = Nothing    : loop evs bs

withElem_ :: Event a -> [b] -> Event b
withElem_ e bs = e `withElem` bs =>> snd

(.|.) :: Event a -> Event a -> Event a
Event fe1 .|. Event fe2
  = Event (\uts -> zipWith aux (fe1 uts) (fe2 uts))
      where aux Nothing  Nothing  = Nothing
            aux (Just x) _        = Just x
            aux _        (Just x) = Just x

snapshot :: Event a -> Behavior b -> Event (a,b)
Event fe `snapshot` Behavior fb
  = Event (\uts -> zipWith aux (fe uts) (fb uts))
      where aux (Just x) y = Just (x,y)
            aux Nothing  _ = Nothing

snapshot_ :: Event a -> Behavior b -> Event b
snapshot_ e b = e `snapshot` b =>> snd

step :: a -> Event a -> Behavior a
a `step` e = constB a `switch` e =>> constB

stepAccum :: a -> Event (a->a) -> Behavior a
a `stepAccum` e = b
   where b = a `step` (e `snapshot` b =>> uncurry ($))

counter = 0 `stepAccum` lbp ->> (+1)

test1 = let Behavior fb = counter
        in take 20 (fb (uas,ts))

predicate :: Behavior Bool -> Event ()
predicate (Behavior fb)
  = Event (\uts -> map aux (fb uts))
    where aux True  = Just ()
          aux False = Nothing

integral :: Behavior Float -> Behavior Float
integral (Behavior fb)
  = Behavior (\uts@(us,t:ts) -> 0 : loop t 0 ts (fb uts))
      where loop t0 acc (t1:ts) (a:as)
                 = let acc' = acc + (t1-t0)*a
                   in acc' : loop t1 acc' ts as

--- INTERFACE TO THE WINDOW AND USER



reactimate :: String -> Behavior a -> (a -> IO Graphic) -> IO ()
reactimate title franProg toGraphic
  = runGraphics $
    do w <- openWindowEx title (Just (0,0)) (Just (xWin,yWin))
              drawBufferedGraphic (Just 30)
       (us,ts,addEvents) <- windowUser w
       addEvents
       let drawPic (Just p) =
             do g <- toGraphic p
                setGraphic w g
                addEvents
                getWindowTick w
           drawPic Nothing  = return ()
       let Event fe = sample `snapshot_` franProg
       mapM_ drawPic (fe (us,ts))

sample :: Event ()
sample = Event (\(us,_) -> map aux us)
  where aux Nothing  = Just ()
        aux (Just _) = Nothing

windowUser :: Window -> IO ([Maybe UserAction], [Time], IO ())
windowUser w
  = do (evs, addEv) <- makeStream
       t0 <- timeGetTime
       let addEvents =
             let loop rt = do
                   mev <- maybeGetWindowEvent w
                   case mev of
                     Nothing -> return ()
                     Just e  -> addEv (rt, Just e) >> loop rt
             in do t <- timeGetTime
                   let rt = w32ToTime (t-t0)
                   loop rt
                   addEv (rt, Nothing)
       return (map snd evs, map fst evs, addEvents)

w32ToTime t = intToFloat (word32ToInt t) / 1000

makeStream :: IO ([a], a -> IO ())
makeStream = do
  ch <- newChan
  contents <- getChanContents ch
  return (contents, writeChan ch)

---- PADDLE BALL EXAMPLE

paddleball vel = walls `over` paddle `over` ball vel

main = test (paddleball 1)

walls = let upper = paint blue (translate ( 0,1.7) (rec 4.4 0.05))
            left  = paint blue (translate (-2.2,0) (rec 0.05 3.4))
            right = paint blue (translate ( 2.2,0) (rec 0.05 3.4))
        in upper `over` left `over` right

paddle = paint red (translate (fst mouse, -1.7) (rec 0.5 0.05))

ball vel =
 let xvel    = vel `stepAccum` xbounce ->> negate
     xpos    = integral xvel
     xbounce = predicate (xpos >*  2 &&* xvel >* 0
                      ||* xpos <* -2 &&* xvel <* 0)
     yvel    = vel `stepAccum` ybounce ->> negate
     ypos    = integral yvel
     roofbounce = ypos >* 1.5 &&* yvel >* 0
     paddlebounce = (ypos `between` (-2.0,-1.5)) &&*
                    (fst mouse `between` (xpos-0.25,xpos+0.25)) &&*
                    (yvel <* 0)
     ybounce = predicate (roofbounce ||* paddlebounce)
 in (paint yellow (translate (xpos, ypos) (ell 0.2 0.2)))

x `between` (a,b) = x >* a &&* x <* b


------ Examples

test beh = reactimate "FAL Test" beh
          (return . picToGraphic)

color0 :: Behavior Color
color0 = red `switch` lbp ->> blue

color1 = red `switch` (lbp `withElem_` cycle [blue,red])

color2 = red `switch` (lbp ->> blue .|. key ->> yellow)

color3 = white `switch` (key =>> \c ->
           case c of 'r' -> red
                     'b' -> blue
                     'y' -> yellow
                     _   -> white  )

color4 = white `switch` (key `snapshot` color4 =>> \(c,old) ->
           case c of 'r' -> red
                     'b' -> blue
                     'y' -> yellow
                     _   -> constB old)

color5 = red `switch` predicate (time >* 5) ->> blue

uas = cycle [Nothing, Just (Button (0,0) True True), Nothing]
ts  = [1,2 ..] :: [Time]

test0 = let Behavior fb = color0
        in take 3 (fb (uas,ts))


ball1   = paint color4 circle1

circle1 = translate mouse (ell 0.2 0.2)

cball0   = paint color0 circle0
cball1   = paint color1 circle0
cball2   = paint color2 circle0
cball3   = paint color3 circle0
cball4   = paint color4 circle0
circle0 = translate (cos time, sin time) (ell 0.2 0.2)

--- Ball falling under gravity
ball2 = paint red (translate (0,y) (ell 0.2 0.2))
       where g = -1
             y = 1.5 + integral v
             v = integral g `switch` (hit `snapshot_` v =>> \v->
                 lift0 (-v) + integral g)
             hit = predicate (y <* -1.5 &&* v <* 0)

------------------------------------------------------------------
-- type "test exN" to run example N
dot = (ell 0.2 0.2)

ex1 = paint red (translate (0, time / 2) dot)
ex2 = paint blue (translate (sin time,cos time) dot)

wander x y color = paint color (translate (x,y) dot)
ex3 = wander (time /2) (sin time) red

modula x y = (period,w)
    where (whole,fract) = properFraction x
          n = whole `mod` y
          period = (whole `div` y)
          w = (fromInt (toInt n)) + fract

bounce t = f fraction
   where (period,fraction) = modula t 2
         f = funs !! (period `mod` 4)
         funs = [id,(2.0 -),negate,(\x -> x - 2.0)]

ex4 = wander (lift1 bounce time) 0 yellow

moon = (translate (sin time,cos time) dot)
ex5 = paint color0 moon
ex6 = paint color1 moon
ex7 = paint color2 moon
ex8 = paint color3 moon
ex9 = paint color4 moon

growCircle :: Char -> Region
growCircle x = Shape(Ellipse (size x) (size x))

size '2' = 0.2  -- size :: Char -> Float
size '3' = 0.4
size '4' = 0.6
size '5' = 0.8
size '6' = 1.0
size '7' = 1.2
size '8' = 1.4
size '9' = 1.6
size _ = 0.1

ex10 =  paint red (Shape(Ellipse 1 1)
                     `step` (key =>> growCircle))

power2 :: Event(Float -> Float)
power2 = (lbp ->> \ x -> x*2)     .|.
         (rbp ->> \ x -> x * 0.5)

dynSize = 1.0 `stepAccum` power2
ex11 = paint red (ell dynSize dynSize)

ex12 = wander x 0 yellow
       where xvel = 1 `stepAccum` (hit ->> negate)
             x = integral xvel
             left = x <=* -2.0 &&* xvel <*0
             right = x >=* 2.0  &&* xvel >*0
             hit = predicate (left ||* right)

mouseDot =
   mm =>> \ (x,y) ->
            translate (constB x,constB y)
                      dot

ex13 = paint red (dot `switch` mouseDot)

main1 = test ex1
main2 = test ex2
main3 = test ex3
main4 = test ex4
main5 = test ex5
main6 = test ex6
main7 = test ex7
main8 = test ex8
main9 = test ex9
main10 = test ex10
main11 = test ex11
main12 = test ex12
main13 = test ex13
main14 = test paddle
main15 = main

-- </PRE>