Continue iTasks simulator

4 files changed, 153 insertions, 84 deletions

diff --git a/assignment-13/uFPL/Bootstrap.dcl b/assignment-13/uFPL/Bootstrap.dcl
index 201957c..583dc75 100644
--- a/assignment-13/uFPL/Bootstrap.dcl
+++ b/assignment-13/uFPL/Bootstrap.dcl
@@ -32,6 +32,8 @@ millis :: Expr Int RO
 false :: Expr Bool RO
 true :: Expr Bool RO
 
+predefShares :: Shares
+
 rts :: String
 
 instance zero CProg
diff --git a/assignment-13/uFPL/Bootstrap.icl b/assignment-13/uFPL/Bootstrap.icl
index b0ccf66..1ca75ac 100644
--- a/assignment-13/uFPL/Bootstrap.icl
+++ b/assignment-13/uFPL/Bootstrap.icl
@@ -1,10 +1,12 @@
 implementation module uFPL.Bootstrap
 
-from StdFunc import const
+from StdFunc import const, o
 import StdGeneric
 from StdMisc import undef
 import StdString
 
+from Data.Func import $
+
 import uFPL.Arduino
 import uFPL.C
 import uFPL
@@ -72,6 +74,19 @@ false = lit False
 true :: Expr Bool RO
 true = lit True
 
+predefShares :: Shares
+predefShares
+	= share b0
+	$ share b1
+	$ share b2
+	$ share b3
+	$ share b4
+	$ share millis
+	NoShares
+where
+	share :: ((Expr t rw) Shares -> Shares) | Expr t
+	share = Shares o (\(EShared s) -> s)
+
 rts :: String
 rts =
 	"#include <LiquidCrystal.h>" +:
@@ -117,4 +132,4 @@ where
 		"	return 0;" +:
 		"}"
 
-instance zero CProg where zero = {bootstrap=rts, globals=[], funs=[]}
+instance zero CProg where zero = {bootstrap=rts, globals=sharesMap gen predefShares, funs=[]}
diff --git a/assignment-13/uFPL/Sim.dcl b/assignment-13/uFPL/Sim.dcl
index f30e107..b4d8528 100644
--- a/assignment-13/uFPL/Sim.dcl
+++ b/assignment-13/uFPL/Sim.dcl
@@ -2,8 +2,6 @@ definition module uFPL.Sim
 
 from Data.Map import :: Map
 
-import iTasks
-
 import uFPL
 from uFPL.C import :: Signedness
 
@@ -11,12 +9,10 @@ from uFPL.C import :: Signedness
 	= LiftException String
 	| NoShareException ISharedRef
 	| WriteToROShare ISharedRef
+	| RunException
 
 instance toString UFPLException
 
-class lift a :: a -> Task Dynamic
-class unlift a b :: b -> a
-
 :: ReadOrWrite = ReadOnly | ReadWrite
 
 :: IShared
@@ -60,26 +56,17 @@ class unlift a b :: b -> a
 
 :: INamedRule = Rule String [IRule]
 
-:: IState =
-	{  isvalues :: Map String Int
-	, uisvalues :: Map String Int
-	,  lsvalues :: Map String Int
-	, ulsvalues :: Map String Int
-	,  bsvalues :: Map String Bool
+:: IShareState t =
+	{ isval           :: t
+	, isdirty         :: Int
+	, issubscriptions :: Int
 	}
 
-derive class iTask Signedness, CType, ReadOrWrite, IShared, IExpr, ITrigger,
-	IRule, INamedRule, IState
-
-instance lift [a] | lift a
-instance unlift [a] [b] | unlift a b
-instance lift IExpr
-instance unlift IExpr (Expr t rw) | Expr t
-instance lift ITrigger
-instance unlift ITrigger Trigger
-instance lift IRule
-instance unlift IRule Rule
-instance lift INamedRule
-instance unlift INamedRule NamedRule
+:: IState =
+	{ isvalues :: Map String (IShareState Int)
+	, csvalues :: Map String (IShareState Char)
+	, bsvalues :: Map String (IShareState Bool)
+	, display  :: Display
+	}
 
-simulate :: [NamedRule] -> Task ()
+simulate :: [NamedRule] -> *World -> *World
diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl
index 09c9a3b..3d38b67 100644
--- a/assignment-13/uFPL/Sim.icl
+++ b/assignment-13/uFPL/Sim.icl
@@ -1,6 +1,6 @@
 implementation module uFPL.Sim
 
-from StdFunc import seq
+from StdFunc import flip, seq
 
 from Data.Func import $
 import Data.Functor
@@ -11,6 +11,7 @@ from Text import <+
 import Text.HTML
 
 import iTasks
+import iTasks.UI.Editor.Common
 
 import uFPL
 import uFPL.Bootstrap
@@ -22,12 +23,16 @@ where
 	toString (LiftException s)    = "Lift exception: " +++ s
 	toString (NoShareException s) = "No such share: " +++ s
 	toString (WriteToROShare s)   = "Write to RO share: " +++ s
+	toString RunException         = "Could not run"
 
 derive class iTask Signedness, CType, ReadOrWrite, IShared, IExpr, ITrigger,
-	IRule, INamedRule, IState
+	IRule, INamedRule, IState, IShareState, Display
+
+class lift a :: a -> Task Dynamic
+class unlift a b :: b -> a
 
 istate :: Shared IState
-istate = sharedStore "istate" gDefault{|*|}
+istate = sharedStore "state" gDefault{|*|}
 
 irules :: Shared [INamedRule]
 irules = sharedStore "irules" []
@@ -36,15 +41,23 @@ ishares :: Shared IShares
 ishares = sharedStore "ishares" gDefault{|*|}
 
 getShared :: ISharedRef -> Task Dynamic
-getShared n = get ishares >>= \shrs -> case filter ((==) n o name) shrs of
+getShared n = get ishares >>= \shrs -> case filter ((==) n o isharedName) shrs of
 	[]    -> throw (NoShareException n)
 	[s:_] -> lift s
-where
-	name (ISharedInt   n _ _) = n
-	name (ISharedUInt  n _ _) = n
-	name (ISharedLong  n _ _) = n
-	name (ISharedULong n _ _) = n
-	name (ISharedBool  n _ _) = n
+
+isharedName :: IShared -> String
+isharedName (ISharedInt   n _ _) = n
+isharedName (ISharedUInt  n _ _) = n
+isharedName (ISharedLong  n _ _) = n
+isharedName (ISharedULong n _ _) = n
+isharedName (ISharedBool  n _ _) = n
+
+isharedInit :: IShared -> Dynamic
+isharedInit (ISharedInt   _ i _) = dynamic i
+isharedInit (ISharedUInt  _ i _) = dynamic i
+isharedInit (ISharedLong  _ i _) = dynamic i
+isharedInit (ISharedULong _ i _) = dynamic i
+isharedInit (ISharedBool  _ i _) = dynamic i
 
 instance lift [a] | lift a
 where
@@ -132,9 +145,9 @@ where
 		ISharedBool  n i ReadWrite -> dynamic {sname=n, stype=CTBool,       sinit=i, srepr=boolmap, srw=RW}
 
 // NOTE: Compiler doesn't allow instances for both Int and Bool or RW and RO,
-// so we use ABC code here. Otherwise, there would have been separate instances
-// for UShared Int RO, UShared Int RW, etc. If rw = RO, we get ReadOnly. In all
-// other cases, we get ReadWrite.
+// so we use dynamics and ABC code here. Otherwise, there would have been
+// separate instances for UShared Int RO, UShared Int RW, etc.
+// If rw = RO, we get ReadOnly. In all other cases, we get ReadWrite.
 instance unlift IShared (UShared t rw) | Expr t
 where
 	unlift s = case dynamic s.sinit of
@@ -173,7 +186,9 @@ where
 		(s :: UShared Int rw) -> return (dynamic Change (EShared s))
 		_ -> throw (LiftException "IChange")
 	lift (IBecomes s e) = getShared s >>= \s -> lift e >>= \e -> case (s,e) of
-		(s :: UShared Int rwa, e :: Expr Int rwb) -> return (dynamic EShared s ?= e)
+		(s :: UShared Int  rwa, e :: Expr Int  rwb) -> return (dynamic EShared s ?= e)
+		(s :: UShared Char rwa, e :: Expr Char rwb) -> return (dynamic EShared s ?= e)
+		(s :: UShared Bool rwa, e :: Expr Bool rwb) -> return (dynamic EShared s ?= e)
 		_ -> throw (LiftException "IBecomes")
 	lift (ITAnd a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of
 		(a :: Trigger, b :: Trigger) -> return (dynamic a ?& b)
@@ -234,54 +249,72 @@ where
 		(r  :: Rule)   -> Rule s [unlift r]
 		(rs :: [Rule]) -> Rule s (unlift rs)
 
-simulate :: [NamedRule] -> Task ()
-simulate rs = setupShares >>| run $> ()
+instance lift IState
 where
-	setupShares :: Task ()
-	setupShares =
-		set
-			/*(  [ISharedInt   n (case i of (i :: Int)  -> i) ReadWrite \\ (n,t,i) <- shrs | t=:(CTInt  Sig)]
-			++ [ISharedUInt  n (case i of (i :: Int)  -> i) ReadWrite \\ (n,t,i) <- shrs | t=:(CTInt  Unsig)]
-			++ [ISharedLong  n (case l of (l :: Int)  -> l) ReadWrite \\ (n,t,l) <- shrs | t=:(CTLong Sig)]
-			++ [ISharedULong n (case l of (l :: Int)  -> l) ReadWrite \\ (n,t,l) <- shrs | t=:(CTLong Unsig)]
-			++ [ISharedBool  n (case b of (b :: Bool) -> b) ReadWrite \\ (n,t,b) <- shrs | t=:CTBool]
-			)*/ (unlift (allShares rs)) ishares >>|
-		set (unlift rs) irules $>
-		()
+	lift ist = return (dynamic
+		{ display = ist.IState.display
+		, vars = 'M'.fromList $
+			map (appSnd liftSharedState) ('M'.toList ist.isvalues) ++
+			map (appSnd liftSharedState) ('M'.toList ist.csvalues) ++
+			map (appSnd liftSharedState) ('M'.toList ist.bsvalues)
+		})
 	where
-		shrs :: [(String, CType, Dynamic)]
-		shrs = sharesMap (\shr -> (shr.sname,shr.stype,dynamic shr.sinit)) (allShares rs)
+		liftSharedState :: (IShareState t) -> ShareState | TC t
+		liftSharedState st = {val=dynamic st.isval, dirty=st.isdirty, subscriptions=st.issubscriptions}
 
-	run =
+instance unlift IState State
+where
+	unlift st =
+		{ isvalues = 'M'.fromList [(n,{isval=v,isdirty=s.dirty,issubscriptions=s.subscriptions}) \\ (n,s=:{val=v :: Int}) <- 'M'.toList st.vars]
+		, csvalues = 'M'.fromList [(n,{isval=v,isdirty=s.dirty,issubscriptions=s.subscriptions}) \\ (n,s=:{val=v :: Char}) <- 'M'.toList st.vars]
+		, bsvalues = 'M'.fromList [(n,{isval=v,isdirty=s.dirty,issubscriptions=s.subscriptions}) \\ (n,s=:{val=v :: Bool}) <- 'M'.toList st.vars]
+		, display = st.State.display
+		}
+
+simulate :: [NamedRule] -> *World -> *World
+simulate rs = startEngine (setupShares >>| sim)
+where
+	setupShares =
+		set (unlift (allShares rs)) ishares >>|
+		set (unlift rs) irules
+
+	sim =
 		(updateSharedInformation (Title "Rules")  [] irules
 			-&&- updateSharedInformation (Title "Shares") [] ishares
 		) -&&-
-		(sim -&&- check)
+		(show -&&- check)
 		<<@ ArrangeHorizontal
 
-	sim :: Task IState
-	sim = whileUnchanged (irules >*< ishares) (\(_,shrs) ->
-		newShares >>| viewSharedInformation (Title "State") [aslist] istate)
+	show :: Task IState
+	show = whileUnchanged (irules >*< ishares) (\(_,shrs) ->
+		newShares shrs >>|
+		viewSharedInformation (Title "State") [viewAsLists] istate)
 	where
-		newShares :: Task IState
-		newShares = get ishares >>= \shrs -> upd (\is ->
-			{ is
-			&  isvalues = seq [alter n i \\ ISharedInt   n i _ <- shrs] is.isvalues
-			, uisvalues = seq [alter n i \\ ISharedUInt  n i _ <- shrs] is.uisvalues
-			,  lsvalues = seq [alter n i \\ ISharedLong  n i _ <- shrs] is.lsvalues
-			, ulsvalues = seq [alter n i \\ ISharedULong n i _ <- shrs] is.ulsvalues
-			,  bsvalues = seq [alter n i \\ ISharedBool  n i _ <- shrs] is.bsvalues
-			}) istate
-		where
-			alter :: k v ('M'.Map k v) -> 'M'.Map k v | Eq, < k
-			alter k nv vs = 'M'.alter (\v -> case v of Nothing -> Just nv; v -> v) k vs
+		newShares :: IShares -> Task IState
+		newShares shrs = get istate >>= lift >>= \ist -> case ist of
+			(st :: State) -> set (unlift
+				{ st & vars = foldr (uncurry 'M'.put) st.vars
+					[(isharedName shr, {val=isharedInit shr, dirty=0, subscriptions=0}) \\ shr <- shrs]}) istate
+
+		viewAsLists = ViewUsing tolists $ container3 listView listView listView
+		with
+			listView :: Editor [(String,IShareState a)] | iTask, == a
+			listView = listEditor Nothing False False Nothing itemView
 
-		aslist = ViewAs \ist ->
-			map (appSnd toString) ('M'.toList ist.isvalues) ++
-			map (appSnd toString) ('M'.toList ist.uisvalues) ++
-			map (appSnd toString) ('M'.toList ist.lsvalues) ++
-			map (appSnd toString) ('M'.toList ist.ulsvalues) ++
-			map (appSnd toString) ('M'.toList ist.bsvalues)
+			itemView :: Editor (String, IShareState a) | iTask, == a
+			itemView = comapEditorValue
+				(\(s,shr) -> (s, shr.isval, shr.isdirty, shr.issubscriptions))
+				(listitem4
+					textView
+					gEditor{|*|}
+					(intView "Dirty")
+					(intView "Subscriptions")
+					<<@ directionAttr Horizontal)
+			with
+				intView s = comapEditorValue (\i -> s <+ ": " <+ i) textView
+
+		tolists :: IState -> ([(String, IShareState Int)], [(String, IShareState Char)], [(String, IShareState Bool)])
+		tolists st = ('M'.toList st.isvalues, 'M'.toList st.csvalues, 'M'.toList st.bsvalues)
 
 	check :: Task String
 	check = whileUnchanged (irules >*< ishares) (\(rs,shrs) -> catchAll (lift rs >>| return "OK") return
@@ -289,17 +322,49 @@ where
 		[ViewUsing id $ viewComponent (\text -> 'M'.unions
 			[ valueAttr (JSONString (escapeStr text))
 			, styleAttr (if (text == "OK") "" "color:red;font-weight:bold;")
-			]) UITextView])
+			]) UITextView]
 		>>*
-		[ OnAction (Action "Step") $ ifOk $ step >>| check
-		]
+		buttonActions shrs ++
+		millisActions shrs ++
+		[action "Step" $ step])
 	where
+		action :: String (Task a) -> TaskCont String (Task String) | iTask a
+		action s t = OnAction (Action s) $ ifOk $ t >>| check
+
 		ifOk :: a (TaskValue String) -> Maybe a
 		ifOk t (Value "OK" _) = Just t
 		ifOk _ _              = Nothing
 
-		step :: Task ()
-		step = return ()
+		step :: Task IState
+		step = get istate >>= lift >>= \st -> case st of
+			(st :: State) -> get irules >>= lift >>= \rs -> case rs of
+				(rs :: [NamedRule]) -> case run rs st of
+					Just st -> set (unlift st) istate
+					Nothing -> throw RunException
+				_ -> throw (LiftException "step rules")
+			_ -> throw (LiftException "step state")
+
+		buttonActions :: IShares -> [TaskCont String (Task String)]
+		buttonActions shrs =
+			[action ("Toggle B" <+ i) $ press i \\ i <- [0..5] | any ((==) ("b" <+ i) o isharedName) shrs]
+		where
+			press :: Int -> Task IState
+			press i = get istate >>= lift >>= \st -> case st of
+				(st :: State) -> set (unlift {st & vars='M'.alter upd ("b" <+ i) st.vars}) istate
+			with upd (Just s=:{val=v :: Bool}) = Just {s & val=dynamic not v, dirty=s.subscriptions}
+
+		millisActions :: IShares -> [TaskCont String (Task String)]
+		millisActions shrs
+		| any ((==) "millis" o isharedName) shrs =
+			[ action "Millis +100"  $ addMillis 100
+			, action "Millis +1000" $ addMillis 1000
+			]
+		| otherwise = []
+		where
+			addMillis :: Int -> Task IState
+			addMillis n = get istate >>= lift >>= \st -> case st of
+				(st :: State) -> set (unlift {st & vars='M'.alter upd "millis" st.vars}) istate
+			with upd (Just s=:{val=v :: Int}) = Just {s & val=dynamic v+n, dirty=s.subscriptions}
 
 // From iTasks.UI.Editor.Controls
 viewComponent toAttributes type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}