1 files changed, 92 insertions, 21 deletions

diff --git a/assignment-13/uFPL.icl b/assignment-13/uFPL.icl
index 23bf85c..b87538e 100644
--- a/assignment-13/uFPL.icl
+++ b/assignment-13/uFPL.icl
@@ -6,14 +6,21 @@ import StdClass
 from StdFunc import const, flip, id, o
 from StdGeneric import :: Bimap{..}, bimapId; bm :== bimapId
 import StdInt
-import StdList
+from StdList import any, map, instance fromString [a]
 import StdMisc
 import StdOverloaded
 import StdString
 import StdTuple
 
+import Control.Applicative
+import Control.Monad
 from Data.Func import $
-import Data.List
+import Data.Functor
+import Data.Maybe
+from Data.List import intersperse, foldr1
+import Data.Map
+import Data.Tuple
+from Text import class Text(concat), instance Text String
 
 import uFPL.Arduino
 import uFPL.Bootstrap
@@ -172,20 +179,7 @@ where
 		, 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 :: ((UShared t rw) -> CVar)
-		genv = gen
-
-instance gen NamedRule   CProg
+instance gen NamedRule CProg
 where
 	gen r = combinePrograms zero
 		{ bootstrap = ""
@@ -197,7 +191,83 @@ instance gen [NamedRule] CProg
 where
 	gen rs = foldr (combinePrograms o gen) zero rs
 
-Start w = startEngine (simulate example_countdown) w
+instance toString Display
+where
+	toString d = concat $ intersperse "\n"
+		[{char c r \\ c <- [0..cols - 1]} \\ r <- [0..rows - 1]]
+	where
+		(cols,rows) = d.size
+
+		char :: Int Int -> Char
+		char c r = case get (c,r) d.text of
+			Just c  -> c
+			Nothing -> ' '
+
+display :: String Display -> Display
+display s dis = foldr (\c -> next o write c) dis (fromString s)
+where
+	write :: Char Display -> Display
+	write v dis = {dis & text=put dis.cursor v dis.text}
+
+	next :: Display -> Display
+	next dis = {dis & cursor=(nc,nr)}
+	where
+		(c,r) = dis.cursor
+		(cols,rows) = dis.size
+		nc = if (c == cols - 1) 0 (c + 1)
+		nr = if (c == cols - 1) (if (r == rows - 1) 0 (r + 1)) r
+
+eval :: (Expr t rw) State -> Maybe t | Expr t
+eval (ELit l) _ = Just l
+eval (EShared s) st = case get s.sname st.vars of
+	Just {val=v :: t^} -> Just v
+	_                  -> Nothing
+eval (a +. b) st = onEval (+) st a b
+eval (a -. b) st = onEval (-) st a b
+eval (a *. b) st = onEval (*) st a b
+eval (a /. b) st = onEval (/) st a b
+eval (EEq  bm a b) st = bm.map_from <$> onEval (==) st a b
+eval (ELt  bm a b) st = bm.map_from <$> onEval (<)  st a b
+eval (EAnd bm a b) st = bm.map_from <$> onEval (&&) st a b
+eval (EOr  bm a b) st = bm.map_from <$> onEval (||) st a b
+eval (EIf b t e) st = liftA3 (\b t e -> if b t e) (eval b st) (eval t st) (eval e st)
+
+onEval :: (t u -> v) State (Expr t rwa) (Expr u rwb) -> Maybe v | Expr t & Expr u
+onEval f st a b = liftA2 f (eval a st) (eval b st)
+
+evalTrigger :: Trigger State -> Maybe (Bool, State)
+evalTrigger (Change (EShared s)) st = case get s.sname st.vars of
+	Just shr=:{dirty=n} | n > 0 -> Just (True, {st & vars=put s.sname {shr & dirty=n-1} st.vars})
+	Just shr                    -> Just (False, st)
+	_                           -> Nothing
+evalTrigger (EShared s ?= e) st = case get s.sname st.vars of
+	Just shr=:{dirty=n} | n > 0 -> eval e st >>= \e -> flip tuple st <$> equals shr.val e
+	Just shr                    -> Just (False, st)
+	_                           -> Nothing
+where
+	equals :: Dynamic t -> Maybe Bool | ==, TC t
+	equals (v :: t^) x = Just (v == x)
+	equals _         _ = Nothing
+evalTrigger (a ?& b) st = evalTrigger a st >>= \(a,st) -> appFst ((&&) a) <$> evalTrigger b st
+evalTrigger (a ?| b) st = evalTrigger a st >>= \(a,st) -> appFst ((||) a) <$> evalTrigger b st
+
+instance run [r] | run r where run rs = flip (foldM (flip run)) rs
+
+instance run Rule
+where
+	run (EShared s <# e) = \st -> eval e st >>= \e -> case get s.sname st.vars of
+		Just shr -> Just {st & vars=put s.sname {shr & val=dynamic e, dirty=shr.subscriptions} st.vars}
+		Nothing  -> Nothing
+	run (When b rs) = \st -> eval b st >>= \b -> if b (run rs) Just st
+	run (t >>> rs) = \st -> evalTrigger t st >>= \(b,st) -> if b (run rs) Just st
+	run (SetCursor (c,r)) = \st -> eval c st >>= \c -> eval r st >>= \r -> Just {State | st & display.cursor=(c,r)}
+	run (Print e) = \st -> eval e st >>= \e -> Just {State | st & display=display (toString e) st.State.display}
+
+instance run NamedRule
+where
+	run (_ :=: r) = run r
+
+Start w = simulate example_countdown w
 Start _ = printToString (genp example_score)
 where
 	genp :: (a -> CProg) | gen a CProg
@@ -220,14 +290,15 @@ where
 example_countdown :: [NamedRule]
 example_countdown =
 		"time" :=:
-			When (millis -. DELAY >. counter)
-				(counter <# counter +. DELAY :.
+			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)
+				Print seconds
+			) :.
+			When (seconds ==. lit 0) (seconds <# lit 60 :. minutes <# minutes -. lit 1)
 	||| "status" :=:
 			When (seconds ==. lit 60 &&. minutes ==. lit 0) [running <# false]
 where