implementation module mTaskSimulation

import Generics.gdynamic
import Generics.gCons

import iTasks
import GenEq, StdMisc, StdArray
import mTask
derive class iTask Display

eval :: (Main (Eval t p)) -> [String] | toString t
eval {main=(E f)} = [toString (fst (f Rd zero))]

:: State` = 
  { tasks :: [(Int, State`->State`)]
  , store :: [Dyn]
  , dpins :: [(DigitalPin, Bool)]
  , apins :: [(AnalogPin, Int)]
  , serial:: [String]
  , millis:: Int
  }

instance zero State` where
	zero = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}

//:: TaskSim :== (Int, State`->State`)
:: Eval t p = E ((ReadWrite t) State` -> (t, State`))
toS2S :: (Eval t p) -> (State`->State`)
toS2S (E f) = \state.snd (f Rd state)

unEval :: (Eval t p) -> ((ReadWrite t) State` -> (t, State`))
unEval (E f) = f

:: ReadWrite t = Rd | Wrt t | Updt (t->t)

(>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
//(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
(>>==) (E f) g = E\r s.let (a,t) = f Rd s in unEval (g a) Rd t

rtrn :: t -> Eval t p
rtrn a = E \r s -> (a, s)

yield :: t (Eval s p) -> Eval t Expr
//yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
yield a (E f) = E \r s.(a,snd (f Rd s))

instance arith Eval where
  lit a = rtrn a
  (+.) x y = x >>==  \a. y >>==  \b. rtrn (a + b)
  (-.) x y = x >>==  \a. y >>==  \b. rtrn (a - b)
  (*.) x y = x >>==  \a. y >>==  \b. rtrn (a * b)
  (/.) x y = x >>==  \a. y >>==  \b. rtrn (a / b)
instance boolExpr Eval where
  (&.) x y = x >>==  \a. if a y (rtrn False) // lazy AND
  (|.) x y = x >>==  \a. if a (rtrn True) (y >>==  rtrn)
  Not x   = x >>==  \a. rtrn (not a)
  (==.) x y = x >>==  \a. y >>==  \b. rtrn (a == b)
  (!=.) x y = x >>==  \a. y >>==  \b. rtrn (a <> b)
  (<.)  x y = x >>==  \a. y >>==  \b. rtrn (a < b)
  (>.)  x y = x >>==  \a. y >>==  \b. rtrn (a > b)
  (<=.)  x y = x >>==  \a. y >>==  \b. rtrn (a <= b)
  (>=.)  x y = x >>==  \a. y >>==  \b. rtrn (a >= b)
instance If Eval p q Expr where
  If  c t e = c >>==  \b.if b (toExpr t) (toExpr e)
instance IF Eval where
  IF  c t e = c >>==  \b.if b (yield () t) (yield () e)
  (?) c t   = c >>==  \b.if b (yield () t) (rtrn ())
instance var2 Eval where
  var2 v f = defEval2 v f
  con2 v f = defEval2 v f

defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
defEval2 v f = 
  {main = E (\r s.(length s.store
          , {s & store = s.store ++ [toDyn v]}))
  >>==  \n.unMain (f (E (read` n)))}
instance sds Eval where
  sds f = defEval f
  con f = defEval f

defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
defEval f = 
  {main = E \r s.let (v In g) = f (E (read` (length s.store))) in
          unEval (unMain g) r {s & store = s.store ++ [toDyn v]}}
instance fun Eval x | arg x where
  fun f = e where (g In e) = f (\a.toExpr (g a))
instance mtask Eval x | arg x where
 task f = e where
  (t In e) = f (\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
instance mtasks Eval x y | arg x & arg y where
 tasks f = e where
  ((t,u) In e) = 
   f ((\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
   ,(\d b.long d >>== \(L j).E\r s.(MTask (length s.tasks),{s&tasks=[(j,toS2S (u b)):s.tasks]}))
   )
instance setDelay Eval where
  setDelay d t = d >>==  \(L x). t >>==  \(MTask n).E \r s.(MTask n,{s & tasks = updateAt n (x,snd (s.tasks !! n)) s.tasks})
class toExpr v where toExpr :: (v t p) -> v t Expr
instance toExpr Eval where toExpr (E f) = E f
instance toExpr Code where toExpr (C f) = C f
instance seq Eval where
  (>>=.) x f = x >>==   f o rtrn
  (:.) x y = x >>==  \_. y
instance assign Eval where
  (=.) (E v) e = e >>==  \a. E \r s.v (Wrt a) s
instance output Eval where
  output x = x >>==  \a.E \r s.((),{s & serial = s.serial ++ [toCode a]})
instance pinMode Eval where
  pinmode p m = rtrn ()
instance digitalIO Eval where
  digitalRead  p   = E \rw s=:{dpins, apins}.(readPinD p dpins apins, s)
  digitalWrite p b = b >>== \a. E \rw s.(a, writePinD p a s)
instance analogIO Eval where
  analogRead  p   = E \rw s=:{apins}. (readPinA p apins, s)
  analogWrite p b = b >>== \a. E \rw s.(a, writePinA p a s)
instance noOp Eval where noOp = E \r s.(undef,s)

class arg x :: x -> Int
instance arg () where arg _ = 0
instance arg (Eval t p) | type t where arg _ = 1
instance arg (Eval t p, Eval u q) | type t & type u where arg _ = 2
instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v where arg _ = 3
instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v where arg _ = 4

instance + String where (+) x y = x +++ y

readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
readPinA p lista
  = case [b \\ (q, b) <- lista | p == q] of
  []  = 0
  [a:x] = a

writePinA :: AnalogPin Int State` -> State`
writePinA p x s
  = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}

class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
instance readPinD DigitalPin where
  readPinD p listd lista
  = case [b \\ (q,b) <- listd | p == q] of
    [] = False
    [a:x] = a
instance readPinD AnalogPin where
  readPinD p listd lista
  = case [b \\ (q,b) <- lista | p == q] of
    [] = False
    [a:x] = a <> 0
class writePinD p :: p Bool State` -> State`
instance writePinD DigitalPin where
  writePinD p b s=:{dpins} = {s & dpins = [(p, b):[(q, c) \\ (q, c) <- dpins | p <> q]]}
instance writePinD AnalogPin where
  writePinD p b s=:{apins} = {s & apins = [(p, if b 1 0):[(q, c) \\ (q, c) <- apins | p <> q]]}


// ----- Interactive Simulation ----- //

derive class iTask StateInterface, DisplayVar

simulate :: (Main (Eval a p)) -> Task ()
simulate {main=(E f)} = setup zero where
  setup s =
	  updateInformation "State" [] (toView s) @! ()
//	  >>* [ OnAction ActionFinish (always shutDown)
//	    , OnAction (Action "setup" []) (hasValue 
//	      (\si.simloop (snd (f Rd (mergeView s si)))))
//	    ]
  simloop s =
	  updateInformation "State" [] (toView s) @!()
//	  >>* [ OnAction ActionFinish (always shutDown)
//	    , OnAction (Action "clear serial" []) (always (simloop {s & serial = []}))
//	    , OnAction ActionNew (always (setup zero))
//	    : if (isEmpty s.tasks)
//	        []
//	        [OnAction (Action "loop" []) (hasValue
//	      \si.simloop (step` (mergeView s si)))
//	      ]
//	    ]

toView :: State` -> StateInterface
toView s = 
  { serialOut = Display s.serial
  , analogPins = s.apins
  , digitalPins = s.dpins
  , var2iables = map toDisplayVar s.store
  , timer = s.millis
  , taskCount = Display (length s.tasks)
  }

mergeView :: State` StateInterface -> State`
mergeView s si = 
  { s
  & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
  , dpins = si.digitalPins
  , apins = si.analogPins
//  , serial = si.serialOut
  , millis = si.timer
  }

:: StateInterface =
  { serialOut   :: Display [String]
  , analogPins  :: [(AnalogPin, Int)]
  , digitalPins :: [(DigitalPin, Bool)]
  , var2iables   :: [DisplayVar]
  , timer     :: Int
  , taskCount   :: Display Int
  }

toDisplayVar :: Dyn -> DisplayVar
toDisplayVar (Dyn [v])
    # i = toInt v
    | toString i == v
        = INT i
        = Variable v
toDisplayVar (Dyn ["L",v]) = LONG (toInt v)
toDisplayVar (Dyn ["Servo",pinKind,pin,pos]) = Servo (fromJust (fromDyn (Dyn [pinKind,pin]))) (toInt pos)
toDisplayVar (Dyn ["LCD",_,_,_,_,_,l1,_,l2,_]) = LCD16x2 l1 l2
toDisplayVar (Dyn l) = DisplayVar l

fromDisplayVar :: DisplayVar Dyn -> Dyn
fromDisplayVar (Variable v)  dyn = Dyn [v]
fromDisplayVar (INT v)     dyn = Dyn [toString v]
fromDisplayVar (LONG v)    dyn = Dyn ["L",toString v]
fromDisplayVar (Servo pin pos) dyn = Dyn (["Servo":let (Dyn p) = toDyn pin in p] ++ [toString pos])
fromDisplayVar (LCD16x2 l1 l2) (Dyn list) = Dyn (updateAt 6 l1 (updateAt 8 l2 list))
fromDisplayVar (DisplayVar l)  dyn = Dyn l

:: DisplayVar
    = Variable String
    | INT Int
    | LONG Int
    | Servo Pin Int
    | LCD16x2 String String
    | DisplayVar [String]


step` :: State` -> State`
step` s = 
  foldr appTask {s & millis = s.millis + delta, tasks = []}
    [(w - delta, f) \\ (w, f) <- s.tasks]
where delta = foldl1 min (map fst s.tasks) // smallest wait

appTask t=:(w,f) s | w <= 0
  = f s
  = {s & tasks = [t:s.tasks]}

foldl1 op [a:x] = foldl op a x
foldr1 op l :== foldr l
  where
    foldr [a]     = a
    foldr [a:x] = op a (foldr x)

class stringQuotes t | type t :: (Code t p) -> Code t p
instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\""
instance stringQuotes t    where stringQuotes x = x


derive   toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED//, Servo
derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED//, Servo
instance ==   () where (==) _ _ = True