mTaskSimulation.icl

   1 implementation module mTaskSimulation
   2
   3 import Generics.gdynamic
   4 import Generics.gCons
   5
   6 import iTasks
   7 import GenEq, StdMisc, StdArray
   8 import mTask
   9 derive class iTask Display
  10
  11 eval :: (Main (Eval t p)) -> [String] | toString t
  12 eval {main=(E f)} = [toString (fst (f Rd zero))]
  13
  14 :: State` =
  15   { tasks :: [(Int, State`->State`)]
  16   , store :: [Dyn]
  17   , dpins :: [(DigitalPin, Bool)]
  18   , apins :: [(AnalogPin, Int)]
  19   , serial:: [String]
  20   , millis:: Int
  21   }
  22
  23 instance zero State` where
  24         zero = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}
  25
  26 //:: TaskSim :== (Int, State`->State`)
  27 :: Eval t p = E ((ReadWrite t) State` -> (t, State`))
  28 toS2S :: (Eval t p) -> (State`->State`)
  29 toS2S (E f) = \state.snd (f Rd state)
  30
  31 unEval :: (Eval t p) -> ((ReadWrite t) State` -> (t, State`))
  32 unEval (E f) = f
  33
  34 :: ReadWrite t = Rd | Wrt t | Updt (t->t)
  35
  36 (>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
  37 //(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
  38 (>>==) (E f) g = E\r s.let (a,t) = f Rd s in unEval (g a) Rd t
  39
  40 rtrn :: t -> Eval t p
  41 rtrn a = E \r s -> (a, s)
  42
  43 yield :: t (Eval s p) -> Eval t Expr
  44 //yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
  45 yield a (E f) = E \r s.(a,snd (f Rd s))
  46
  47 instance arith Eval where
  48   lit a = rtrn a
  49   (+.) x y = x >>==  \a. y >>==  \b. rtrn (a + b)
  50   (-.) x y = x >>==  \a. y >>==  \b. rtrn (a - b)
  51   (*.) x y = x >>==  \a. y >>==  \b. rtrn (a * b)
  52   (/.) x y = x >>==  \a. y >>==  \b. rtrn (a / b)
  53 instance boolExpr Eval where
  54   (&.) x y = x >>==  \a. if a y (rtrn False) // lazy AND
  55   (|.) x y = x >>==  \a. if a (rtrn True) (y >>==  rtrn)
  56   Not x   = x >>==  \a. rtrn (not a)
  57   (==.) x y = x >>==  \a. y >>==  \b. rtrn (a == b)
  58   (!=.) x y = x >>==  \a. y >>==  \b. rtrn (a <> b)
  59   (<.)  x y = x >>==  \a. y >>==  \b. rtrn (a < b)
  60   (>.)  x y = x >>==  \a. y >>==  \b. rtrn (a > b)
  61   (<=.)  x y = x >>==  \a. y >>==  \b. rtrn (a <= b)
  62   (>=.)  x y = x >>==  \a. y >>==  \b. rtrn (a >= b)
  63 instance If Eval p q Expr where
  64   If  c t e = c >>==  \b.if b (toExpr t) (toExpr e)
  65 instance IF Eval where
  66   IF  c t e = c >>==  \b.if b (yield () t) (yield () e)
  67   (?) c t   = c >>==  \b.if b (yield () t) (rtrn ())
  68 instance var2 Eval where
  69   var2 v f = defEval2 v f
  70   con2 v f = defEval2 v f
  71
  72 defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
  73 defEval2 v f =
  74   {main = E (\r s.(length s.store
  75           , {s & store = s.store ++ [toDyn v]}))
  76   >>==  \n.unMain (f (E (read` n)))}
  77 instance sds Eval where
  78   sds f = defEval f
  79   con f = defEval f
  80   pub _ = undef
  81
  82 defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
  83 defEval f =
  84   {main = E \r s.let (v In g) = f (E (read` (length s.store))) in
  85           unEval (unMain g) r {s & store = s.store ++ [toDyn v]}}
  86 instance fun Eval x | arg x where
  87   fun f = e where (g In e) = f (\a.toExpr (g a))
  88 instance mtask Eval x | arg x where
  89  task f = e where
  90   (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]}))
  91 instance mtasks Eval x y | arg x & arg y where
  92  tasks f = e where
  93   ((t,u) In e) =
  94    f ((\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
  95    ,(\d b.long d >>== \(L j).E\r s.(MTask (length s.tasks),{s&tasks=[(j,toS2S (u b)):s.tasks]}))
  96    )
  97 instance setDelay Eval where
  98   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})
  99 class toExpr v where toExpr :: (v t p) -> v t Expr
 100 instance toExpr Eval where toExpr (E f) = E f
 101 instance toExpr Code where toExpr (C f) = C f
 102 instance seq Eval where
 103   (>>=.) x f = x >>==   f o rtrn
 104   (:.) x y = x >>==  \_. y
 105 instance assign Eval where
 106   (=.) (E v) e = e >>==  \a. E \r s.v (Wrt a) s
 107 instance output Eval where
 108   output x = x >>==  \a.E \r s.((),{s & serial = s.serial ++ [toCode a]})
 109 instance pinMode Eval where
 110   pinmode p m = rtrn ()
 111 instance digitalIO Eval where
 112   digitalRead  p   = E \rw s=:{dpins, apins}.(readPinD p dpins apins, s)
 113   digitalWrite p b = b >>== \a. E \rw s.(a, writePinD p a s)
 114 instance analogIO Eval where
 115   analogRead  p   = E \rw s=:{apins}. (readPinA p apins, s)
 116   analogWrite p b = b >>== \a. E \rw s.(a, writePinA p a s)
 117 instance noOp Eval where noOp = E \r s.(undef,s)
 118
 119 class arg x :: x -> Int
 120 instance arg () where arg _ = 0
 121 instance arg (Eval t p) | type t where arg _ = 1
 122 instance arg (Eval t p, Eval u q) | type t & type u where arg _ = 2
 123 instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v where arg _ = 3
 124 instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v where arg _ = 4
 125
 126 instance + String where (+) x y = x +++ y
 127
 128 readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
 129 readPinA p lista
 130   = case [b \\ (q, b) <- lista | p == q] of
 131   []  = 0
 132   [a:x] = a
 133
 134 writePinA :: AnalogPin Int State` -> State`
 135 writePinA p x s
 136   = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}
 137
 138 class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
 139 instance readPinD DigitalPin where
 140   readPinD p listd lista
 141   = case [b \\ (q,b) <- listd | p == q] of
 142     [] = False
 143     [a:x] = a
 144 instance readPinD AnalogPin where
 145   readPinD p listd lista
 146   = case [b \\ (q,b) <- lista | p == q] of
 147     [] = False
 148     [a:x] = a <> 0
 149 class writePinD p :: p Bool State` -> State`
 150 instance writePinD DigitalPin where
 151   writePinD p b s=:{dpins} = {s & dpins = [(p, b):[(q, c) \\ (q, c) <- dpins | p <> q]]}
 152 instance writePinD AnalogPin where
 153   writePinD p b s=:{apins} = {s & apins = [(p, if b 1 0):[(q, c) \\ (q, c) <- apins | p <> q]]}
 154
 155
 156 // ----- Interactive Simulation ----- //
 157
 158 derive class iTask StateInterface, DisplayVar
 159
 160 simulate :: (Main (Eval a p)) -> Task ()
 161 simulate {main=(E f)} = setup zero where
 162   setup s =
 163           updateInformation "State" [] (toView s) @! ()
 164 //        >>* [ OnAction ActionFinish (always shutDown)
 165 //          , OnAction (Action "setup" []) (hasValue
 166 //            (\si.simloop (snd (f Rd (mergeView s si)))))
 167 //          ]
 168   simloop s =
 169           updateInformation "State" [] (toView s) @!()
 170 //        >>* [ OnAction ActionFinish (always shutDown)
 171 //          , OnAction (Action "clear serial" []) (always (simloop {s & serial = []}))
 172 //          , OnAction ActionNew (always (setup zero))
 173 //          : if (isEmpty s.tasks)
 174 //              []
 175 //              [OnAction (Action "loop" []) (hasValue
 176 //            \si.simloop (step` (mergeView s si)))
 177 //            ]
 178 //          ]
 179
 180 toView :: State` -> StateInterface
 181 toView s =
 182   { serialOut = Display s.serial
 183   , analogPins = s.apins
 184   , digitalPins = s.dpins
 185   , var2iables = map toDisplayVar s.store
 186   , timer = s.millis
 187   , taskCount = Display (length s.tasks)
 188   }
 189
 190 mergeView :: State` StateInterface -> State`
 191 mergeView s si =
 192   { s
 193   & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
 194   , dpins = si.digitalPins
 195   , apins = si.analogPins
 196 //  , serial = si.serialOut
 197   , millis = si.timer
 198   }
 199
 200 :: StateInterface =
 201   { serialOut   :: Display [String]
 202   , analogPins  :: [(AnalogPin, Int)]
 203   , digitalPins :: [(DigitalPin, Bool)]
 204   , var2iables   :: [DisplayVar]
 205   , timer     :: Int
 206   , taskCount   :: Display Int
 207   }
 208
 209 toDisplayVar :: Dyn -> DisplayVar
 210 toDisplayVar (Dyn [v])
 211     # i = toInt v
 212     | toString i == v
 213         = INT i
 214         = Variable v
 215 toDisplayVar (Dyn ["L",v]) = LONG (toInt v)
 216 toDisplayVar (Dyn ["Servo",pinKind,pin,pos]) = Servo (fromJust (fromDyn (Dyn [pinKind,pin]))) (toInt pos)
 217 toDisplayVar (Dyn ["LCD",_,_,_,_,_,l1,_,l2,_]) = LCD16x2 l1 l2
 218 toDisplayVar (Dyn l) = DisplayVar l
 219
 220 fromDisplayVar :: DisplayVar Dyn -> Dyn
 221 fromDisplayVar (Variable v)  dyn = Dyn [v]
 222 fromDisplayVar (INT v)     dyn = Dyn [toString v]
 223 fromDisplayVar (LONG v)    dyn = Dyn ["L",toString v]
 224 fromDisplayVar (Servo pin pos) dyn = Dyn (["Servo":let (Dyn p) = toDyn pin in p] ++ [toString pos])
 225 fromDisplayVar (LCD16x2 l1 l2) (Dyn list) = Dyn (updateAt 6 l1 (updateAt 8 l2 list))
 226 fromDisplayVar (DisplayVar l)  dyn = Dyn l
 227
 228 :: DisplayVar
 229     = Variable String
 230     | INT Int
 231     | LONG Int
 232     | Servo Pin Int
 233     | LCD16x2 String String
 234     | DisplayVar [String]
 235
 236
 237 step` :: State` -> State`
 238 step` s =
 239   foldr appTask {s & millis = s.millis + delta, tasks = []}
 240     [(w - delta, f) \\ (w, f) <- s.tasks]
 241 where delta = foldl1 min (map fst s.tasks) // smallest wait
 242
 243 appTask t=:(w,f) s | w <= 0
 244   = f s
 245   = {s & tasks = [t:s.tasks]}
 246
 247 foldl1 op [a:x] = foldl op a x
 248 foldr1 op l :== foldr l
 249   where
 250     foldr [a]     = a
 251     foldr [a:x] = op a (foldr x)
 252
 253 class stringQuotes t | type t :: (Code t p) -> Code t p
 254 instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\""
 255 instance stringQuotes t    where stringQuotes x = x
 256
 257
 258 derive   toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED//, Servo
 259 derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED//, Servo
 260 instance ==   () where (==) _ _ = True
 261
 262
 263