-I $(CLEAN_HOME)/lib/TCPIP\
-I ./CleanSerial
-all: mTask
+all: mTaskExamples
%: %.icl
$(CLM) $(CLMLIBS) $(CLMFLAGS) $(basename $<) -o $@
--- /dev/null
+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
-module mTask
+implementation module mTask
/*
Pieter Koopman pieter@cs.ru.nl
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
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)
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"
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"
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)
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 "
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})
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
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))
: if (isEmpty s.tasks)
[]
[OnAction (Action "loop" []) (hasValue
- \si.simloop (step (mergeView s si)))
+ \si.simloop (step` (mergeView s si)))
]
]
| 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
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
--- /dev/null
+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) ()}
--- /dev/null
+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
--- /dev/null
+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)
--- /dev/null
+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)
+ }
--- /dev/null
+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)
+ }
repositories / mTask.git / commitdiff