\begin{code}
module Behavior (
 module Behavior,	
 lift1,at,($*),time,Behavior,constantB,snapshotFL,snapshotFE,
 traceB
 )
where
import BPrim
import BaseTypes
import Event
import EventPrim (franTick)
import Monad
import Array
import Maybe
import FranTime
import Compatibility

infixr 8  ^*, ^^*
infixr 5  ++*
infix  4  ==*, <*, <=* , >=*, >*
infixr 3  &&*
infixr 2  ||*

infixl 3 `snapshotE`, `snapshotE_`, `whenE`, `snapshotL`, `snapshotL_`, 
         `snapshotFE_`, `snapshotFL_`

\end{code}


-- Create and snapshot a behavior at an event occurrence

\begin{code}
-- event snapshots
snapshotFE_ :: Event a -> (a -> Behavior b) -> Event b
e `snapshotFE_` f = e `snapshotFE` f ==> snd

snapshotE :: Event a -> Behavior b -> Event (a,b)
e `snapshotE` b = e `snapshotFE` const b

snapshotE_ :: Event a -> Behavior b -> Event b
e `snapshotE_` b = e `snapshotE` b ==> snd

withSnapE :: (a -> b -> c) -> Behavior b -> Event a -> Event c
withSnapE f bh e = snapshotE e bh ==> uncurry f

-- listener snapshots
snapshotFL_ :: (a -> Behavior b) -> Listener b -> Listener a
snapshotFL_ f l = snapshotFL f (comapL snd l) 
 
snapshotL :: Behavior b -> Listener (a,b) -> Listener a
snapshotL bh l = snapshotFL (const bh) l

snapshotL_ :: Behavior b -> Listener b -> Listener a
snapshotL_ bh l = snapshotL bh (comapL snd l) 

withSnapL :: (a -> b -> c) -> Behavior b -> Listener c -> Listener a
withSnapL f bh l = snapshotL bh (comapL (uncurry f) l)

\end{code}

Filtering events based on behaviors

\begin{code}
-- Generalized whenE
whenSnap :: Event a -> Behavior b -> (a -> b -> Bool) -> Event a
whenSnap e b pred = e `snapshotE` b `suchThat` uncurry pred ==> fst

whenE :: Event a -> Behavior Bool -> Event a
e `whenE` b =  e `snapshotE` b `suchThat` snd ==> fst

-- Like whenE, but the BoolB comes from an event.  This function probably
-- requires a new primitive.  Look for a better name.

whenEP :: Event (a,Behavior Bool) -> Event a
whenEP e = e `snapshotFE` snd `suchThat` snd ==> (fst . fst)
\end{code}

\begin{code}
-- inefficient predicates based on franTick
-- see BehaviorIO for more efficient version

predicate :: Behavior Bool -> Event ()
predicate b = franTick `whenE` b

-- Generalization of predicate
maybeBE :: MaybeB a -> Event a
maybeBE mbB = isJustE $ franTick `snapshotE_` mbB
\end{code}


-- choosing an event based on a behavior, not very efficient
\begin{code}
arrIndexE :: Ix ix => Array ix (Event a) -> Behavior ix -> Event a
arrIndexE = arrIndexEGeneral

-- It's worth partially applying !* to an array in the event case.
arrIndexEGeneral arr = indexer
 where
   -- pairedE :: Event (ix,a)
   pairedE  = anyE [ e ==> (ix `pair`) | (ix,e) <- assocs arr ]
   indexer ixb =
     pairedE `snapshotE` ixb
             `suchThat` (\ ((occIx,a),ix) -> occIx == ix)
             ==>        snd . fst


-- choosing a behavior based on a behavior

arrIndexB :: Ix ix => Array ix (Behavior a) -> Behavior ix -> Behavior a
arr `arrIndexB` ixb = cachingBehavior sampler invalidate
 where
   sampler t  = do --putStrLn $ "arrIndexB at " ++ show t
                   (ix,tix) <- ixb `sample` t
                   (a ,ta ) <- (arr ! ix) `sample` t
                   return (a, tix `min` ta)
   invalidate = invalidateEv ixb .|. (fmap invalidateEv arr `arrIndexE` ixb)
\end{code}

-- if on behaviors
\begin{code}
condB :: Behavior Bool -> Behavior a -> Behavior a -> Behavior a
condB c b b' = cachingBehavior sampler invalidate
 where
  sampler t = do (cVal,cConst) <- c `sample` t
                 (vVal,vConst) <- (if cVal then b else b') `sample` t
                 return (vVal, cConst && vConst)

  invalidate = invalidateEv c
               .|. invalidateEv b  `whenE` c
               .|. invalidateEv b' `whenE` (notB c)

condE :: Behavior Bool -> Event a -> Event a -> Event a
condE c e1 e2 = e1 `whenE` c .|. e2 `whenE` (notB c)
\end{code}

-- Utils:
\begin{code}
lift0                        = constantB
lift2 f b1 b2                = lift1 f b1 $* b2
lift3 f b1 b2 b3             = lift2 f b1 b2 $* b3
lift4 f b1 b2 b3 b4          = lift3 f b1 b2 b3 $* b4
lift5 f b1 b2 b3 b4 b5       = lift4 f b1 b2 b3 b4 $* b5
lift6 f b1 b2 b3 b4 b5 b6    = lift5 f b1 b2 b3 b4 b5 $* b6
lift7 f b1 b2 b3 b4 b5 b6 b7 = lift6 f b1 b2 b3 b4 b5 b6 $* b7
lift8 f b1 b2 b3 b4 b5 b6 b7 b8 = lift7 f b1 b2 b3 b4 b5 b6 b7 $* b8
lift9 f b1 b2 b3 b4 b5 b6 b7 b8 b9 = lift8 f b1 b2 b3 b4 b5 b6 b7 b8 $* b9
\end{code}

-- Utilities
\begin{code}
timeSince :: Time -> Behavior DTime
timeSince t0 = time - constantB t0

wiggle, waggle :: RealB
wiggle = sin (pi * time)
waggle = cos (pi * time)

wiggleRange lo hi = lo + (hi-lo) * (wiggle+1)/2
\end{code}

-- A few convenient type abbreviations:
\begin{code}
type BoolB    = Behavior Bool
type TimeB    = Behavior Time
type RealB    = Behavior RealVal
type IntB     = Behavior Int
type StringB  = Behavior String
type MaybeB a = Behavior (Maybe a)
type IOB    a = Behavior (IO a)
\end{code}

-- Now we define a bazillion liftings.  The naming policy is to use the
-- same name as the unlifted function if overloaded and the types permit.
-- Sadly, type restrictions prevent us from defining some of the methods
-- on behaviors.  In such cases, add a suffix of "*" or "B" if the name is
-- a syntactic "operator" rather than an identifier.  (Does the Haskell
-- language spec use the terms "operator" and "identifier" in this way?)

\begin{code}
noOverloadB   :: String -> String -> a
noOverloadBId :: String -> a
noOverloadBOp :: String -> a

noOverloadB suffix name =
 error ("Couldn't overload \"" ++ name ++ "\" for behaviors.  Use \"" ++
        name ++ suffix ++"\" instead.")

noOverloadBId = noOverloadB "B"
noOverloadBOp = noOverloadB "*"


-- Needed because Num derives from Eq and Show.  Similarly below.
instance  (Eq a) => Eq (Behavior a)  where
  (==) = noOverloadBOp "=="
  (/=) = noOverloadBOp "/="

(==*),(/=*) :: Eq a => Behavior a -> Behavior a -> BoolB

(==*) = {-_scc_ "(==)"-} ( lift2 (==) )
(/=*) = {-_scc_ "(/=)"-} ( lift2 (/=) )


instance  Ord a => Ord (Behavior a)  where
  (<)   =  noOverloadBOp "<"
  (<=)  =  noOverloadBOp "<="
  (>)   =  noOverloadBOp ">"
  (>=)  =  noOverloadBOp ">="
  min   =  {-_scc_ "min"-} ( lift2 min )
  max   =  {-_scc_ "max"-} ( lift2 max )

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

(<*)  = {-_scc_ "(<)"-} ( lift2 (<) )
(<=*) = {-_scc_ "(<=)"-} ( lift2 (<=) )
(>=*) = {-_scc_ "(>=)"-} ( lift2 (>=) )
(>*)  = {-_scc_ "(>)"-} ( lift2 (>) )


instance  Num a => Num (Behavior a)  where
  (+)          =  {-_scc_ "(+)"-} ( lift2 (+) )
  (-)          =  {-_scc_ "(-)"-} ( lift2 (-) )
  (*)          =  {-_scc_ "(*)"-} ( lift2 (*) )
  negate       =  {-_scc_ "negate"-} ( lift1 negate )
  abs          =  {-_scc_ "abs"-} ( lift1 abs )
  fromInteger  =  constantB . fromInteger
  signum       =  noOverloadBId "signum"

fromIntegerB :: Num a => Behavior Integer -> Behavior a
fromIntegerB = {-_scc_ "fromInteger"-} ( lift1 fromInteger )


instance  Real a => Real (Behavior a)  where
  toRational = noOverloadBId "toRational"

toRationalB ::  Real a => Behavior a -> Behavior Rational
toRationalB = {-_scc_ "toRational"-} ( lift1 toRational )


enumSorry =
 error --"Sorry behavior enums currently only work for constant behaviors." 
       "Sorry behavior enums don't work."

instance Enum a => Enum (Behavior a) where
    toEnum	  = noOverloadBId "toEnum"
    fromEnum	  = noOverloadBId "fromEnum"
--  enumFrom (Behavior (ConstantB from) _) = fmap constantB (enumFrom from)
    enumFrom _                             = enumSorry
--      enumFromThen (Behavior (ConstantB from) _)
--                   (Behavior (ConstantB to  ) _) =
--         fmap constantB (enumFromThen from to)
    enumFromThen _ _ = enumSorry

instance (Integral a) => Integral (Behavior a) where
    quot      = {-_scc_ "quot"-} ( lift2 quot )
    rem       = {-_scc_ "rem"-} ( lift2 rem )
    div       = {-_scc_ "div"-} ( lift2 div )
    mod       = {-_scc_ "mod"-} ( lift2 mod )
    quotRem x y  = pairBSplit ({-_scc_ "quotRem"-} ( lift2 quotRem x y) )
    divMod  x y  = pairBSplit ({-_scc_ "divMod"-} ( lift2 divMod  x y) )
    toInteger = noOverloadBId "toInteger"
--    even      = noOverloadBId "even"
--    odd       = noOverloadBId "odd"
    toInt     = noOverloadBId "toInt"

toIntegerB  :: Integral a => Behavior a -> Behavior Integer
evenB, oddB :: Integral a => Behavior a -> BoolB
toIntB      :: Integral a => Behavior a -> IntB

toIntegerB = {-_scc_ "toInteger"-} ( lift1 toInteger )
evenB      = {-_scc_ "even"-} ( lift1 even )
oddB       = {-_scc_ "odd"-} ( lift1 odd )
toIntB     = {-_scc_ "toInt"-} ( lift1 toInt )

instance Fractional a => Fractional (Behavior a) where
  -- fromDouble is not standard Haskell, so GHC objects.  On some tests,
  -- it improved speed by about 10%.
  --fromDouble   =  constantB . fromDouble
  fromRational =  constantB . fromRational
  (/)          =  {-_scc_ "(/)"-} ( lift2 (/) )

instance Floating a => Floating (Behavior a) where
  sin  =  {-_scc_ "sin"-} ( lift1 sin )
  cos  =  {-_scc_ "cos"-} ( lift1 cos )
  tan  =  {-_scc_ "tan"-} ( lift1 tan )
  asin =  {-_scc_ "asin"-} ( lift1 asin )
  acos =  {-_scc_ "acos"-} ( lift1 acos )
  atan =  {-_scc_ "atan"-} ( lift1 atan )
  sinh =  {-_scc_ "sinh"-} ( lift1 sinh )
  cosh =  {-_scc_ "cosh"-} ( lift1 cosh )
  tanh =  {-_scc_ "tanh"-} ( lift1 tanh )
  asinh =  {-_scc_ "asinh"-} ( lift1 asinh )
  acosh =  {-_scc_ "acosh"-} ( lift1 acosh )
  atanh =  {-_scc_ "atanh"-} ( lift1 atanh )

  pi   =  constantB pi
  exp  =  {-_scc_ "exp"-} ( lift1 exp )
  log  =  {-_scc_ "log"-} ( lift1 log )
  sqrt =  {-_scc_ "sqrt"-} ( lift1 sqrt )
  (**) =  {-_scc_ "(**)"-} ( lift2 (**) )
  logBase = {-_scc_ "logBase"-} ( lift2 logBase )


-- The types are too general here.  For all (Integral b), we need to
-- handle b, but can only handle Behavior b.  (See prelude.hs.)

instance  RealFrac a => RealFrac (Behavior a)  where
    properFraction = noOverloadBId "properFraction"
    truncate       = noOverloadBId "truncate"
    round          = noOverloadBId "round"
    ceiling        = noOverloadBId "ceiling"
    floor          = noOverloadBId "floor"

properFractionB   :: (RealFrac a, Integral b) => Behavior a -> Behavior (b,a)
truncateB, roundB :: (RealFrac a, Integral b) => Behavior a -> Behavior b
ceilingB, floorB  :: (RealFrac a, Integral b) => Behavior a -> Behavior b

properFractionB = {-_scc_ "properFraction"-} ( lift1 properFraction )
truncateB = {-_scc_ "truncate"-} ( lift1 truncate )
roundB    = {-_scc_ "round"-} ( lift1 round )
ceilingB  = {-_scc_ "ceiling"-} ( lift1 ceiling )
floorB    = {-_scc_ "floor"-} ( lift1 floor )


{-
instance  RealFloat a => RealFloat (Behavior a)  where
  ... types too restrictive to be liftable ...
-}

{- We could also add these.  Need type declarations.

floatRadixB      = {-_scc_ "floatRadix"-} ( lift1 floatRadix )
floatDigitsB     = {-_scc_ "floatDigits"-} ( lift1 floatDigits )
floatRangeB      = pairBSplit . {-_scc_ "floatRange"-} ( lift1 floatRange )
decodeFloatB     = pairBSplit . {-_scc_ "decodeFloat"-} ( lift1 decodeFloat )
encodeFloatB     = {-_scc_ "encodeFloat"-} ( lift2 encodeFloat )
exponentB        = {-_scc_ "exponent"-} ( lift1 exponent )
significandB     = {-_scc_ "significand"-} ( lift1 significand )
scaleFloatB      = {-_scc_ "scaleFloat"-} ( lift2 scaleFloat )
isNaNB           = {-_scc_ "isNaN"-} ( lift1 isNaN )
isInfiniteB      = {-_scc_ "isInfinite"-} ( lift1 isInfinite )
isDenormalizedB  = {-_scc_ "isDenormalized"-} ( lift1 isDenormalized )
isNegativeZeroB  = {-_scc_ "isNegativeZero"-} ( lift1 isNegativeZero )
isIEEEB          = {-_scc_ "isIEEE"-} ( lift1 isIEEE )

-}
  
-- Non-overloadable numeric functions

-- Various flavors of exponentiation
(^*)    :: (Num a, Integral b)
        => Behavior a -> Behavior b -> Behavior a
(^^*)   :: (Fractional a, Integral b)
        => Behavior a -> Behavior b -> Behavior a

(^*)  = {-_scc_ "(^)"-} ( lift2 (^) )
(^^*) = {-_scc_ "(^^)"-} ( lift2 (^^) )


-- Boolean

trueB, falseB :: BoolB
trueB  = constantB True
falseB = constantB False

notB :: BoolB -> BoolB
notB = {-_scc_ "not"-} ( lift1 (not) )

(&&*) :: BoolB -> BoolB -> BoolB
(&&*) = {-_scc_ "(&&)"-} ( lift2 (&&)  )
(||*) :: BoolB -> BoolB -> BoolB
(||*) = {-_scc_ "(||)"-} ( lift2 (||) )


-- Pair formation and extraction

type PairB a b = Behavior (a,b)

pairB :: Behavior a -> Behavior b -> PairB a b 
fstB  :: PairB a b -> Behavior a
sndB  :: PairB a b -> Behavior b

pairB = {-_scc_ "pair"-} ( lift2 pair )
fstB  = {-_scc_ "fst"-} ( lift1 fst )
sndB  = {-_scc_ "snd"-} ( lift1 snd )

pairBSplit :: PairB a b -> (Behavior a, Behavior b)

pairBSplit b = (fstB b, sndB b)

-- triple formation/extraction

tripleB  :: Behavior a -> Behavior b -> Behavior c -> Behavior (a, b, c)
triple1B :: Behavior (a, b, c) -> Behavior a
triple2B :: Behavior (a, b, c) -> Behavior b
triple3B :: Behavior (a, b, c) -> Behavior c

tripleB  = {-_scc_ "tripleB"-}  ( lift3 (\ a b c -> (a, b, c)) )
triple1B = {-_scc_ "triple1B"-} ( lift1 (\ (a, _, _) -> a) )
triple2B = {-_scc_ "triple2B"-} ( lift1 (\ (_, b, _) -> b) )
triple3B = {-_scc_ "triple3B"-} ( lift1 (\ (_, _, c) -> c) )

tripleBSplit :: Behavior (a, b, c) -> (Behavior a, Behavior b, Behavior c)
tripleBSplit b = (triple1B b, triple2B b, triple3B b)

-- List formation and extraction

nilB  :: Behavior [a]
consB :: Behavior a -> Behavior [a] -> Behavior [a]
headB :: Behavior [a] -> Behavior a
tailB :: Behavior [a] -> Behavior [a]
nullB :: Behavior [a] -> BoolB
(!!*) :: Behavior [a] -> IntB -> Behavior a

nilB  = constantB []
consB = {-_scc_ "(:)"-} ( lift2 (:) )
headB = {-_scc_ "head"-} ( lift1 head )
tailB = {-_scc_ "tail"-} ( lift1 tail )
nullB = {-_scc_ "null"-} ( lift1 null )
(!!*) = {-_scc_ "(!!)"-} ( lift2 (!!) )

-- Turn a list of behaviors into a behavior over list
bListToListB :: [Behavior a] -> Behavior [a]
bListToListB = foldr consB nilB

-- Lift a function over lists into a function over behavior lists
liftL :: ([a] -> b) -> ([Behavior a] -> Behavior b)
liftL f bs = {-_scc_ "f"-} ( lift1 f (bListToListB bs) )

instance Functor Behavior where
 fmap = lift1

-- Maybe

nothingB :: MaybeB a
nothingB = lift0 Nothing

justB :: Behavior a -> MaybeB a
justB = lift1 Just

maybeB :: Behavior a -> Behavior (b -> a) -> MaybeB b -> Behavior a
maybeB = lift3 maybe

-- Monads

-- To do: see if it makes sense to lift monads to monads and monadPlus's
-- to monadPlus's.

(++*) :: MonadPlus m => Behavior (m a) -> Behavior (m a) -> Behavior (m a)
(++*) = {-_scc_ "(++)"-} ( lift2 mplus )

-- Other

showB :: (Show a) => Behavior a -> Behavior String
showB = {-_scc_ "show"-} ( lift1 show )


\end{code}
