1 implementation module mTask
4 Pieter Koopman pieter@cs.ru.nl
5 Final version for TFP2016
7 -2: assignment =. suited for digital and analog input and output
11 move task-loop ti setup()
18 import gdynamic, gCons, GenEq, StdMisc, StdArray
19 import mTaskSerial, mTaskLCD
21 instance toCode Pin where
22 toCode (Digital p) = toCode p
23 toCode (Analog p) = toCode p
25 instance pin DigitalPin where
28 instance pin AnalogPin where
31 instance isExpr Upd where isExpr _ = 0
32 instance isExpr Expr where isExpr _ = 1
34 instance isStmt Upd where isStmt _ = 10
35 instance isStmt Expr where isStmt _ = 11
36 instance isStmt Stmt where isStmt _ = 12
38 instance == MTask where (==) (MTask x) (MTask y) = x == y
39 instance toCode MTask where toCode (MTask x) = "Task " + toCode x
41 unMain :: (Main x) -> x
42 unMain m = m.main //{main=x} = x
44 instance pio AnalogPin Int where pio p = aIO p
45 instance pio AnalogPin Bool where pio p = dIO p
46 instance pio DigitalPin Bool where pio p = dIO p
48 int :: (v Int p) -> (v Int p)
50 bool :: (v Bool p) -> (v Bool p)
52 char :: (v Char p) -> (v Char p)
55 instance type2string Int where type2string _ = "int"
56 instance type2string Long where type2string _ = "long"
57 instance type2string Real where type2string _ = "float"
58 instance type2string Bool where type2string _ = "bool" //"boolean"
59 instance type2string Char where type2string _ = "char"
60 instance type2string MTask where type2string _ = "task"
61 instance type2string DigitalPin where type2string _ = "int"
62 instance type2string AnalogPin where type2string _ = "int"
63 instance type2string String where type2string _ = "Char []"
64 instance type2string () where type2string _ = ""
66 instance varName Int where varName _ = "vInt"
67 instance varName Long where varName _ = "vLong"
68 instance varName Bool where varName _ = "vBool"
69 instance varName Char where varName _ = "vChar"
70 instance varName Real where varName _ = "vFloat"
71 instance varName x where varName _ = ""
73 argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
76 instance argTypes (Code a p) | showType a where argTypes f = showType
77 instance argTypes (Code a p, Code b q) | showType a & showType b where argTypes f = (showType, showType)
78 instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c where argTypes f = (showType, showType, showType)
80 resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
83 var2Type :: (Code t p) -> Code t p | showType t
86 resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
87 resType2 f = showType2
89 instance toCode (SV t) where toCode (SV s) = s
91 instance showType2 () where showType2 = SV "void "
92 instance showType2 Int where showType2 = SV "int "
93 instance showType2 Char where showType2 = SV "char "
94 instance showType2 Bool where showType2 = SV "bool "
95 instance showType2 a where showType2 = SV "word /* default */"
97 instance showType () where showType = c "void "
98 instance showType Int where showType = c "int "
99 instance showType Long where showType = c "long "
100 instance showType Char where showType = c "char "
101 instance showType Bool where showType = c "bool "
102 instance showType a where showType = c "word /* default */ "
104 instance typeSelector Int where typeSelector = c ".i"
105 instance typeSelector Char where typeSelector = c ".c"
106 instance typeSelector Bool where typeSelector = c ".b"
107 instance typeSelector a where typeSelector = c ".w"
109 read` :: Int (ReadWrite a) State -> (a,State) | dyn a
110 read` n Rd s = (fromJust (fromDyn (s.store !! n)), s)
111 read` n (Wrt a) s = (a,{s&store=updateAt n (toDyn a) s.store})
112 read` n (Updt f) s=:{store}
113 # obj = f (fromJust (fromDyn (store !! n)))
114 = (obj, {s & store = updateAt n (toDyn obj) store})
116 // ----- code generation ----- //
118 instance arith Code where
120 (+.) x y = codeOp2 x " + " y
121 (-.) x y = codeOp2 x " - " y
122 (*.) x y = codeOp2 x " * " y
123 (/.) x y = codeOp2 x " / " y
124 instance boolExpr Code where
125 (&.) x y = codeOp2 x " && " y
126 (|.) x y = codeOp2 x " || " y
127 Not x = embed (brac (c "! " +.+ brac x))
128 (==.) x y = codeOp2 x " == " y
129 (!=.) x y = codeOp2 x " != " y
130 (<.) x y = codeOp2 x " < " y
131 (<=.) x y = codeOp2 x " <= " y
132 (>.) x y = codeOp2 x " > " y
133 (>=.) x y = codeOp2 x " >= " y
134 instance If Code Stmt Stmt Stmt where If c t e = IfStmt c t e
135 instance If Code e Stmt Stmt where If c t e = IfStmt c t e
136 instance If Code Stmt e Stmt where If c t e = IfStmt c t e
137 instance If Code x y Expr where If c t e = IfExpr c t e
138 IfExpr b t e = embed (brac (b +.+ indent +.+ nl +.+ c " ? " +.+ t +.+ nl +.+ c " : " +.+ e +.+ unindent))
147 _ = if (v == "") NoReturn (Assign v)
150 c "if " +.+ brac b +.+ c " {" +.+
151 indent +.+ nl +.+ setMode newMode +.+ t +.+ unindent +.+ nl +.+ c "} else {" +.+
152 indent +.+ nl +.+ setMode newMode +.+ e +.+ unindent +.+ nl +.+ c "}"
153 instance IF Code where
154 IF b t e = IfStmt b t e
157 c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+
158 indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}"
160 instance sds Code where
163 let name = "sds"+toCode n
164 (v In body) = f (C (var name))
165 in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
166 ";\n") +.+ setCode Setup +.+ unMain body}
169 defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
172 let name = "sds"+toCode n
173 (v In body) = f (C (var name))
174 in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
175 ";\n") +.+ setCode Setup +.+ unMain body}
177 var :: String (ReadWrite (Code v q)) CODE -> CODE
178 var sds Rd s = unC (embed (c sds)) Rd s
179 var sds (Wrt v) s = unC (embed (c ("(" + sds + " = ") +.+ v +.+ c ")")) Rd s
181 instance assign Code where
182 (=.) (C v) e = embed (setMode SubExp +.+ C \rw c.v (Wrt (toExpr e)) c)
183 instance seq Code where
185 getMode \mode. fresh \n. let v = "b" + toCode n in
186 addBinds v +.+ var2Type x +.+ c (v + ";") +.+ nl +.+
187 setMode (Assign v) +.+ x +.+ nl +.+ setMode mode +.+ f (embed (c v))
188 (:.) x y = getMode \mode. setMode NoReturn +.+ embed x +.+ nl +.+ setMode mode +.+ y
189 instance step` Code where
191 getMode \mode. fresh \n.
192 let v = "s" + toCode n in
193 c "while(true) {" +.+ indent +.+ nl +.+
194 var2Type x +.+ c (v + ";") +.+ nl +.+
195 setMode (Assign v) +.+ x +.+ nl +.+
196 setMode mode +.+ codeSteps (f (c v)) +.+
197 unindent +.+ nl +.+ c "}"
198 codeSteps :: [Step Code t] -> Code u p
199 codeSteps [] = C \rw c.c
200 codeSteps [Cond b e:x] =
201 getMode \mode. setMode SubExp +.+
202 c "if (" +.+ b +.+ c ") {" +.+ indent +.+ nl +.+
203 setMode mode +.+ e +.+
204 optBreak mode +.+ unindent +.+ nl +.+ c "}" +.+ nl +.+ setMode mode +.+ codeSteps x
205 codeSteps [Ever e:x] =
206 getMode \mode. e +.+ optBreak mode
208 optBreak :: Mode -> Code u p
212 _ = nl +.+ c "break;"
214 instance setDelay Code where
215 setDelay d t = embed (c "setDelay" +.+ brac (t +.+ c ", " +.+ d))
216 instance mtask Code a | taskImp2 a & types a where
218 {main = freshMTask \n.
219 let (app, a) = taskImp2 n types
220 (b In main) = f (\d a.app (long d) a)
221 in codeMTaskBody (loopCode n (b a)) (unMain main)}
222 instance mtasks Code a b | taskImp2 a & types a & taskImp2 b & types b where
227 let (app1, a1) = taskImp2 t1 types
228 (app2, a2) = taskImp2 t2 types
229 ((b1, b2) In main) = f ((\d a.app1 (long d) a),(\d a.app2 (long d) a))
230 in codeMTaskBody (loopCode t2 (b2 a2)) (codeMTaskBody (loopCode t1 (b1 a1)) (unMain main))}
231 loopCode :: Int (Code a b) -> Code c d
233 nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
234 setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+
235 unindent +.+ nl +.+ c "} "
237 class taskImp2 a :: Int a -> ((Code Long p) a->Code MTask Expr, a) | /*long Code delay &*/ isExpr p
238 instance taskImp2 () where
239 taskImp2 n () = (app, ())
240 where app d a = setBinds [] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ d +.+ c ")")
241 instance taskImp2 (Code t p) where
242 taskImp2 n type1 = (app, ta)
247 setBinds [n0] +.+ embed (c "newTask(" +.+
251 instance taskImp2 (Code a p, Code b q) where
252 taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
258 setBinds [n0,n1] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ long d +.+
259 c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
260 instance taskImp2 (Code a p, Code b q, Code c r) where
261 taskImp2 n (type1, type2, type3) = (app, (ta1, ta2, ta3))
270 setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+
276 instance taskImp2 (Code a p, Code b q, Code c r, Code d s) where
277 taskImp2 n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
287 app d (a1, a2, a3, a4) =
288 setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+
296 class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
297 instance taskImp () where
298 taskImp n () = (app, ())
299 where app i a = embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+ c ")")
300 instance taskImp (Code t p) where
301 taskImp n type1 = (app, ta)
303 ta = c "t0p->a[0]" +.+ type1
305 embed (c "newTask(" +.+
309 instance taskImp (Code a p, Code b q) where
310 taskImp n (type1, type2) = (app, (ta1, ta2)) where
311 ta1 = c "t0p->a[0]" +.+ type1
312 ta2 = c "t0p->a[1]" +.+ type2
314 embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+
315 c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
316 instance taskImp (Code a p, Code b q, Code c r) where
317 taskImp n (type1, type2, type3) = (app, (ta1, ta2, ta3))
319 ta1 = c "t0p->a[0]" +.+ type1
320 ta2 = c "t0p->a[1]" +.+ type2
321 ta3 = c "t0p->a[2]" +.+ type3
323 embed (c "newTask(" +.+
329 instance taskImp (Code a p, Code b q, Code c r, Code d s) where
330 taskImp n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
332 ta1 = c "t0p->a[0]" +.+ type1
333 ta2 = c "t0p->a[1]" +.+ type2
334 ta3 = c "t0p->a[2]" +.+ type3
335 ta4 = c "t0p->a[3]" +.+ type4
336 app i (a1, a2, a3, a4) =
337 embed (c "newTask(" +.+
345 tasksMain :: Int Int ((a->Code MTask Expr,b->Code MTask Expr) -> In (a->Code c d,b->Code e f) (Main (Code g h))) -> Main (Code i j) | taskImp a & types a & taskImp b & types b
348 freshMTask \n. freshMTask \m.
350 (app1, a1) = taskImp n types
351 (app2, a2) = taskImp m types
352 ((b1, b2) In {main = e}) = f (app1 i, app2 j)
354 codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
357 instance types () where types = ()
358 instance types (Code a p) | typeSelector a & isExpr p
359 where types = typeSelector
360 instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
361 where types = (typeSelector, typeSelector)
362 instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
363 where types = (typeSelector, typeSelector, typeSelector)
364 instance types (Code a p, Code b q, Code c r, Code d s) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r & typeSelector d & isExpr s
365 where types = (typeSelector, typeSelector, typeSelector, typeSelector)
367 codeMTaskBody :: (Code v w) (Code c d) -> Code e f
368 codeMTaskBody loop e =
371 setCode Loop +.+ loop +.+
372 setMode mode +.+ setCode Setup +.+ embed e
373 instance fun Code () where
375 {main = getMode \mode. fresh \n.
376 let fname = c ("f" + toCode n)
377 (g In {main=e}) = f (\x.embed (fname +.+ c " ()"))
378 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " () " +.+
379 funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [] +.+ g ()) +.+ setCode Setup +.+ setMode mode +.+ e
381 instance fun Code (Code t p) | type, showType t & isExpr p where
384 getMode \mode. fresh \n.
385 let fname = c ("f" + toCode n)
386 aname = "a" + toCode n
387 (g In {main=e}) = f (\x.embed (fname +.+ c " " +.+ brac x))
388 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
389 brac (argTypes f +.+ c (" " + aname)) +.+
390 funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [aname] +.+ g (embed (c aname))) +.+ setCode Setup +.+ setMode mode +.+ e
392 instance fun Code (Code a p, Code b q) | showType a & showType b where
395 getMode \mode. fresh \n.
396 let fname = c ("f" + toCode n + " ")
397 aname = "a" + toCode n //+ " "
398 bname = "b" + toCode n //+ " "
399 (atype, btype) = argTypes f
401 = f (\(x,y).embed (fname +.+ codeOp2 x ", " y))
402 in setCode Fun +.+ nl +.+ resType f +.+ fname +.+
403 codeOp2 (atype +.+ c aname) ", " (btype +.+ c bname) +.+
404 funBody (setMode (Return (toCode (resType2 f))) +.+
405 setBinds [aname,bname] +.+ g (embed (c aname), embed (c bname))) +.+
406 setCode Setup +.+ setMode mode +.+ unMain main
408 instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
411 getMode \mode. fresh \n.
412 let fname = c ("f" + toCode n)
413 aname = "a" + toCode n
414 bname = "b" + toCode n
415 cname = "c" + toCode n
416 (atype,btype,ctype) = argTypes f
417 (g In {main=e}) = f (\(x,y,z).embed (fname +.+ c " " +.+ brac (x +.+ c ", " +.+ y +.+ c ", " +.+ z)))
418 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
419 brac (atype +.+ c (" " + aname + ", ") +.+ btype +.+ c (" " + bname + ", ") +.+ ctype +.+ c (" " + cname)) +.+
420 funBody (setMode (Return (toCode (resType2 f))) +.+
421 setBinds [aname,bname,cname] +.+ g (embed (c aname), embed (c bname), embed (c cname))) +.+ setCode Setup +.+ setMode mode +.+ e
423 instance output Code where
424 output x = embed (c "Serial.println(" +.+ x +.+ c ")")
425 instance pinMode Code where
426 pinmode p m = embed (c ("pinMode(" + toCode p + ", " + consName{|*|} m + ")"))
427 instance digitalIO Code where
428 digitalRead p = embed (c ("digitalRead(" + toCode p + ")"))
429 digitalWrite p b = embed (c ("digitalWrite(" + toCode p + ", ") +.+ b +.+ c ")")
430 instance dIO Code where
431 dIO p = C (ioc p) where
432 ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin, readPinD p
433 ioc p Rd s = f Rd s where (C f) = embed (c ("digitalRead(" + toCode p + ")"))
434 ioc p (Wrt v) s = f Rd s where (C f) = embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")
435 instance aIO Code where
436 aIO p = C (ioc p) where
437 ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin p
438 ioc p Rd s = unC (embed (c ("analogRead(" + toCode p + ")"))) Rd s
439 ioc p (Wrt v) s = unC (embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")) Rd s
440 instance analogIO Code where
441 analogRead p = embed (c ("analogRead(" + toCode p + ")"))
442 analogWrite p b = embed (c ("analogWrite(" + toCode p + ", ") +.+ b +.+ c ")")
443 instance noOp Code where noOp = C \rw c.c
445 :: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
457 , includes :: [String]
463 unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
466 :: Def = Var | Fun | Setup | Loop
467 :: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
469 setMode :: Mode -> Code a p
470 setMode m = C \rw c.{c & mode = m}
472 getMode :: (Mode -> Code a p) -> Code a p
473 getMode f = C \rw c.unC (f c.mode) rw c
475 embed :: (Code a p) -> Code a p
477 getMode \m. case m of
478 NoReturn = setMode SubExp +.+ e +.+ c ";"
479 Return "void" = setMode SubExp +.+ e +.+ c ";"
480 Return t = c "return " +.+ setMode SubExp +.+ e +.+ c ";"
481 Assign s = c (s + " = ") +.+ setMode SubExp +.+ e +.+ c ";"
483 _ = abort "\n\nembed: unknown mode.\n"
485 (+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
486 (+.+) (C f) (C g) = C \rw c.g Rd (f Rd c)
488 fresh :: (Int -> (Code a p)) -> (Code a p)
489 fresh f = C \rw c.unC (f c.fresh) rw {c & fresh = c.fresh + 1}
491 freshMTask :: (Int -> (Code a p)) -> (Code a p)
492 freshMTask f = C \rw c.unC (f c.freshMTask) rw {c & freshMTask = c.freshMTask + 1}
494 setCode :: Def -> (Code a p)
495 setCode d = C \rw c.{c & def = d}
497 getCode :: (Def -> Code a p) -> (Code a p)
498 getCode f = C \rw c.unC (f c.def) rw c
500 brac :: (Code a p) -> Code b q
501 brac e = c "(" +.+ e +.+ c ")"
503 funBody :: (Code a p) -> Code b q
504 funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl
506 codeOp2 :: (Code a p) String (Code b q) -> Code c r
507 codeOp2 x n y = embed (brac (x +.+ c n +.+ y))
509 include :: String -> Code a b
510 include lib = C \rw c.{c & includes = [lib:c.includes]}
512 argList :: [a] -> String | toCode a
513 argList [a] = toCode a
514 argList [a:x] = toCode a + "," + argList x
517 c :: a -> Code b p | toCode a
518 c a = C \rw c.case c.def of
519 Fun = {c & funs = [toCode a: c.funs]}
520 Var = {c & vars = [toCode a: c.vars]}
521 Setup = {c & setup = [toCode a: c.setup]}
522 Loop = {c & loop = [toCode a: c.loop]}
526 C \rw c.case c.def of
527 Fun = {c & ifuns = inc c.ifuns}
528 Var = {c & ivars = inc c.ivars}
529 Setup = {c & isetup = inc c.isetup}
530 Loop = {c & iloop = inc c.iloop}
534 C \rw c.case c.def of
535 Fun = {c & ifuns = dec c.ifuns}
536 Var = {c & ivars = dec c.ivars}
537 Setup = {c & isetup = dec c.isetup}
538 Loop = {c & iloop = dec c.iloop}
546 C \rw c.case c.def of
547 Fun = {c & funs = [str c.ifuns: c.funs]}
548 Var = {c & vars = [str c.ivars: c.vars]}
549 Setup = {c & setup = [str c.isetup: c.setup]}
550 Loop = {c & loop = [str c.iloop: c.loop]}
552 str n = toString ['\n':repeatn (tabSize * n) ' ']
554 setBinds :: [String] -> Code a p
555 setBinds list = C \rw c.{c & binds = list}
557 addBinds :: String -> Code a p
558 addBinds name = C \rw c.{c & binds = [name:c.binds]}
560 getBinds :: ([String] -> Code a p) -> (Code a p)
561 getBinds f = C \rw c.unC (f c.binds) rw c
563 // ----- driver ----- //
565 compile :: (Main (Code a p)) -> [String]
566 compile {main=(C f)} =
568 ," Generated code for Arduino\n"
569 ," Pieter Koopman, pieter@cs.ru.nl\n"
572 ,"#define MAX_ARGS 4\n"
573 ,"#define MAX_TASKS 20\n"
574 ,"#define MAX_TASK_NO MAX_TASKS - 1\n"
575 ,"#define NEXT_TASK(n) ((n) == MAX_TASK_NO ? 0 : (n) + 1)\n"
577 ,"typedef union Arg {\n"
581 // ," float f;\n" // requires 4 bytes
585 ,"typedef struct Task {\n"
588 ," ARG a[MAX_ARGS];\n"
592 foldr (\lib c.["#include <":lib:".h>\n":c]) [] (mkset c.includes) ++
593 ["\n// --- variables ---\n"
594 ,"TASK tasks[MAX_TASKS];\n"
595 ,"byte t0 = 0, tc = 0, tn = 0;\n"
602 ,"unsigned long time = 0;\n"
605 ["\n// --- functions ---\n"
606 ,"byte newTask(byte id, long wait, word a0 = 0, word a1 = 0, word a2 = 0, word a3 = 0) {\n"
607 ," TASK *tnp = &tasks[tn];\n"
609 ," tnp->wait = wait;\n"
610 ," tnp->a[0].w = a0;\n"
611 ," tnp->a[1].w = a1;\n"
612 ," tnp->a[2].w = a2;\n"
613 ," tnp->a[3].w = a3;\n"
615 ," tn = NEXT_TASK(tn);\n"
619 ,"byte setDelay(byte t, long d) {\n"
620 ," tasks[t].wait = d;\n"
623 ,"boolean pressed(int b) {\n"
624 ," pinMode(A0, INPUT);\n"
625 ," int a0 = analogRead(A0);\n"
627 ," case 0: return a0 < ",toString RightBound,"; // right\n"
628 ," case 1: return ",toString RightBound," < a0 && a0 < ",toString UpBound,"; // up\n"
629 ," case 2: return ",toString UpBound," < a0 && a0 < ",toString DownBound,";// down\n"
630 ," case 3: return ",toString DownBound," < a0 && a0 < ",toString LeftBound,";//left\n"
631 ," case 4: return ",toString LeftBound," < a0 && a0 < ",toString SelectBound,";//select\n"
632 ," default: return ",toString SelectBound," < a0; //no button\n"
635 ,"boolean pWrite (int pin, boolean b) {\n"
636 ," pinMode(pin, OUTPUT);\n"
637 ," digitalWrite(pin, b);\n"
640 ,"int pWrite (int pin, int i) {\n"
641 ," pinMode(pin, OUTPUT);\n"
642 ," analogWrite(pin, i);\n"
647 ["\n// --- setup --- \n"
649 ," Serial.begin(9600);\n"
654 ,"\n// --- loop --- \n"
656 ," if (t0 != tn) {\n"
657 ," if (t0 == tc) {\n"
658 ," unsigned long time2 = millis();\n"
659 ," delta = time2 - time;\n"
663 ," TASK* t0p = &tasks[t0];\n"
664 ," t0p->wait -= delta;\n"
665 ," if (t0p->wait > 0L) {\n"
666 ," newTask(t0p->id, t0p->wait, t0p->a[0].w, t0p->a[1].w, t0p->a[2].w, t0p->a[3].w);\n"
668 ," switch (t0p->id) {"
673 ," Serial.println(\"stopped\");\n"
674 ," t0 = tn; // no known task: force termination of tasks\n"
678 ," t0 = NEXT_TASK(t0);\n"
682 where c = f Rd newCode
684 mkset :: [a] -> [a] | Eq a
685 mkset [a:x] = [a:mkset (filter ((<>) a) x)]
706 // ----- simulation ----- //
708 eval :: (Main (Eval t p)) -> [String] | toString t
709 eval {main=(E f)} = [toString (fst (f Rd state0))]
712 { tasks :: [(Int, State->State)]
714 , dpins :: [(DigitalPin, Bool)]
715 , apins :: [(AnalogPin, Int)]
721 state0 = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}
723 //:: TaskSim :== (Int, State->State)
724 :: Eval t p = E ((ReadWrite t) State -> (t, State))
725 toS2S :: (Eval t p) -> (State->State)
726 toS2S (E f) = \state.snd (f Rd state)
728 unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
731 :: ReadWrite t = Rd | Wrt t | Updt (t->t)
733 (>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
734 //(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
735 (>>==) (E f) g = E\r s.let (a,t) = f Rd s in unEval (g a) Rd t
737 rtrn :: t -> Eval t p
738 rtrn a = E \r s -> (a, s)
740 yield :: t (Eval s p) -> Eval t Expr
741 //yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
742 yield a (E f) = E \r s.(a,snd (f Rd s))
744 instance arith Eval where
746 (+.) x y = x >>== \a. y >>== \b. rtrn (a + b)
747 (-.) x y = x >>== \a. y >>== \b. rtrn (a - b)
748 (*.) x y = x >>== \a. y >>== \b. rtrn (a * b)
749 (/.) x y = x >>== \a. y >>== \b. rtrn (a / b)
750 instance boolExpr Eval where
751 (&.) x y = x >>== \a. if a y (rtrn False) // lazy AND
752 (|.) x y = x >>== \a. if a (rtrn True) (y >>== rtrn)
753 Not x = x >>== \a. rtrn (not a)
754 (==.) x y = x >>== \a. y >>== \b. rtrn (a == b)
755 (!=.) x y = x >>== \a. y >>== \b. rtrn (a <> b)
756 (<.) x y = x >>== \a. y >>== \b. rtrn (a < b)
757 (>.) x y = x >>== \a. y >>== \b. rtrn (a > b)
758 (<=.) x y = x >>== \a. y >>== \b. rtrn (a <= b)
759 (>=.) x y = x >>== \a. y >>== \b. rtrn (a >= b)
760 instance If Eval p q Expr where
761 If c t e = c >>== \b.if b (toExpr t) (toExpr e)
762 instance IF Eval where
763 IF c t e = c >>== \b.if b (yield () t) (yield () e)
764 (?) c t = c >>== \b.if b (yield () t) (rtrn ())
765 instance var2 Eval where
766 var2 v f = defEval2 v f
767 con2 v f = defEval2 v f
769 defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
771 {main = E (\r s.(length s.store
772 , {s & store = s.store ++ [toDyn v]}))
773 >>== \n.unMain (f (E (read` n)))}
774 instance sds Eval where
778 defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
780 {main = E \r s.let (v In g) = f (E (read` (length s.store))) in
781 unEval (unMain g) r {s & store = s.store ++ [toDyn v]}}
782 instance fun Eval x | arg x where
783 fun f = e where (g In e) = f (\a.toExpr (g a))
784 instance mtask Eval x | arg x where
786 (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]}))
787 instance mtasks Eval x y | arg x & arg y where
790 f ((\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
791 ,(\d b.long d >>== \(L j).E\r s.(MTask (length s.tasks),{s&tasks=[(j,toS2S (u b)):s.tasks]}))
793 instance setDelay Eval where
794 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})
795 class toExpr v where toExpr :: (v t p) -> v t Expr
796 instance toExpr Eval where toExpr (E f) = E f
797 instance toExpr Code where toExpr (C f) = C f
798 instance seq Eval where
799 (>>=.) x f = x >>== f o rtrn
800 (:.) x y = x >>== \_. y
801 instance assign Eval where
802 (=.) (E v) e = e >>== \a. E \r s.v (Wrt a) s
803 instance output Eval where
804 output x = x >>== \a.E \r s.((),{s & serial = s.serial ++ [toCode a]})
805 instance pinMode Eval where
806 pinmode p m = rtrn ()
807 instance digitalIO Eval where
808 digitalRead p = E \rw s=:{dpins, apins}.(readPinD p dpins apins, s)
809 digitalWrite p b = b >>== \a. E \rw s.(a, writePinD p a s)
810 instance analogIO Eval where
811 analogRead p = E \rw s=:{apins}. (readPinA p apins, s)
812 analogWrite p b = b >>== \a. E \rw s.(a, writePinA p a s)
813 instance noOp Eval where noOp = E \r s.(undef,s)
815 class arg x :: x -> Int
816 instance arg () where arg _ = 0
817 instance arg (Eval t p) | type t where arg _ = 1
818 instance arg (Eval t p, Eval u q) | type t & type u where arg _ = 2
819 instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v where arg _ = 3
820 instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v where arg _ = 4
822 instance + String where (+) x y = x +++ y
824 readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
826 = case [b \\ (q, b) <- lista | p == q] of
830 writePinA :: AnalogPin Int State -> State
832 = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}
834 class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
835 instance readPinD DigitalPin where
836 readPinD p listd lista
837 = case [b \\ (q,b) <- listd | p == q] of
840 instance readPinD AnalogPin where
841 readPinD p listd lista
842 = case [b \\ (q,b) <- lista | p == q] of
845 class writePinD p :: p Bool State -> State
846 instance writePinD DigitalPin where
847 writePinD p b s=:{dpins} = {s & dpins = [(p, b):[(q, c) \\ (q, c) <- dpins | p <> q]]}
848 instance writePinD AnalogPin where
849 writePinD p b s=:{apins} = {s & apins = [(p, if b 1 0):[(q, c) \\ (q, c) <- apins | p <> q]]}
852 // ----- Interactive Simulation ----- //
854 derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
856 simulate :: (Main (Eval a p)) -> Task ()
857 simulate {main=(E f)} = setup state0 where
859 updateInformation "State" [] (toView s)
860 >>* [ OnAction ActionFinish (always shutDown)
861 , OnAction (Action "setup" []) (hasValue
862 (\si.simloop (snd (f Rd (mergeView s si)))))
865 updateInformation "State" [] (toView s)
866 >>* [ OnAction ActionFinish (always shutDown)
867 , OnAction (Action "clear serial" []) (always (simloop {s & serial = []}))
868 , OnAction ActionNew (always (setup state0))
869 : if (isEmpty s.tasks)
871 [OnAction (Action "loop" []) (hasValue
872 \si.simloop (step` (mergeView s si)))
876 toView :: State -> StateInterface
878 { serialOut = Display s.serial
879 , analogPins = s.apins
880 , digitalPins = s.dpins
881 , var2iables = map toDisplayVar s.store
883 , taskCount = Display (length s.tasks)
886 mergeView :: State StateInterface -> State
889 & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
890 , dpins = si.digitalPins
891 , apins = si.analogPins
892 // , serial = si.serialOut
897 { serialOut :: Display [String]
898 , analogPins :: [(AnalogPin, Int)]
899 , digitalPins :: [(DigitalPin, Bool)]
900 , var2iables :: [DisplayVar]
902 , taskCount :: Display Int
905 toDisplayVar :: Dyn -> DisplayVar
906 toDisplayVar (Dyn [v])
911 toDisplayVar (Dyn ["L",v]) = LONG (toInt v)
912 toDisplayVar (Dyn ["Servo",pinKind,pin,pos]) = Servo (fromJust (fromDyn (Dyn [pinKind,pin]))) (toInt pos)
913 toDisplayVar (Dyn ["LCD",_,_,_,_,_,l1,_,l2,_]) = LCD16x2 l1 l2
914 toDisplayVar (Dyn l) = DisplayVar l
916 fromDisplayVar :: DisplayVar Dyn -> Dyn
917 fromDisplayVar (Variable v) dyn = Dyn [v]
918 fromDisplayVar (INT v) dyn = Dyn [toString v]
919 fromDisplayVar (LONG v) dyn = Dyn ["L",toString v]
920 fromDisplayVar (Servo pin pos) dyn = Dyn (["Servo":let (Dyn p) = toDyn pin in p] ++ [toString pos])
921 fromDisplayVar (LCD16x2 l1 l2) (Dyn list) = Dyn (updateAt 6 l1 (updateAt 8 l2 list))
922 fromDisplayVar (DisplayVar l) dyn = Dyn l
929 | LCD16x2 String String
930 | DisplayVar [String]
933 step` :: State -> State
935 foldr appTask {s & millis = s.millis + delta, tasks = []}
936 [(w - delta, f) \\ (w, f) <- s.tasks]
937 where delta = foldl1 min (map fst s.tasks) // smallest wait
939 appTask t=:(w,f) s | w <= 0
941 = {s & tasks = [t:s.tasks]}
943 foldl1 op [a:x] = foldl op a x
944 foldr1 op l :== foldr l
947 foldr [a:x] = op a (foldr x)
949 class stringQuotes t | type t :: (Code t p) -> Code t p
950 instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\""
951 instance stringQuotes t where stringQuotes x = x
954 derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
955 derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
956 instance toCode () where toCode _ = ""
957 instance == () where (==) _ _ = True
959 // ----- long ----- //
961 :: Long = L Int // 32 bit on Arduino
962 instance toCode Long where toCode (L i) = toCode i + "L"
963 instance + Long where (+) (L x) (L y) = L (x + y)
964 instance - Long where (-) (L x) (L y) = L (x + y)
965 instance * Long where (*) (L x) (L y) = L (x + y)
966 instance / Long where (/) (L x) (L y) = L (x + y)
967 instance == Long where (==) (L x) (L y) = x == y
968 instance one Long where one = L one
969 instance zero Long where zero = L zero
972 class long v t :: (v t p) -> v Long Expr | isExpr p
973 instance long Code Int where
974 long x = embed (c "long" +.+ brac x)
975 instance long Code Long where
976 long x = embed (c "long" +.+ brac x)
977 instance long Eval Int where
978 long x = x >>== rtrn o L
979 instance long Eval Long where
982 // ----- tools ----- //
984 class toCode a :: a -> String
985 instance toCode Bool where toCode b = if b "true" "false"
986 instance toCode Int where toCode a = toString a
987 instance toCode Real where toCode a = toString a
988 instance toCode Char where
989 toCode '\0' = "'\\0'"
990 toCode '\n' = "'\\n'"
992 toCode a = "'" + toString a + "'"
993 instance toCode String where toCode s = s
994 instance toCode DigitalPin where toCode x = s%(1, size s - 1) where s = consName{|*|} x
995 instance toCode AnalogPin where toCode x = consName{|*|} x
996 derive consName DigitalPin, AnalogPin, PinMode
998 instance == DigitalPin where (==) x y = x === y
999 instance == AnalogPin where (==) x y = x === y
1001 derive consIndex DigitalPin, AnalogPin
1003 tab =: toString (repeatn tabSize ' ')
1006 instance toString () where toString _ = "()"