summaryrefslogtreecommitdiff
path: root/assignment-13/uFPL/Sim.icl
diff options
context:
space:
mode:
Diffstat (limited to 'assignment-13/uFPL/Sim.icl')
-rw-r--r--assignment-13/uFPL/Sim.icl179
1 files changed, 122 insertions, 57 deletions
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}
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-15 00:45:49 +0000