mTask.icl

   1 module mTask
   2
   3 /*
   4     Pieter Koopman pieter@cs.ru.nl
   5     Final version for TFP2016
   6
   7     -2: assignment =. suited for digital and analog input and output
   8     -3: ad hoc tasks
   9
  10 todo:
  11         move task-loop ti setup()
  12         adhoc tasks
  13         task combinators
  14         imporove setp: >>*.
  15 */
  16
  17 import iTasks
  18 import gdynamic, gCons, GenEq, StdMisc, StdArray
  19
  20 // =================== examples ===================
  21
  22 Start =
  23     [["//mTaskTFP16_3 \n"]
  24 /*  ,["// --- p1 \n"]
  25   ,compile p1
  26     ,["// --- p2 \n"]
  27   ,compile p2
  28     ,["// --- p3 \n"]
  29   ,compile p3
  30     ,["// --- p4 \n"]
  31   ,compile p4
  32     ,["// --- p5 \n"]
  33   ,compile p5
  34     ,["// --- p6 \n"]
  35   ,compile p6
  36     ,["// --- p7 \n"]
  37   ,compile p7
  38     ,["// --- p8 \n"]
  39   ,compile p8
  40     ,["// --- p9 \n"]
  41   ,compile p9
  42     ,["// --- p10 \n"]
  43   ,compile p10
  44     ,["// --- p11 \n"]
  45   ,compile p11
  46     ,["// --- p12 \n"]
  47   ,compile p12
  48     ,["// --- fac \n"]
  49   ,compile fac
  50     ,["// --- blink \n"]
  51   ,compile blink
  52     ,["// --- heatingDemo \n"]
  53   ,compile heatingDemo
  54     ,["// --- hpinDemo \n"]
  55   ,compile pinDemo
  56     ,["// --- blink2 \n"]
  57   ,compile blink2
  58   ,["// --- blink3 \n"]
  59   ,compile blink3
  60   ,["// --- blinks \n"]
  61   ,compile blinks
  62   ,["// --- lcdCount \n"]
  63   ,compile lcdCount
  64 */
  65   ,["// --- heating \n"]
  66   ,compile heating
  67   ]
  68
  69 lcdHello = LCD 16 2 [] \lcd = {main = print lcd (lit "Hello world")}
  70
  71 lcdCount =
  72         LCD 16 2 [] \lcd =
  73         task \t = (\c.
  74                 If (pressed upButton) (
  75                         setCursor lcd Zero Zero :.
  76                         print lcd c :.
  77                         t (sec 1) (c +. One)
  78                 ) (t (msec 10) c)) In
  79         {main = t (sec 0) Zero}
  80
  81 printD0 = {main = serialPrint (Not d0)}
  82
  83 print36 = sds \x = 6 In {main = x =. x *. x :. serialPrint x}
  84
  85 pinDemo =
  86     {main = a1 =. a0 =. lit 1 +. a0 :.  a0 =. Not a0}
  87
  88 fac = fun \fac = (\n. If (n <. One) One (n *. fac (n -. One)))
  89     In {main = fac (lit 6)}
  90 One = lit 1
  91 Zero = lit 0
  92
  93 blink =
  94   task \t = (\s. setLED s :. t (If s (sec 1) (sec 3)) (Not s)) In {main = t (sec 0) (lit True)}
  95 blink2 =
  96   task \t = (\(). d13 =. Not d13 :. t (sec 1) ()) In {main = t (sec 0) ()}
  97 blink3 =
  98   task \t = (\s. d13 =. s :. t (If s (msec 100) (sec 1)) (Not s)) In {main = t (sec 0) (lit False)}
  99 blinks =
 100         task \t = (\b. d13 =. b :. t (sec 1) b) In {main = t (msec 0) true :. t (msec 100) false}
 101
 102 setLED b = d13 =. b
 103 sec n = long (lit (n * 1000))
 104 msec n = long (lit n)
 105
 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)}
 108
 109 q1 =
 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)
 116     ])
 117  In {main = heat (sec 0) off}
 118 where
 119     upper = lit 876
 120     lower = lit 123
 121
 122 serialReadInt = serialParseInt >>=. \i. serialRead >>*. \c. [Cond (c ==. lit '\n') i]
 123
 124 heating =
 125   sds \goal     = 500 In
 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)
 132    ]) In
 133   task \change = (\().
 134     serialAvailable ? (serialReadInt >>=. \g.goal =. g) :.
 135     change (sec 1) ()) In
 136   {main = switch off :. control (sec 0) off :. change (sec 1) ()}
 137 where
 138   minOnTime  = sec 2
 139   minOffTime = sec 1
 140
 141 heating2 =
 142   sds \goal = 500 In
 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)
 150    ]) In
 151   task \change = (\().
 152     serialAvailable ? (serialReadInt >>=. \i. serialPrintln (goal =. i)) :.
 153     change (sec 1) ()) In
 154   {main = switch off :. control (sec 0) off :. change (sec 1) ()}
 155 where
 156   minOnTime  = sec 2
 157   minOffTime = sec 1
 158
 159 thermoTask =
 160         sds \goal = 500 In
 161         fun \switch = (\on. d13 =. bool on :. a0 =. on) In
 162         task \control =
 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)
 167                         ]) In
 168         {main = switch off :. control (sec 0) off}
 169 where
 170         minOnTime = sec 1 // 60
 171         minOffTime = sec 2 //10
 172         off = lit False
 173
 174 heatingDemo =
 175  sds \heat = False In
 176  sds \temp = 500 In
 177  LCD 16 2 [] \lcd.
 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 ") :.
 183     print lcd temp :.
 184     print lcd (lit " ") :.
 185     tempChange (msec 789) ()) In
 186  fun  \switch  = (\s.
 187   heat =. s :.
 188     setCursor lcd Zero Zero :.
 189     If s
 190         (print lcd (lit "On "))
 191         (print lcd (lit "Off"))) In
 192  fun \measure = (\().
 193     analogRead A0 >>=. \a0.
 194     setCursor lcd Zero One :.
 195     print lcd a0 :.
 196     print lcd (lit "   ") :.
 197   a0) In
 198  task \control = (\isOn.
 199    measure () >>=. \val.temp <. val
 200    >>*. \mustOn.
 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)
 204    ]
 205    ) In
 206  {main = switch off :. control (msec 10) off :. tempChange (sec 0) ()}
 207 where
 208   limit   = lit 512
 209   minOnTime  = sec 3
 210   minOffTime = sec 2
 211 true = lit True
 212 on = true
 213 false = lit False
 214 off = false
 215
 216 count =
 217     LCD 16 2 [] \lcd.
 218     task \count = (\n.
 219       setCursor lcd Zero Zero :.
 220       print lcd n :.
 221       count (sec 1) (n +. One)) In
 222     {main = count (sec 0) Zero}
 223
 224 p0 = sds \x = 6 In {main = x =. x *. lit 7}
 225 p1 = {main = lit 2 +. lit 4 >>=. \x. (x +. lit 1) *. x}
 226 p2 =
 227     fun \f. (\x. lit 6 *. x)
 228     In {main = lit 3 +. lit 4 >>=. \x. f x}
 229 p3 =
 230     fun \f. (\x. lit 6 *. x)
 231     In {main = lit 3 +. lit 4 >>=. f} // higher order, somewhat remarkable that this works
 232 p4 =
 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)}
 242 p10 =
 243     sds \y = 1 In
 244     {main =
 245         (pressed upButton >>*. \x.
 246             [Cond x (y =. y +. y :.
 247              x)
 248             ,Ever (y =. lit 36 :.
 249              lit False)
 250             ])
 251         >>=. \z. z &. z}
 252 p11 =
 253     sds \y = 1 In
 254     {main =
 255          y =. lit 2 :.
 256          (pressed upButton >>=. \b.
 257           If b
 258             (y =. lit 3 :.
 259              y +. lit 1)
 260             (lit 42))
 261         >>*. \x.
 262             [Cond (x <. lit 36)
 263                     ((y =. x *. x) >>*. \z.
 264                         [Cond (z ==. x) (serialPrint y)
 265                         ,Ever (serialPrint (lit 0))
 266                         ])
 267             ,Ever (y =. x)
 268             ]
 269     }
 270 p12 =
 271     task \t = (\(). pressed upButton >>*. \b.[Cond b (serialPrintln (lit 7)),Ever (t (lit 250) ():. lit 0)]) In
 272     {main = t (lit 0) ()}
 273
 274 // ----- serial definition ----- //
 275
 276 class serial v where
 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)
 282
 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()")
 289
 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
 296
 297 class char2int v :: (v Char p) -> v Int Expr
 298 instance char2int Code where char2int (C f) = C \rw c.f Rd c
 299
 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)
 305   }
 306
 307 // =================== shields ===================
 308
 309 // ----- LCD definition ----- //
 310
 311 :: LCD =
 312   { cursorRow :: Int
 313   , cursorCol :: Int
 314   , sizeH     :: Int
 315   , sizeW     :: Int
 316   , lcdtxt    :: [String]
 317   }
 318
 319 :: Button = RightButton | UpButton | DownButton | LeftButton | SelectButton | NoButton
 320
 321 rightButton = lit RightButton
 322 upButton = lit UpButton
 323 downButton = lit DownButton
 324 leftButton = LeftButton
 325 selectButton = lit SelectButton
 326 noButton = lit NoButton
 327
 328 class lcd v where
 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
 337
 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 =
 346     {main =
 347      getCode \cd. fresh \n.
 348       let
 349           name = "lcd" + toString n
 350           rest = f (c name)
 351       in
 352       include "LiquidCrystal" +.+
 353       setCode Var +.+
 354         c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+
 355       setCode cd +.+
 356         rest.main
 357     }
 358   LCD x y [] f = LCD x y [D8, D9, D4, D5, D6, D7] f
 359   LCD x y pins f =
 360     {main =
 361      getCode \cd. fresh \n.
 362       let
 363           name = "lcd" + toString n
 364           rest = f (c name)
 365       in
 366           include "LiquidCrystal" +.+
 367           setCode Var +.+
 368             c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+
 369           setCode Setup +.+
 370             c (name + ".begin(" + toCode x + ", " + toCode y +");") +.+ nl +.+
 371           setCode cd +.+
 372             rest.main
 373     }
 374   pressed b = embed (c "pressed(" +.+ setMode SubExp +.+ b +.+ c ")")
 375
 376 RightBound  = 50
 377 UpBound   = 190
 378 DownBound   = 380
 379 LeftBound   = 555
 380 SelectBound = 790
 381
 382 instance lcd Eval where
 383   begin   (E v) x y =
 384    x >>== \w.
 385    y >>== \h.
 386    yield () (E \r.v (Updt \lcd.{lcd & sizeH = h, sizeW = w, lcdtxt = repeatn h (toString (repeatn w ' '))}))
 387   print   (E v) x   =
 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 =
 391     x >>== \w.
 392     y >>== \h.
 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
 397       lcd =
 398               { cursorRow = 0
 399               , cursorCol = 0
 400               , sizeH = h
 401               , sizeW = w
 402               , lcdtxt = repeatn h (toString (repeatn w ' '))
 403               }
 404   liquidCrystal0 pins f = defEval2 lcd f where
 405     lcd =
 406           { cursorRow = 0
 407           , cursorCol = 0
 408           , sizeH = 0
 409           , sizeW = 0
 410           , lcdtxt = []
 411           }
 412   pressed b = rtrn False
 413
 414 lcdPrintStr str lcd
 415   | lcd.cursorRow < 0 || lcd.cursorRow >= length lcd.lcdtxt ||
 416     lcd.cursorCol < 0 || lcd.cursorCol >= size (lcd.lcdtxt !! lcd.cursorRow)
 417     = lcd
 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}
 425
 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
 429
 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)
 432  =  v >>=. \w.
 433   If (w <. lit RightBound)
 434     right
 435   (If (w <. lit UpBound)
 436     up
 437   (If (w <. lit DownBound)
 438     down
 439   (If (w <.lit  LeftBound)
 440     left
 441   (If (w <. lit SelectBound)
 442     select
 443     nokey
 444   ))))
 445
 446 // =================== mTask ===================
 447
 448
 449 // ----- dsl definition ----- //
 450
 451 :: DigitalPin
 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
 461
 462 class pin p | type, == p where
 463   pin :: p -> Pin
 464 instance pin DigitalPin where
 465         pin p = Digital p
 466 instance pin AnalogPin  where
 467   pin p = Analog  p
 468
 469 :: Upd   = Upd
 470 :: Expr  = Expr
 471 :: Stmt  = Stmt
 472 :: MTask = MTask Int // String
 473
 474 class isExpr a :: a -> Int
 475 instance isExpr Upd  where isExpr _ = 0
 476 instance isExpr Expr where isExpr _ = 1
 477
 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
 482
 483 instance == MTask where (==) (MTask x) (MTask y) = x == y
 484 instance toCode MTask where toCode (MTask x) = "Task " + toCode x
 485
 486 :: Main a = {main :: a}
 487
 488 unMain :: (Main x) -> x
 489 unMain m = m.main //{main=x} = x
 490
 491 class arith v where
 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
 510 class IF v where
 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
 513 class var2 v where
 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
 516 class sds v where
 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
 519 class seq v where
 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
 522 class step v where
 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)
 525 class assign v where
 526   (=.) infixr 2 :: (v t Upd) (v t p) -> v t Expr | type t & isExpr p
 527 class fun v t where
 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
 531 class lag v where
 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
 537 class output v where
 538   output :: (v t p) -> v () Expr | type t & isExpr p
 539 class noOp v where noOp :: v t p
 540
 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
 549 class dIO v where
 550     dIO :: p -> v Bool Upd | pin, readPinD p
 551 class aIO v where
 552     aIO :: AnalogPin -> v Int Upd
 553 class time v where
 554   delay  :: (v Long p) -> (v Long Expr)
 555   millis ::         (v Long Expr)
 556
 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
 561
 562 a0 = pio A0
 563 a1 = pio A1
 564 a2 = pio A2
 565 a3 = pio A3
 566 a4 = pio A4
 567 a5 = pio A5
 568
 569 d0 = pio D0
 570 d1 = pio D1
 571 d2 = pio D2
 572 d3 = pio D3
 573 d4 = pio D4
 574 d5 = pio D5
 575 d6 = pio D6
 576 d7 = pio D7
 577 d8 = pio D8
 578 d9 = pio D9
 579 d10 = pio D10
 580 d11 = pio D11
 581 d12 = pio D12
 582 d13 = pio D13
 583
 584 int :: (v Int p) -> (v Int p)
 585 int x = x
 586 bool :: (v Bool p) -> (v Bool p)
 587 bool x = x
 588 char :: (v Char p) -> (v Char p)
 589 char x = x
 590
 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 _ = ""
 610
 611 class dsl t | arith, boolExpr, sds, assign, seq t
 612
 613 argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
 614 argType f = undef
 615
 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)
 620
 621 resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
 622 resType f = showType
 623
 624 var2Type :: (Code t p) -> Code t p | showType t
 625 var2Type x = showType
 626
 627 resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
 628 resType2 f = showType2
 629
 630 :: SV t = SV String
 631 instance toCode (SV t) where toCode (SV s) = s
 632
 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 */"
 639
 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 */ "
 647
 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"
 653
 654 :: In a b = In infix 0 a b
 655
 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})
 662
 663 // ----- code generation ----- //
 664
 665 instance arith Code where
 666   lit a = embed (c a)
 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))
 686 IfStmt b t e =
 687   getMode \mode.
 688   let
 689     v = varName t
 690     newMode =
 691       case mode of
 692         Return s = Return s
 693         Assign v = Assign v
 694         _    = if (v == "") NoReturn (Assign v)
 695   in
 696     setMode SubExp +.+
 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
 702   (?) b t =
 703     getMode \mode.
 704     c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+
 705     indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}"
 706
 707 instance sds Code where
 708   sds f = // defCode f
 709    {main = fresh \n.
 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}
 714   con f = defCode f
 715
 716 defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
 717 defCode f =
 718   {main = fresh \n.
 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}
 723
 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
 727
 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
 731   (>>=.) x f =
 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
 737     (>>*.) x f =
 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
 754
 755 optBreak :: Mode -> Code u p
 756 optBreak mode =
 757     case mode of
 758         Return s    = C \rw c.c
 759         _           = nl +.+ c "break;"
 760
 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
 764   task f =
 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
 770   tasks f =
 771     {main =
 772             freshMTask \t1.
 773             freshMTask \t2.
 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
 779 loopCode n b =
 780   nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
 781   setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+
 782   unindent +.+ nl +.+ c "} "
 783
 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)
 790     where
 791       n0 = "t0p->a[0]"
 792       ta = c n0 +.+ type1
 793       app d a =
 794         setBinds [n0] +.+ embed (c "newTask(" +.+
 795           c n +.+ c ", " +.+
 796           d +.+ c ", " +.+
 797           a +.+ c ")")
 798 instance taskImp2 (Code a p, Code b q) where
 799   taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
 800     n0 = "t0p->a[0]"
 801     n1 = "t0p->a[1]"
 802     ta1 = c n0 +.+ type1
 803     ta2 = c n1 +.+ type2
 804     app d (a1, a2) =
 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))
 809     where
 810       n0 = "t0p->a[0]"
 811       n1 = "t0p->a[1]"
 812       n2 = "t0p->a[2]"
 813       ta1 = c n0 +.+ type1
 814       ta2 = c n1 +.+ type2
 815       ta3 = c n2 +.+ type3
 816       app d (a1, a2, a3) =
 817         setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+
 818           c n +.+ c ", " +.+
 819           d  +.+ c ", " +.+
 820           a1 +.+ c ", " +.+
 821           a2 +.+ c ", " +.+
 822           a3 +.+ c ", 0)")
 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))
 825     where
 826       n0 = "t0p->a[0]"
 827       n1 = "t0p->a[1]"
 828       n2 = "t0p->a[2]"
 829       n3 = "t0p->a[3]"
 830       ta1 = c n0 +.+ type1
 831       ta2 = c n1 +.+ type2
 832       ta3 = c n2 +.+ type3
 833       ta4 = c n3 +.+ type4
 834       app d (a1, a2, a3, a4) =
 835         setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+
 836           c n +.+ c ", " +.+
 837           d  +.+ c ", " +.+
 838           a1 +.+ c ", " +.+
 839           a2 +.+ c ", " +.+
 840           a3 +.+ c ", " +.+
 841           a4 +.+ c ")")
 842
 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)
 849     where
 850       ta = c "t0p->a[0]" +.+ type1
 851       app i a =
 852         embed (c "newTask(" +.+
 853           c n +.+ c ", " +.+
 854           c i +.+ c ", " +.+
 855           a +.+ c ")")
 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
 860           app i (a1, a2) =
 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))
 865     where
 866       ta1 = c "t0p->a[0]" +.+ type1
 867       ta2 = c "t0p->a[1]" +.+ type2
 868       ta3 = c "t0p->a[2]" +.+ type3
 869       app i (a1, a2, a3) =
 870         embed (c "newTask(" +.+
 871           c n +.+ c ", " +.+
 872           c i +.+ c ", " +.+
 873           a1 +.+ c ", " +.+
 874           a2 +.+ c ", " +.+
 875           a3 +.+ c ")")
 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))
 878     where
 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(" +.+
 885           c n +.+ c ", " +.+
 886           c i +.+ c ", " +.+
 887           a1 +.+ c ", " +.+
 888           a2 +.+ c ", " +.+
 889           a3 +.+ c ", " +.+
 890           a4 +.+ c ")")
 891
 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
 893 tasksMain i j f =
 894     { main =
 895       freshMTask \n. freshMTask \m.
 896         let
 897           (app1, a1) = taskImp n types
 898           (app2, a2) = taskImp m types
 899           ((b1, b2) In {main = e}) = f (app1 i, app2 j)
 900         in
 901           codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
 902     }
 903 class types a :: a
 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)
 913
 914 codeMTaskBody :: (Code v w) (Code c d) -> Code e f
 915 codeMTaskBody loop e =
 916   getMode \mode.
 917     setMode NoReturn +.+
 918     setCode Loop +.+ loop +.+
 919     setMode mode +.+ setCode Setup +.+ embed e
 920 instance fun Code () where
 921   fun f  =
 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
 927    }
 928 instance fun Code (Code t p) | type, showType t & isExpr p  where
 929   fun f  =
 930     {main =
 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
 938     }
 939 instance fun Code (Code a p, Code b q) | showType a & showType b where
 940   fun f =
 941          {main =
 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
 947               (g In main)
 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
 954          }
 955 instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
 956   fun f  =
 957     {main =
 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
 969     }
 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
 991
 992 :: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
 993 :: CODE =
 994   { fresh       :: Int
 995   , freshMTask :: Int
 996   , funs        :: [String]
 997   , ifuns                       :: Int
 998   , vars          :: [String]
 999   , ivars                       :: Int
1000   , setup                       :: [String]
1001   , isetup        :: Int
1002   , loop          :: [String]
1003   , iloop                       :: Int
1004   , includes  :: [String]
1005   , def           :: Def
1006   , mode          :: Mode
1007   , binds                       :: [String]
1008   }
1009
1010 unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
1011 unC (C f) = f
1012
1013 :: Def = Var | Fun | Setup | Loop
1014 :: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
1015
1016 setMode :: Mode -> Code a p
1017 setMode m = C \rw c.{c & mode = m}
1018
1019 getMode :: (Mode -> Code a p) -> Code a p
1020 getMode f = C \rw c.unC (f c.mode) rw c
1021
1022 embed :: (Code a p) -> Code a p
1023 embed e =
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 ";"
1029     SubExp    = e
1030     _       = abort "\n\nembed: unknown mode.\n"
1031
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)
1034
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}
1037
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}
1040
1041 setCode :: Def -> (Code a p)
1042 setCode d = C \rw c.{c & def = d}
1043
1044 getCode :: (Def -> Code a p) -> (Code a p)
1045 getCode f = C \rw c.unC (f c.def) rw c
1046
1047 brac :: (Code a p) -> Code b q
1048 brac e = c "(" +.+ e +.+ c ")"
1049
1050 funBody :: (Code a p) -> Code b q
1051 funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl
1052
1053 codeOp2 :: (Code a p) String (Code b q) -> Code c r
1054 codeOp2 x n y = embed (brac (x +.+ c n +.+ y))
1055
1056 include :: String -> Code a b
1057 include lib = C \rw c.{c & includes = [lib:c.includes]}
1058
1059 argList :: [a] -> String | toCode a
1060 argList [a] = toCode a
1061 argList [a:x] = toCode a + "," + argList x
1062 argList [] = ""
1063
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]}
1070
1071 indent :: Code a p
1072 indent =
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}
1078
1079 unindent :: Code a p
1080 unindent =
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}
1086 where
1087   dec n | n > 1
1088     = n - 1
1089     = 0
1090
1091 nl :: Code a p
1092 nl =
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]}
1098 where
1099   str n = toString ['\n':repeatn (tabSize * n) ' ']
1100
1101 setBinds :: [String] -> Code a p
1102 setBinds list = C \rw c.{c & binds = list}
1103
1104 addBinds :: String -> Code a p
1105 addBinds name = C \rw c.{c & binds = [name:c.binds]}
1106
1107 getBinds :: ([String] -> Code a p) -> (Code a p)
1108 getBinds f = C \rw c.unC (f c.binds) rw c
1109
1110 // ----- driver ----- //
1111
1112 compile :: (Main (Code a p)) -> [String]
1113 compile {main=(C f)} =
1114   ["/*\n"
1115   ,"  Generated code for Arduino\n"
1116   ,"  Pieter Koopman, pieter@cs.ru.nl\n"
1117   ,"*/\n"
1118   ,"\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"
1123   ,"\n"
1124   ,"typedef union Arg {\n"
1125   ,"  int i;\n"
1126   ,"  bool b;\n"
1127   ,"  char c;\n"
1128 //  ,"  float f;\n" // requires 4 bytes
1129   ,"  word w;\n"
1130   ,"} ARG;\n"
1131   ,"\n"
1132   ,"typedef struct Task {\n"
1133   ,"  byte id;\n"
1134   ,"  long wait;\n"
1135   ,"  ARG a[MAX_ARGS];\n"
1136   ,"} TASK;\n"
1137   ,"\n"
1138   ] ++
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"
1143   ,"long delta;\n"
1144   ,"\n"
1145   ,"int vInt;\n"
1146   ,"bool vBool;\n"
1147   ,"char vChar;\n"
1148   ,"float vFloat;\n"
1149   ,"unsigned long time = 0;\n"
1150   :reverse c.vars
1151   ] ++
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"
1155   ,"  tnp->id = id;\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"
1161   ,"  byte r = tn;\n"
1162   ,"  tn = NEXT_TASK(tn);\n"
1163   ,"  return r;\n"
1164   ,"}\n"
1165   ,"\n"
1166   ,"byte setDelay(byte t, long d) {\n"
1167   ,"  tasks[t].wait = d;\n"
1168   ,"  return t;\n"
1169   ,"}\n"
1170   ,"boolean pressed(int b) {\n"
1171   ,"  pinMode(A0, INPUT);\n"
1172   ,"  int a0 = analogRead(A0);\n"
1173   ,"  switch (b) {\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"
1180   ,"  }\n"
1181   ,"}\n"
1182   ,"boolean pWrite (int pin, boolean b) {\n"
1183   ,"  pinMode(pin, OUTPUT);\n"
1184   ,"  digitalWrite(pin, b);\n"
1185   ,"  return b;\n"
1186   ,"}\n"
1187   ,"int pWrite (int pin, int i) {\n"
1188   ,"  pinMode(pin, OUTPUT);\n"
1189   ,"  analogWrite(pin, i);\n"
1190   ,"  return i;\n"
1191   ,"}\n"
1192   :reverse c.funs
1193   ] ++
1194   ["\n// --- setup --- \n"
1195   ,"void setup () {\n"
1196   ,"  Serial.begin(9600);\n"
1197   ,"  "
1198   :reverse c.setup
1199   ] ++
1200   ["\n}\n"
1201   ,"\n// --- loop --- \n"
1202   ,"void loop () {\n"
1203   ,"  if (t0 != tn) {\n"
1204   ,"  if (t0 == tc) {\n"
1205   ,"    unsigned long time2 = millis();\n"
1206   ,"    delta = time2 - time;\n"
1207   ,"    time = time2;\n"
1208   ,"    tc = tn;\n"
1209   ,"  };\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"
1214   ,"  } else {\n"
1215   ,"    switch (t0p->id) {"
1216   :reverse c.loop
1217   ] ++
1218   ["\n"
1219   ,"    default:\n"
1220   ,"    Serial.println(\"stopped\");\n"
1221   ,"    t0 = tn; // no known task: force termination of tasks\n"
1222   ,"    return;\n"
1223   ,"    };\n"
1224   ,"  }\n"
1225   ,"  t0 = NEXT_TASK(t0);\n"
1226   ,"  }\n"
1227   ,"}\n"
1228   ]
1229 where c = f Rd newCode
1230
1231 mkset :: [a] -> [a] | Eq a
1232 mkset [a:x] = [a:mkset (filter ((<>) a) x)]
1233 mkset [] = []
1234
1235 newCode :: CODE
1236 newCode =
1237   { fresh   = 0
1238   , freshMTask = 0
1239   , funs    = []
1240   , ifuns   = 0
1241   , vars    = []
1242   , ivars   = 0
1243   , setup   = []
1244   , isetup  = 1
1245   , loop    = []
1246   , iloop   = 4
1247   , includes  = []
1248   , def     = Setup
1249   , mode    = NoReturn
1250   , binds               = []
1251   }
1252
1253 // ----- simulation ----- //
1254
1255 eval :: (Main (Eval t p)) -> [String] | toString t
1256 eval {main=(E f)} = [toString (fst (f Rd state0))]
1257
1258 :: State =
1259   { tasks :: [(Int, State->State)]
1260   , store :: [Dyn]
1261   , dpins :: [(DigitalPin, Bool)]
1262   , apins :: [(AnalogPin, Int)]
1263   , serial:: [String]
1264   , millis:: Int
1265   }
1266
1267 state0 :: State
1268 state0 = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}
1269
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)
1274
1275 unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
1276 unEval (E f) = f
1277
1278 :: ReadWrite t = Rd | Wrt t | Updt (t->t)
1279
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
1283
1284 rtrn :: t -> Eval t p
1285 rtrn a = E \r s -> (a, s)
1286
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))
1290
1291 instance arith Eval where
1292   lit a = rtrn a
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
1315
1316 defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
1317 defEval2 v f =
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
1322   sds f = defEval f
1323   con f = defEval f
1324
1325 defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
1326 defEval f =
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
1332  task f = e 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
1335  tasks f = e where
1336   ((t,u) In e) =
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]}))
1339    )
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)
1361
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
1368
1369 instance + String where (+) x y = x +++ y
1370
1371 readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
1372 readPinA p lista
1373   = case [b \\ (q, b) <- lista | p == q] of
1374   []  = 0
1375   [a:x] = a
1376
1377 writePinA :: AnalogPin Int State -> State
1378 writePinA p x s
1379   = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}
1380
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
1385     [] = False
1386     [a:x] = a
1387 instance readPinD AnalogPin where
1388   readPinD p listd lista
1389   = case [b \\ (q,b) <- lista | p == q] of
1390     [] = False
1391     [a:x] = a <> 0
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]]}
1397
1398
1399 // ----- Interactive Simulation ----- //
1400
1401 derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
1402
1403 simulate :: (Main (Eval a p)) -> Task ()
1404 simulate {main=(E f)} = setup state0 where
1405   setup s =
1406           updateInformation "State" [] (toView s)
1407           >>* [ OnAction ActionFinish (always shutDown)
1408             , OnAction (Action "setup" []) (hasValue
1409               (\si.simloop (snd (f Rd (mergeView s si)))))
1410             ]
1411   simloop s =
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)
1417                 []
1418                 [OnAction (Action "loop" []) (hasValue
1419               \si.simloop (step (mergeView s si)))
1420               ]
1421             ]
1422
1423 toView :: State -> StateInterface
1424 toView s =
1425   { serialOut = Display s.serial
1426   , analogPins = s.apins
1427   , digitalPins = s.dpins
1428   , var2iables = map toDisplayVar s.store
1429   , timer = s.millis
1430   , taskCount = Display (length s.tasks)
1431   }
1432
1433 mergeView :: State StateInterface -> State
1434 mergeView s si =
1435   { s
1436   & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
1437   , dpins = si.digitalPins
1438   , apins = si.analogPins
1439 //  , serial = si.serialOut
1440   , millis = si.timer
1441   }
1442
1443 :: StateInterface =
1444   { serialOut   :: Display [String]
1445   , analogPins  :: [(AnalogPin, Int)]
1446   , digitalPins :: [(DigitalPin, Bool)]
1447   , var2iables   :: [DisplayVar]
1448   , timer     :: Int
1449   , taskCount   :: Display Int
1450   }
1451
1452 toDisplayVar :: Dyn -> DisplayVar
1453 toDisplayVar (Dyn [v])
1454     # i = toInt v
1455     | toString i == v
1456         = INT i
1457         = Variable 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
1462
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
1470
1471 :: DisplayVar
1472     = Variable String
1473     | INT Int
1474     | LONG Int
1475     | Servo Pin Int
1476     | LCD16x2 String String
1477     | DisplayVar [String]
1478
1479
1480 step :: State -> State
1481 step s =
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
1485
1486 appTask t=:(w,f) s | w <= 0
1487   = f s
1488   = {s & tasks = [t:s.tasks]}
1489
1490 foldl1 op [a:x] = foldl op a x
1491 foldr1 op l :== foldr l
1492   where
1493     foldr [a]     = a
1494     foldr [a:x] = op a (foldr x)
1495
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
1499
1500
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
1505
1506 // ----- long ----- //
1507
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
1517 now = lit (L 0)
1518
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
1527   long (E x) = E x
1528
1529 // ----- tools ----- //
1530
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'"
1538   toCode '\\' = "\\"
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
1544
1545 instance == DigitalPin where (==) x y = x === y
1546 instance == AnalogPin   where (==) x y = x === y
1547
1548 derive consIndex DigitalPin, AnalogPin
1549
1550 tab =: toString (repeatn tabSize ' ')
1551 tabSize :== 2
1552
1553 instance toString () where toString _ = "()"