Clean System Files
mTask
+mTaskExamples
sapl
mTask-data
$(CLM) $(CLMLIBS) $(CLMFLAGS) $(basename $<) -o $@
clean:
- $(RM) -r mTask Clean\ System\ Files
+ $(RM) -r mTaskExamples Clean\ System\ Files
from iTasks.API.Core.Types import :: Display
import gdynamic, gCons, GenEq, StdMisc, StdArray
+import mTaskCode, mTaskSimulation
import mTaskSerial, mTaskLCD
// =================== mTask ===================
:: AnalogPin = A0 | A1 | A2 | A3 | A4 | A5
:: PinMode = INPUT | OUTPUT | INPUT_PULLUP
:: Pin = Digital DigitalPin | Analog AnalogPin
-instance toCode Pin
class pin p | type, == p where
pin :: p -> Pin
instance isStmt Stmt
instance == MTask
-instance toCode MTask
:: Main a = {main :: a}
class dsl t | arith, boolExpr, sds, assign, seq t
-argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
-
-class argTypes t :: ((t->Code b Expr)->In (t->Code b2 q) (Main (Code c s))) -> t
-instance argTypes (Code a p) | showType a
-instance argTypes (Code a p, Code b q) | showType a & showType b
-instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c
-
-resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
-
-var2Type :: (Code t p) -> Code t p | showType t
-
-resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
-
:: SV t = SV String
-instance toCode (SV t)
class showType2 t :: SV t
instance showType2 ()
read` :: Int (ReadWrite a) State -> (a,State) | dyn a
-// ----- code generation ----- //
-
-instance arith Code
-instance boolExpr Code
-instance If Code Stmt Stmt Stmt
-instance If Code e Stmt Stmt
-instance If Code Stmt e Stmt
-instance If Code x y Expr
-instance IF Code
-instance sds Code
-
-defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
-
-var :: String (ReadWrite (Code v q)) CODE -> CODE
-
-instance assign Code
-instance seq Code
-instance step` Code
-codeSteps :: [Step Code t] -> Code u p
-optBreak :: Mode -> Code u p
-
-instance setDelay Code
-instance mtask Code a | taskImp2 a & types a
-instance mtasks Code a b | taskImp2 a & types a & taskImp2 b & types b
-
-loopCode :: Int (Code a b) -> Code c d
-
-class taskImp2 a :: Int a -> ((Code Long p) a->Code MTask Expr, a) | /*long Code delay &*/ isExpr p
-instance taskImp2 ()
-instance taskImp2 (Code t p)
-instance taskImp2 (Code a p, Code b q)
-instance taskImp2 (Code a p, Code b q, Code c r)
-instance taskImp2 (Code a p, Code b q, Code c r, Code d s)
-
-class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
-instance taskImp ()
-instance taskImp (Code t p)
-instance taskImp (Code a p, Code b q)
-instance taskImp (Code a p, Code b q, Code c r)
-instance taskImp (Code a p, Code b q, Code c r, Code d s)
-
-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
-class types a :: a
-instance types ()
-instance types (Code a p) | typeSelector a & isExpr p
-instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
-instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
-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
-
-codeMTaskBody :: (Code v w) (Code c d) -> Code e f
-instance fun Code ()
-instance fun Code (Code t p) | type, showType t & isExpr p
-instance fun Code (Code a p, Code b q) | showType a & showType b
-instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c
-instance output Code
-instance pinMode Code
-instance digitalIO Code
-instance dIO Code
-instance aIO Code
-instance analogIO Code
-instance noOp Code
-
-:: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
-:: CODE =
- { fresh :: Int
- , freshMTask :: Int
- , funs :: [String]
- , ifuns :: Int
- , vars :: [String]
- , ivars :: Int
- , setup :: [String]
- , isetup :: Int
- , loop :: [String]
- , iloop :: Int
- , includes :: [String]
- , def :: Def
- , mode :: Mode
- , binds :: [String]
- }
-
-unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
-
-:: Def = Var | Fun | Setup | Loop
-:: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
-
-setMode :: Mode -> Code a p
-getMode :: (Mode -> Code a p) -> Code a p
-embed :: (Code a p) -> Code a p
-(+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
-fresh :: (Int -> (Code a p)) -> (Code a p)
-freshMTask :: (Int -> (Code a p)) -> (Code a p)
-setCode :: Def -> (Code a p)
-getCode :: (Def -> Code a p) -> (Code a p)
-brac :: (Code a p) -> Code b q
-funBody :: (Code a p) -> Code b q
-codeOp2 :: (Code a p) String (Code b q) -> Code c r
-include :: String -> Code a b
-argList :: [a] -> String | toCode a
-c :: a -> Code b p | toCode a
-indent :: Code a p
-unindent :: Code a p
-nl :: Code a p
-setBinds :: [String] -> Code a p
-addBinds :: String -> Code a p
-getBinds :: ([String] -> Code a p) -> (Code a p)
-
-// ----- driver ----- //
-
-compile :: (Main (Code a p)) -> [String]
-mkset :: [a] -> [a] | Eq a
-newCode :: CODE
-
-// ----- simulation ----- //
-
-eval :: (Main (Eval t p)) -> [String] | toString t
-:: State =
- { tasks :: [(Int, State->State)]
- , store :: [Dyn]
- , dpins :: [(DigitalPin, Bool)]
- , apins :: [(AnalogPin, Int)]
- , serial:: [String]
- , millis:: Int
- }
-
-state0 :: State
-
-//:: TaskSim :== (Int, State->State)
-:: Eval t p = E ((ReadWrite t) State -> (t, State))
-toS2S :: (Eval t p) -> (State->State)
-
-unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
-
-:: ReadWrite t = Rd | Wrt t | Updt (t->t)
-
-(>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
-//(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
-
-rtrn :: t -> Eval t p
-
-yield :: t (Eval s p) -> Eval t Expr
-//yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
-
-instance arith Eval
-instance boolExpr Eval
-instance If Eval p q Expr
-instance IF Eval
-instance var2 Eval
-
-defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
-instance sds Eval
-
-defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
-instance fun Eval x | arg x
-instance mtask Eval x | arg x
-instance mtasks Eval x y | arg x & arg y
-instance setDelay Eval
-
-class toExpr v where toExpr :: (v t p) -> v t Expr
-instance toExpr Eval
-instance toExpr Code
-instance seq Eval
-instance assign Eval
-instance output Eval
-instance pinMode Eval
-instance digitalIO Eval
-instance analogIO Eval
-instance noOp Eval
-
-class arg x :: x -> Int
-instance arg ()
-instance arg (Eval t p) | type t
-instance arg (Eval t p, Eval u q) | type t & type u
-instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v
-instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v
-
-instance + String
-
-readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
-writePinA :: AnalogPin Int State -> State
-
-class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
-instance readPinD DigitalPin
-instance readPinD AnalogPin
-
-class writePinD p :: p Bool State -> State
-instance writePinD DigitalPin
-instance writePinD AnalogPin
-
-// ----- Interactive Simulation ----- //
-
-derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
-
-simulate :: (Main (Eval a p)) -> Task ()
-toView :: State -> StateInterface
-mergeView :: State StateInterface -> State
-:: StateInterface =
- { serialOut :: Display [String]
- , analogPins :: [(AnalogPin, Int)]
- , digitalPins :: [(DigitalPin, Bool)]
- , var2iables :: [DisplayVar]
- , timer :: Int
- , taskCount :: Display Int
- }
-
-toDisplayVar :: Dyn -> DisplayVar
-fromDisplayVar :: DisplayVar Dyn -> Dyn
-:: DisplayVar
- = Variable String
- | INT Int
- | LONG Int
- | Servo Pin Int
- | LCD16x2 String String
- | DisplayVar [String]
-
-step` :: State -> State
-
-class stringQuotes t | type t :: (Code t p) -> Code t p
-instance stringQuotes String
-instance stringQuotes t
-
-derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo
-derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo
-instance toCode ()
-instance == ()
-
// ----- long ----- //
:: Long = L Int // 32 bit on Arduino
-instance toCode Long
instance + Long
instance - Long
instance * Long
// ----- tools ----- //
-class toCode a :: a -> String
-instance toCode Bool
-instance toCode Int
-instance toCode Real
-instance toCode Char
-instance toCode String
-instance toCode DigitalPin
-instance toCode AnalogPin
derive consName DigitalPin, AnalogPin, PinMode
instance == DigitalPin
import iTasks
import gdynamic, gCons, GenEq, StdMisc, StdArray
+import mTaskCode
import mTaskSerial, mTaskLCD
-instance toCode Pin where
- toCode (Digital p) = toCode p
- toCode (Analog p) = toCode p
-
instance pin DigitalPin where
pin p = Digital p
instance isStmt Stmt where isStmt _ = 12
instance == MTask where (==) (MTask x) (MTask y) = x == y
-instance toCode MTask where toCode (MTask x) = "Task " + toCode x
unMain :: (Main x) -> x
unMain m = m.main //{main=x} = x
instance varName Real where varName _ = "vFloat"
instance varName x where varName _ = ""
-argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
-argType f = undef
-
-instance argTypes (Code a p) | showType a where argTypes f = showType
-instance argTypes (Code a p, Code b q) | showType a & showType b where argTypes f = (showType, showType)
-instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c where argTypes f = (showType, showType, showType)
-
-resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
-resType f = showType
-
-var2Type :: (Code t p) -> Code t p | showType t
-var2Type x = showType
-
-resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
-resType2 f = showType2
-
-instance toCode (SV t) where toCode (SV s) = s
-
instance showType2 () where showType2 = SV "void "
instance showType2 Int where showType2 = SV "int "
instance showType2 Char where showType2 = SV "char "
# obj = f (fromJust (fromDyn (store !! n)))
= (obj, {s & store = updateAt n (toDyn obj) store})
-// ----- code generation ----- //
-
-instance arith Code where
- lit a = embed (c a)
- (+.) x y = codeOp2 x " + " y
- (-.) x y = codeOp2 x " - " y
- (*.) x y = codeOp2 x " * " y
- (/.) x y = codeOp2 x " / " y
-instance boolExpr Code where
- (&.) x y = codeOp2 x " && " y
- (|.) x y = codeOp2 x " || " y
- Not x = embed (brac (c "! " +.+ brac x))
- (==.) x y = codeOp2 x " == " y
- (!=.) x y = codeOp2 x " != " y
- (<.) x y = codeOp2 x " < " y
- (<=.) x y = codeOp2 x " <= " y
- (>.) x y = codeOp2 x " > " y
- (>=.) x y = codeOp2 x " >= " y
-instance If Code Stmt Stmt Stmt where If c t e = IfStmt c t e
-instance If Code e Stmt Stmt where If c t e = IfStmt c t e
-instance If Code Stmt e Stmt where If c t e = IfStmt c t e
-instance If Code x y Expr where If c t e = IfExpr c t e
-IfExpr b t e = embed (brac (b +.+ indent +.+ nl +.+ c " ? " +.+ t +.+ nl +.+ c " : " +.+ e +.+ unindent))
-IfStmt b t e =
- getMode \mode.
- let
- v = varName t
- newMode =
- case mode of
- Return s = Return s
- Assign v = Assign v
- _ = if (v == "") NoReturn (Assign v)
- in
- setMode SubExp +.+
- c "if " +.+ brac b +.+ c " {" +.+
- indent +.+ nl +.+ setMode newMode +.+ t +.+ unindent +.+ nl +.+ c "} else {" +.+
- indent +.+ nl +.+ setMode newMode +.+ e +.+ unindent +.+ nl +.+ c "}"
-instance IF Code where
- IF b t e = IfStmt b t e
- (?) b t =
- getMode \mode.
- c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+
- indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}"
-
-instance sds Code where
- sds f = // defCode f
- {main = fresh \n.
- let name = "sds"+toCode n
- (v In body) = f (C (var name))
- in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
- ";\n") +.+ setCode Setup +.+ unMain body}
- con f = defCode f
-
-defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
-defCode f =
- {main = fresh \n.
- let name = "sds"+toCode n
- (v In body) = f (C (var name))
- in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
- ";\n") +.+ setCode Setup +.+ unMain body}
-
-var :: String (ReadWrite (Code v q)) CODE -> CODE
-var sds Rd s = unC (embed (c sds)) Rd s
-var sds (Wrt v) s = unC (embed (c ("(" + sds + " = ") +.+ v +.+ c ")")) Rd s
-
-instance assign Code where
- (=.) (C v) e = embed (setMode SubExp +.+ C \rw c.v (Wrt (toExpr e)) c)
-instance seq Code where
- (>>=.) x f =
- getMode \mode. fresh \n. let v = "b" + toCode n in
- addBinds v +.+ var2Type x +.+ c (v + ";") +.+ nl +.+
- setMode (Assign v) +.+ x +.+ nl +.+ setMode mode +.+ f (embed (c v))
- (:.) x y = getMode \mode. setMode NoReturn +.+ embed x +.+ nl +.+ setMode mode +.+ y
-instance step` Code where
- (>>*.) x f =
- getMode \mode. fresh \n.
- let v = "s" + toCode n in
- c "while(true) {" +.+ indent +.+ nl +.+
- var2Type x +.+ c (v + ";") +.+ nl +.+
- setMode (Assign v) +.+ x +.+ nl +.+
- setMode mode +.+ codeSteps (f (c v)) +.+
- unindent +.+ nl +.+ c "}"
-codeSteps :: [Step Code t] -> Code u p
-codeSteps [] = C \rw c.c
-codeSteps [Cond b e:x] =
- getMode \mode. setMode SubExp +.+
- c "if (" +.+ b +.+ c ") {" +.+ indent +.+ nl +.+
- setMode mode +.+ e +.+
- optBreak mode +.+ unindent +.+ nl +.+ c "}" +.+ nl +.+ setMode mode +.+ codeSteps x
-codeSteps [Ever e:x] =
- getMode \mode. e +.+ optBreak mode
-
-optBreak :: Mode -> Code u p
-optBreak mode =
- case mode of
- Return s = C \rw c.c
- _ = nl +.+ c "break;"
-
-instance setDelay Code where
- setDelay d t = embed (c "setDelay" +.+ brac (t +.+ c ", " +.+ d))
-instance mtask Code a | taskImp2 a & types a where
- task f =
- {main = freshMTask \n.
- let (app, a) = taskImp2 n types
- (b In main) = f (\d a.app (long d) a)
- in codeMTaskBody (loopCode n (b a)) (unMain main)}
-instance mtasks Code a b | taskImp2 a & types a & taskImp2 b & types b where
- tasks f =
- {main =
- freshMTask \t1.
- freshMTask \t2.
- let (app1, a1) = taskImp2 t1 types
- (app2, a2) = taskImp2 t2 types
- ((b1, b2) In main) = f ((\d a.app1 (long d) a),(\d a.app2 (long d) a))
- in codeMTaskBody (loopCode t2 (b2 a2)) (codeMTaskBody (loopCode t1 (b1 a1)) (unMain main))}
-loopCode :: Int (Code a b) -> Code c d
-loopCode n b =
- nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
- setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+
- unindent +.+ nl +.+ c "} "
-
-class taskImp2 a :: Int a -> ((Code Long p) a->Code MTask Expr, a) | /*long Code delay &*/ isExpr p
-instance taskImp2 () where
- taskImp2 n () = (app, ())
- where app d a = setBinds [] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ d +.+ c ")")
-instance taskImp2 (Code t p) where
- taskImp2 n type1 = (app, ta)
- where
- n0 = "t0p->a[0]"
- ta = c n0 +.+ type1
- app d a =
- setBinds [n0] +.+ embed (c "newTask(" +.+
- c n +.+ c ", " +.+
- d +.+ c ", " +.+
- a +.+ c ")")
-instance taskImp2 (Code a p, Code b q) where
- taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
- n0 = "t0p->a[0]"
- n1 = "t0p->a[1]"
- ta1 = c n0 +.+ type1
- ta2 = c n1 +.+ type2
- app d (a1, a2) =
- setBinds [n0,n1] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ long d +.+
- c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
-instance taskImp2 (Code a p, Code b q, Code c r) where
- taskImp2 n (type1, type2, type3) = (app, (ta1, ta2, ta3))
- where
- n0 = "t0p->a[0]"
- n1 = "t0p->a[1]"
- n2 = "t0p->a[2]"
- ta1 = c n0 +.+ type1
- ta2 = c n1 +.+ type2
- ta3 = c n2 +.+ type3
- app d (a1, a2, a3) =
- setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+
- c n +.+ c ", " +.+
- d +.+ c ", " +.+
- a1 +.+ c ", " +.+
- a2 +.+ c ", " +.+
- a3 +.+ c ", 0)")
-instance taskImp2 (Code a p, Code b q, Code c r, Code d s) where
- taskImp2 n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
- where
- n0 = "t0p->a[0]"
- n1 = "t0p->a[1]"
- n2 = "t0p->a[2]"
- n3 = "t0p->a[3]"
- ta1 = c n0 +.+ type1
- ta2 = c n1 +.+ type2
- ta3 = c n2 +.+ type3
- ta4 = c n3 +.+ type4
- app d (a1, a2, a3, a4) =
- setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+
- c n +.+ c ", " +.+
- d +.+ c ", " +.+
- a1 +.+ c ", " +.+
- a2 +.+ c ", " +.+
- a3 +.+ c ", " +.+
- a4 +.+ c ")")
-
-class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
-instance taskImp () where
- taskImp n () = (app, ())
- where app i a = embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+ c ")")
-instance taskImp (Code t p) where
- taskImp n type1 = (app, ta)
- where
- ta = c "t0p->a[0]" +.+ type1
- app i a =
- embed (c "newTask(" +.+
- c n +.+ c ", " +.+
- c i +.+ c ", " +.+
- a +.+ c ")")
-instance taskImp (Code a p, Code b q) where
- taskImp n (type1, type2) = (app, (ta1, ta2)) where
- ta1 = c "t0p->a[0]" +.+ type1
- ta2 = c "t0p->a[1]" +.+ type2
- app i (a1, a2) =
- embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+
- c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
-instance taskImp (Code a p, Code b q, Code c r) where
- taskImp n (type1, type2, type3) = (app, (ta1, ta2, ta3))
- where
- ta1 = c "t0p->a[0]" +.+ type1
- ta2 = c "t0p->a[1]" +.+ type2
- ta3 = c "t0p->a[2]" +.+ type3
- app i (a1, a2, a3) =
- embed (c "newTask(" +.+
- c n +.+ c ", " +.+
- c i +.+ c ", " +.+
- a1 +.+ c ", " +.+
- a2 +.+ c ", " +.+
- a3 +.+ c ")")
-instance taskImp (Code a p, Code b q, Code c r, Code d s) where
- taskImp n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
- where
- ta1 = c "t0p->a[0]" +.+ type1
- ta2 = c "t0p->a[1]" +.+ type2
- ta3 = c "t0p->a[2]" +.+ type3
- ta4 = c "t0p->a[3]" +.+ type4
- app i (a1, a2, a3, a4) =
- embed (c "newTask(" +.+
- c n +.+ c ", " +.+
- c i +.+ c ", " +.+
- a1 +.+ c ", " +.+
- a2 +.+ c ", " +.+
- a3 +.+ c ", " +.+
- a4 +.+ c ")")
-
-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
-tasksMain i j f =
- { main =
- freshMTask \n. freshMTask \m.
- let
- (app1, a1) = taskImp n types
- (app2, a2) = taskImp m types
- ((b1, b2) In {main = e}) = f (app1 i, app2 j)
- in
- codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
- }
-class types a :: a
-instance types () where types = ()
-instance types (Code a p) | typeSelector a & isExpr p
- where types = typeSelector
-instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
- where types = (typeSelector, typeSelector)
-instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
- where types = (typeSelector, typeSelector, typeSelector)
-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
- where types = (typeSelector, typeSelector, typeSelector, typeSelector)
-
-codeMTaskBody :: (Code v w) (Code c d) -> Code e f
-codeMTaskBody loop e =
- getMode \mode.
- setMode NoReturn +.+
- setCode Loop +.+ loop +.+
- setMode mode +.+ setCode Setup +.+ embed e
-instance fun Code () where
- fun f =
- {main = getMode \mode. fresh \n.
- let fname = c ("f" + toCode n)
- (g In {main=e}) = f (\x.embed (fname +.+ c " ()"))
- in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " () " +.+
- funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [] +.+ g ()) +.+ setCode Setup +.+ setMode mode +.+ e
- }
-instance fun Code (Code t p) | type, showType t & isExpr p where
- fun f =
- {main =
- getMode \mode. fresh \n.
- let fname = c ("f" + toCode n)
- aname = "a" + toCode n
- (g In {main=e}) = f (\x.embed (fname +.+ c " " +.+ brac x))
- in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
- brac (argTypes f +.+ c (" " + aname)) +.+
- funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [aname] +.+ g (embed (c aname))) +.+ setCode Setup +.+ setMode mode +.+ e
- }
-instance fun Code (Code a p, Code b q) | showType a & showType b where
- fun f =
- {main =
- getMode \mode. fresh \n.
- let fname = c ("f" + toCode n + " ")
- aname = "a" + toCode n //+ " "
- bname = "b" + toCode n //+ " "
- (atype, btype) = argTypes f
- (g In main)
- = f (\(x,y).embed (fname +.+ codeOp2 x ", " y))
- in setCode Fun +.+ nl +.+ resType f +.+ fname +.+
- codeOp2 (atype +.+ c aname) ", " (btype +.+ c bname) +.+
- funBody (setMode (Return (toCode (resType2 f))) +.+
- setBinds [aname,bname] +.+ g (embed (c aname), embed (c bname))) +.+
- setCode Setup +.+ setMode mode +.+ unMain main
- }
-instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
- fun f =
- {main =
- getMode \mode. fresh \n.
- let fname = c ("f" + toCode n)
- aname = "a" + toCode n
- bname = "b" + toCode n
- cname = "c" + toCode n
- (atype,btype,ctype) = argTypes f
- (g In {main=e}) = f (\(x,y,z).embed (fname +.+ c " " +.+ brac (x +.+ c ", " +.+ y +.+ c ", " +.+ z)))
- in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
- brac (atype +.+ c (" " + aname + ", ") +.+ btype +.+ c (" " + bname + ", ") +.+ ctype +.+ c (" " + cname)) +.+
- funBody (setMode (Return (toCode (resType2 f))) +.+
- setBinds [aname,bname,cname] +.+ g (embed (c aname), embed (c bname), embed (c cname))) +.+ setCode Setup +.+ setMode mode +.+ e
- }
-instance output Code where
- output x = embed (c "Serial.println(" +.+ x +.+ c ")")
-instance pinMode Code where
- pinmode p m = embed (c ("pinMode(" + toCode p + ", " + consName{|*|} m + ")"))
-instance digitalIO Code where
- digitalRead p = embed (c ("digitalRead(" + toCode p + ")"))
- digitalWrite p b = embed (c ("digitalWrite(" + toCode p + ", ") +.+ b +.+ c ")")
-instance dIO Code where
- dIO p = C (ioc p) where
- ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin, readPinD p
- ioc p Rd s = f Rd s where (C f) = embed (c ("digitalRead(" + toCode p + ")"))
- ioc p (Wrt v) s = f Rd s where (C f) = embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")
-instance aIO Code where
- aIO p = C (ioc p) where
- ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin p
- ioc p Rd s = unC (embed (c ("analogRead(" + toCode p + ")"))) Rd s
- ioc p (Wrt v) s = unC (embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")) Rd s
-instance analogIO Code where
- analogRead p = embed (c ("analogRead(" + toCode p + ")"))
- analogWrite p b = embed (c ("analogWrite(" + toCode p + ", ") +.+ b +.+ c ")")
-instance noOp Code where noOp = C \rw c.c
-
-:: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
-:: CODE =
- { fresh :: Int
- , freshMTask :: Int
- , funs :: [String]
- , ifuns :: Int
- , vars :: [String]
- , ivars :: Int
- , setup :: [String]
- , isetup :: Int
- , loop :: [String]
- , iloop :: Int
- , includes :: [String]
- , def :: Def
- , mode :: Mode
- , binds :: [String]
- }
-
-unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
-unC (C f) = f
-
-:: Def = Var | Fun | Setup | Loop
-:: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
-
-setMode :: Mode -> Code a p
-setMode m = C \rw c.{c & mode = m}
-
-getMode :: (Mode -> Code a p) -> Code a p
-getMode f = C \rw c.unC (f c.mode) rw c
-
-embed :: (Code a p) -> Code a p
-embed e =
- getMode \m. case m of
- NoReturn = setMode SubExp +.+ e +.+ c ";"
- Return "void" = setMode SubExp +.+ e +.+ c ";"
- Return t = c "return " +.+ setMode SubExp +.+ e +.+ c ";"
- Assign s = c (s + " = ") +.+ setMode SubExp +.+ e +.+ c ";"
- SubExp = e
- _ = abort "\n\nembed: unknown mode.\n"
-
-(+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
-(+.+) (C f) (C g) = C \rw c.g Rd (f Rd c)
-
-fresh :: (Int -> (Code a p)) -> (Code a p)
-fresh f = C \rw c.unC (f c.fresh) rw {c & fresh = c.fresh + 1}
-
-freshMTask :: (Int -> (Code a p)) -> (Code a p)
-freshMTask f = C \rw c.unC (f c.freshMTask) rw {c & freshMTask = c.freshMTask + 1}
-
-setCode :: Def -> (Code a p)
-setCode d = C \rw c.{c & def = d}
-
-getCode :: (Def -> Code a p) -> (Code a p)
-getCode f = C \rw c.unC (f c.def) rw c
-
-brac :: (Code a p) -> Code b q
-brac e = c "(" +.+ e +.+ c ")"
-
-funBody :: (Code a p) -> Code b q
-funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl
-
-codeOp2 :: (Code a p) String (Code b q) -> Code c r
-codeOp2 x n y = embed (brac (x +.+ c n +.+ y))
-
-include :: String -> Code a b
-include lib = C \rw c.{c & includes = [lib:c.includes]}
-
-argList :: [a] -> String | toCode a
-argList [a] = toCode a
-argList [a:x] = toCode a + "," + argList x
-argList [] = ""
-
-c :: a -> Code b p | toCode a
-c a = C \rw c.case c.def of
- Fun = {c & funs = [toCode a: c.funs]}
- Var = {c & vars = [toCode a: c.vars]}
- Setup = {c & setup = [toCode a: c.setup]}
- Loop = {c & loop = [toCode a: c.loop]}
-
-indent :: Code a p
-indent =
- C \rw c.case c.def of
- Fun = {c & ifuns = inc c.ifuns}
- Var = {c & ivars = inc c.ivars}
- Setup = {c & isetup = inc c.isetup}
- Loop = {c & iloop = inc c.iloop}
-
-unindent :: Code a p
-unindent =
- C \rw c.case c.def of
- Fun = {c & ifuns = dec c.ifuns}
- Var = {c & ivars = dec c.ivars}
- Setup = {c & isetup = dec c.isetup}
- Loop = {c & iloop = dec c.iloop}
-where
- dec n | n > 1
- = n - 1
- = 0
-
-nl :: Code a p
-nl =
- C \rw c.case c.def of
- Fun = {c & funs = [str c.ifuns: c.funs]}
- Var = {c & vars = [str c.ivars: c.vars]}
- Setup = {c & setup = [str c.isetup: c.setup]}
- Loop = {c & loop = [str c.iloop: c.loop]}
-where
- str n = toString ['\n':repeatn (tabSize * n) ' ']
-
-setBinds :: [String] -> Code a p
-setBinds list = C \rw c.{c & binds = list}
-
-addBinds :: String -> Code a p
-addBinds name = C \rw c.{c & binds = [name:c.binds]}
-
-getBinds :: ([String] -> Code a p) -> (Code a p)
-getBinds f = C \rw c.unC (f c.binds) rw c
-
-// ----- driver ----- //
-
-compile :: (Main (Code a p)) -> [String]
-compile {main=(C f)} =
- ["/*\n"
- ," Generated code for Arduino\n"
- ," Pieter Koopman, pieter@cs.ru.nl\n"
- ,"*/\n"
- ,"\n"
- ,"#define MAX_ARGS 4\n"
- ,"#define MAX_TASKS 20\n"
- ,"#define MAX_TASK_NO MAX_TASKS - 1\n"
- ,"#define NEXT_TASK(n) ((n) == MAX_TASK_NO ? 0 : (n) + 1)\n"
- ,"\n"
- ,"typedef union Arg {\n"
- ," int i;\n"
- ," bool b;\n"
- ," char c;\n"
-// ," float f;\n" // requires 4 bytes
- ," word w;\n"
- ,"} ARG;\n"
- ,"\n"
- ,"typedef struct Task {\n"
- ," byte id;\n"
- ," long wait;\n"
- ," ARG a[MAX_ARGS];\n"
- ,"} TASK;\n"
- ,"\n"
- ] ++
- foldr (\lib c.["#include <":lib:".h>\n":c]) [] (mkset c.includes) ++
- ["\n// --- variables ---\n"
- ,"TASK tasks[MAX_TASKS];\n"
- ,"byte t0 = 0, tc = 0, tn = 0;\n"
- ,"long delta;\n"
- ,"\n"
- ,"int vInt;\n"
- ,"bool vBool;\n"
- ,"char vChar;\n"
- ,"float vFloat;\n"
- ,"unsigned long time = 0;\n"
- :reverse c.vars
- ] ++
- ["\n// --- functions ---\n"
- ,"byte newTask(byte id, long wait, word a0 = 0, word a1 = 0, word a2 = 0, word a3 = 0) {\n"
- ," TASK *tnp = &tasks[tn];\n"
- ," tnp->id = id;\n"
- ," tnp->wait = wait;\n"
- ," tnp->a[0].w = a0;\n"
- ," tnp->a[1].w = a1;\n"
- ," tnp->a[2].w = a2;\n"
- ," tnp->a[3].w = a3;\n"
- ," byte r = tn;\n"
- ," tn = NEXT_TASK(tn);\n"
- ," return r;\n"
- ,"}\n"
- ,"\n"
- ,"byte setDelay(byte t, long d) {\n"
- ," tasks[t].wait = d;\n"
- ," return t;\n"
- ,"}\n"
- ,"boolean pressed(int b) {\n"
- ," pinMode(A0, INPUT);\n"
- ," int a0 = analogRead(A0);\n"
- ," switch (b) {\n"
- ," case 0: return a0 < ",toString RightBound,"; // right\n"
- ," case 1: return ",toString RightBound," < a0 && a0 < ",toString UpBound,"; // up\n"
- ," case 2: return ",toString UpBound," < a0 && a0 < ",toString DownBound,";// down\n"
- ," case 3: return ",toString DownBound," < a0 && a0 < ",toString LeftBound,";//left\n"
- ," case 4: return ",toString LeftBound," < a0 && a0 < ",toString SelectBound,";//select\n"
- ," default: return ",toString SelectBound," < a0; //no button\n"
- ," }\n"
- ,"}\n"
- ,"boolean pWrite (int pin, boolean b) {\n"
- ," pinMode(pin, OUTPUT);\n"
- ," digitalWrite(pin, b);\n"
- ," return b;\n"
- ,"}\n"
- ,"int pWrite (int pin, int i) {\n"
- ," pinMode(pin, OUTPUT);\n"
- ," analogWrite(pin, i);\n"
- ," return i;\n"
- ,"}\n"
- :reverse c.funs
- ] ++
- ["\n// --- setup --- \n"
- ,"void setup () {\n"
- ," Serial.begin(9600);\n"
- ," "
- :reverse c.setup
- ] ++
- ["\n}\n"
- ,"\n// --- loop --- \n"
- ,"void loop () {\n"
- ," if (t0 != tn) {\n"
- ," if (t0 == tc) {\n"
- ," unsigned long time2 = millis();\n"
- ," delta = time2 - time;\n"
- ," time = time2;\n"
- ," tc = tn;\n"
- ," };\n"
- ," TASK* t0p = &tasks[t0];\n"
- ," t0p->wait -= delta;\n"
- ," if (t0p->wait > 0L) {\n"
- ," newTask(t0p->id, t0p->wait, t0p->a[0].w, t0p->a[1].w, t0p->a[2].w, t0p->a[3].w);\n"
- ," } else {\n"
- ," switch (t0p->id) {"
- :reverse c.loop
- ] ++
- ["\n"
- ," default:\n"
- ," Serial.println(\"stopped\");\n"
- ," t0 = tn; // no known task: force termination of tasks\n"
- ," return;\n"
- ," };\n"
- ," }\n"
- ," t0 = NEXT_TASK(t0);\n"
- ," }\n"
- ,"}\n"
- ]
-where c = f Rd newCode
-
-mkset :: [a] -> [a] | Eq a
-mkset [a:x] = [a:mkset (filter ((<>) a) x)]
-mkset [] = []
-
-newCode :: CODE
-newCode =
- { fresh = 0
- , freshMTask = 0
- , funs = []
- , ifuns = 0
- , vars = []
- , ivars = 0
- , setup = []
- , isetup = 1
- , loop = []
- , iloop = 4
- , includes = []
- , def = Setup
- , mode = NoReturn
- , binds = []
- }
-
-// ----- simulation ----- //
-
-eval :: (Main (Eval t p)) -> [String] | toString t
-eval {main=(E f)} = [toString (fst (f Rd state0))]
-
-:: State =
- { tasks :: [(Int, State->State)]
- , store :: [Dyn]
- , dpins :: [(DigitalPin, Bool)]
- , apins :: [(AnalogPin, Int)]
- , serial:: [String]
- , millis:: Int
- }
-
-state0 :: State
-state0 = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}
-
-//:: TaskSim :== (Int, State->State)
-:: Eval t p = E ((ReadWrite t) State -> (t, State))
-toS2S :: (Eval t p) -> (State->State)
-toS2S (E f) = \state.snd (f Rd state)
-
-unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
-unEval (E f) = f
-
-:: ReadWrite t = Rd | Wrt t | Updt (t->t)
-
-(>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
-//(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
-(>>==) (E f) g = E\r s.let (a,t) = f Rd s in unEval (g a) Rd t
-
-rtrn :: t -> Eval t p
-rtrn a = E \r s -> (a, s)
-
-yield :: t (Eval s p) -> Eval t Expr
-//yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
-yield a (E f) = E \r s.(a,snd (f Rd s))
-
-instance arith Eval where
- lit a = rtrn a
- (+.) x y = x >>== \a. y >>== \b. rtrn (a + b)
- (-.) x y = x >>== \a. y >>== \b. rtrn (a - b)
- (*.) x y = x >>== \a. y >>== \b. rtrn (a * b)
- (/.) x y = x >>== \a. y >>== \b. rtrn (a / b)
-instance boolExpr Eval where
- (&.) x y = x >>== \a. if a y (rtrn False) // lazy AND
- (|.) x y = x >>== \a. if a (rtrn True) (y >>== rtrn)
- Not x = x >>== \a. rtrn (not a)
- (==.) x y = x >>== \a. y >>== \b. rtrn (a == b)
- (!=.) x y = x >>== \a. y >>== \b. rtrn (a <> b)
- (<.) x y = x >>== \a. y >>== \b. rtrn (a < b)
- (>.) x y = x >>== \a. y >>== \b. rtrn (a > b)
- (<=.) x y = x >>== \a. y >>== \b. rtrn (a <= b)
- (>=.) x y = x >>== \a. y >>== \b. rtrn (a >= b)
-instance If Eval p q Expr where
- If c t e = c >>== \b.if b (toExpr t) (toExpr e)
-instance IF Eval where
- IF c t e = c >>== \b.if b (yield () t) (yield () e)
- (?) c t = c >>== \b.if b (yield () t) (rtrn ())
-instance var2 Eval where
- var2 v f = defEval2 v f
- con2 v f = defEval2 v f
-
-defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
-defEval2 v f =
- {main = E (\r s.(length s.store
- , {s & store = s.store ++ [toDyn v]}))
- >>== \n.unMain (f (E (read` n)))}
-instance sds Eval where
- sds f = defEval f
- con f = defEval f
-
-defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
-defEval f =
- {main = E \r s.let (v In g) = f (E (read` (length s.store))) in
- unEval (unMain g) r {s & store = s.store ++ [toDyn v]}}
-instance fun Eval x | arg x where
- fun f = e where (g In e) = f (\a.toExpr (g a))
-instance mtask Eval x | arg x where
- task f = e where
- (t In e) = f (\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
-instance mtasks Eval x y | arg x & arg y where
- tasks f = e where
- ((t,u) In e) =
- f ((\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
- ,(\d b.long d >>== \(L j).E\r s.(MTask (length s.tasks),{s&tasks=[(j,toS2S (u b)):s.tasks]}))
- )
-instance setDelay Eval where
- setDelay d t = d >>== \(L x). t >>== \(MTask n).E \r s.(MTask n,{s & tasks = updateAt n (x,snd (s.tasks !! n)) s.tasks})
-class toExpr v where toExpr :: (v t p) -> v t Expr
-instance toExpr Eval where toExpr (E f) = E f
-instance toExpr Code where toExpr (C f) = C f
-instance seq Eval where
- (>>=.) x f = x >>== f o rtrn
- (:.) x y = x >>== \_. y
-instance assign Eval where
- (=.) (E v) e = e >>== \a. E \r s.v (Wrt a) s
-instance output Eval where
- output x = x >>== \a.E \r s.((),{s & serial = s.serial ++ [toCode a]})
-instance pinMode Eval where
- pinmode p m = rtrn ()
-instance digitalIO Eval where
- digitalRead p = E \rw s=:{dpins, apins}.(readPinD p dpins apins, s)
- digitalWrite p b = b >>== \a. E \rw s.(a, writePinD p a s)
-instance analogIO Eval where
- analogRead p = E \rw s=:{apins}. (readPinA p apins, s)
- analogWrite p b = b >>== \a. E \rw s.(a, writePinA p a s)
-instance noOp Eval where noOp = E \r s.(undef,s)
-
-class arg x :: x -> Int
-instance arg () where arg _ = 0
-instance arg (Eval t p) | type t where arg _ = 1
-instance arg (Eval t p, Eval u q) | type t & type u where arg _ = 2
-instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v where arg _ = 3
-instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v where arg _ = 4
-
-instance + String where (+) x y = x +++ y
-
-readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
-readPinA p lista
- = case [b \\ (q, b) <- lista | p == q] of
- [] = 0
- [a:x] = a
-
-writePinA :: AnalogPin Int State -> State
-writePinA p x s
- = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}
-
-class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
-instance readPinD DigitalPin where
- readPinD p listd lista
- = case [b \\ (q,b) <- listd | p == q] of
- [] = False
- [a:x] = a
-instance readPinD AnalogPin where
- readPinD p listd lista
- = case [b \\ (q,b) <- lista | p == q] of
- [] = False
- [a:x] = a <> 0
-class writePinD p :: p Bool State -> State
-instance writePinD DigitalPin where
- writePinD p b s=:{dpins} = {s & dpins = [(p, b):[(q, c) \\ (q, c) <- dpins | p <> q]]}
-instance writePinD AnalogPin where
- writePinD p b s=:{apins} = {s & apins = [(p, if b 1 0):[(q, c) \\ (q, c) <- apins | p <> q]]}
-
-
-// ----- Interactive Simulation ----- //
-
-derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
-
-simulate :: (Main (Eval a p)) -> Task ()
-simulate {main=(E f)} = setup state0 where
- setup s =
- updateInformation "State" [] (toView s)
- >>* [ OnAction ActionFinish (always shutDown)
- , OnAction (Action "setup" []) (hasValue
- (\si.simloop (snd (f Rd (mergeView s si)))))
- ]
- simloop s =
- updateInformation "State" [] (toView s)
- >>* [ OnAction ActionFinish (always shutDown)
- , OnAction (Action "clear serial" []) (always (simloop {s & serial = []}))
- , OnAction ActionNew (always (setup state0))
- : if (isEmpty s.tasks)
- []
- [OnAction (Action "loop" []) (hasValue
- \si.simloop (step` (mergeView s si)))
- ]
- ]
-
-toView :: State -> StateInterface
-toView s =
- { serialOut = Display s.serial
- , analogPins = s.apins
- , digitalPins = s.dpins
- , var2iables = map toDisplayVar s.store
- , timer = s.millis
- , taskCount = Display (length s.tasks)
- }
-
-mergeView :: State StateInterface -> State
-mergeView s si =
- { s
- & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
- , dpins = si.digitalPins
- , apins = si.analogPins
-// , serial = si.serialOut
- , millis = si.timer
- }
-
-:: StateInterface =
- { serialOut :: Display [String]
- , analogPins :: [(AnalogPin, Int)]
- , digitalPins :: [(DigitalPin, Bool)]
- , var2iables :: [DisplayVar]
- , timer :: Int
- , taskCount :: Display Int
- }
-
-toDisplayVar :: Dyn -> DisplayVar
-toDisplayVar (Dyn [v])
- # i = toInt v
- | toString i == v
- = INT i
- = Variable v
-toDisplayVar (Dyn ["L",v]) = LONG (toInt v)
-toDisplayVar (Dyn ["Servo",pinKind,pin,pos]) = Servo (fromJust (fromDyn (Dyn [pinKind,pin]))) (toInt pos)
-toDisplayVar (Dyn ["LCD",_,_,_,_,_,l1,_,l2,_]) = LCD16x2 l1 l2
-toDisplayVar (Dyn l) = DisplayVar l
-
-fromDisplayVar :: DisplayVar Dyn -> Dyn
-fromDisplayVar (Variable v) dyn = Dyn [v]
-fromDisplayVar (INT v) dyn = Dyn [toString v]
-fromDisplayVar (LONG v) dyn = Dyn ["L",toString v]
-fromDisplayVar (Servo pin pos) dyn = Dyn (["Servo":let (Dyn p) = toDyn pin in p] ++ [toString pos])
-fromDisplayVar (LCD16x2 l1 l2) (Dyn list) = Dyn (updateAt 6 l1 (updateAt 8 l2 list))
-fromDisplayVar (DisplayVar l) dyn = Dyn l
-
-:: DisplayVar
- = Variable String
- | INT Int
- | LONG Int
- | Servo Pin Int
- | LCD16x2 String String
- | DisplayVar [String]
-
-
-step` :: State -> State
-step` s =
- foldr appTask {s & millis = s.millis + delta, tasks = []}
- [(w - delta, f) \\ (w, f) <- s.tasks]
-where delta = foldl1 min (map fst s.tasks) // smallest wait
-
-appTask t=:(w,f) s | w <= 0
- = f s
- = {s & tasks = [t:s.tasks]}
-
-foldl1 op [a:x] = foldl op a x
-foldr1 op l :== foldr l
- where
- foldr [a] = a
- foldr [a:x] = op a (foldr x)
-
-class stringQuotes t | type t :: (Code t p) -> Code t p
-instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\""
-instance stringQuotes t where stringQuotes x = x
-
-
-derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
-derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
-instance toCode () where toCode _ = ""
-instance == () where (==) _ _ = True
-
// ----- long ----- //
:: Long = L Int // 32 bit on Arduino
-instance toCode Long where toCode (L i) = toCode i + "L"
instance + Long where (+) (L x) (L y) = L (x + y)
instance - Long where (-) (L x) (L y) = L (x + y)
instance * Long where (*) (L x) (L y) = L (x + y)
// ----- tools ----- //
-class toCode a :: a -> String
-instance toCode Bool where toCode b = if b "true" "false"
-instance toCode Int where toCode a = toString a
-instance toCode Real where toCode a = toString a
-instance toCode Char where
- toCode '\0' = "'\\0'"
- toCode '\n' = "'\\n'"
- toCode '\\' = "\\"
- toCode a = "'" + toString a + "'"
-instance toCode String where toCode s = s
-instance toCode DigitalPin where toCode x = s%(1, size s - 1) where s = consName{|*|} x
-instance toCode AnalogPin where toCode x = consName{|*|} x
-derive consName DigitalPin, AnalogPin, PinMode
-
instance == DigitalPin where (==) x y = x === y
instance == AnalogPin where (==) x y = x === y
+derive consName DigitalPin, AnalogPin, PinMode
derive consIndex DigitalPin, AnalogPin
tab =: toString (repeatn tabSize ' ')
--- /dev/null
+definition module mTaskCode
+
+import mTask
+
+instance toCode Pin
+instance toCode MTask
+instance toCode ()
+instance toCode Long
+
+class toCode a :: a -> String
+instance toCode Bool
+instance toCode Int
+instance toCode Real
+instance toCode Char
+instance toCode String
+instance toCode DigitalPin
+instance toCode AnalogPin
+
+argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
+
+class argTypes t :: ((t->Code b Expr)->In (t->Code b2 q) (Main (Code c s))) -> t
+instance argTypes (Code a p) | showType a
+instance argTypes (Code a p, Code b q) | showType a & showType b
+instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c
+
+instance toCode (SV t)
+
+instance arith Code
+instance boolExpr Code
+instance If Code Stmt Stmt Stmt
+instance If Code e Stmt Stmt
+instance If Code Stmt e Stmt
+instance If Code x y Expr
+instance IF Code
+instance sds Code
+
+defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
+
+var :: String (ReadWrite (Code v q)) CODE -> CODE
+
+instance assign Code
+instance seq Code
+instance step` Code
+codeSteps :: [Step Code t] -> Code u p
+optBreak :: Mode -> Code u p
+
+instance setDelay Code
+instance mtask Code a | taskImp2 a & types a
+instance mtasks Code a b | taskImp2 a & types a & taskImp2 b & types b
+
+loopCode :: Int (Code a b) -> Code c d
+
+class taskImp2 a :: Int a -> ((Code Long p) a->Code MTask Expr, a) | /*long Code delay &*/ isExpr p
+instance taskImp2 ()
+instance taskImp2 (Code t p)
+instance taskImp2 (Code a p, Code b q)
+instance taskImp2 (Code a p, Code b q, Code c r)
+instance taskImp2 (Code a p, Code b q, Code c r, Code d s)
+
+class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
+instance taskImp ()
+instance taskImp (Code t p)
+instance taskImp (Code a p, Code b q)
+instance taskImp (Code a p, Code b q, Code c r)
+instance taskImp (Code a p, Code b q, Code c r, Code d s)
+
+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
+class types a :: a
+instance types ()
+instance types (Code a p) | typeSelector a & isExpr p
+instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
+instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
+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
+
+codeMTaskBody :: (Code v w) (Code c d) -> Code e f
+instance fun Code ()
+instance fun Code (Code t p) | type, showType t & isExpr p
+instance fun Code (Code a p, Code b q) | showType a & showType b
+instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c
+instance output Code
+instance pinMode Code
+instance digitalIO Code
+instance dIO Code
+instance aIO Code
+instance analogIO Code
+instance noOp Code
+
+:: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
+:: CODE =
+ { fresh :: Int
+ , freshMTask :: Int
+ , funs :: [String]
+ , ifuns :: Int
+ , vars :: [String]
+ , ivars :: Int
+ , setup :: [String]
+ , isetup :: Int
+ , loop :: [String]
+ , iloop :: Int
+ , includes :: [String]
+ , def :: Def
+ , mode :: Mode
+ , binds :: [String]
+ }
+
+unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
+
+:: Def = Var | Fun | Setup | Loop
+:: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
+
+setMode :: Mode -> Code a p
+getMode :: (Mode -> Code a p) -> Code a p
+embed :: (Code a p) -> Code a p
+(+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
+fresh :: (Int -> (Code a p)) -> (Code a p)
+freshMTask :: (Int -> (Code a p)) -> (Code a p)
+setCode :: Def -> (Code a p)
+getCode :: (Def -> Code a p) -> (Code a p)
+brac :: (Code a p) -> Code b q
+funBody :: (Code a p) -> Code b q
+codeOp2 :: (Code a p) String (Code b q) -> Code c r
+include :: String -> Code a b
+argList :: [a] -> String | toCode a
+c :: a -> Code b p | toCode a
+indent :: Code a p
+unindent :: Code a p
+nl :: Code a p
+setBinds :: [String] -> Code a p
+addBinds :: String -> Code a p
+getBinds :: ([String] -> Code a p) -> (Code a p)
+
+// ----- driver ----- //
+
+compile :: (Main (Code a p)) -> [String]
+mkset :: [a] -> [a] | Eq a
+newCode :: CODE
--- /dev/null
+implementation module mTaskCode
+
+import iTasks
+import gdynamic, gCons, GenEq, StdMisc, StdArray
+import mTask
+
+instance toCode MTask where toCode (MTask x) = "Task " + toCode x
+
+argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
+argType f = undef
+
+instance argTypes (Code a p) | showType a where argTypes f = showType
+instance argTypes (Code a p, Code b q) | showType a & showType b where argTypes f = (showType, showType)
+instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c where argTypes f = (showType, showType, showType)
+
+resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
+resType f = showType
+
+var2Type :: (Code t p) -> Code t p | showType t
+var2Type x = showType
+
+resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
+resType2 f = showType2
+
+instance toCode (SV t) where toCode (SV s) = s
+
+instance arith Code where
+ lit a = embed (c a)
+ (+.) x y = codeOp2 x " + " y
+ (-.) x y = codeOp2 x " - " y
+ (*.) x y = codeOp2 x " * " y
+ (/.) x y = codeOp2 x " / " y
+instance boolExpr Code where
+ (&.) x y = codeOp2 x " && " y
+ (|.) x y = codeOp2 x " || " y
+ Not x = embed (brac (c "! " +.+ brac x))
+ (==.) x y = codeOp2 x " == " y
+ (!=.) x y = codeOp2 x " != " y
+ (<.) x y = codeOp2 x " < " y
+ (<=.) x y = codeOp2 x " <= " y
+ (>.) x y = codeOp2 x " > " y
+ (>=.) x y = codeOp2 x " >= " y
+instance If Code Stmt Stmt Stmt where If c t e = IfStmt c t e
+instance If Code e Stmt Stmt where If c t e = IfStmt c t e
+instance If Code Stmt e Stmt where If c t e = IfStmt c t e
+instance If Code x y Expr where If c t e = IfExpr c t e
+IfExpr b t e = embed (brac (b +.+ indent +.+ nl +.+ c " ? " +.+ t +.+ nl +.+ c " : " +.+ e +.+ unindent))
+IfStmt b t e =
+ getMode \mode.
+ let
+ v = varName t
+ newMode =
+ case mode of
+ Return s = Return s
+ Assign v = Assign v
+ _ = if (v == "") NoReturn (Assign v)
+ in
+ setMode SubExp +.+
+ c "if " +.+ brac b +.+ c " {" +.+
+ indent +.+ nl +.+ setMode newMode +.+ t +.+ unindent +.+ nl +.+ c "} else {" +.+
+ indent +.+ nl +.+ setMode newMode +.+ e +.+ unindent +.+ nl +.+ c "}"
+instance IF Code where
+ IF b t e = IfStmt b t e
+ (?) b t =
+ getMode \mode.
+ c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+
+ indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}"
+
+instance sds Code where
+ sds f = // defCode f
+ {main = fresh \n.
+ let name = "sds"+toCode n
+ (v In body) = f (C (var name))
+ in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
+ ";\n") +.+ setCode Setup +.+ unMain body}
+ con f = defCode f
+
+defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
+defCode f =
+ {main = fresh \n.
+ let name = "sds"+toCode n
+ (v In body) = f (C (var name))
+ in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
+ ";\n") +.+ setCode Setup +.+ unMain body}
+
+var :: String (ReadWrite (Code v q)) CODE -> CODE
+var sds Rd s = unC (embed (c sds)) Rd s
+var sds (Wrt v) s = unC (embed (c ("(" + sds + " = ") +.+ v +.+ c ")")) Rd s
+
+instance assign Code where
+ (=.) (C v) e = embed (setMode SubExp +.+ C \rw c.v (Wrt (toExpr e)) c)
+instance seq Code where
+ (>>=.) x f =
+ getMode \mode. fresh \n. let v = "b" + toCode n in
+ addBinds v +.+ var2Type x +.+ c (v + ";") +.+ nl +.+
+ setMode (Assign v) +.+ x +.+ nl +.+ setMode mode +.+ f (embed (c v))
+ (:.) x y = getMode \mode. setMode NoReturn +.+ embed x +.+ nl +.+ setMode mode +.+ y
+instance step` Code where
+ (>>*.) x f =
+ getMode \mode. fresh \n.
+ let v = "s" + toCode n in
+ c "while(true) {" +.+ indent +.+ nl +.+
+ var2Type x +.+ c (v + ";") +.+ nl +.+
+ setMode (Assign v) +.+ x +.+ nl +.+
+ setMode mode +.+ codeSteps (f (c v)) +.+
+ unindent +.+ nl +.+ c "}"
+codeSteps :: [Step Code t] -> Code u p
+codeSteps [] = C \rw c.c
+codeSteps [Cond b e:x] =
+ getMode \mode. setMode SubExp +.+
+ c "if (" +.+ b +.+ c ") {" +.+ indent +.+ nl +.+
+ setMode mode +.+ e +.+
+ optBreak mode +.+ unindent +.+ nl +.+ c "}" +.+ nl +.+ setMode mode +.+ codeSteps x
+codeSteps [Ever e:x] =
+ getMode \mode. e +.+ optBreak mode
+
+optBreak :: Mode -> Code u p
+optBreak mode =
+ case mode of
+ Return s = C \rw c.c
+ _ = nl +.+ c "break;"
+
+instance setDelay Code where
+ setDelay d t = embed (c "setDelay" +.+ brac (t +.+ c ", " +.+ d))
+instance mtask Code a | taskImp2 a & types a where
+ task f =
+ {main = freshMTask \n.
+ let (app, a) = taskImp2 n types
+ (b In main) = f (\d a.app (long d) a)
+ in codeMTaskBody (loopCode n (b a)) (unMain main)}
+instance mtasks Code a b | taskImp2 a & types a & taskImp2 b & types b where
+ tasks f =
+ {main =
+ freshMTask \t1.
+ freshMTask \t2.
+ let (app1, a1) = taskImp2 t1 types
+ (app2, a2) = taskImp2 t2 types
+ ((b1, b2) In main) = f ((\d a.app1 (long d) a),(\d a.app2 (long d) a))
+ in codeMTaskBody (loopCode t2 (b2 a2)) (codeMTaskBody (loopCode t1 (b1 a1)) (unMain main))}
+
+loopCode :: Int (Code a b) -> Code c d
+loopCode n b =
+ nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
+ setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+
+ unindent +.+ nl +.+ c "} "
+
+instance taskImp2 () where
+ taskImp2 n () = (app, ())
+ where app d a = setBinds [] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ d +.+ c ")")
+instance taskImp2 (Code t p) where
+ taskImp2 n type1 = (app, ta)
+ where
+ n0 = "t0p->a[0]"
+ ta = c n0 +.+ type1
+ app d a =
+ setBinds [n0] +.+ embed (c "newTask(" +.+
+ c n +.+ c ", " +.+
+ d +.+ c ", " +.+
+ a +.+ c ")")
+instance taskImp2 (Code a p, Code b q) where
+ taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
+ n0 = "t0p->a[0]"
+ n1 = "t0p->a[1]"
+ ta1 = c n0 +.+ type1
+ ta2 = c n1 +.+ type2
+ app d (a1, a2) =
+ setBinds [n0,n1] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ long d +.+
+ c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
+instance taskImp2 (Code a p, Code b q, Code c r) where
+ taskImp2 n (type1, type2, type3) = (app, (ta1, ta2, ta3))
+ where
+ n0 = "t0p->a[0]"
+ n1 = "t0p->a[1]"
+ n2 = "t0p->a[2]"
+ ta1 = c n0 +.+ type1
+ ta2 = c n1 +.+ type2
+ ta3 = c n2 +.+ type3
+ app d (a1, a2, a3) =
+ setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+
+ c n +.+ c ", " +.+
+ d +.+ c ", " +.+
+ a1 +.+ c ", " +.+
+ a2 +.+ c ", " +.+
+ a3 +.+ c ", 0)")
+instance taskImp2 (Code a p, Code b q, Code c r, Code d s) where
+ taskImp2 n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
+ where
+ n0 = "t0p->a[0]"
+ n1 = "t0p->a[1]"
+ n2 = "t0p->a[2]"
+ n3 = "t0p->a[3]"
+ ta1 = c n0 +.+ type1
+ ta2 = c n1 +.+ type2
+ ta3 = c n2 +.+ type3
+ ta4 = c n3 +.+ type4
+ app d (a1, a2, a3, a4) =
+ setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+
+ c n +.+ c ", " +.+
+ d +.+ c ", " +.+
+ a1 +.+ c ", " +.+
+ a2 +.+ c ", " +.+
+ a3 +.+ c ", " +.+
+ a4 +.+ c ")")
+
+class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
+instance taskImp () where
+ taskImp n () = (app, ())
+ where app i a = embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+ c ")")
+instance taskImp (Code t p) where
+ taskImp n type1 = (app, ta)
+ where
+ ta = c "t0p->a[0]" +.+ type1
+ app i a =
+ embed (c "newTask(" +.+
+ c n +.+ c ", " +.+
+ c i +.+ c ", " +.+
+ a +.+ c ")")
+instance taskImp (Code a p, Code b q) where
+ taskImp n (type1, type2) = (app, (ta1, ta2)) where
+ ta1 = c "t0p->a[0]" +.+ type1
+ ta2 = c "t0p->a[1]" +.+ type2
+ app i (a1, a2) =
+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+
+ c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
+instance taskImp (Code a p, Code b q, Code c r) where
+ taskImp n (type1, type2, type3) = (app, (ta1, ta2, ta3))
+ where
+ ta1 = c "t0p->a[0]" +.+ type1
+ ta2 = c "t0p->a[1]" +.+ type2
+ ta3 = c "t0p->a[2]" +.+ type3
+ app i (a1, a2, a3) =
+ embed (c "newTask(" +.+
+ c n +.+ c ", " +.+
+ c i +.+ c ", " +.+
+ a1 +.+ c ", " +.+
+ a2 +.+ c ", " +.+
+ a3 +.+ c ")")
+instance taskImp (Code a p, Code b q, Code c r, Code d s) where
+ taskImp n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
+ where
+ ta1 = c "t0p->a[0]" +.+ type1
+ ta2 = c "t0p->a[1]" +.+ type2
+ ta3 = c "t0p->a[2]" +.+ type3
+ ta4 = c "t0p->a[3]" +.+ type4
+ app i (a1, a2, a3, a4) =
+ embed (c "newTask(" +.+
+ c n +.+ c ", " +.+
+ c i +.+ c ", " +.+
+ a1 +.+ c ", " +.+
+ a2 +.+ c ", " +.+
+ a3 +.+ c ", " +.+
+ a4 +.+ c ")")
+
+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
+tasksMain i j f =
+ { main =
+ freshMTask \n. freshMTask \m.
+ let
+ (app1, a1) = taskImp n types
+ (app2, a2) = taskImp m types
+ ((b1, b2) In {main = e}) = f (app1 i, app2 j)
+ in
+ codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
+ }
+class types a :: a
+instance types () where types = ()
+instance types (Code a p) | typeSelector a & isExpr p
+ where types = typeSelector
+instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
+ where types = (typeSelector, typeSelector)
+instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
+ where types = (typeSelector, typeSelector, typeSelector)
+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
+ where types = (typeSelector, typeSelector, typeSelector, typeSelector)
+
+codeMTaskBody :: (Code v w) (Code c d) -> Code e f
+codeMTaskBody loop e =
+ getMode \mode.
+ setMode NoReturn +.+
+ setCode Loop +.+ loop +.+
+ setMode mode +.+ setCode Setup +.+ embed e
+instance fun Code () where
+ fun f =
+ {main = getMode \mode. fresh \n.
+ let fname = c ("f" + toCode n)
+ (g In {main=e}) = f (\x.embed (fname +.+ c " ()"))
+ in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " () " +.+
+ funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [] +.+ g ()) +.+ setCode Setup +.+ setMode mode +.+ e
+ }
+instance fun Code (Code t p) | type, showType t & isExpr p where
+ fun f =
+ {main =
+ getMode \mode. fresh \n.
+ let fname = c ("f" + toCode n)
+ aname = "a" + toCode n
+ (g In {main=e}) = f (\x.embed (fname +.+ c " " +.+ brac x))
+ in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
+ brac (argTypes f +.+ c (" " + aname)) +.+
+ funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [aname] +.+ g (embed (c aname))) +.+ setCode Setup +.+ setMode mode +.+ e
+ }
+instance fun Code (Code a p, Code b q) | showType a & showType b where
+ fun f =
+ {main =
+ getMode \mode. fresh \n.
+ let fname = c ("f" + toCode n + " ")
+ aname = "a" + toCode n //+ " "
+ bname = "b" + toCode n //+ " "
+ (atype, btype) = argTypes f
+ (g In main)
+ = f (\(x,y).embed (fname +.+ codeOp2 x ", " y))
+ in setCode Fun +.+ nl +.+ resType f +.+ fname +.+
+ codeOp2 (atype +.+ c aname) ", " (btype +.+ c bname) +.+
+ funBody (setMode (Return (toCode (resType2 f))) +.+
+ setBinds [aname,bname] +.+ g (embed (c aname), embed (c bname))) +.+
+ setCode Setup +.+ setMode mode +.+ unMain main
+ }
+instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
+ fun f =
+ {main =
+ getMode \mode. fresh \n.
+ let fname = c ("f" + toCode n)
+ aname = "a" + toCode n
+ bname = "b" + toCode n
+ cname = "c" + toCode n
+ (atype,btype,ctype) = argTypes f
+ (g In {main=e}) = f (\(x,y,z).embed (fname +.+ c " " +.+ brac (x +.+ c ", " +.+ y +.+ c ", " +.+ z)))
+ in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
+ brac (atype +.+ c (" " + aname + ", ") +.+ btype +.+ c (" " + bname + ", ") +.+ ctype +.+ c (" " + cname)) +.+
+ funBody (setMode (Return (toCode (resType2 f))) +.+
+ setBinds [aname,bname,cname] +.+ g (embed (c aname), embed (c bname), embed (c cname))) +.+ setCode Setup +.+ setMode mode +.+ e
+ }
+instance output Code where
+ output x = embed (c "Serial.println(" +.+ x +.+ c ")")
+instance pinMode Code where
+ pinmode p m = embed (c ("pinMode(" + toCode p + ", " + consName{|*|} m + ")"))
+instance digitalIO Code where
+ digitalRead p = embed (c ("digitalRead(" + toCode p + ")"))
+ digitalWrite p b = embed (c ("digitalWrite(" + toCode p + ", ") +.+ b +.+ c ")")
+instance dIO Code where
+ dIO p = C (ioc p) where
+ ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin, readPinD p
+ ioc p Rd s = f Rd s where (C f) = embed (c ("digitalRead(" + toCode p + ")"))
+ ioc p (Wrt v) s = f Rd s where (C f) = embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")
+instance aIO Code where
+ aIO p = C (ioc p) where
+ ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin p
+ ioc p Rd s = unC (embed (c ("analogRead(" + toCode p + ")"))) Rd s
+ ioc p (Wrt v) s = unC (embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")) Rd s
+instance analogIO Code where
+ analogRead p = embed (c ("analogRead(" + toCode p + ")"))
+ analogWrite p b = embed (c ("analogWrite(" + toCode p + ", ") +.+ b +.+ c ")")
+instance noOp Code where noOp = C \rw c.c
+
+:: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
+:: CODE =
+ { fresh :: Int
+ , freshMTask :: Int
+ , funs :: [String]
+ , ifuns :: Int
+ , vars :: [String]
+ , ivars :: Int
+ , setup :: [String]
+ , isetup :: Int
+ , loop :: [String]
+ , iloop :: Int
+ , includes :: [String]
+ , def :: Def
+ , mode :: Mode
+ , binds :: [String]
+ }
+
+unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
+unC (C f) = f
+
+:: Def = Var | Fun | Setup | Loop
+:: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
+
+setMode :: Mode -> Code a p
+setMode m = C \rw c.{c & mode = m}
+
+getMode :: (Mode -> Code a p) -> Code a p
+getMode f = C \rw c.unC (f c.mode) rw c
+
+embed :: (Code a p) -> Code a p
+embed e =
+ getMode \m. case m of
+ NoReturn = setMode SubExp +.+ e +.+ c ";"
+ Return "void" = setMode SubExp +.+ e +.+ c ";"
+ Return t = c "return " +.+ setMode SubExp +.+ e +.+ c ";"
+ Assign s = c (s + " = ") +.+ setMode SubExp +.+ e +.+ c ";"
+ SubExp = e
+ _ = abort "\n\nembed: unknown mode.\n"
+
+(+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
+(+.+) (C f) (C g) = C \rw c.g Rd (f Rd c)
+
+fresh :: (Int -> (Code a p)) -> (Code a p)
+fresh f = C \rw c.unC (f c.fresh) rw {c & fresh = c.fresh + 1}
+
+freshMTask :: (Int -> (Code a p)) -> (Code a p)
+freshMTask f = C \rw c.unC (f c.freshMTask) rw {c & freshMTask = c.freshMTask + 1}
+
+setCode :: Def -> (Code a p)
+setCode d = C \rw c.{c & def = d}
+
+getCode :: (Def -> Code a p) -> (Code a p)
+getCode f = C \rw c.unC (f c.def) rw c
+
+brac :: (Code a p) -> Code b q
+brac e = c "(" +.+ e +.+ c ")"
+
+funBody :: (Code a p) -> Code b q
+funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl
+
+codeOp2 :: (Code a p) String (Code b q) -> Code c r
+codeOp2 x n y = embed (brac (x +.+ c n +.+ y))
+
+include :: String -> Code a b
+include lib = C \rw c.{c & includes = [lib:c.includes]}
+
+argList :: [a] -> String | toCode a
+argList [a] = toCode a
+argList [a:x] = toCode a + "," + argList x
+argList [] = ""
+
+c :: a -> Code b p | toCode a
+c a = C \rw c.case c.def of
+ Fun = {c & funs = [toCode a: c.funs]}
+ Var = {c & vars = [toCode a: c.vars]}
+ Setup = {c & setup = [toCode a: c.setup]}
+ Loop = {c & loop = [toCode a: c.loop]}
+
+indent :: Code a p
+indent =
+ C \rw c.case c.def of
+ Fun = {c & ifuns = inc c.ifuns}
+ Var = {c & ivars = inc c.ivars}
+ Setup = {c & isetup = inc c.isetup}
+ Loop = {c & iloop = inc c.iloop}
+
+unindent :: Code a p
+unindent =
+ C \rw c.case c.def of
+ Fun = {c & ifuns = dec c.ifuns}
+ Var = {c & ivars = dec c.ivars}
+ Setup = {c & isetup = dec c.isetup}
+ Loop = {c & iloop = dec c.iloop}
+where
+ dec n | n > 1
+ = n - 1
+ = 0
+
+nl :: Code a p
+nl =
+ C \rw c.case c.def of
+ Fun = {c & funs = [str c.ifuns: c.funs]}
+ Var = {c & vars = [str c.ivars: c.vars]}
+ Setup = {c & setup = [str c.isetup: c.setup]}
+ Loop = {c & loop = [str c.iloop: c.loop]}
+where
+ str n = toString ['\n':repeatn (tabSize * n) ' ']
+
+setBinds :: [String] -> Code a p
+setBinds list = C \rw c.{c & binds = list}
+
+addBinds :: String -> Code a p
+addBinds name = C \rw c.{c & binds = [name:c.binds]}
+
+getBinds :: ([String] -> Code a p) -> (Code a p)
+getBinds f = C \rw c.unC (f c.binds) rw c
+
+// ----- driver ----- //
+
+compile :: (Main (Code a p)) -> [String]
+compile {main=(C f)} =
+ ["/*\n"
+ ," Generated code for Arduino\n"
+ ," Pieter Koopman, pieter@cs.ru.nl\n"
+ ,"*/\n"
+ ,"\n"
+ ,"#define MAX_ARGS 4\n"
+ ,"#define MAX_TASKS 20\n"
+ ,"#define MAX_TASK_NO MAX_TASKS - 1\n"
+ ,"#define NEXT_TASK(n) ((n) == MAX_TASK_NO ? 0 : (n) + 1)\n"
+ ,"\n"
+ ,"typedef union Arg {\n"
+ ," int i;\n"
+ ," bool b;\n"
+ ," char c;\n"
+// ," float f;\n" // requires 4 bytes
+ ," word w;\n"
+ ,"} ARG;\n"
+ ,"\n"
+ ,"typedef struct Task {\n"
+ ," byte id;\n"
+ ," long wait;\n"
+ ," ARG a[MAX_ARGS];\n"
+ ,"} TASK;\n"
+ ,"\n"
+ ] ++
+ foldr (\lib c.["#include <":lib:".h>\n":c]) [] (mkset c.includes) ++
+ ["\n// --- variables ---\n"
+ ,"TASK tasks[MAX_TASKS];\n"
+ ,"byte t0 = 0, tc = 0, tn = 0;\n"
+ ,"long delta;\n"
+ ,"\n"
+ ,"int vInt;\n"
+ ,"bool vBool;\n"
+ ,"char vChar;\n"
+ ,"float vFloat;\n"
+ ,"unsigned long time = 0;\n"
+ :reverse c.vars
+ ] ++
+ ["\n// --- functions ---\n"
+ ,"byte newTask(byte id, long wait, word a0 = 0, word a1 = 0, word a2 = 0, word a3 = 0) {\n"
+ ," TASK *tnp = &tasks[tn];\n"
+ ," tnp->id = id;\n"
+ ," tnp->wait = wait;\n"
+ ," tnp->a[0].w = a0;\n"
+ ," tnp->a[1].w = a1;\n"
+ ," tnp->a[2].w = a2;\n"
+ ," tnp->a[3].w = a3;\n"
+ ," byte r = tn;\n"
+ ," tn = NEXT_TASK(tn);\n"
+ ," return r;\n"
+ ,"}\n"
+ ,"\n"
+ ,"byte setDelay(byte t, long d) {\n"
+ ," tasks[t].wait = d;\n"
+ ," return t;\n"
+ ,"}\n"
+ ,"boolean pressed(int b) {\n"
+ ," pinMode(A0, INPUT);\n"
+ ," int a0 = analogRead(A0);\n"
+ ," switch (b) {\n"
+ ," case 0: return a0 < ",toString RightBound,"; // right\n"
+ ," case 1: return ",toString RightBound," < a0 && a0 < ",toString UpBound,"; // up\n"
+ ," case 2: return ",toString UpBound," < a0 && a0 < ",toString DownBound,";// down\n"
+ ," case 3: return ",toString DownBound," < a0 && a0 < ",toString LeftBound,";//left\n"
+ ," case 4: return ",toString LeftBound," < a0 && a0 < ",toString SelectBound,";//select\n"
+ ," default: return ",toString SelectBound," < a0; //no button\n"
+ ," }\n"
+ ,"}\n"
+ ,"boolean pWrite (int pin, boolean b) {\n"
+ ," pinMode(pin, OUTPUT);\n"
+ ," digitalWrite(pin, b);\n"
+ ," return b;\n"
+ ,"}\n"
+ ,"int pWrite (int pin, int i) {\n"
+ ," pinMode(pin, OUTPUT);\n"
+ ," analogWrite(pin, i);\n"
+ ," return i;\n"
+ ,"}\n"
+ :reverse c.funs
+ ] ++
+ ["\n// --- setup --- \n"
+ ,"void setup () {\n"
+ ," Serial.begin(9600);\n"
+ ," "
+ :reverse c.setup
+ ] ++
+ ["\n}\n"
+ ,"\n// --- loop --- \n"
+ ,"void loop () {\n"
+ ," if (t0 != tn) {\n"
+ ," if (t0 == tc) {\n"
+ ," unsigned long time2 = millis();\n"
+ ," delta = time2 - time;\n"
+ ," time = time2;\n"
+ ," tc = tn;\n"
+ ," };\n"
+ ," TASK* t0p = &tasks[t0];\n"
+ ," t0p->wait -= delta;\n"
+ ," if (t0p->wait > 0L) {\n"
+ ," newTask(t0p->id, t0p->wait, t0p->a[0].w, t0p->a[1].w, t0p->a[2].w, t0p->a[3].w);\n"
+ ," } else {\n"
+ ," switch (t0p->id) {"
+ :reverse c.loop
+ ] ++
+ ["\n"
+ ," default:\n"
+ ," Serial.println(\"stopped\");\n"
+ ," t0 = tn; // no known task: force termination of tasks\n"
+ ," return;\n"
+ ," };\n"
+ ," }\n"
+ ," t0 = NEXT_TASK(t0);\n"
+ ," }\n"
+ ,"}\n"
+ ]
+where c = f Rd newCode
+
+mkset :: [a] -> [a] | Eq a
+mkset [a:x] = [a:mkset (filter ((<>) a) x)]
+mkset [] = []
+
+newCode :: CODE
+newCode =
+ { fresh = 0
+ , freshMTask = 0
+ , funs = []
+ , ifuns = 0
+ , vars = []
+ , ivars = 0
+ , setup = []
+ , isetup = 1
+ , loop = []
+ , iloop = 4
+ , includes = []
+ , def = Setup
+ , mode = NoReturn
+ , binds = []
+ }
+
+
+//Tools
+instance toCode () where toCode _ = ""
+
+class toCode a :: a -> String
+
+instance toCode Long where toCode (L i) = toCode i + "L"
+
+instance toCode Bool where toCode b = if b "true" "false"
+instance toCode Int where toCode a = toString a
+instance toCode Real where toCode a = toString a
+instance toCode Char where
+ toCode '\0' = "'\\0'"
+ toCode '\n' = "'\\n'"
+ toCode '\\' = "\\"
+ toCode a = "'" + toString a + "'"
+instance toCode String where toCode s = s
+instance toCode DigitalPin where toCode x = s%(1, size s - 1) where s = consName{|*|} x
+instance toCode AnalogPin where toCode x = consName{|*|} x
+
+instance toCode Pin where
+ toCode (Digital p) = toCode p
+ toCode (Analog p) = toCode p
+
--- /dev/null
+definition module mTaskSimulation
+
+import mTask
+
+eval :: (Main (Eval t p)) -> [String] | toString t
+:: State =
+ { tasks :: [(Int, State->State)]
+ , store :: [Dyn]
+ , dpins :: [(DigitalPin, Bool)]
+ , apins :: [(AnalogPin, Int)]
+ , serial:: [String]
+ , millis:: Int
+ }
+
+state0 :: State
+
+//:: TaskSim :== (Int, State->State)
+:: Eval t p = E ((ReadWrite t) State -> (t, State))
+toS2S :: (Eval t p) -> (State->State)
+
+unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
+
+:: ReadWrite t = Rd | Wrt t | Updt (t->t)
+
+(>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
+//(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
+
+rtrn :: t -> Eval t p
+
+yield :: t (Eval s p) -> Eval t Expr
+//yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
+
+instance arith Eval
+instance boolExpr Eval
+instance If Eval p q Expr
+instance IF Eval
+instance var2 Eval
+
+defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
+instance sds Eval
+
+defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
+instance fun Eval x | arg x
+instance mtask Eval x | arg x
+instance mtasks Eval x y | arg x & arg y
+instance setDelay Eval
+
+class toExpr v where toExpr :: (v t p) -> v t Expr
+instance toExpr Eval
+instance toExpr Code
+instance seq Eval
+instance assign Eval
+instance output Eval
+instance pinMode Eval
+instance digitalIO Eval
+instance analogIO Eval
+instance noOp Eval
+
+class arg x :: x -> Int
+instance arg ()
+instance arg (Eval t p) | type t
+instance arg (Eval t p, Eval u q) | type t & type u
+instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v
+instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v
+
+instance + String
+
+readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
+writePinA :: AnalogPin Int State -> State
+
+class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
+instance readPinD DigitalPin
+instance readPinD AnalogPin
+
+class writePinD p :: p Bool State -> State
+instance writePinD DigitalPin
+instance writePinD AnalogPin
+
+// ----- Interactive Simulation ----- //
+
+derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
+
+simulate :: (Main (Eval a p)) -> Task ()
+toView :: State -> StateInterface
+mergeView :: State StateInterface -> State
+:: StateInterface =
+ { serialOut :: Display [String]
+ , analogPins :: [(AnalogPin, Int)]
+ , digitalPins :: [(DigitalPin, Bool)]
+ , var2iables :: [DisplayVar]
+ , timer :: Int
+ , taskCount :: Display Int
+ }
+
+toDisplayVar :: Dyn -> DisplayVar
+fromDisplayVar :: DisplayVar Dyn -> Dyn
+:: DisplayVar
+ = Variable String
+ | INT Int
+ | LONG Int
+ | Servo Pin Int
+ | LCD16x2 String String
+ | DisplayVar [String]
+
+step` :: State -> State
+
+class stringQuotes t | type t :: (Code t p) -> Code t p
+instance stringQuotes String
+instance stringQuotes t
+
+derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo
+derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo
+instance == ()
--- /dev/null
+implementation module mTaskSimulation
+
+import iTasks
+import gdynamic, gCons, GenEq, StdMisc, StdArray
+import mTask
+
+eval :: (Main (Eval t p)) -> [String] | toString t
+eval {main=(E f)} = [toString (fst (f Rd state0))]
+
+:: State =
+ { tasks :: [(Int, State->State)]
+ , store :: [Dyn]
+ , dpins :: [(DigitalPin, Bool)]
+ , apins :: [(AnalogPin, Int)]
+ , serial:: [String]
+ , millis:: Int
+ }
+
+state0 :: State
+state0 = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}
+
+//:: TaskSim :== (Int, State->State)
+:: Eval t p = E ((ReadWrite t) State -> (t, State))
+toS2S :: (Eval t p) -> (State->State)
+toS2S (E f) = \state.snd (f Rd state)
+
+unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
+unEval (E f) = f
+
+:: ReadWrite t = Rd | Wrt t | Updt (t->t)
+
+(>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
+//(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
+(>>==) (E f) g = E\r s.let (a,t) = f Rd s in unEval (g a) Rd t
+
+rtrn :: t -> Eval t p
+rtrn a = E \r s -> (a, s)
+
+yield :: t (Eval s p) -> Eval t Expr
+//yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
+yield a (E f) = E \r s.(a,snd (f Rd s))
+
+instance arith Eval where
+ lit a = rtrn a
+ (+.) x y = x >>== \a. y >>== \b. rtrn (a + b)
+ (-.) x y = x >>== \a. y >>== \b. rtrn (a - b)
+ (*.) x y = x >>== \a. y >>== \b. rtrn (a * b)
+ (/.) x y = x >>== \a. y >>== \b. rtrn (a / b)
+instance boolExpr Eval where
+ (&.) x y = x >>== \a. if a y (rtrn False) // lazy AND
+ (|.) x y = x >>== \a. if a (rtrn True) (y >>== rtrn)
+ Not x = x >>== \a. rtrn (not a)
+ (==.) x y = x >>== \a. y >>== \b. rtrn (a == b)
+ (!=.) x y = x >>== \a. y >>== \b. rtrn (a <> b)
+ (<.) x y = x >>== \a. y >>== \b. rtrn (a < b)
+ (>.) x y = x >>== \a. y >>== \b. rtrn (a > b)
+ (<=.) x y = x >>== \a. y >>== \b. rtrn (a <= b)
+ (>=.) x y = x >>== \a. y >>== \b. rtrn (a >= b)
+instance If Eval p q Expr where
+ If c t e = c >>== \b.if b (toExpr t) (toExpr e)
+instance IF Eval where
+ IF c t e = c >>== \b.if b (yield () t) (yield () e)
+ (?) c t = c >>== \b.if b (yield () t) (rtrn ())
+instance var2 Eval where
+ var2 v f = defEval2 v f
+ con2 v f = defEval2 v f
+
+defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
+defEval2 v f =
+ {main = E (\r s.(length s.store
+ , {s & store = s.store ++ [toDyn v]}))
+ >>== \n.unMain (f (E (read` n)))}
+instance sds Eval where
+ sds f = defEval f
+ con f = defEval f
+
+defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
+defEval f =
+ {main = E \r s.let (v In g) = f (E (read` (length s.store))) in
+ unEval (unMain g) r {s & store = s.store ++ [toDyn v]}}
+instance fun Eval x | arg x where
+ fun f = e where (g In e) = f (\a.toExpr (g a))
+instance mtask Eval x | arg x where
+ task f = e where
+ (t In e) = f (\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
+instance mtasks Eval x y | arg x & arg y where
+ tasks f = e where
+ ((t,u) In e) =
+ f ((\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
+ ,(\d b.long d >>== \(L j).E\r s.(MTask (length s.tasks),{s&tasks=[(j,toS2S (u b)):s.tasks]}))
+ )
+instance setDelay Eval where
+ setDelay d t = d >>== \(L x). t >>== \(MTask n).E \r s.(MTask n,{s & tasks = updateAt n (x,snd (s.tasks !! n)) s.tasks})
+class toExpr v where toExpr :: (v t p) -> v t Expr
+instance toExpr Eval where toExpr (E f) = E f
+instance toExpr Code where toExpr (C f) = C f
+instance seq Eval where
+ (>>=.) x f = x >>== f o rtrn
+ (:.) x y = x >>== \_. y
+instance assign Eval where
+ (=.) (E v) e = e >>== \a. E \r s.v (Wrt a) s
+instance output Eval where
+ output x = x >>== \a.E \r s.((),{s & serial = s.serial ++ [toCode a]})
+instance pinMode Eval where
+ pinmode p m = rtrn ()
+instance digitalIO Eval where
+ digitalRead p = E \rw s=:{dpins, apins}.(readPinD p dpins apins, s)
+ digitalWrite p b = b >>== \a. E \rw s.(a, writePinD p a s)
+instance analogIO Eval where
+ analogRead p = E \rw s=:{apins}. (readPinA p apins, s)
+ analogWrite p b = b >>== \a. E \rw s.(a, writePinA p a s)
+instance noOp Eval where noOp = E \r s.(undef,s)
+
+class arg x :: x -> Int
+instance arg () where arg _ = 0
+instance arg (Eval t p) | type t where arg _ = 1
+instance arg (Eval t p, Eval u q) | type t & type u where arg _ = 2
+instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v where arg _ = 3
+instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v where arg _ = 4
+
+instance + String where (+) x y = x +++ y
+
+readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
+readPinA p lista
+ = case [b \\ (q, b) <- lista | p == q] of
+ [] = 0
+ [a:x] = a
+
+writePinA :: AnalogPin Int State -> State
+writePinA p x s
+ = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}
+
+class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
+instance readPinD DigitalPin where
+ readPinD p listd lista
+ = case [b \\ (q,b) <- listd | p == q] of
+ [] = False
+ [a:x] = a
+instance readPinD AnalogPin where
+ readPinD p listd lista
+ = case [b \\ (q,b) <- lista | p == q] of
+ [] = False
+ [a:x] = a <> 0
+class writePinD p :: p Bool State -> State
+instance writePinD DigitalPin where
+ writePinD p b s=:{dpins} = {s & dpins = [(p, b):[(q, c) \\ (q, c) <- dpins | p <> q]]}
+instance writePinD AnalogPin where
+ writePinD p b s=:{apins} = {s & apins = [(p, if b 1 0):[(q, c) \\ (q, c) <- apins | p <> q]]}
+
+
+// ----- Interactive Simulation ----- //
+
+derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
+
+simulate :: (Main (Eval a p)) -> Task ()
+simulate {main=(E f)} = setup state0 where
+ setup s =
+ updateInformation "State" [] (toView s)
+ >>* [ OnAction ActionFinish (always shutDown)
+ , OnAction (Action "setup" []) (hasValue
+ (\si.simloop (snd (f Rd (mergeView s si)))))
+ ]
+ simloop s =
+ updateInformation "State" [] (toView s)
+ >>* [ OnAction ActionFinish (always shutDown)
+ , OnAction (Action "clear serial" []) (always (simloop {s & serial = []}))
+ , OnAction ActionNew (always (setup state0))
+ : if (isEmpty s.tasks)
+ []
+ [OnAction (Action "loop" []) (hasValue
+ \si.simloop (step` (mergeView s si)))
+ ]
+ ]
+
+toView :: State -> StateInterface
+toView s =
+ { serialOut = Display s.serial
+ , analogPins = s.apins
+ , digitalPins = s.dpins
+ , var2iables = map toDisplayVar s.store
+ , timer = s.millis
+ , taskCount = Display (length s.tasks)
+ }
+
+mergeView :: State StateInterface -> State
+mergeView s si =
+ { s
+ & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
+ , dpins = si.digitalPins
+ , apins = si.analogPins
+// , serial = si.serialOut
+ , millis = si.timer
+ }
+
+:: StateInterface =
+ { serialOut :: Display [String]
+ , analogPins :: [(AnalogPin, Int)]
+ , digitalPins :: [(DigitalPin, Bool)]
+ , var2iables :: [DisplayVar]
+ , timer :: Int
+ , taskCount :: Display Int
+ }
+
+toDisplayVar :: Dyn -> DisplayVar
+toDisplayVar (Dyn [v])
+ # i = toInt v
+ | toString i == v
+ = INT i
+ = Variable v
+toDisplayVar (Dyn ["L",v]) = LONG (toInt v)
+toDisplayVar (Dyn ["Servo",pinKind,pin,pos]) = Servo (fromJust (fromDyn (Dyn [pinKind,pin]))) (toInt pos)
+toDisplayVar (Dyn ["LCD",_,_,_,_,_,l1,_,l2,_]) = LCD16x2 l1 l2
+toDisplayVar (Dyn l) = DisplayVar l
+
+fromDisplayVar :: DisplayVar Dyn -> Dyn
+fromDisplayVar (Variable v) dyn = Dyn [v]
+fromDisplayVar (INT v) dyn = Dyn [toString v]
+fromDisplayVar (LONG v) dyn = Dyn ["L",toString v]
+fromDisplayVar (Servo pin pos) dyn = Dyn (["Servo":let (Dyn p) = toDyn pin in p] ++ [toString pos])
+fromDisplayVar (LCD16x2 l1 l2) (Dyn list) = Dyn (updateAt 6 l1 (updateAt 8 l2 list))
+fromDisplayVar (DisplayVar l) dyn = Dyn l
+
+:: DisplayVar
+ = Variable String
+ | INT Int
+ | LONG Int
+ | Servo Pin Int
+ | LCD16x2 String String
+ | DisplayVar [String]
+
+
+step` :: State -> State
+step` s =
+ foldr appTask {s & millis = s.millis + delta, tasks = []}
+ [(w - delta, f) \\ (w, f) <- s.tasks]
+where delta = foldl1 min (map fst s.tasks) // smallest wait
+
+appTask t=:(w,f) s | w <= 0
+ = f s
+ = {s & tasks = [t:s.tasks]}
+
+foldl1 op [a:x] = foldl op a x
+foldr1 op l :== foldr l
+ where
+ foldr [a] = a
+ foldr [a:x] = op a (foldr x)
+
+class stringQuotes t | type t :: (Code t p) -> Code t p
+instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\""
+instance stringQuotes t where stringQuotes x = x
+
+
+derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
+derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
+instance == () where (==) _ _ = True
+
+
+
repositories / mTask.git / commitdiff