From 52f578ee2b3bf45b8db970c6b571257d23078f5c Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Tue, 1 Nov 2016 15:02:58 +0100 Subject: [PATCH] started splitting up into modules --- Makefile | 2 +- mTask.dcl | 487 ++++++++++++++++++++++++++++++++++++++ mTask.icl | 579 ++-------------------------------------------- mTaskExamples.icl | 257 ++++++++++++++++++++ mTaskLCD.dcl | 47 ++++ mTaskLCD.icl | 133 +++++++++++ mTaskSerial.dcl | 23 ++ mTaskSerial.icl | 28 +++ 8 files changed, 992 insertions(+), 564 deletions(-) create mode 100644 mTask.dcl create mode 100644 mTaskExamples.icl create mode 100644 mTaskLCD.dcl create mode 100644 mTaskLCD.icl create mode 100644 mTaskSerial.dcl create mode 100644 mTaskSerial.icl diff --git a/Makefile b/Makefile index 70565ce..f510b38 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,7 @@ CLMLIBS:=\ -I $(CLEAN_HOME)/lib/TCPIP\ -I ./CleanSerial -all: mTask +all: mTaskExamples %: %.icl $(CLM) $(CLMLIBS) $(CLMFLAGS) $(basename $<) -o $@ diff --git a/mTask.dcl b/mTask.dcl new file mode 100644 index 0000000..f7aa613 --- /dev/null +++ b/mTask.dcl @@ -0,0 +1,487 @@ +definition module mTask + +/* + Pieter Koopman pieter@cs.ru.nl + Final version for TFP2016 + + -2: assignment =. suited for digital and analog input and output + -3: ad hoc tasks + +todo: + move task-loop ti setup() + adhoc tasks + task combinators + imporove setp: >>*. +*/ + +//import iTasks +import iTasks._Framework.Generic +import iTasks._Framework.Task +import StdClass +from iTasks.API.Core.Types import :: Display +import gdynamic, gCons, GenEq, StdMisc, StdArray + +import mTaskSerial, mTaskLCD + +// =================== mTask =================== + + +// ----- dsl definition ----- // + +:: DigitalPin + = D0 | D1 | D2 | D3 | D4 | D5 |D6 | D7 | D8 | D9 | D10 | D11 | D12 | D13 +:: 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 pin DigitalPin +instance pin AnalogPin + +:: Upd = Upd +:: Expr = Expr +:: Stmt = Stmt +:: MTask = MTask Int // String + +class isExpr a :: a -> Int +instance isExpr Upd +instance isExpr Expr + +class isStmt a :: a -> Int +instance isStmt Upd +instance isStmt Expr +instance isStmt Stmt + +instance == MTask +instance toCode MTask + +:: Main a = {main :: a} + +unMain :: (Main x) -> x + +class arith v where + lit :: t -> v t Expr | toCode t + (+.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, +, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (-.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, -, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (*.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, *, zero, one t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (/.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, / t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q +class boolExpr v where + (&.) infixr 3 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (|.) infixr 2 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q + Not :: (v Bool p) -> v Bool Expr | isExpr p //& toExpr2 p + (==.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (!=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (<.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (>.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (<=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (>=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q +// using functional dependencies +class If v q r ~s where + If :: (v Bool p) (v t q) (v t r) -> v t s | isExpr p & type t +class IF v where + IF :: (v Bool p) (v t q) (v s r) -> v () Stmt | isExpr p + (?) infix 1 :: (v Bool p) (v t q) -> v () Stmt | isExpr p +class var2 v where + var2 :: t ((v t Upd)->(Main (v c s))) -> (Main (v c s)) | type, toCode t + con2 :: t ((v t Expr) ->(Main (v c s))) -> (Main (v c s)) | type t +class sds v where + sds :: ((v t Upd)->In t (Main (v c s))) -> (Main (v c s)) | type, toCode t + con :: ((v t Expr) ->In t (Main (v c s))) -> (Main (v c s)) | type t +class seq v where + (>>=.) infixr 0 :: (v t p) ((v t Expr) -> (v u q)) -> (v u Stmt) | type t & type u + (:.) infixr 0 :: (v t p) (v u q) -> v u Stmt | type t & type u +class step` v where + (>>*.) infixl 1 :: (v t p) ((v t Expr) -> [Step v u]) -> v u Stmt | type t & type u +:: Step v t = E.p.q: Cond (v Bool q) (v t p) | E.p: Ever (v t p) +class assign v where + (=.) infixr 2 :: (v t Upd) (v t p) -> v t Expr | type t & isExpr p +class fun v t where + fun :: ((t->v s Expr)->In (t->v s p) (Main (v u q))) -> Main (v u q) | type s +class mtask v a where + task :: (((v delay r) a->v MTask Expr)->In (a->v u p) (Main (v t q))) -> Main (v t q) | type t & type u & isExpr r & long v delay +class lag v where + lag :: (v delay r) (v t p) -> v MTask Expr | type t & long v delay +class setDelay v where + setDelay :: (v Long p) (v MTask Expr) -> (v MTask Expr) | isExpr p +class mtasks v a b where + tasks :: (((v delay r1) a->v MTask Expr, (v delay r2) b->v MTask Expr)->In (a->v t p, b->v u p) (Main (v s q))) -> Main (v s q) | type s & isExpr r1 & isExpr r2 & long v delay +class output v where + output :: (v t p) -> v () Expr | type t & isExpr p +class noOp v where noOp :: v t p + +class pinMode v where + pinmode :: p PinMode -> v () Expr | pin p +class digitalIO v where + digitalRead :: p -> v Bool Expr | pin, readPinD p + digitalWrite :: p (v Bool q) -> v Bool Expr | pin, writePinD p +class analogIO v where + analogRead :: AnalogPin -> v Int Expr + analogWrite :: AnalogPin (v Int p) -> v Int Expr +class dIO v where + dIO :: p -> v Bool Upd | pin, readPinD p +class aIO v where + aIO :: AnalogPin -> v Int Upd +class time v where + delay :: (v Long p) -> (v Long Expr) + millis :: (v Long Expr) + +class pio p t where pio :: p -> v t Upd | aIO v & dIO v +instance pio AnalogPin Int +instance pio AnalogPin Bool +instance pio DigitalPin Bool + +int :: (v Int p) -> (v Int p) +bool :: (v Bool p) -> (v Bool p) +char :: (v Char p) -> (v Char p) + +class type t | showType, dyn, toCode, ==, type2string, varName t +class type2string t :: t -> String +instance type2string Int +instance type2string Long +instance type2string Real +instance type2string Bool +instance type2string Char +instance type2string MTask +instance type2string DigitalPin +instance type2string AnalogPin +instance type2string String +instance type2string () +class varName a :: a -> String +instance varName Int +instance varName Long +instance varName Bool +instance varName Char +instance varName Real +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 () +instance showType2 Int +instance showType2 Char +instance showType2 Bool +instance showType2 a + +class showType t | showType2 /*, type*/ t :: (Code t p) +instance showType () +instance showType Int +instance showType Long +instance showType Char +instance showType Bool +instance showType a + +class typeSelector t | showType2, type t :: (Code t p) +instance typeSelector Int +instance typeSelector Char +instance typeSelector Bool +instance typeSelector a + +:: In a b = In infix 0 a b + +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 +instance / Long +instance == Long +instance one Long +instance zero Long + +class long v t :: (v t p) -> v Long Expr | isExpr p +instance long Code Int +instance long Code Long +instance long Eval Int +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 +instance == AnalogPin + +derive consIndex DigitalPin, AnalogPin + +tab =: toString (repeatn tabSize ' ') +tabSize :== 2 + +instance toString () + +a0 :== pio A0 +a1 :== pio A1 +a2 :== pio A2 +a3 :== pio A3 +a4 :== pio A4 +a5 :== pio A5 + +d0 :== pio D0 +d1 :== pio D1 +d2 :== pio D2 +d3 :== pio D3 +d4 :== pio D4 +d5 :== pio D5 +d6 :== pio D6 +d7 :== pio D7 +d8 :== pio D8 +d9 :== pio D9 +d10 :== pio D10 +d11 :== pio D11 +d12 :== pio D12 +d13 :== pio D13 diff --git a/mTask.icl b/mTask.icl index 6c6ddc5..87087e2 100644 --- a/mTask.icl +++ b/mTask.icl @@ -1,4 +1,4 @@ -module mTask +implementation module mTask /* Pieter Koopman pieter@cs.ru.nl @@ -16,466 +16,21 @@ todo: import iTasks import gdynamic, gCons, GenEq, StdMisc, StdArray +import mTaskSerial, mTaskLCD -// =================== examples =================== - -Start = - [["//mTaskTFP16_3 \n"] -/* ,["// --- p1 \n"] - ,compile p1 - ,["// --- p2 \n"] - ,compile p2 - ,["// --- p3 \n"] - ,compile p3 - ,["// --- p4 \n"] - ,compile p4 - ,["// --- p5 \n"] - ,compile p5 - ,["// --- p6 \n"] - ,compile p6 - ,["// --- p7 \n"] - ,compile p7 - ,["// --- p8 \n"] - ,compile p8 - ,["// --- p9 \n"] - ,compile p9 - ,["// --- p10 \n"] - ,compile p10 - ,["// --- p11 \n"] - ,compile p11 - ,["// --- p12 \n"] - ,compile p12 - ,["// --- fac \n"] - ,compile fac - ,["// --- blink \n"] - ,compile blink - ,["// --- heatingDemo \n"] - ,compile heatingDemo - ,["// --- hpinDemo \n"] - ,compile pinDemo - ,["// --- blink2 \n"] - ,compile blink2 - ,["// --- blink3 \n"] - ,compile blink3 - ,["// --- blinks \n"] - ,compile blinks - ,["// --- lcdCount \n"] - ,compile lcdCount -*/ - ,["// --- heating \n"] - ,compile heating - ] - -lcdHello = LCD 16 2 [] \lcd = {main = print lcd (lit "Hello world")} - -lcdCount = - LCD 16 2 [] \lcd = - task \t = (\c. - If (pressed upButton) ( - setCursor lcd Zero Zero :. - print lcd c :. - t (sec 1) (c +. One) - ) (t (msec 10) c)) In - {main = t (sec 0) Zero} - -printD0 = {main = serialPrint (Not d0)} - -print36 = sds \x = 6 In {main = x =. x *. x :. serialPrint x} - -pinDemo = - {main = a1 =. a0 =. lit 1 +. a0 :. a0 =. Not a0} - -fac = fun \fac = (\n. If (n <. One) One (n *. fac (n -. One))) - In {main = fac (lit 6)} -One = lit 1 -Zero = lit 0 - -blink = - task \t = (\s. setLED s :. t (If s (sec 1) (sec 3)) (Not s)) In {main = t (sec 0) (lit True)} -blink2 = - task \t = (\(). d13 =. Not d13 :. t (sec 1) ()) In {main = t (sec 0) ()} -blink3 = - task \t = (\s. d13 =. s :. t (If s (msec 100) (sec 1)) (Not s)) In {main = t (sec 0) (lit False)} -blinks = - task \t = (\b. d13 =. b :. t (sec 1) b) In {main = t (msec 0) true :. t (msec 100) false} - -setLED b = d13 =. b -sec n = long (lit (n * 1000)) -msec n = long (lit n) - -qt = task \plus = (\(x,y).x +. y) In {main = plus (sec 0) (lit 3, lit 4)} -qs = fun \plus = (\(x,y).x +. y) In {main = plus (lit 3, lit 4)} - -q1 = - tasks \(switch, heat) = - (\s1 = digitalWrite D2 s1:. heat (sec 60) s1 - ,\s2 = analogRead A3 >>*. \v. - [Cond (v >. upper) (switch (sec 0) off) - ,Cond (v <. lower) (switch (sec 0) on) - ,Ever (heat (sec 1) s2) - ]) - In {main = heat (sec 0) off} -where - upper = lit 876 - lower = lit 123 - -serialReadInt = serialParseInt >>=. \i. serialRead >>*. \c. [Cond (c ==. lit '\n') i] - -heating = - sds \goal = 500 In - fun \switch = (\s. d13 =. s) In - task \control = (\isOn. - a0 <. goal >>*. \mustOn. - [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on) - ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off) - ,Ever (control (msec 100) isOn) - ]) In - task \change = (\(). - serialAvailable ? (serialReadInt >>=. \g.goal =. g) :. - change (sec 1) ()) In - {main = switch off :. control (sec 0) off :. change (sec 1) ()} -where - minOnTime = sec 2 - minOffTime = sec 1 - -heating2 = - sds \goal = 500 In -// fun \switch = setLED In - fun \switch = (\b. setLED b :. serialPrintln b) In - task \control = (\isOn. - a0 <. goal >>*. \mustOn. - [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on) - ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off) - ,Ever (control (msec 100) isOn) - ]) In - task \change = (\(). - serialAvailable ? (serialReadInt >>=. \i. serialPrintln (goal =. i)) :. - change (sec 1) ()) In - {main = switch off :. control (sec 0) off :. change (sec 1) ()} -where - minOnTime = sec 2 - minOffTime = sec 1 - -thermoTask = - sds \goal = 500 In - fun \switch = (\on. d13 =. bool on :. a0 =. on) In - task \control = - (\isOn. a0 <. goal >>*. \mustOn. - [Cond (mustOn &. Not isOn) (switch mustOn :. control minOnTime mustOn) - ,Cond (Not mustOn &. isOn) (switch mustOn :. control minOffTime mustOn) - ,Ever (control (msec 100) isOn) - ]) In - {main = switch off :. control (sec 0) off} -where - minOnTime = sec 1 // 60 - minOffTime = sec 2 //10 - off = lit False - -heatingDemo = - sds \heat = False In - sds \temp = 500 In - LCD 16 2 [] \lcd. - task \tempChange = (\(). - lit 0 <. temp &. Not heat ? temp =. temp -. One:. - temp <. lit 1000 &. heat ? temp =. temp +. One :. - setCursor lcd (lit 5) Zero :. - print lcd (lit "temp ") :. - print lcd temp :. - print lcd (lit " ") :. - tempChange (msec 789) ()) In - fun \switch = (\s. - heat =. s :. - setCursor lcd Zero Zero :. - If s - (print lcd (lit "On ")) - (print lcd (lit "Off"))) In - fun \measure = (\(). - analogRead A0 >>=. \a0. - setCursor lcd Zero One :. - print lcd a0 :. - print lcd (lit " ") :. - a0) In - task \control = (\isOn. - measure () >>=. \val.temp <. val - >>*. \mustOn. - [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on) - ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off) - ,Ever (control (msec 100) isOn) - ] - ) In - {main = switch off :. control (msec 10) off :. tempChange (sec 0) ()} -where - limit = lit 512 - minOnTime = sec 3 - minOffTime = sec 2 -true = lit True -on = true -false = lit False -off = false - -count = - LCD 16 2 [] \lcd. - task \count = (\n. - setCursor lcd Zero Zero :. - print lcd n :. - count (sec 1) (n +. One)) In - {main = count (sec 0) Zero} - -p0 = sds \x = 6 In {main = x =. x *. lit 7} -p1 = {main = lit 2 +. lit 4 >>=. \x. (x +. lit 1) *. x} -p2 = - fun \f. (\x. lit 6 *. x) - In {main = lit 3 +. lit 4 >>=. \x. f x} -p3 = - fun \f. (\x. lit 6 *. x) - In {main = lit 3 +. lit 4 >>=. f} // higher order, somewhat remarkable that this works -p4 = - fun \f. (\x. lit 6 *. x) - In {main = lit 3 +. lit 4 >>=. \x. f x >>=. serialPrint} -p5 = {main = lit 7 >>*. \x. [Cond (x <. lit 36) (x *. x),Ever (lit 42)]} -p6 = sds \y = 1 In {main = lit 7 >>*. \x. [Cond (x <. lit 36) (y =. x *. x),Ever (y =. x)]} -p7 = sds \y = 1 In {main = y +. lit 1 >>*. \x. [Cond (x <. lit 36) ((y =. x *. x) >>*. \z.[Cond (z ==. x) y, Ever y]),Ever (y =. x)]} -p8 = sds \y = 1 In {main = pressed upButton >>*. \x. [Cond x (y =. y +. y),Ever (y =. lit 36)]} -//p8 = sds \y = 1 In {main = pressed upButton >>*. \x. [Cond x ((y =. lit 42) >>*. \z.[Cond (z ==. y) y, Ever y]),Ever (y =. lit 36)]} -//p9 = {main = If (pressed upButton) (lit 1) (lit 7)} // Overloading error [mTaskTFP16.icl,61,p9]: "isExpr" no instance available of type Stmt -p9 = {main = pressed upButton >>=. \b.If b (lit 1) (lit 7)} -p10 = - sds \y = 1 In - {main = - (pressed upButton >>*. \x. - [Cond x (y =. y +. y :. - x) - ,Ever (y =. lit 36 :. - lit False) - ]) - >>=. \z. z &. z} -p11 = - sds \y = 1 In - {main = - y =. lit 2 :. - (pressed upButton >>=. \b. - If b - (y =. lit 3 :. - y +. lit 1) - (lit 42)) - >>*. \x. - [Cond (x <. lit 36) - ((y =. x *. x) >>*. \z. - [Cond (z ==. x) (serialPrint y) - ,Ever (serialPrint (lit 0)) - ]) - ,Ever (y =. x) - ] - } -p12 = - task \t = (\(). pressed upButton >>*. \b.[Cond b (serialPrintln (lit 7)),Ever (t (lit 250) ():. lit 0)]) In - {main = t (lit 0) ()} - -// ----- serial definition ----- // - -class serial v where - serialAvailable :: (v Bool Expr) - serialPrint :: (v t p) -> v Int Expr | stringQuotes t & isExpr p - serialPrintln :: (v t p) -> v Int Expr | stringQuotes t & isExpr p - serialRead :: (v t Expr) - serialParseInt :: (v Int Expr) - -instance serial Code where - serialAvailable = embed (c "Serial.available()") - serialPrint x = embed (c "Serial.print(" +.+ x +.+ c ")") - serialPrintln x = embed (c "Serial.println(" +.+ x +.+ c ")") - serialRead = embed (c "Serial.read()") - serialParseInt = embed (c "Serial.parseInt()") - -instance serial Eval where - serialAvailable = rtrn False - serialPrint x = x >>== \a.E \r s.let str = toCode a in (size str,{s & serial = s.serial ++ [str]}) - serialPrintln x = x >>== \a.E \r s.let str = toCode a + "\n" in (size str,{s & serial = s.serial ++ [str]}) - serialRead = rtrn undef - serialParseInt = rtrn undef - -class char2int v :: (v Char p) -> v Int Expr -instance char2int Code where char2int (C f) = C \rw c.f Rd c - -:: SerialObject v t p = - { available :: v Bool Expr - , print :: (v t p) -> v Int Expr - , println :: (v t p) -> v Int Expr - , read :: (v Char Expr) - } - -// =================== shields =================== - -// ----- LCD definition ----- // - -:: LCD = - { cursorRow :: Int - , cursorCol :: Int - , sizeH :: Int - , sizeW :: Int - , lcdtxt :: [String] - } - -:: Button = RightButton | UpButton | DownButton | LeftButton | SelectButton | NoButton - -rightButton = lit RightButton -upButton = lit UpButton -downButton = lit DownButton -leftButton = LeftButton -selectButton = lit SelectButton -noButton = lit NoButton - -class lcd v where - begin :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr - print :: (v LCD Expr) (v t p) -> v Int Expr | stringQuotes t // returns bytes written - setCursor :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr - liquidCrystal0 :: [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q) - LCD :: Int Int [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q) - scrollLeft :: (v LCD Expr) -> v () Expr - scrollRight :: (v LCD Expr) -> v () Expr - pressed :: (v Button Expr) -> v Bool Expr - -instance lcd Code where - begin v x y = embed (v +.+ c ".begin" +.+ codeOp2 x ", " y) - print v x = embed (v +.+ c ".print (" +.+ stringQuotes x +.+ c ")") - setCursor v x y = embed (v +.+ c ".setCursor" +.+ codeOp2 x ", " y) - scrollLeft v = embed (v +.+ c ".scrollDisplayLeft()") - scrollRight v = embed (v +.+ c ".scrollDisplayRight()") - liquidCrystal0 [] f = liquidCrystal0 [D8, D9, D4, D5, D6, D7] f - liquidCrystal0 pins f = - {main = - getCode \cd. fresh \n. - let - name = "lcd" + toString n - rest = f (c name) - in - include "LiquidCrystal" +.+ - setCode Var +.+ - c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+ - setCode cd +.+ - rest.main - } - LCD x y [] f = LCD x y [D8, D9, D4, D5, D6, D7] f - LCD x y pins f = - {main = - getCode \cd. fresh \n. - let - name = "lcd" + toString n - rest = f (c name) - in - include "LiquidCrystal" +.+ - setCode Var +.+ - c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+ - setCode Setup +.+ - c (name + ".begin(" + toCode x + ", " + toCode y +");") +.+ nl +.+ - setCode cd +.+ - rest.main - } - pressed b = embed (c "pressed(" +.+ setMode SubExp +.+ b +.+ c ")") - -RightBound = 50 -UpBound = 190 -DownBound = 380 -LeftBound = 555 -SelectBound = 790 - -instance lcd Eval where - begin (E v) x y = - x >>== \w. - y >>== \h. - yield () (E \r.v (Updt \lcd.{lcd & sizeH = h, sizeW = w, lcdtxt = repeatn h (toString (repeatn w ' '))})) - print (E v) x = - x >>== \a. let str = toCode a in - yield (size str) (E \r.v (Updt \lcd.lcdPrintStr str lcd)) - setCursor (E v) x y = - x >>== \w. - y >>== \h. - yield () (E \r.v (Updt \lcd.{lcd & cursorRow = h, cursorCol = w})) - scrollLeft v = rtrn () - scrollRight v = rtrn () - LCD w h pins f = defEval2 lcd f where - lcd = - { cursorRow = 0 - , cursorCol = 0 - , sizeH = h - , sizeW = w - , lcdtxt = repeatn h (toString (repeatn w ' ')) - } - liquidCrystal0 pins f = defEval2 lcd f where - lcd = - { cursorRow = 0 - , cursorCol = 0 - , sizeH = 0 - , sizeW = 0 - , lcdtxt = [] - } - pressed b = rtrn False - -lcdPrintStr str lcd - | lcd.cursorRow < 0 || lcd.cursorRow >= length lcd.lcdtxt || - lcd.cursorCol < 0 || lcd.cursorCol >= size (lcd.lcdtxt !! lcd.cursorRow) - = lcd - # line = lcd.lcdtxt !! lcd.cursorRow - # endPos = size str + lcd.cursorCol - | endPos >= lcd.sizeW - # newLine = line % (0, lcd.cursorCol - 1) + str % (0, size str - lcd.cursorCol) - = {lcd & lcdtxt = updateAt lcd.cursorRow newLine lcd.lcdtxt, cursorCol = lcd.sizeW - 1} - # newLine = line % (0, lcd.cursorCol - 1) + str + line % (endPos, lcd.sizeW - 1) - = {lcd & lcdtxt = updateAt lcd.cursorRow newLine lcd.lcdtxt, cursorCol = endPos} - -printAt :: (v LCD Expr) (v Int b) (v Int c) (v t e) -> v Int Stmt - | lcd, seq v & stringQuotes t -printAt lcd x y z = setCursor lcd x y :. print lcd z - -keySwitch :: (a Int b) (a c d,a c e,a c f,a c g,a c h,a c a0) -> a c Stmt | arith, boolExpr, seq a & If a h a0 b0 & If a g b0 c0 & If a f c0 d0 & If a e d0 e0 & If a d e0 f0 & type c -keySwitch v (right, up, down, left, select, nokey) - = v >>=. \w. - If (w <. lit RightBound) - right - (If (w <. lit UpBound) - up - (If (w <. lit DownBound) - down - (If (w <.lit LeftBound) - left - (If (w <. lit SelectBound) - select - nokey - )))) - -// =================== mTask =================== - - -// ----- dsl definition ----- // - -:: DigitalPin - = D0 | D1 | D2 | D3 | D4 | D5 |D6 | D7 | D8 | D9 | D10 | D11 | D12 | D13 -:: AnalogPin = A0 | A1 | A2 | A3 | A4 | A5 -:: PinMode = INPUT | OUTPUT | INPUT_PULLUP -:: Pin = Digital DigitalPin | Analog AnalogPin instance toCode Pin where toCode (Digital p) = toCode p toCode (Analog p) = toCode p -instance toCode Button where toCode b = toCode (consIndex{|*|} b) -derive consIndex Button -class pin p | type, == p where - pin :: p -> Pin instance pin DigitalPin where pin p = Digital p + instance pin AnalogPin where pin p = Analog p -:: Upd = Upd -:: Expr = Expr -:: Stmt = Stmt -:: MTask = MTask Int // String - -class isExpr a :: a -> Int instance isExpr Upd where isExpr _ = 0 instance isExpr Expr where isExpr _ = 1 -class isStmt a :: a -> Int instance isStmt Upd where isStmt _ = 10 instance isStmt Expr where isStmt _ = 11 instance isStmt Stmt where isStmt _ = 12 @@ -483,104 +38,13 @@ 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 -:: Main a = {main :: a} - unMain :: (Main x) -> x unMain m = m.main //{main=x} = x -class arith v where - lit :: t -> v t Expr | toCode t - (+.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, +, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (-.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, -, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (*.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, *, zero, one t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (/.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, / t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q -class boolExpr v where - (&.) infixr 3 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (|.) infixr 2 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q - Not :: (v Bool p) -> v Bool Expr | isExpr p //& toExpr2 p - (==.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (!=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (<.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (>.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (<=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q - (>=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q -// using functional dependencies -class If v q r ~s where - If :: (v Bool p) (v t q) (v t r) -> v t s | isExpr p & type t -class IF v where - IF :: (v Bool p) (v t q) (v s r) -> v () Stmt | isExpr p - (?) infix 1 :: (v Bool p) (v t q) -> v () Stmt | isExpr p -class var2 v where - var2 :: t ((v t Upd)->(Main (v c s))) -> (Main (v c s)) | type, toCode t - con2 :: t ((v t Expr) ->(Main (v c s))) -> (Main (v c s)) | type t -class sds v where - sds :: ((v t Upd)->In t (Main (v c s))) -> (Main (v c s)) | type, toCode t - con :: ((v t Expr) ->In t (Main (v c s))) -> (Main (v c s)) | type t -class seq v where - (>>=.) infixr 0 :: (v t p) ((v t Expr) -> (v u q)) -> (v u Stmt) | type t & type u - (:.) infixr 0 :: (v t p) (v u q) -> v u Stmt | type t & type u -class step v where - (>>*.) infixl 1 :: (v t p) ((v t Expr) -> [Step v u]) -> v u Stmt | type t & type u -:: Step v t = E.p.q: Cond (v Bool q) (v t p) | E.p: Ever (v t p) -class assign v where - (=.) infixr 2 :: (v t Upd) (v t p) -> v t Expr | type t & isExpr p -class fun v t where - fun :: ((t->v s Expr)->In (t->v s p) (Main (v u q))) -> Main (v u q) | type s -class mtask v a where - task :: (((v delay r) a->v MTask Expr)->In (a->v u p) (Main (v t q))) -> Main (v t q) | type t & type u & isExpr r & long v delay -class lag v where - lag :: (v delay r) (v t p) -> v MTask Expr | type t & long v delay -class setDelay v where - setDelay :: (v Long p) (v MTask Expr) -> (v MTask Expr) | isExpr p -class mtasks v a b where - tasks :: (((v delay r1) a->v MTask Expr, (v delay r2) b->v MTask Expr)->In (a->v t p, b->v u p) (Main (v s q))) -> Main (v s q) | type s & isExpr r1 & isExpr r2 & long v delay -class output v where - output :: (v t p) -> v () Expr | type t & isExpr p -class noOp v where noOp :: v t p - -class pinMode v where - pinmode :: p PinMode -> v () Expr | pin p -class digitalIO v where - digitalRead :: p -> v Bool Expr | pin, readPinD p - digitalWrite :: p (v Bool q) -> v Bool Expr | pin, writePinD p -class analogIO v where - analogRead :: AnalogPin -> v Int Expr - analogWrite :: AnalogPin (v Int p) -> v Int Expr -class dIO v where - dIO :: p -> v Bool Upd | pin, readPinD p -class aIO v where - aIO :: AnalogPin -> v Int Upd -class time v where - delay :: (v Long p) -> (v Long Expr) - millis :: (v Long Expr) - -class pio p t where pio :: p -> v t Upd | aIO v & dIO v instance pio AnalogPin Int where pio p = aIO p instance pio AnalogPin Bool where pio p = dIO p instance pio DigitalPin Bool where pio p = dIO p -a0 = pio A0 -a1 = pio A1 -a2 = pio A2 -a3 = pio A3 -a4 = pio A4 -a5 = pio A5 - -d0 = pio D0 -d1 = pio D1 -d2 = pio D2 -d3 = pio D3 -d4 = pio D4 -d5 = pio D5 -d6 = pio D6 -d7 = pio D7 -d8 = pio D8 -d9 = pio D9 -d10 = pio D10 -d11 = pio D11 -d12 = pio D12 -d13 = pio D13 - int :: (v Int p) -> (v Int p) int x = x bool :: (v Bool p) -> (v Bool p) @@ -588,8 +52,6 @@ bool x = x char :: (v Char p) -> (v Char p) char x = x -class type t | showType, dyn, toCode, ==, type2string, varName t -class type2string t :: t -> String instance type2string Int where type2string _ = "int" instance type2string Long where type2string _ = "long" instance type2string Real where type2string _ = "float" @@ -600,7 +62,7 @@ instance type2string DigitalPin where type2string _ = "int" instance type2string AnalogPin where type2string _ = "int" instance type2string String where type2string _ = "Char []" instance type2string () where type2string _ = "" -class varName a :: a -> String + instance varName Int where varName _ = "vInt" instance varName Long where varName _ = "vLong" instance varName Bool where varName _ = "vBool" @@ -608,12 +70,9 @@ instance varName Char where varName _ = "vChar" instance varName Real where varName _ = "vFloat" instance varName x where varName _ = "" -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 argType f = undef -class argTypes t :: ((t->Code b Expr)->In (t->Code b2 q) (Main (Code c s))) -> t 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) @@ -627,17 +86,14 @@ var2Type x = showType resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b resType2 f = showType2 -:: SV t = SV String instance toCode (SV t) where toCode (SV s) = s -class showType2 t :: SV t instance showType2 () where showType2 = SV "void " instance showType2 Int where showType2 = SV "int " instance showType2 Char where showType2 = SV "char " instance showType2 Bool where showType2 = SV "bool " instance showType2 a where showType2 = SV "word /* default */" -class showType t | showType2 /*, type*/ t :: (Code t p) instance showType () where showType = c "void " instance showType Int where showType = c "int " instance showType Long where showType = c "long " @@ -645,18 +101,15 @@ instance showType Char where showType = c "char " instance showType Bool where showType = c "bool " instance showType a where showType = c "word /* default */ " -class typeSelector t | showType2, type t :: (Code t p) instance typeSelector Int where typeSelector = c ".i" instance typeSelector Char where typeSelector = c ".c" instance typeSelector Bool where typeSelector = c ".b" instance typeSelector a where typeSelector = c ".w" -:: In a b = In infix 0 a b - -read :: Int (ReadWrite a) State -> (a,State) | dyn a -read n Rd s = (fromJust (fromDyn (s.store !! n)), s) -read n (Wrt a) s = (a,{s&store=updateAt n (toDyn a) s.store}) -read n (Updt f) s=:{store} +read` :: Int (ReadWrite a) State -> (a,State) | dyn a +read` n Rd s = (fromJust (fromDyn (s.store !! n)), s) +read` n (Wrt a) s = (a,{s&store=updateAt n (toDyn a) s.store}) +read` n (Updt f) s=:{store} # obj = f (fromJust (fromDyn (store !! n))) = (obj, {s & store = updateAt n (toDyn obj) store}) @@ -733,7 +186,7 @@ instance seq Code where 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 +instance step` Code where (>>*.) x f = getMode \mode. fresh \n. let v = "s" + toCode n in @@ -1317,14 +770,14 @@ 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)))} + >>== \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 + {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)) @@ -1416,7 +869,7 @@ simulate {main=(E f)} = setup state0 where : if (isEmpty s.tasks) [] [OnAction (Action "loop" []) (hasValue - \si.simloop (step (mergeView s si))) + \si.simloop (step` (mergeView s si))) ] ] @@ -1477,8 +930,8 @@ fromDisplayVar (DisplayVar l) dyn = Dyn l | DisplayVar [String] -step :: State -> State -step s = +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 @@ -1498,8 +951,8 @@ instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\"" instance stringQuotes t where stringQuotes x = x -derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, LCD //, Servo -derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, LCD //, Servo +derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo +derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo instance toCode () where toCode _ = "" instance == () where (==) _ _ = True diff --git a/mTaskExamples.icl b/mTaskExamples.icl new file mode 100644 index 0000000..dbe2ca7 --- /dev/null +++ b/mTaskExamples.icl @@ -0,0 +1,257 @@ +module mTaskExamples + +import iTasks +import gdynamic, gCons, GenEq, StdMisc, StdArray +import mTask + +Start = + [["//mTaskTFP16_3 \n"] + ,["// --- p1 \n"] + ,compile p1 + ,["// --- p2 \n"] + ,compile p2 + ,["// --- p3 \n"] + ,compile p3 + ,["// --- p4 \n"] + ,compile p4 + ,["// --- p5 \n"] + ,compile p5 + ,["// --- p6 \n"] + ,compile p6 + ,["// --- p7 \n"] + ,compile p7 + ,["// --- p8 \n"] + ,compile p8 + ,["// --- p9 \n"] + ,compile p9 + ,["// --- p10 \n"] + ,compile p10 + ,["// --- p11 \n"] + ,compile p11 + ,["// --- p12 \n"] + ,compile p12 + ,["// --- fac \n"] + ,compile fac + ,["// --- blink \n"] + ,compile blink + ,["// --- heatingDemo \n"] + ,compile heatingDemo + ,["// --- hpinDemo \n"] + ,compile pinDemo + ,["// --- blink2 \n"] + ,compile blink2 + ,["// --- blink3 \n"] + ,compile blink3 + ,["// --- blinks \n"] + ,compile blinks + ,["// --- lcdCount \n"] + ,compile lcdCount + + ,["// --- heating \n"] + ,compile heating + ] + +lcdHello = LCD 16 2 [] \lcd = {main = print lcd (lit "Hello world")} + +lcdCount = + LCD 16 2 [] \lcd = + task \t = (\c. + If (pressed upButton) ( + setCursor lcd Zero Zero :. + print lcd c :. + t (sec 1) (c +. One) + ) (t (msec 10) c)) In + {main = t (sec 0) Zero} + +printD0 = {main = serialPrint (Not d0)} + +print36 = sds \x = 6 In {main = x =. x *. x :. serialPrint x} + +pinDemo = + {main = a1 =. a0 =. lit 1 +. a0 :. a0 =. Not a0} + +fac = fun \fac = (\n. If (n <. One) One (n *. fac (n -. One))) + In {main = fac (lit 6)} +One = lit 1 +Zero = lit 0 + +blink = + task \t = (\s. setLED s :. t (If s (sec 1) (sec 3)) (Not s)) In {main = t (sec 0) (lit True)} +blink2 = + task \t = (\(). d13 =. Not d13 :. t (sec 1) ()) In {main = t (sec 0) ()} +blink3 = + task \t = (\s. d13 =. s :. t (If s (msec 100) (sec 1)) (Not s)) In {main = t (sec 0) (lit False)} +blinks = + task \t = (\b. d13 =. b :. t (sec 1) b) In {main = t (msec 0) true :. t (msec 100) false} + +setLED b = d13 =. b +sec n = long (lit (n * 1000)) +msec n = long (lit n) + +qt = task \plus = (\(x,y).x +. y) In {main = plus (sec 0) (lit 3, lit 4)} +qs = fun \plus = (\(x,y).x +. y) In {main = plus (lit 3, lit 4)} + +q1 = + tasks \(switch, heat) = + (\s1 = digitalWrite D2 s1:. heat (sec 60) s1 + ,\s2 = analogRead A3 >>*. \v. + [Cond (v >. upper) (switch (sec 0) off) + ,Cond (v <. lower) (switch (sec 0) on) + ,Ever (heat (sec 1) s2) + ]) + In {main = heat (sec 0) off} +where + upper = lit 876 + lower = lit 123 + +serialReadInt = serialParseInt >>=. \i. serialRead >>*. \c. [Cond (c ==. lit '\n') i] + +heating = + sds \goal = 500 In + fun \switch = (\s. d13 =. s) In + task \control = (\isOn. + a0 <. goal >>*. \mustOn. + [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on) + ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off) + ,Ever (control (msec 100) isOn) + ]) In + task \change = (\(). + serialAvailable ? (serialReadInt >>=. \g.goal =. g) :. + change (sec 1) ()) In + {main = switch off :. control (sec 0) off :. change (sec 1) ()} +where + minOnTime = sec 2 + minOffTime = sec 1 + +heating2 = + sds \goal = 500 In +// fun \switch = setLED In + fun \switch = (\b. setLED b :. serialPrintln b) In + task \control = (\isOn. + a0 <. goal >>*. \mustOn. + [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on) + ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off) + ,Ever (control (msec 100) isOn) + ]) In + task \change = (\(). + serialAvailable ? (serialReadInt >>=. \i. serialPrintln (goal =. i)) :. + change (sec 1) ()) In + {main = switch off :. control (sec 0) off :. change (sec 1) ()} +where + minOnTime = sec 2 + minOffTime = sec 1 + +thermoTask = + sds \goal = 500 In + fun \switch = (\on. d13 =. bool on :. a0 =. on) In + task \control = + (\isOn. a0 <. goal >>*. \mustOn. + [Cond (mustOn &. Not isOn) (switch mustOn :. control minOnTime mustOn) + ,Cond (Not mustOn &. isOn) (switch mustOn :. control minOffTime mustOn) + ,Ever (control (msec 100) isOn) + ]) In + {main = switch off :. control (sec 0) off} +where + minOnTime = sec 1 // 60 + minOffTime = sec 2 //10 + off = lit False + +heatingDemo = + sds \heat = False In + sds \temp = 500 In + LCD 16 2 [] \lcd. + task \tempChange = (\(). + lit 0 <. temp &. Not heat ? temp =. temp -. One:. + temp <. lit 1000 &. heat ? temp =. temp +. One :. + setCursor lcd (lit 5) Zero :. + print lcd (lit "temp ") :. + print lcd temp :. + print lcd (lit " ") :. + tempChange (msec 789) ()) In + fun \switch = (\s. + heat =. s :. + setCursor lcd Zero Zero :. + If s + (print lcd (lit "On ")) + (print lcd (lit "Off"))) In + fun \measure = (\(). + analogRead A0 >>=. \a0. + setCursor lcd Zero One :. + print lcd a0 :. + print lcd (lit " ") :. + a0) In + task \control = (\isOn. + measure () >>=. \val.temp <. val + >>*. \mustOn. + [Cond (Not isOn &. mustOn) (switch on :. control minOnTime on) + ,Cond (isOn &. Not mustOn) (switch off:. control minOffTime off) + ,Ever (control (msec 100) isOn) + ] + ) In + {main = switch off :. control (msec 10) off :. tempChange (sec 0) ()} +where + limit = lit 512 + minOnTime = sec 3 + minOffTime = sec 2 +true = lit True +on = true +false = lit False +off = false + +count = + LCD 16 2 [] \lcd. + task \count = (\n. + setCursor lcd Zero Zero :. + print lcd n :. + count (sec 1) (n +. One)) In + {main = count (sec 0) Zero} + +p0 = sds \x = 6 In {main = x =. x *. lit 7} +p1 = {main = lit 2 +. lit 4 >>=. \x. (x +. lit 1) *. x} +p2 = + fun \f. (\x. lit 6 *. x) + In {main = lit 3 +. lit 4 >>=. \x. f x} +p3 = + fun \f. (\x. lit 6 *. x) + In {main = lit 3 +. lit 4 >>=. f} // higher order, somewhat remarkable that this works +p4 = + fun \f. (\x. lit 6 *. x) + In {main = lit 3 +. lit 4 >>=. \x. f x >>=. serialPrint} +p5 = {main = lit 7 >>*. \x. [Cond (x <. lit 36) (x *. x),Ever (lit 42)]} +p6 = sds \y = 1 In {main = lit 7 >>*. \x. [Cond (x <. lit 36) (y =. x *. x),Ever (y =. x)]} +p7 = sds \y = 1 In {main = y +. lit 1 >>*. \x. [Cond (x <. lit 36) ((y =. x *. x) >>*. \z.[Cond (z ==. x) y, Ever y]),Ever (y =. x)]} +p8 = sds \y = 1 In {main = pressed upButton >>*. \x. [Cond x (y =. y +. y),Ever (y =. lit 36)]} +//p8 = sds \y = 1 In {main = pressed upButton >>*. \x. [Cond x ((y =. lit 42) >>*. \z.[Cond (z ==. y) y, Ever y]),Ever (y =. lit 36)]} +//p9 = {main = If (pressed upButton) (lit 1) (lit 7)} // Overloading error [mTaskTFP16.icl,61,p9]: "isExpr" no instance available of type Stmt +p9 = {main = pressed upButton >>=. \b.If b (lit 1) (lit 7)} +p10 = + sds \y = 1 In + {main = + (pressed upButton >>*. \x. + [Cond x (y =. y +. y :. + x) + ,Ever (y =. lit 36 :. + lit False) + ]) + >>=. \z. z &. z} +p11 = + sds \y = 1 In + {main = + y =. lit 2 :. + (pressed upButton >>=. \b. + If b + (y =. lit 3 :. + y +. lit 1) + (lit 42)) + >>*. \x. + [Cond (x <. lit 36) + ((y =. x *. x) >>*. \z. + [Cond (z ==. x) (serialPrint y) + ,Ever (serialPrint (lit 0)) + ]) + ,Ever (y =. x) + ] + } +p12 = + task \t = (\(). pressed upButton >>*. \b.[Cond b (serialPrintln (lit 7)),Ever (t (lit 250) ():. lit 0)]) In + {main = t (lit 0) ()} diff --git a/mTaskLCD.dcl b/mTaskLCD.dcl new file mode 100644 index 0000000..cd912cf --- /dev/null +++ b/mTaskLCD.dcl @@ -0,0 +1,47 @@ +definition module mTaskLCD + +import mTask + +:: LCD = + { cursorRow :: Int + , cursorCol :: Int + , sizeH :: Int + , sizeW :: Int + , lcdtxt :: [String] + } + +:: Button = RightButton | UpButton | DownButton | LeftButton | SelectButton | NoButton + +class lcd v where + begin :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr + print :: (v LCD Expr) (v t p) -> v Int Expr | stringQuotes t // returns bytes written + setCursor :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr + liquidCrystal0 :: [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q) + LCD :: Int Int [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q) + scrollLeft :: (v LCD Expr) -> v () Expr + scrollRight :: (v LCD Expr) -> v () Expr + pressed :: (v Button Expr) -> v Bool Expr + +instance lcd Code +instance lcd Eval + +printAt :: (v LCD Expr) (v Int b) (v Int c) (v t e) -> v Int Stmt | lcd, seq v & stringQuotes t +keySwitch :: (a Int b) (a c d,a c e,a c f,a c g,a c h,a c a0) -> a c Stmt | arith, boolExpr, seq a & If a h a0 b0 & If a g b0 c0 & If a f c0 d0 & If a e d0 e0 & If a d e0 f0 & type c + +derive toGenDynamic LCD +derive fromGenDynamic LCD + +instance toCode Button + +RightBound :== 50 +UpBound :== 190 +DownBound :== 380 +LeftBound :== 555 +SelectBound :== 790 + +rightButton :== lit RightButton +upButton :== lit UpButton +downButton :== lit DownButton +leftButton :== LeftButton +selectButton :== lit SelectButton +noButton :== lit NoButton diff --git a/mTaskLCD.icl b/mTaskLCD.icl new file mode 100644 index 0000000..56b4eb4 --- /dev/null +++ b/mTaskLCD.icl @@ -0,0 +1,133 @@ +implementation module mTaskLCD + +import iTasks +import gdynamic, gCons, GenEq, StdMisc, StdArray +import mTask + +derive consIndex Button +derive toGenDynamic LCD +derive fromGenDynamic LCD + +:: LCD = + { cursorRow :: Int + , cursorCol :: Int + , sizeH :: Int + , sizeW :: Int + , lcdtxt :: [String] + } + +:: Button = RightButton | UpButton | DownButton | LeftButton | SelectButton | NoButton + +class lcd v where + begin :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr + print :: (v LCD Expr) (v t p) -> v Int Expr | stringQuotes t // returns bytes written + setCursor :: (v LCD Expr) (v Int p) (v Int q) -> v () Expr + liquidCrystal0 :: [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q) + LCD :: Int Int [DigitalPin] ((v LCD Expr)->Main (v b q)) -> Main (v b q) + scrollLeft :: (v LCD Expr) -> v () Expr + scrollRight :: (v LCD Expr) -> v () Expr + pressed :: (v Button Expr) -> v Bool Expr + +instance lcd Code where + begin v x y = embed (v +.+ c ".begin" +.+ codeOp2 x ", " y) + print v x = embed (v +.+ c ".print (" +.+ stringQuotes x +.+ c ")") + setCursor v x y = embed (v +.+ c ".setCursor" +.+ codeOp2 x ", " y) + scrollLeft v = embed (v +.+ c ".scrollDisplayLeft()") + scrollRight v = embed (v +.+ c ".scrollDisplayRight()") + liquidCrystal0 [] f = liquidCrystal0 [D8, D9, D4, D5, D6, D7] f + liquidCrystal0 pins f = + {main = + getCode \cd. fresh \n. + let + name = "lcd" + toString n + rest = f (c name) + in + include "LiquidCrystal" +.+ + setCode Var +.+ + c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+ + setCode cd +.+ + rest.main + } + LCD x y [] f = LCD x y [D8, D9, D4, D5, D6, D7] f + LCD x y pins f = + {main = + getCode \cd. fresh \n. + let + name = "lcd" + toString n + rest = f (c name) + in + include "LiquidCrystal" +.+ + setCode Var +.+ + c ("LiquidCrystal " + name + "(" + argList pins + ");\n") +.+ + setCode Setup +.+ + c (name + ".begin(" + toCode x + ", " + toCode y +");") +.+ nl +.+ + setCode cd +.+ + rest.main + } + pressed b = embed (c "pressed(" +.+ setMode SubExp +.+ b +.+ c ")") + +instance lcd Eval where + begin (E v) x y = + x >>== \w. + y >>== \h. + yield () (E \r.v (Updt \lcd.{lcd & sizeH = h, sizeW = w, lcdtxt = repeatn h (toString (repeatn w ' '))})) + print (E v) x = + x >>== \a. let str = toCode a in + yield (size str) (E \r.v (Updt \lcd.lcdPrintStr str lcd)) + setCursor (E v) x y = + x >>== \w. + y >>== \h. + yield () (E \r.v (Updt \lcd.{lcd & cursorRow = h, cursorCol = w})) + scrollLeft v = rtrn () + scrollRight v = rtrn () + LCD w h pins f = defEval2 lcd f where + lcd = + { cursorRow = 0 + , cursorCol = 0 + , sizeH = h + , sizeW = w + , lcdtxt = repeatn h (toString (repeatn w ' ')) + } + liquidCrystal0 pins f = defEval2 lcd f where + lcd = + { cursorRow = 0 + , cursorCol = 0 + , sizeH = 0 + , sizeW = 0 + , lcdtxt = [] + } + pressed b = rtrn False + +lcdPrintStr str lcd + | lcd.cursorRow < 0 || lcd.cursorRow >= length lcd.lcdtxt || + lcd.cursorCol < 0 || lcd.cursorCol >= size (lcd.lcdtxt !! lcd.cursorRow) + = lcd + # line = lcd.lcdtxt !! lcd.cursorRow + # endPos = size str + lcd.cursorCol + | endPos >= lcd.sizeW + # newLine = line % (0, lcd.cursorCol - 1) + str % (0, size str - lcd.cursorCol) + = {lcd & lcdtxt = updateAt lcd.cursorRow newLine lcd.lcdtxt, cursorCol = lcd.sizeW - 1} + # newLine = line % (0, lcd.cursorCol - 1) + str + line % (endPos, lcd.sizeW - 1) + = {lcd & lcdtxt = updateAt lcd.cursorRow newLine lcd.lcdtxt, cursorCol = endPos} + +printAt :: (v LCD Expr) (v Int b) (v Int c) (v t e) -> v Int Stmt + | lcd, seq v & stringQuotes t +printAt lcd x y z = setCursor lcd x y :. print lcd z + +keySwitch :: (a Int b) (a c d,a c e,a c f,a c g,a c h,a c a0) -> a c Stmt | arith, boolExpr, seq a & If a h a0 b0 & If a g b0 c0 & If a f c0 d0 & If a e d0 e0 & If a d e0 f0 & type c +keySwitch v (right, up, down, left, select, nokey) + = v >>=. \w. + If (w <. lit RightBound) + right + (If (w <. lit UpBound) + up + (If (w <. lit DownBound) + down + (If (w <.lit LeftBound) + left + (If (w <. lit SelectBound) + select + nokey + )))) + +instance toCode Button where toCode b = toCode (consIndex{|*|} b) diff --git a/mTaskSerial.dcl b/mTaskSerial.dcl new file mode 100644 index 0000000..0e01ce5 --- /dev/null +++ b/mTaskSerial.dcl @@ -0,0 +1,23 @@ +definition module mTaskSerial + +import mTask + +class serial v where + serialAvailable :: (v Bool Expr) + serialPrint :: (v t p) -> v Int Expr | stringQuotes t & isExpr p + serialPrintln :: (v t p) -> v Int Expr | stringQuotes t & isExpr p + serialRead :: (v t Expr) + serialParseInt :: (v Int Expr) + +instance serial Code +instance serial Eval + +class char2int v :: (v Char p) -> v Int Expr +instance char2int Code + +:: SerialObject v t p = + { available :: v Bool Expr + , print :: (v t p) -> v Int Expr + , println :: (v t p) -> v Int Expr + , read :: (v Char Expr) + } diff --git a/mTaskSerial.icl b/mTaskSerial.icl new file mode 100644 index 0000000..e0e9f58 --- /dev/null +++ b/mTaskSerial.icl @@ -0,0 +1,28 @@ +implementation module mTaskSerial + +import iTasks +import gdynamic, gCons, GenEq, StdMisc, StdArray +import mTask + +instance serial Code where + serialAvailable = embed (c "Serial.available()") + serialPrint x = embed (c "Serial.print(" +.+ x +.+ c ")") + serialPrintln x = embed (c "Serial.println(" +.+ x +.+ c ")") + serialRead = embed (c "Serial.read()") + serialParseInt = embed (c "Serial.parseInt()") + +instance serial Eval where + serialAvailable = rtrn False + serialPrint x = x >>== \a.E \r s.let str = toCode a in (size str,{s & serial = s.serial ++ [str]}) + serialPrintln x = x >>== \a.E \r s.let str = toCode a + "\n" in (size str,{s & serial = s.serial ++ [str]}) + serialRead = rtrn undef + serialParseInt = rtrn undef + +instance char2int Code where char2int (C f) = C \rw c.f Rd c + +:: SerialObject v t p = + { available :: v Bool Expr + , print :: (v t p) -> v Int Expr + , println :: (v t p) -> v Int Expr + , read :: (v Char Expr) + } -- 2.20.1