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
20 // =================== examples ===================
23 [["//mTaskTFP16_3 \n"]
52 ,["// --- heatingDemo \n"]
54 ,["// --- hpinDemo \n"]
62 ,["// --- lcdCount \n"]
65 ,["// --- heating \n"]
69 lcdHello = LCD 16 2 [] \lcd = {main = print lcd (lit "Hello world")}
74 If (pressed upButton) (
75 setCursor lcd Zero Zero :.
79 {main = t (sec 0) Zero}
81 printD0 = {main = serialPrint (Not d0)}
83 print36 = sds \x = 6 In {main = x =. x *. x :. serialPrint x}
86 {main = a1 =. a0 =. lit 1 +. a0 :. a0 =. Not a0}
88 fac = fun \fac = (\n. If (n <. One) One (n *. fac (n -. One)))
89 In {main = fac (lit 6)}
94 task \t = (\s. setLED s :. t (If s (sec 1) (sec 3)) (Not s)) In {main = t (sec 0) (lit True)}
96 task \t = (\(). d13 =. Not d13 :. t (sec 1) ()) In {main = t (sec 0) ()}
98 task \t = (\s. d13 =. s :. t (If s (msec 100) (sec 1)) (Not s)) In {main = t (sec 0) (lit False)}
100 task \t = (\b. d13 =. b :. t (sec 1) b) In {main = t (msec 0) true :. t (msec 100) false}
103 sec n = long (lit (n * 1000))
104 msec n = long (lit n)
106 qt = task \plus = (\(x,y).x +. y) In {main = plus (sec 0) (lit 3, lit 4)}
107 qs = fun \plus = (\(x,y).x +. y) In {main = plus (lit 3, lit 4)}
110 tasks \(switch, heat) =
111 (\s1 = digitalWrite D2 s1:. heat (sec 60) s1
112 ,\s2 = analogRead A3 >>*. \v.
113 [Cond (v >. upper) (switch (sec 0) off)
114 ,Cond (v <. lower) (switch (sec 0) on)
115 ,Ever (heat (sec 1) s2)
117 In {main = heat (sec 0) off}
122 serialReadInt = serialParseInt >>=. \i. serialRead >>*. \c. [Cond (c ==. lit '\n') i]
126 fun \switch = (\s. d13 =. s) In
127 task \control = (\isOn.
128 a0 <. goal >>*. \mustOn.
129 [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on)
130 ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off)
131 ,Ever (control (msec 100) isOn)
134 serialAvailable ? (serialReadInt >>=. \g.goal =. g) :.
135 change (sec 1) ()) In
136 {main = switch off :. control (sec 0) off :. change (sec 1) ()}
143 // fun \switch = setLED In
144 fun \switch = (\b. setLED b :. serialPrintln b) In
145 task \control = (\isOn.
146 a0 <. goal >>*. \mustOn.
147 [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on)
148 ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off)
149 ,Ever (control (msec 100) isOn)
152 serialAvailable ? (serialReadInt >>=. \i. serialPrintln (goal =. i)) :.
153 change (sec 1) ()) In
154 {main = switch off :. control (sec 0) off :. change (sec 1) ()}
161 fun \switch = (\on. d13 =. bool on :. a0 =. on) In
163 (\isOn. a0 <. goal >>*. \mustOn.
164 [Cond (mustOn &. Not isOn) (switch mustOn :. control minOnTime mustOn)
165 ,Cond (Not mustOn &. isOn) (switch mustOn :. control minOffTime mustOn)
166 ,Ever (control (msec 100) isOn)
168 {main = switch off :. control (sec 0) off}
170 minOnTime = sec 1 // 60
171 minOffTime = sec 2 //10
178 task \tempChange = (\().
179 lit 0 <. temp &. Not heat ? temp =. temp -. One:.
180 temp <. lit 1000 &. heat ? temp =. temp +. One :.
181 setCursor lcd (lit 5) Zero :.
182 print lcd (lit "temp ") :.
184 print lcd (lit " ") :.
185 tempChange (msec 789) ()) In
188 setCursor lcd Zero Zero :.
190 (print lcd (lit "On "))
191 (print lcd (lit "Off"))) In
193 analogRead A0 >>=. \a0.
194 setCursor lcd Zero One :.
196 print lcd (lit " ") :.
198 task \control = (\isOn.
199 measure () >>=. \val.temp <. val
201 [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on)
202 ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off)
203 ,Ever (control (msec 100) isOn)
206 {main = switch off :. control (msec 10) off :. tempChange (sec 0) ()}
219 setCursor lcd Zero Zero :.
221 count (sec 1) (n +. One)) In
222 {main = count (sec 0) Zero}
224 p0 = sds \x = 6 In {main = x =. x *. lit 7}
225 p1 = {main = lit 2 +. lit 4 >>=. \x. (x +. lit 1) *. x}
227 fun \f. (\x. lit 6 *. x)
228 In {main = lit 3 +. lit 4 >>=. \x. f x}
230 fun \f. (\x. lit 6 *. x)
231 In {main = lit 3 +. lit 4 >>=. f} // higher order, somewhat remarkable that this works
233 fun \f. (\x. lit 6 *. x)
234 In {main = lit 3 +. lit 4 >>=. \x. f x >>=. serialPrint}
235 p5 = {main = lit 7 >>*. \x. [Cond (x <. lit 36) (x *. x),Ever (lit 42)]}
236 p6 = sds \y = 1 In {main = lit 7 >>*. \x. [Cond (x <. lit 36) (y =. x *. x),Ever (y =. x)]}
237 p7 = sds \y = 1 In {main = y +. lit 1 >>*. \x. [Cond (x <. lit 36) ((y =. x *. x) >>*. \z.[Cond (z ==. x) y, Ever y]),Ever (y =. x)]}
238 p8 = sds \y = 1 In {main = pressed upButton >>*. \x. [Cond x (y =. y +. y),Ever (y =. lit 36)]}
239 //p8 = sds \y = 1 In {main = pressed upButton >>*. \x. [Cond x ((y =. lit 42) >>*. \z.[Cond (z ==. y) y, Ever y]),Ever (y =. lit 36)]}
240 //p9 = {main = If (pressed upButton) (lit 1) (lit 7)} // Overloading error [mTaskTFP16.icl,61,p9]: "isExpr" no instance available of type Stmt
241 p9 = {main = pressed upButton >>=. \b.If b (lit 1) (lit 7)}
245 (pressed upButton >>*. \x.
246 [Cond x (y =. y +. y :.
248 ,Ever (y =. lit 36 :.
256 (pressed upButton >>=. \b.
263 ((y =. x *. x) >>*. \z.
264 [Cond (z ==. x) (serialPrint y)
265 ,Ever (serialPrint (lit 0))
271 task \t = (\(). pressed upButton >>*. \b.[Cond b (serialPrintln (lit 7)),Ever (t (lit 250) ():. lit 0)]) In
272 {main = t (lit 0) ()}
274 // ----- serial definition ----- //
277 serialAvailable :: (v Bool Expr)
278 serialPrint :: (v t p) -> v Int Expr | stringQuotes t & isExpr p
279 serialPrintln :: (v t p) -> v Int Expr | stringQuotes t & isExpr p
280 serialRead :: (v t Expr)
281 serialParseInt :: (v Int Expr)
283 instance serial Code where
284 serialAvailable = embed (c "Serial.available()")
285 serialPrint x = embed (c "Serial.print(" +.+ x +.+ c ")")
286 serialPrintln x = embed (c "Serial.println(" +.+ x +.+ c ")")
287 serialRead = embed (c "Serial.read()")
288 serialParseInt = embed (c "Serial.parseInt()")
290 instance serial Eval where
291 serialAvailable = rtrn False
292 serialPrint x = x >>== \a.E \r s.let str = toCode a in (size str,{s & serial = s.serial ++ [str]})
293 serialPrintln x = x >>== \a.E \r s.let str = toCode a + "\n" in (size str,{s & serial = s.serial ++ [str]})
294 serialRead = rtrn undef
295 serialParseInt = rtrn undef
297 class char2int v :: (v Char p) -> v Int Expr
298 instance char2int Code where char2int (C f) = C \rw c.f Rd c
300 :: SerialObject v t p =
301 { available :: v Bool Expr
302 , print :: (v t p) -> v Int Expr
303 , println :: (v t p) -> v Int Expr
304 , read :: (v Char Expr)
307 // =================== shields ===================
309 // ----- LCD definition ----- //
319 :: Button = RightButton | UpButton | DownButton | LeftButton | SelectButton | NoButton
321 rightButton = lit RightButton
322 upButton = lit UpButton
323 downButton = lit DownButton
324 leftButton = LeftButton
325 selectButton = lit SelectButton
326 noButton = lit NoButton
329 begin :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr
330 print :: (v LCD Expr) (v t p) -> v Int Expr | stringQuotes t // returns bytes written
331 setCursor :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr
332 liquidCrystal0 :: [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q)
333 LCD :: Int Int [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q)
334 scrollLeft :: (v LCD Expr) -> v () Expr
335 scrollRight :: (v LCD Expr) -> v () Expr
336 pressed :: (v Button Expr) -> v Bool Expr
338 instance lcd Code where
339 begin v x y = embed (v +.+ c ".begin" +.+ codeOp2 x ", " y)
340 print v x = embed (v +.+ c ".print (" +.+ stringQuotes x +.+ c ")")
341 setCursor v x y = embed (v +.+ c ".setCursor" +.+ codeOp2 x ", " y)
342 scrollLeft v = embed (v +.+ c ".scrollDisplayLeft()")
343 scrollRight v = embed (v +.+ c ".scrollDisplayRight()")
344 liquidCrystal0 [] f = liquidCrystal0 [D8, D9, D4, D5, D6, D7] f
345 liquidCrystal0 pins f =
347 getCode \cd. fresh \n.
349 name = "lcd" + toString n
352 include "LiquidCrystal" +.+
354 c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+
358 LCD x y [] f = LCD x y [D8, D9, D4, D5, D6, D7] f
361 getCode \cd. fresh \n.
363 name = "lcd" + toString n
366 include "LiquidCrystal" +.+
368 c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+
370 c (name + ".begin(" + toCode x + ", " + toCode y +");") +.+ nl +.+
374 pressed b = embed (c "pressed(" +.+ setMode SubExp +.+ b +.+ c ")")
382 instance lcd Eval where
386 yield () (E \r.v (Updt \lcd.{lcd & sizeH = h, sizeW = w, lcdtxt = repeatn h (toString (repeatn w ' '))}))
388 x >>== \a. let str = toCode a in
389 yield (size str) (E \r.v (Updt \lcd.lcdPrintStr str lcd))
390 setCursor (E v) x y =
393 yield () (E \r.v (Updt \lcd.{lcd & cursorRow = h, cursorCol = w}))
394 scrollLeft v = rtrn ()
395 scrollRight v = rtrn ()
396 LCD w h pins f = defEval2 lcd f where
402 , lcdtxt = repeatn h (toString (repeatn w ' '))
404 liquidCrystal0 pins f = defEval2 lcd f where
412 pressed b = rtrn False
415 | lcd.cursorRow < 0 || lcd.cursorRow >= length lcd.lcdtxt ||
416 lcd.cursorCol < 0 || lcd.cursorCol >= size (lcd.lcdtxt !! lcd.cursorRow)
418 # line = lcd.lcdtxt !! lcd.cursorRow
419 # endPos = size str + lcd.cursorCol
420 | endPos >= lcd.sizeW
421 # newLine = line % (0, lcd.cursorCol - 1) + str % (0, size str - lcd.cursorCol)
422 = {lcd & lcdtxt = updateAt lcd.cursorRow newLine lcd.lcdtxt, cursorCol = lcd.sizeW - 1}
423 # newLine = line % (0, lcd.cursorCol - 1) + str + line % (endPos, lcd.sizeW - 1)
424 = {lcd & lcdtxt = updateAt lcd.cursorRow newLine lcd.lcdtxt, cursorCol = endPos}
426 printAt :: (v LCD Expr) (v Int b) (v Int c) (v t e) -> v Int Stmt
427 | lcd, seq v & stringQuotes t
428 printAt lcd x y z = setCursor lcd x y :. print lcd z
430 keySwitch :: (a Int b) (a c d,a c e,a c f,a c g,a c h,a c a0) -> a c Stmt | arith, boolExpr, seq a & If a h a0 b0 & If a g b0 c0 & If a f c0 d0 & If a e d0 e0 & If a d e0 f0 & type c
431 keySwitch v (right, up, down, left, select, nokey)
433 If (w <. lit RightBound)
435 (If (w <. lit UpBound)
437 (If (w <. lit DownBound)
439 (If (w <.lit LeftBound)
441 (If (w <. lit SelectBound)
446 // =================== mTask ===================
449 // ----- dsl definition ----- //
452 = D0 | D1 | D2 | D3 | D4 | D5 |D6 | D7 | D8 | D9 | D10 | D11 | D12 | D13
453 :: AnalogPin = A0 | A1 | A2 | A3 | A4 | A5
454 :: PinMode = INPUT | OUTPUT | INPUT_PULLUP
455 :: Pin = Digital DigitalPin | Analog AnalogPin
456 instance toCode Pin where
457 toCode (Digital p) = toCode p
458 toCode (Analog p) = toCode p
459 instance toCode Button where toCode b = toCode (consIndex{|*|} b)
460 derive consIndex Button
462 class pin p | type, == p where
464 instance pin DigitalPin where
466 instance pin AnalogPin where
472 :: MTask = MTask Int // String
474 class isExpr a :: a -> Int
475 instance isExpr Upd where isExpr _ = 0
476 instance isExpr Expr where isExpr _ = 1
478 class isStmt a :: a -> Int
479 instance isStmt Upd where isStmt _ = 10
480 instance isStmt Expr where isStmt _ = 11
481 instance isStmt Stmt where isStmt _ = 12
483 instance == MTask where (==) (MTask x) (MTask y) = x == y
484 instance toCode MTask where toCode (MTask x) = "Task " + toCode x
486 :: Main a = {main :: a}
488 unMain :: (Main x) -> x
489 unMain m = m.main //{main=x} = x
492 lit :: t -> v t Expr | toCode t
493 (+.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, +, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
494 (-.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, -, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
495 (*.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, *, zero, one t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
496 (/.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, / t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
497 class boolExpr v where
498 (&.) infixr 3 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q
499 (|.) infixr 2 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q
500 Not :: (v Bool p) -> v Bool Expr | isExpr p //& toExpr2 p
501 (==.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
502 (!=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
503 (<.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
504 (>.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
505 (<=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
506 (>=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
507 // using functional dependencies
508 class If v q r ~s where
509 If :: (v Bool p) (v t q) (v t r) -> v t s | isExpr p & type t
511 IF :: (v Bool p) (v t q) (v s r) -> v () Stmt | isExpr p
512 (?) infix 1 :: (v Bool p) (v t q) -> v () Stmt | isExpr p
514 var2 :: t ((v t Upd)->(Main (v c s))) -> (Main (v c s)) | type, toCode t
515 con2 :: t ((v t Expr) ->(Main (v c s))) -> (Main (v c s)) | type t
517 sds :: ((v t Upd)->In t (Main (v c s))) -> (Main (v c s)) | type, toCode t
518 con :: ((v t Expr) ->In t (Main (v c s))) -> (Main (v c s)) | type t
520 (>>=.) infixr 0 :: (v t p) ((v t Expr) -> (v u q)) -> (v u Stmt) | type t & type u
521 (:.) infixr 0 :: (v t p) (v u q) -> v u Stmt | type t & type u
523 (>>*.) infixl 1 :: (v t p) ((v t Expr) -> [Step v u]) -> v u Stmt | type t & type u
524 :: Step v t = E.p.q: Cond (v Bool q) (v t p) | E.p: Ever (v t p)
526 (=.) infixr 2 :: (v t Upd) (v t p) -> v t Expr | type t & isExpr p
528 fun :: ((t->v s Expr)->In (t->v s p) (Main (v u q))) -> Main (v u q) | type s
529 class mtask v a where
530 task :: (((v delay r) a->v MTask Expr)->In (a->v u p) (Main (v t q))) -> Main (v t q) | type t & type u & isExpr r & long v delay
532 lag :: (v delay r) (v t p) -> v MTask Expr | type t & long v delay
533 class setDelay v where
534 setDelay :: (v Long p) (v MTask Expr) -> (v MTask Expr) | isExpr p
535 class mtasks v a b where
536 tasks :: (((v delay r1) a->v MTask Expr, (v delay r2) b->v MTask Expr)->In (a->v t p, b->v u p) (Main (v s q))) -> Main (v s q) | type s & isExpr r1 & isExpr r2 & long v delay
538 output :: (v t p) -> v () Expr | type t & isExpr p
539 class noOp v where noOp :: v t p
541 class pinMode v where
542 pinmode :: p PinMode -> v () Expr | pin p
543 class digitalIO v where
544 digitalRead :: p -> v Bool Expr | pin, readPinD p
545 digitalWrite :: p (v Bool q) -> v Bool Expr | pin, writePinD p
546 class analogIO v where
547 analogRead :: AnalogPin -> v Int Expr
548 analogWrite :: AnalogPin (v Int p) -> v Int Expr
550 dIO :: p -> v Bool Upd | pin, readPinD p
552 aIO :: AnalogPin -> v Int Upd
554 delay :: (v Long p) -> (v Long Expr)
555 millis :: (v Long Expr)
557 class pio p t where pio :: p -> v t Upd | aIO v & dIO v
558 instance pio AnalogPin Int where pio p = aIO p
559 instance pio AnalogPin Bool where pio p = dIO p
560 instance pio DigitalPin Bool where pio p = dIO p
584 int :: (v Int p) -> (v Int p)
586 bool :: (v Bool p) -> (v Bool p)
588 char :: (v Char p) -> (v Char p)
591 class type t | showType, dyn, toCode, ==, type2string, varName t
592 class type2string t :: t -> String
593 instance type2string Int where type2string _ = "int"
594 instance type2string Long where type2string _ = "long"
595 instance type2string Real where type2string _ = "float"
596 instance type2string Bool where type2string _ = "bool" //"boolean"
597 instance type2string Char where type2string _ = "char"
598 instance type2string MTask where type2string _ = "task"
599 instance type2string DigitalPin where type2string _ = "int"
600 instance type2string AnalogPin where type2string _ = "int"
601 instance type2string String where type2string _ = "Char []"
602 instance type2string () where type2string _ = ""
603 class varName a :: a -> String
604 instance varName Int where varName _ = "vInt"
605 instance varName Long where varName _ = "vLong"
606 instance varName Bool where varName _ = "vBool"
607 instance varName Char where varName _ = "vChar"
608 instance varName Real where varName _ = "vFloat"
609 instance varName x where varName _ = ""
611 class dsl t | arith, boolExpr, sds, assign, seq t
613 argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
616 class argTypes t :: ((t->Code b Expr)->In (t->Code b2 q) (Main (Code c s))) -> t
617 instance argTypes (Code a p) | showType a where argTypes f = showType
618 instance argTypes (Code a p, Code b q) | showType a & showType b where argTypes f = (showType, showType)
619 instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c where argTypes f = (showType, showType, showType)
621 resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
624 var2Type :: (Code t p) -> Code t p | showType t
625 var2Type x = showType
627 resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
628 resType2 f = showType2
631 instance toCode (SV t) where toCode (SV s) = s
633 class showType2 t :: SV t
634 instance showType2 () where showType2 = SV "void "
635 instance showType2 Int where showType2 = SV "int "
636 instance showType2 Char where showType2 = SV "char "
637 instance showType2 Bool where showType2 = SV "bool "
638 instance showType2 a where showType2 = SV "word /* default */"
640 class showType t | showType2 /*, type*/ t :: (Code t p)
641 instance showType () where showType = c "void "
642 instance showType Int where showType = c "int "
643 instance showType Long where showType = c "long "
644 instance showType Char where showType = c "char "
645 instance showType Bool where showType = c "bool "
646 instance showType a where showType = c "word /* default */ "
648 class typeSelector t | showType2, type t :: (Code t p)
649 instance typeSelector Int where typeSelector = c ".i"
650 instance typeSelector Char where typeSelector = c ".c"
651 instance typeSelector Bool where typeSelector = c ".b"
652 instance typeSelector a where typeSelector = c ".w"
654 :: In a b = In infix 0 a b
656 read :: Int (ReadWrite a) State -> (a,State) | dyn a
657 read n Rd s = (fromJust (fromDyn (s.store !! n)), s)
658 read n (Wrt a) s = (a,{s&store=updateAt n (toDyn a) s.store})
659 read n (Updt f) s=:{store}
660 # obj = f (fromJust (fromDyn (store !! n)))
661 = (obj, {s & store = updateAt n (toDyn obj) store})
663 // ----- code generation ----- //
665 instance arith Code where
667 (+.) x y = codeOp2 x " + " y
668 (-.) x y = codeOp2 x " - " y
669 (*.) x y = codeOp2 x " * " y
670 (/.) x y = codeOp2 x " / " y
671 instance boolExpr Code where
672 (&.) x y = codeOp2 x " && " y
673 (|.) x y = codeOp2 x " || " y
674 Not x = embed (brac (c "! " +.+ brac x))
675 (==.) x y = codeOp2 x " == " y
676 (!=.) x y = codeOp2 x " != " y
677 (<.) x y = codeOp2 x " < " y
678 (<=.) x y = codeOp2 x " <= " y
679 (>.) x y = codeOp2 x " > " y
680 (>=.) x y = codeOp2 x " >= " y
681 instance If Code Stmt Stmt Stmt where If c t e = IfStmt c t e
682 instance If Code e Stmt Stmt where If c t e = IfStmt c t e
683 instance If Code Stmt e Stmt where If c t e = IfStmt c t e
684 instance If Code x y Expr where If c t e = IfExpr c t e
685 IfExpr b t e = embed (brac (b +.+ indent +.+ nl +.+ c " ? " +.+ t +.+ nl +.+ c " : " +.+ e +.+ unindent))
694 _ = if (v == "") NoReturn (Assign v)
697 c "if " +.+ brac b +.+ c " {" +.+
698 indent +.+ nl +.+ setMode newMode +.+ t +.+ unindent +.+ nl +.+ c "} else {" +.+
699 indent +.+ nl +.+ setMode newMode +.+ e +.+ unindent +.+ nl +.+ c "}"
700 instance IF Code where
701 IF b t e = IfStmt b t e
704 c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+
705 indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}"
707 instance sds Code where
710 let name = "sds"+toCode n
711 (v In body) = f (C (var name))
712 in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
713 ";\n") +.+ setCode Setup +.+ unMain body}
716 defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
719 let name = "sds"+toCode n
720 (v In body) = f (C (var name))
721 in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
722 ";\n") +.+ setCode Setup +.+ unMain body}
724 var :: String (ReadWrite (Code v q)) CODE -> CODE
725 var sds Rd s = unC (embed (c sds)) Rd s
726 var sds (Wrt v) s = unC (embed (c ("(" + sds + " = ") +.+ v +.+ c ")")) Rd s
728 instance assign Code where
729 (=.) (C v) e = embed (setMode SubExp +.+ C \rw c.v (Wrt (toExpr e)) c)
730 instance seq Code where
732 getMode \mode. fresh \n. let v = "b" + toCode n in
733 addBinds v +.+ var2Type x +.+ c (v + ";") +.+ nl +.+
734 setMode (Assign v) +.+ x +.+ nl +.+ setMode mode +.+ f (embed (c v))
735 (:.) x y = getMode \mode. setMode NoReturn +.+ embed x +.+ nl +.+ setMode mode +.+ y
736 instance step Code where
738 getMode \mode. fresh \n.
739 let v = "s" + toCode n in
740 c "while(true) {" +.+ indent +.+ nl +.+
741 var2Type x +.+ c (v + ";") +.+ nl +.+
742 setMode (Assign v) +.+ x +.+ nl +.+
743 setMode mode +.+ codeSteps (f (c v)) +.+
744 unindent +.+ nl +.+ c "}"
745 codeSteps :: [Step Code t] -> Code u p
746 codeSteps [] = C \rw c.c
747 codeSteps [Cond b e:x] =
748 getMode \mode. setMode SubExp +.+
749 c "if (" +.+ b +.+ c ") {" +.+ indent +.+ nl +.+
750 setMode mode +.+ e +.+
751 optBreak mode +.+ unindent +.+ nl +.+ c "}" +.+ nl +.+ setMode mode +.+ codeSteps x
752 codeSteps [Ever e:x] =
753 getMode \mode. e +.+ optBreak mode
755 optBreak :: Mode -> Code u p
759 _ = nl +.+ c "break;"
761 instance setDelay Code where
762 setDelay d t = embed (c "setDelay" +.+ brac (t +.+ c ", " +.+ d))
763 instance mtask Code a | taskImp2 a & types a where
765 {main = freshMTask \n.
766 let (app, a) = taskImp2 n types
767 (b In main) = f (\d a.app (long d) a)
768 in codeMTaskBody (loopCode n (b a)) (unMain main)}
769 instance mtasks Code a b | taskImp2 a & types a & taskImp2 b & types b where
774 let (app1, a1) = taskImp2 t1 types
775 (app2, a2) = taskImp2 t2 types
776 ((b1, b2) In main) = f ((\d a.app1 (long d) a),(\d a.app2 (long d) a))
777 in codeMTaskBody (loopCode t2 (b2 a2)) (codeMTaskBody (loopCode t1 (b1 a1)) (unMain main))}
778 loopCode :: Int (Code a b) -> Code c d
780 nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
781 setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+
782 unindent +.+ nl +.+ c "} "
784 class taskImp2 a :: Int a -> ((Code Long p) a->Code MTask Expr, a) | /*long Code delay &*/ isExpr p
785 instance taskImp2 () where
786 taskImp2 n () = (app, ())
787 where app d a = setBinds [] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ d +.+ c ")")
788 instance taskImp2 (Code t p) where
789 taskImp2 n type1 = (app, ta)
794 setBinds [n0] +.+ embed (c "newTask(" +.+
798 instance taskImp2 (Code a p, Code b q) where
799 taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
805 setBinds [n0,n1] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ long d +.+
806 c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
807 instance taskImp2 (Code a p, Code b q, Code c r) where
808 taskImp2 n (type1, type2, type3) = (app, (ta1, ta2, ta3))
817 setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+
823 instance taskImp2 (Code a p, Code b q, Code c r, Code d s) where
824 taskImp2 n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
834 app d (a1, a2, a3, a4) =
835 setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+
843 class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
844 instance taskImp () where
845 taskImp n () = (app, ())
846 where app i a = embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+ c ")")
847 instance taskImp (Code t p) where
848 taskImp n type1 = (app, ta)
850 ta = c "t0p->a[0]" +.+ type1
852 embed (c "newTask(" +.+
856 instance taskImp (Code a p, Code b q) where
857 taskImp n (type1, type2) = (app, (ta1, ta2)) where
858 ta1 = c "t0p->a[0]" +.+ type1
859 ta2 = c "t0p->a[1]" +.+ type2
861 embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+
862 c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
863 instance taskImp (Code a p, Code b q, Code c r) where
864 taskImp n (type1, type2, type3) = (app, (ta1, ta2, ta3))
866 ta1 = c "t0p->a[0]" +.+ type1
867 ta2 = c "t0p->a[1]" +.+ type2
868 ta3 = c "t0p->a[2]" +.+ type3
870 embed (c "newTask(" +.+
876 instance taskImp (Code a p, Code b q, Code c r, Code d s) where
877 taskImp n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
879 ta1 = c "t0p->a[0]" +.+ type1
880 ta2 = c "t0p->a[1]" +.+ type2
881 ta3 = c "t0p->a[2]" +.+ type3
882 ta4 = c "t0p->a[3]" +.+ type4
883 app i (a1, a2, a3, a4) =
884 embed (c "newTask(" +.+
892 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
895 freshMTask \n. freshMTask \m.
897 (app1, a1) = taskImp n types
898 (app2, a2) = taskImp m types
899 ((b1, b2) In {main = e}) = f (app1 i, app2 j)
901 codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
904 instance types () where types = ()
905 instance types (Code a p) | typeSelector a & isExpr p
906 where types = typeSelector
907 instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
908 where types = (typeSelector, typeSelector)
909 instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
910 where types = (typeSelector, typeSelector, typeSelector)
911 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
912 where types = (typeSelector, typeSelector, typeSelector, typeSelector)
914 codeMTaskBody :: (Code v w) (Code c d) -> Code e f
915 codeMTaskBody loop e =
918 setCode Loop +.+ loop +.+
919 setMode mode +.+ setCode Setup +.+ embed e
920 instance fun Code () where
922 {main = getMode \mode. fresh \n.
923 let fname = c ("f" + toCode n)
924 (g In {main=e}) = f (\x.embed (fname +.+ c " ()"))
925 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " () " +.+
926 funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [] +.+ g ()) +.+ setCode Setup +.+ setMode mode +.+ e
928 instance fun Code (Code t p) | type, showType t & isExpr p where
931 getMode \mode. fresh \n.
932 let fname = c ("f" + toCode n)
933 aname = "a" + toCode n
934 (g In {main=e}) = f (\x.embed (fname +.+ c " " +.+ brac x))
935 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
936 brac (argTypes f +.+ c (" " + aname)) +.+
937 funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [aname] +.+ g (embed (c aname))) +.+ setCode Setup +.+ setMode mode +.+ e
939 instance fun Code (Code a p, Code b q) | showType a & showType b where
942 getMode \mode. fresh \n.
943 let fname = c ("f" + toCode n + " ")
944 aname = "a" + toCode n //+ " "
945 bname = "b" + toCode n //+ " "
946 (atype, btype) = argTypes f
948 = f (\(x,y).embed (fname +.+ codeOp2 x ", " y))
949 in setCode Fun +.+ nl +.+ resType f +.+ fname +.+
950 codeOp2 (atype +.+ c aname) ", " (btype +.+ c bname) +.+
951 funBody (setMode (Return (toCode (resType2 f))) +.+
952 setBinds [aname,bname] +.+ g (embed (c aname), embed (c bname))) +.+
953 setCode Setup +.+ setMode mode +.+ unMain main
955 instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
958 getMode \mode. fresh \n.
959 let fname = c ("f" + toCode n)
960 aname = "a" + toCode n
961 bname = "b" + toCode n
962 cname = "c" + toCode n
963 (atype,btype,ctype) = argTypes f
964 (g In {main=e}) = f (\(x,y,z).embed (fname +.+ c " " +.+ brac (x +.+ c ", " +.+ y +.+ c ", " +.+ z)))
965 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
966 brac (atype +.+ c (" " + aname + ", ") +.+ btype +.+ c (" " + bname + ", ") +.+ ctype +.+ c (" " + cname)) +.+
967 funBody (setMode (Return (toCode (resType2 f))) +.+
968 setBinds [aname,bname,cname] +.+ g (embed (c aname), embed (c bname), embed (c cname))) +.+ setCode Setup +.+ setMode mode +.+ e
970 instance output Code where
971 output x = embed (c "Serial.println(" +.+ x +.+ c ")")
972 instance pinMode Code where
973 pinmode p m = embed (c ("pinMode(" + toCode p + ", " + consName{|*|} m + ")"))
974 instance digitalIO Code where
975 digitalRead p = embed (c ("digitalRead(" + toCode p + ")"))
976 digitalWrite p b = embed (c ("digitalWrite(" + toCode p + ", ") +.+ b +.+ c ")")
977 instance dIO Code where
978 dIO p = C (ioc p) where
979 ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin, readPinD p
980 ioc p Rd s = f Rd s where (C f) = embed (c ("digitalRead(" + toCode p + ")"))
981 ioc p (Wrt v) s = f Rd s where (C f) = embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")
982 instance aIO Code where
983 aIO p = C (ioc p) where
984 ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin p
985 ioc p Rd s = unC (embed (c ("analogRead(" + toCode p + ")"))) Rd s
986 ioc p (Wrt v) s = unC (embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")) Rd s
987 instance analogIO Code where
988 analogRead p = embed (c ("analogRead(" + toCode p + ")"))
989 analogWrite p b = embed (c ("analogWrite(" + toCode p + ", ") +.+ b +.+ c ")")
990 instance noOp Code where noOp = C \rw c.c
992 :: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
1004 , includes :: [String]
1010 unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
1013 :: Def = Var | Fun | Setup | Loop
1014 :: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
1016 setMode :: Mode -> Code a p
1017 setMode m = C \rw c.{c & mode = m}
1019 getMode :: (Mode -> Code a p) -> Code a p
1020 getMode f = C \rw c.unC (f c.mode) rw c
1022 embed :: (Code a p) -> Code a p
1024 getMode \m. case m of
1025 NoReturn = setMode SubExp +.+ e +.+ c ";"
1026 Return "void" = setMode SubExp +.+ e +.+ c ";"
1027 Return t = c "return " +.+ setMode SubExp +.+ e +.+ c ";"
1028 Assign s = c (s + " = ") +.+ setMode SubExp +.+ e +.+ c ";"
1030 _ = abort "\n\nembed: unknown mode.\n"
1032 (+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
1033 (+.+) (C f) (C g) = C \rw c.g Rd (f Rd c)
1035 fresh :: (Int -> (Code a p)) -> (Code a p)
1036 fresh f = C \rw c.unC (f c.fresh) rw {c & fresh = c.fresh + 1}
1038 freshMTask :: (Int -> (Code a p)) -> (Code a p)
1039 freshMTask f = C \rw c.unC (f c.freshMTask) rw {c & freshMTask = c.freshMTask + 1}
1041 setCode :: Def -> (Code a p)
1042 setCode d = C \rw c.{c & def = d}
1044 getCode :: (Def -> Code a p) -> (Code a p)
1045 getCode f = C \rw c.unC (f c.def) rw c
1047 brac :: (Code a p) -> Code b q
1048 brac e = c "(" +.+ e +.+ c ")"
1050 funBody :: (Code a p) -> Code b q
1051 funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl
1053 codeOp2 :: (Code a p) String (Code b q) -> Code c r
1054 codeOp2 x n y = embed (brac (x +.+ c n +.+ y))
1056 include :: String -> Code a b
1057 include lib = C \rw c.{c & includes = [lib:c.includes]}
1059 argList :: [a] -> String | toCode a
1060 argList [a] = toCode a
1061 argList [a:x] = toCode a + "," + argList x
1064 c :: a -> Code b p | toCode a
1065 c a = C \rw c.case c.def of
1066 Fun = {c & funs = [toCode a: c.funs]}
1067 Var = {c & vars = [toCode a: c.vars]}
1068 Setup = {c & setup = [toCode a: c.setup]}
1069 Loop = {c & loop = [toCode a: c.loop]}
1073 C \rw c.case c.def of
1074 Fun = {c & ifuns = inc c.ifuns}
1075 Var = {c & ivars = inc c.ivars}
1076 Setup = {c & isetup = inc c.isetup}
1077 Loop = {c & iloop = inc c.iloop}
1079 unindent :: Code a p
1081 C \rw c.case c.def of
1082 Fun = {c & ifuns = dec c.ifuns}
1083 Var = {c & ivars = dec c.ivars}
1084 Setup = {c & isetup = dec c.isetup}
1085 Loop = {c & iloop = dec c.iloop}
1093 C \rw c.case c.def of
1094 Fun = {c & funs = [str c.ifuns: c.funs]}
1095 Var = {c & vars = [str c.ivars: c.vars]}
1096 Setup = {c & setup = [str c.isetup: c.setup]}
1097 Loop = {c & loop = [str c.iloop: c.loop]}
1099 str n = toString ['\n':repeatn (tabSize * n) ' ']
1101 setBinds :: [String] -> Code a p
1102 setBinds list = C \rw c.{c & binds = list}
1104 addBinds :: String -> Code a p
1105 addBinds name = C \rw c.{c & binds = [name:c.binds]}
1107 getBinds :: ([String] -> Code a p) -> (Code a p)
1108 getBinds f = C \rw c.unC (f c.binds) rw c
1110 // ----- driver ----- //
1112 compile :: (Main (Code a p)) -> [String]
1113 compile {main=(C f)} =
1115 ," Generated code for Arduino\n"
1116 ," Pieter Koopman, pieter@cs.ru.nl\n"
1119 ,"#define MAX_ARGS 4\n"
1120 ,"#define MAX_TASKS 20\n"
1121 ,"#define MAX_TASK_NO MAX_TASKS - 1\n"
1122 ,"#define NEXT_TASK(n) ((n) == MAX_TASK_NO ? 0 : (n) + 1)\n"
1124 ,"typedef union Arg {\n"
1128 // ," float f;\n" // requires 4 bytes
1132 ,"typedef struct Task {\n"
1135 ," ARG a[MAX_ARGS];\n"
1139 foldr (\lib c.["#include <":lib:".h>\n":c]) [] (mkset c.includes) ++
1140 ["\n// --- variables ---\n"
1141 ,"TASK tasks[MAX_TASKS];\n"
1142 ,"byte t0 = 0, tc = 0, tn = 0;\n"
1149 ,"unsigned long time = 0;\n"
1152 ["\n// --- functions ---\n"
1153 ,"byte newTask(byte id, long wait, word a0 = 0, word a1 = 0, word a2 = 0, word a3 = 0) {\n"
1154 ," TASK *tnp = &tasks[tn];\n"
1156 ," tnp->wait = wait;\n"
1157 ," tnp->a[0].w = a0;\n"
1158 ," tnp->a[1].w = a1;\n"
1159 ," tnp->a[2].w = a2;\n"
1160 ," tnp->a[3].w = a3;\n"
1162 ," tn = NEXT_TASK(tn);\n"
1166 ,"byte setDelay(byte t, long d) {\n"
1167 ," tasks[t].wait = d;\n"
1170 ,"boolean pressed(int b) {\n"
1171 ," pinMode(A0, INPUT);\n"
1172 ," int a0 = analogRead(A0);\n"
1174 ," case 0: return a0 < ",toString RightBound,"; // right\n"
1175 ," case 1: return ",toString RightBound," < a0 && a0 < ",toString UpBound,"; // up\n"
1176 ," case 2: return ",toString UpBound," < a0 && a0 < ",toString DownBound,";// down\n"
1177 ," case 3: return ",toString DownBound," < a0 && a0 < ",toString LeftBound,";//left\n"
1178 ," case 4: return ",toString LeftBound," < a0 && a0 < ",toString SelectBound,";//select\n"
1179 ," default: return ",toString SelectBound," < a0; //no button\n"
1182 ,"boolean pWrite (int pin, boolean b) {\n"
1183 ," pinMode(pin, OUTPUT);\n"
1184 ," digitalWrite(pin, b);\n"
1187 ,"int pWrite (int pin, int i) {\n"
1188 ," pinMode(pin, OUTPUT);\n"
1189 ," analogWrite(pin, i);\n"
1194 ["\n// --- setup --- \n"
1195 ,"void setup () {\n"
1196 ," Serial.begin(9600);\n"
1201 ,"\n// --- loop --- \n"
1203 ," if (t0 != tn) {\n"
1204 ," if (t0 == tc) {\n"
1205 ," unsigned long time2 = millis();\n"
1206 ," delta = time2 - time;\n"
1210 ," TASK* t0p = &tasks[t0];\n"
1211 ," t0p->wait -= delta;\n"
1212 ," if (t0p->wait > 0L) {\n"
1213 ," newTask(t0p->id, t0p->wait, t0p->a[0].w, t0p->a[1].w, t0p->a[2].w, t0p->a[3].w);\n"
1215 ," switch (t0p->id) {"
1220 ," Serial.println(\"stopped\");\n"
1221 ," t0 = tn; // no known task: force termination of tasks\n"
1225 ," t0 = NEXT_TASK(t0);\n"
1229 where c = f Rd newCode
1231 mkset :: [a] -> [a] | Eq a
1232 mkset [a:x] = [a:mkset (filter ((<>) a) x)]
1253 // ----- simulation ----- //
1255 eval :: (Main (Eval t p)) -> [String] | toString t
1256 eval {main=(E f)} = [toString (fst (f Rd state0))]
1259 { tasks :: [(Int, State->State)]
1261 , dpins :: [(DigitalPin, Bool)]
1262 , apins :: [(AnalogPin, Int)]
1268 state0 = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}
1270 //:: TaskSim :== (Int, State->State)
1271 :: Eval t p = E ((ReadWrite t) State -> (t, State))
1272 toS2S :: (Eval t p) -> (State->State)
1273 toS2S (E f) = \state.snd (f Rd state)
1275 unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
1278 :: ReadWrite t = Rd | Wrt t | Updt (t->t)
1280 (>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
1281 //(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
1282 (>>==) (E f) g = E\r s.let (a,t) = f Rd s in unEval (g a) Rd t
1284 rtrn :: t -> Eval t p
1285 rtrn a = E \r s -> (a, s)
1287 yield :: t (Eval s p) -> Eval t Expr
1288 //yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
1289 yield a (E f) = E \r s.(a,snd (f Rd s))
1291 instance arith Eval where
1293 (+.) x y = x >>== \a. y >>== \b. rtrn (a + b)
1294 (-.) x y = x >>== \a. y >>== \b. rtrn (a - b)
1295 (*.) x y = x >>== \a. y >>== \b. rtrn (a * b)
1296 (/.) x y = x >>== \a. y >>== \b. rtrn (a / b)
1297 instance boolExpr Eval where
1298 (&.) x y = x >>== \a. if a y (rtrn False) // lazy AND
1299 (|.) x y = x >>== \a. if a (rtrn True) (y >>== rtrn)
1300 Not x = x >>== \a. rtrn (not a)
1301 (==.) x y = x >>== \a. y >>== \b. rtrn (a == b)
1302 (!=.) x y = x >>== \a. y >>== \b. rtrn (a <> b)
1303 (<.) x y = x >>== \a. y >>== \b. rtrn (a < b)
1304 (>.) x y = x >>== \a. y >>== \b. rtrn (a > b)
1305 (<=.) x y = x >>== \a. y >>== \b. rtrn (a <= b)
1306 (>=.) x y = x >>== \a. y >>== \b. rtrn (a >= b)
1307 instance If Eval p q Expr where
1308 If c t e = c >>== \b.if b (toExpr t) (toExpr e)
1309 instance IF Eval where
1310 IF c t e = c >>== \b.if b (yield () t) (yield () e)
1311 (?) c t = c >>== \b.if b (yield () t) (rtrn ())
1312 instance var2 Eval where
1313 var2 v f = defEval2 v f
1314 con2 v f = defEval2 v f
1316 defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
1318 {main = E (\r s.(length s.store
1319 , {s & store = s.store ++ [toDyn v]}))
1320 >>== \n.unMain (f (E (read n)))}
1321 instance sds Eval where
1325 defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
1327 {main = E \r s.let (v In g) = f (E (read (length s.store))) in
1328 unEval (unMain g) r {s & store = s.store ++ [toDyn v]}}
1329 instance fun Eval x | arg x where
1330 fun f = e where (g In e) = f (\a.toExpr (g a))
1331 instance mtask Eval x | arg x where
1333 (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]}))
1334 instance mtasks Eval x y | arg x & arg y where
1337 f ((\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
1338 ,(\d b.long d >>== \(L j).E\r s.(MTask (length s.tasks),{s&tasks=[(j,toS2S (u b)):s.tasks]}))
1340 instance setDelay Eval where
1341 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})
1342 class toExpr v where toExpr :: (v t p) -> v t Expr
1343 instance toExpr Eval where toExpr (E f) = E f
1344 instance toExpr Code where toExpr (C f) = C f
1345 instance seq Eval where
1346 (>>=.) x f = x >>== f o rtrn
1347 (:.) x y = x >>== \_. y
1348 instance assign Eval where
1349 (=.) (E v) e = e >>== \a. E \r s.v (Wrt a) s
1350 instance output Eval where
1351 output x = x >>== \a.E \r s.((),{s & serial = s.serial ++ [toCode a]})
1352 instance pinMode Eval where
1353 pinmode p m = rtrn ()
1354 instance digitalIO Eval where
1355 digitalRead p = E \rw s=:{dpins, apins}.(readPinD p dpins apins, s)
1356 digitalWrite p b = b >>== \a. E \rw s.(a, writePinD p a s)
1357 instance analogIO Eval where
1358 analogRead p = E \rw s=:{apins}. (readPinA p apins, s)
1359 analogWrite p b = b >>== \a. E \rw s.(a, writePinA p a s)
1360 instance noOp Eval where noOp = E \r s.(undef,s)
1362 class arg x :: x -> Int
1363 instance arg () where arg _ = 0
1364 instance arg (Eval t p) | type t where arg _ = 1
1365 instance arg (Eval t p, Eval u q) | type t & type u where arg _ = 2
1366 instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v where arg _ = 3
1367 instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v where arg _ = 4
1369 instance + String where (+) x y = x +++ y
1371 readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
1373 = case [b \\ (q, b) <- lista | p == q] of
1377 writePinA :: AnalogPin Int State -> State
1379 = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}
1381 class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
1382 instance readPinD DigitalPin where
1383 readPinD p listd lista
1384 = case [b \\ (q,b) <- listd | p == q] of
1387 instance readPinD AnalogPin where
1388 readPinD p listd lista
1389 = case [b \\ (q,b) <- lista | p == q] of
1392 class writePinD p :: p Bool State -> State
1393 instance writePinD DigitalPin where
1394 writePinD p b s=:{dpins} = {s & dpins = [(p, b):[(q, c) \\ (q, c) <- dpins | p <> q]]}
1395 instance writePinD AnalogPin where
1396 writePinD p b s=:{apins} = {s & apins = [(p, if b 1 0):[(q, c) \\ (q, c) <- apins | p <> q]]}
1399 // ----- Interactive Simulation ----- //
1401 derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
1403 simulate :: (Main (Eval a p)) -> Task ()
1404 simulate {main=(E f)} = setup state0 where
1406 updateInformation "State" [] (toView s)
1407 >>* [ OnAction ActionFinish (always shutDown)
1408 , OnAction (Action "setup" []) (hasValue
1409 (\si.simloop (snd (f Rd (mergeView s si)))))
1412 updateInformation "State" [] (toView s)
1413 >>* [ OnAction ActionFinish (always shutDown)
1414 , OnAction (Action "clear serial" []) (always (simloop {s & serial = []}))
1415 , OnAction ActionNew (always (setup state0))
1416 : if (isEmpty s.tasks)
1418 [OnAction (Action "loop" []) (hasValue
1419 \si.simloop (step (mergeView s si)))
1423 toView :: State -> StateInterface
1425 { serialOut = Display s.serial
1426 , analogPins = s.apins
1427 , digitalPins = s.dpins
1428 , var2iables = map toDisplayVar s.store
1430 , taskCount = Display (length s.tasks)
1433 mergeView :: State StateInterface -> State
1436 & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
1437 , dpins = si.digitalPins
1438 , apins = si.analogPins
1439 // , serial = si.serialOut
1444 { serialOut :: Display [String]
1445 , analogPins :: [(AnalogPin, Int)]
1446 , digitalPins :: [(DigitalPin, Bool)]
1447 , var2iables :: [DisplayVar]
1449 , taskCount :: Display Int
1452 toDisplayVar :: Dyn -> DisplayVar
1453 toDisplayVar (Dyn [v])
1458 toDisplayVar (Dyn ["L",v]) = LONG (toInt v)
1459 toDisplayVar (Dyn ["Servo",pinKind,pin,pos]) = Servo (fromJust (fromDyn (Dyn [pinKind,pin]))) (toInt pos)
1460 toDisplayVar (Dyn ["LCD",_,_,_,_,_,l1,_,l2,_]) = LCD16x2 l1 l2
1461 toDisplayVar (Dyn l) = DisplayVar l
1463 fromDisplayVar :: DisplayVar Dyn -> Dyn
1464 fromDisplayVar (Variable v) dyn = Dyn [v]
1465 fromDisplayVar (INT v) dyn = Dyn [toString v]
1466 fromDisplayVar (LONG v) dyn = Dyn ["L",toString v]
1467 fromDisplayVar (Servo pin pos) dyn = Dyn (["Servo":let (Dyn p) = toDyn pin in p] ++ [toString pos])
1468 fromDisplayVar (LCD16x2 l1 l2) (Dyn list) = Dyn (updateAt 6 l1 (updateAt 8 l2 list))
1469 fromDisplayVar (DisplayVar l) dyn = Dyn l
1476 | LCD16x2 String String
1477 | DisplayVar [String]
1480 step :: State -> State
1482 foldr appTask {s & millis = s.millis + delta, tasks = []}
1483 [(w - delta, f) \\ (w, f) <- s.tasks]
1484 where delta = foldl1 min (map fst s.tasks) // smallest wait
1486 appTask t=:(w,f) s | w <= 0
1488 = {s & tasks = [t:s.tasks]}
1490 foldl1 op [a:x] = foldl op a x
1491 foldr1 op l :== foldr l
1494 foldr [a:x] = op a (foldr x)
1496 class stringQuotes t | type t :: (Code t p) -> Code t p
1497 instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\""
1498 instance stringQuotes t where stringQuotes x = x
1501 derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, LCD //, Servo
1502 derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, LCD //, Servo
1503 instance toCode () where toCode _ = ""
1504 instance == () where (==) _ _ = True
1506 // ----- long ----- //
1508 :: Long = L Int // 32 bit on Arduino
1509 instance toCode Long where toCode (L i) = toCode i + "L"
1510 instance + Long where (+) (L x) (L y) = L (x + y)
1511 instance - Long where (-) (L x) (L y) = L (x + y)
1512 instance * Long where (*) (L x) (L y) = L (x + y)
1513 instance / Long where (/) (L x) (L y) = L (x + y)
1514 instance == Long where (==) (L x) (L y) = x == y
1515 instance one Long where one = L one
1516 instance zero Long where zero = L zero
1519 class long v t :: (v t p) -> v Long Expr | isExpr p
1520 instance long Code Int where
1521 long x = embed (c "long" +.+ brac x)
1522 instance long Code Long where
1523 long x = embed (c "long" +.+ brac x)
1524 instance long Eval Int where
1525 long x = x >>== rtrn o L
1526 instance long Eval Long where
1529 // ----- tools ----- //
1531 class toCode a :: a -> String
1532 instance toCode Bool where toCode b = if b "true" "false"
1533 instance toCode Int where toCode a = toString a
1534 instance toCode Real where toCode a = toString a
1535 instance toCode Char where
1536 toCode '\0' = "'\\0'"
1537 toCode '\n' = "'\\n'"
1539 toCode a = "'" + toString a + "'"
1540 instance toCode String where toCode s = s
1541 instance toCode DigitalPin where toCode x = s%(1, size s - 1) where s = consName{|*|} x
1542 instance toCode AnalogPin where toCode x = consName{|*|} x
1543 derive consName DigitalPin, AnalogPin, PinMode
1545 instance == DigitalPin where (==) x y = x === y
1546 instance == AnalogPin where (==) x y = x === y
1548 derive consIndex DigitalPin, AnalogPin
1550 tab =: toString (repeatn tabSize ' ')
1553 instance toString () where toString _ = "()"