diff options
Diffstat (limited to 'assignment-13/ufpl.icl')
| -rw-r--r-- | assignment-13/ufpl.icl | 217 |
1 files changed, 217 insertions, 0 deletions
diff --git a/assignment-13/ufpl.icl b/assignment-13/ufpl.icl new file mode 100644 index 0000000..73d1ff0 --- /dev/null +++ b/assignment-13/ufpl.icl @@ -0,0 +1,217 @@ +implementation module ufpl + +import StdArray +import StdBool +import StdClass +from StdFunc import const, flip, id, o +from StdGeneric import :: Bimap{..}, bimapId; bm :== bimapId +import StdInt +import StdList +import StdMisc +import StdOverloaded +import StdString +import StdTuple + +from Data.Func import $ +import Data.List + +import Arduino +import Bootstrap +import C +import Util + +typedfun :: CType String -> String +typedfun t f = flip (+++) f case t of + CTBool -> "b" + CTInt s -> sig s +++ "i" + CTChar s -> sig s +++ "c" + CTLong s -> sig s +++ "l" +where + sig :: Signedness -> String + sig Sig = "" + sig Unsig = "u" + +append :: Shares Shares -> Shares +append NoShares ss = ss +append (Shares s ss) sss = Shares s (append ss sss) + +removeDupShares :: Shares -> Shares +removeDupShares NoShares = NoShares +removeDupShares (Shares s ss) = if exists id (Shares s) (removeDupShares ss) +where + exists = any (\s` -> s.sname == s`) (sharesMap (\s -> s.sname) ss) + +sharesMap :: (A.t rw: (Shared t rw) -> a) Shares -> [a] +sharesMap _ NoShares = [] +sharesMap f (Shares s ss) = [f s:sharesMap f ss] + +instance allShares [t] | allShares t +where + allShares` [] = NoShares + allShares` [x:xs] = append (allShares` x) (allShares` xs) + +instance allShares (Expr t rw) +where + allShares` (ELit _) = NoShares + allShares` (EShared s) = Shares s NoShares + allShares` (a +. b) = append (allShares` a) (allShares` b) + allShares` (a -. b) = append (allShares` a) (allShares` b) + allShares` (a *. b) = append (allShares` a) (allShares` b) + allShares` (a /. b) = append (allShares` a) (allShares` b) + allShares` (EEq _ a b) = append (allShares` a) (allShares` b) + allShares` (ELt _ a b) = append (allShares` a) (allShares` b) + allShares` (EAnd _ a b) = append (allShares` a) (allShares` b) + allShares` (EOr _ a b) = append (allShares` a) (allShares` b) + allShares` (EIf b t e) = append (allShares` b) (append (allShares` t) (allShares` e)) + +instance allShares Trigger +where + allShares` (Change t) = allShares` t + allShares` (s ?= t) = append (allShares` s) (allShares` t) + allShares` (a ?& b) = append (allShares` a) (allShares` b) + allShares` (a ?| b) = append (allShares` a) (allShares` b) + +instance allShares Rule +where + allShares` (s <# e) = append (allShares` s) (allShares` e) + allShares` (When t rs) = foldr1 append [allShares` t:map allShares` rs] + allShares` (t >>> rs) = foldr1 append [allShares` t:map allShares` rs] + allShares` (SetCursor (c,r)) = append (allShares` c) (allShares` r) + allShares` (Print v) = allShares` v + +instance allShares NamedRule +where + allShares` (_ :=: r) = allShares` r + +instance Expr Int where litExpr i = CEInt i +instance Expr Bool where litExpr b = CEBool b +instance Expr Char where litExpr c = CEChar c + +lit :: (t -> Expr t RO) +lit = ELit + +(?) infix 4 :: (Expr Bool rwa) (Expr t rwb, Expr t rwc) -> Expr t RO +(?) b (t,e) = EIf b t e + +(==.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, == t +(==.) a b = EEq bm a b + +(<.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, < t +(<.) a b = ELt bm a b + +(>.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, < t +(>.) a b = ELt bm b a + +(&&.) infixr 3 :: (Expr Bool rwa) (Expr Bool rwb) -> Expr Bool RO +(&&.) a b = EAnd bm a b + +(||.) infixr 4 :: (Expr Bool rwa) (Expr Bool rwb) -> Expr Bool RO +(||.) a b = EOr bm a b + +instance :. Rule where (:.) a b = [a,b] +instance :. [Rule] where (:.) r rs = [r:rs] + +instance ||| NamedRule where (|||) a b = [a,b] +instance ||| [NamedRule] where (|||) r rs = [r:rs] + +instance gen (Expr t rw) CExpr | Expr t +where + gen (ELit v) = litExpr v + gen (EShared s) = CEGlobal ("s" +++ s.sname +++ ".val") + gen (a +. b) = CEInfix "+" (gen a) (gen b) + gen (a -. b) = CEInfix "-" (gen a) (gen b) + gen (a *. b) = CEInfix "*" (gen a) (gen b) + gen (a /. b) = CEInfix "/" (gen a) (gen b) + gen (EEq _ a b) = CEInfix "==" (gen a) (gen b) + gen (ELt _ a b) = CEInfix "<" (gen a) (gen b) + gen (EAnd _ a b) = CEInfix "&&" (gen a) (gen b) + gen (EOr _ a b) = CEInfix "||" (gen a) (gen b) + gen (EIf b t e) = CEIf (gen b) (gen t) (gen e) + +instance gen Trigger CExpr +where + gen (Change (EShared shr)) = CEApp (typedfun shr.stype "dirty") [CERef (CEGlobal ("s" +++ shr.sname))] + gen (EShared shr ?= e) = CEInfix "&&" (gen (Change (EShared shr))) (CEInfix "==" (CEGlobal ("s" +++ shr.sname +++ ".val")) (gen e)) + gen (a ?& b) = CEInfix "&&" (gen a) (gen b) + gen (a ?| b) = CEInfix "||" (gen a) (gen b) + +instance gen Rule CBody +where + gen (EShared shr <# val) = CBExpr (CEApp (typedfun shr.stype "set") [CERef (CEGlobal ("s" +++ shr.sname)), gen val]) + gen (When b rs) = CBIf (gen b) (gen rs) CBEmpty + gen (t >>> rs) = CBIf (gen t) (gen rs) CBEmpty + gen (SetCursor (c,r)) = CBExpr (CEApp "lcd.setCursor" [gen c, gen r]) + gen (Print e) = CBExpr (CEApp "lcd.print" [gen e]) + +instance gen [r] CBody | gen r CBody +where + gen [] = CBEmpty + gen rs = foldr1 CBSeq (map gen rs) + +instance gen NamedRule CFun +where + gen (name :=: rs) = + { params = [] + , body = gen rs + , fresh = 0 + , type = CTVoid + , name = "t" +++ name + } + +instance gen (Shared t rw) CVar +where + gen shr = + { name = "s" +++ shr.sname + , type = CTStruct (typedfun shr.stype "share") + , value = shr.srepr.map_to shr.sinit + } + +instance gen [NamedRule] String +where + gen rs = foldl1 (+++) $ + [rts] ++ + ["\n" +++ printToString var \\ var <- sharesMap genv (allShares rs)] ++ + ["\n" +++ printToString (genf rule) \\ rule <- rs] + where + genf :: (NamedRule -> CFun) + genf = gen + + genv :: ((Shared t rw) -> CVar) + genv = gen + +Start :: String +Start = gen example_score + +example_score :: [NamedRule] +example_score = + "a" :=: b0 ?= true >>> [scorea <# scorea +. lit 1] + ||| "b" :=: b1 ?= true >>> [scoreb <# scoreb +. lit 1] + ||| "r" :=: b2 ?= true >>> [scorea <# lit 0, scoreb <# lit 0] + ||| "print" :=: Change scorea ?| Change scoreb >>> + SetCursor (lit 0, lit 0) :. + Print scorea :. + Print (lit '-') :. + Print scoreb +where + scorea = rwInt "scorea" 0 + scoreb = rwInt "scoreb" 0 + +example_countdown :: [NamedRule] +example_countdown = + "time" :=: + When (millis -. DELAY >. counter) + (counter <# counter +. DELAY :. + seconds <# seconds -. lit 1 :. + SetCursor (lit 0, lit 0) :. + Print minutes :. + Print (lit ':') :. + Print seconds) + :. When (seconds ==. lit 0) (seconds <# lit 60 :. minutes <# minutes -. lit 1) + ||| "status" :=: + When (seconds ==. lit 60 &&. minutes ==. lit 0) [running <# false] +where + running = rwBool "running" False + minutes = rwUInt "minutes" 0 + seconds = rwUInt "seconds" 0 + counter = rwULong "counter" 1000 // If set to 0, this will overflow on first iteration + DELAY = lit 1000 |