From e25fda18ca554ec3fe937152403872b916367ddb Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Tue, 1 Nov 2016 15:24:42 +0100 Subject: [PATCH] Finish modulization --- .gitignore | 1 + Makefile | 2 +- mTask.dcl | 251 +------------ mTask.icl | 883 +------------------------------------------- mTaskCode.dcl | 136 +++++++ mTaskCode.icl | 638 ++++++++++++++++++++++++++++++++ mTaskSimulation.dcl | 113 ++++++ mTaskSimulation.icl | 258 +++++++++++++ 8 files changed, 1150 insertions(+), 1132 deletions(-) create mode 100644 mTaskCode.dcl create mode 100644 mTaskCode.icl create mode 100644 mTaskSimulation.dcl create mode 100644 mTaskSimulation.icl diff --git a/.gitignore b/.gitignore index 23d53e6..73b32ae 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ Clean System Files mTask +mTaskExamples sapl mTask-data diff --git a/Makefile b/Makefile index f510b38..b8ba871 100644 --- a/Makefile +++ b/Makefile @@ -29,4 +29,4 @@ all: mTaskExamples $(CLM) $(CLMLIBS) $(CLMFLAGS) $(basename $<) -o $@ clean: - $(RM) -r mTask Clean\ System\ Files + $(RM) -r mTaskExamples Clean\ System\ Files diff --git a/mTask.dcl b/mTask.dcl index f7aa613..d341ff7 100644 --- a/mTask.dcl +++ b/mTask.dcl @@ -21,6 +21,7 @@ import StdClass from iTasks.API.Core.Types import :: Display import gdynamic, gCons, GenEq, StdMisc, StdArray +import mTaskCode, mTaskSimulation import mTaskSerial, mTaskLCD // =================== mTask =================== @@ -33,7 +34,6 @@ import mTaskSerial, mTaskLCD :: 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 @@ -55,7 +55,6 @@ instance isStmt Expr instance isStmt Stmt instance == MTask -instance toCode MTask :: Main a = {main :: a} @@ -158,21 +157,7 @@ instance varName x 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 () @@ -199,235 +184,9 @@ instance typeSelector a 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 @@ -444,14 +203,6 @@ instance long Eval 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 diff --git a/mTask.icl b/mTask.icl index 87087e2..f0249c9 100644 --- a/mTask.icl +++ b/mTask.icl @@ -16,12 +16,9 @@ todo: 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 @@ -36,7 +33,6 @@ instance isStmt Expr where isStmt _ = 11 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 @@ -70,24 +66,6 @@ instance varName Char where varName _ = "vChar" 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 " @@ -113,853 +91,9 @@ read` n (Updt f) s=:{store} # 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) @@ -981,23 +115,10 @@ instance long Eval Long where // ----- 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 ' ') diff --git a/mTaskCode.dcl b/mTaskCode.dcl new file mode 100644 index 0000000..8e5f0f5 --- /dev/null +++ b/mTaskCode.dcl @@ -0,0 +1,136 @@ +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 diff --git a/mTaskCode.icl b/mTaskCode.icl new file mode 100644 index 0000000..3edd2ce --- /dev/null +++ b/mTaskCode.icl @@ -0,0 +1,638 @@ +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 + diff --git a/mTaskSimulation.dcl b/mTaskSimulation.dcl new file mode 100644 index 0000000..2b13acf --- /dev/null +++ b/mTaskSimulation.dcl @@ -0,0 +1,113 @@ +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 == () diff --git a/mTaskSimulation.icl b/mTaskSimulation.icl new file mode 100644 index 0000000..180d7e1 --- /dev/null +++ b/mTaskSimulation.icl @@ -0,0 +1,258 @@ +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 + + + -- 2.20.1