diff options
Diffstat (limited to 'assignment-13/ufpl.icl')
| -rw-r--r-- | assignment-13/ufpl.icl | 235 |
1 files changed, 0 insertions, 235 deletions
diff --git a/assignment-13/ufpl.icl b/assignment-13/ufpl.icl deleted file mode 100644 index bfd8a8a..0000000 --- a/assignment-13/ufpl.icl +++ /dev/null @@ -1,235 +0,0 @@ -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 (Shared t rw) CVar -where - gen shr = - { name = "s" +++ shr.sname - , type = CTStruct (typedfun shr.stype "share") - , value = CEStruct - [ ("val", shr.srepr.map_to shr.sinit) - , ("dirty", CEInt 0) - , ("subscriptions", CEInt 0) - ] - } - -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 [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 - -instance gen NamedRule CProg -where - gen r = combinePrograms zero - { bootstrap = "" - , globals = sharesMap gen (allShares r) - , funs = [gen r] - } - -instance gen [NamedRule] CProg -where - gen rs = foldr (combinePrograms o gen) zero rs - -Start = printToString (genp example_score) -where - genp :: (a -> CProg) | gen a CProg - genp = gen - -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 |