Start with assignment 13

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