diff options
| -rw-r--r-- | assignment-13/uFPL.icl | 2 | ||||
| -rw-r--r-- | assignment-13/uFPL/Sim.icl | 81 |
2 files changed, 53 insertions, 30 deletions
diff --git a/assignment-13/uFPL.icl b/assignment-13/uFPL.icl index b87538e..129df92 100644 --- a/assignment-13/uFPL.icl +++ b/assignment-13/uFPL.icl @@ -241,7 +241,7 @@ evalTrigger (Change (EShared s)) st = case get s.sname st.vars of 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=:{dirty=n} | n > 0 -> eval e st >>= \e -> flip tuple {st & vars=put s.sname {shr & dirty=n-1} st.vars} <$> equals shr.val e Just shr -> Just (False, st) _ -> Nothing where diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl index 3d38b67..0f232fc 100644 --- a/assignment-13/uFPL/Sim.icl +++ b/assignment-13/uFPL/Sim.icl @@ -4,6 +4,7 @@ from StdFunc import flip, seq from Data.Func import $ import Data.Functor +from Data.List import concatMap import qualified Data.Map as M import Data.Maybe import Data.Tuple @@ -11,6 +12,7 @@ from Text import <+ import Text.HTML import iTasks +import iTasks.Extensions.DateTime import iTasks.UI.Editor.Common import uFPL @@ -40,6 +42,9 @@ irules = sharedStore "irules" [] ishares :: Shared IShares ishares = sharedStore "ishares" gDefault{|*|} +simulatorRunning :: Shared Bool +simulatorRunning = sharedStore "simulatorRunning" False + getShared :: ISharedRef -> Task Dynamic getShared n = get ishares >>= \shrs -> case filter ((==) n o isharedName) shrs of [] -> throw (NoShareException n) @@ -272,11 +277,15 @@ where } simulate :: [NamedRule] -> *World -> *World -simulate rs = startEngine (setupShares >>| sim) +simulate rs = startEngine $ + (setupShares >>| sim) + -&&- (( + whileUnchanged (irules >*< ishares) (uncurry newShares) + ) <<@ NoUserInterface) where setupShares = - set (unlift (allShares rs)) ishares >>| - set (unlift rs) irules + set (unlift rs) irules >>| + set (unlift (allShares rs)) ishares sim = (updateSharedInformation (Title "Rules") [] irules @@ -285,17 +294,28 @@ where (show -&&- check) <<@ ArrangeHorizontal - show :: Task IState - show = whileUnchanged (irules >*< ishares) (\(_,shrs) -> - newShares shrs >>| - viewSharedInformation (Title "State") [viewAsLists] istate) + newShares :: [INamedRule] IShares -> Task IState + newShares rs shrs = get istate >>= lift >>= \ist -> case ist of + (st :: State) -> set (unlift + { st & vars = 'M'.mapWithKey (\k v -> {v & subscriptions=subscriptions k rs}) $ foldr (uncurry 'M'.put) st.vars + [(isharedName shr, {val=isharedInit shr, dirty=0, subscriptions=0}) \\ shr <- shrs]}) istate where - 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 + subscriptions :: String [INamedRule] -> Int + subscriptions s rs = length $ filter ((==) s) $ concatMap allSharedSubscriptions $ flatten [allTriggers rs` \\ Rule _ rs` <- rs] + + allTriggers :: [IRule] -> [ITrigger] + allTriggers rs = [t \\ ITrigger t _ <- rs] + allSharedSubscriptions :: ITrigger -> [ISharedRef] + allSharedSubscriptions t = case t of + IChange s -> [s] + IBecomes s _ -> [s] + ITAnd a b -> allSharedSubscriptions a ++ allSharedSubscriptions b + ITOr a b -> allSharedSubscriptions a ++ allSharedSubscriptions b + + show :: Task IState + show = viewSharedInformation (Title "State") [viewAsLists] istate + where viewAsLists = ViewUsing tolists $ container3 listView listView listView with listView :: Editor [(String,IShareState a)] | iTask, == a @@ -329,21 +349,12 @@ where [action "Step" $ step]) where action :: String (Task a) -> TaskCont String (Task String) | iTask a - action s t = OnAction (Action s) $ ifOk $ t >>| check + 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 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] @@ -356,15 +367,27 @@ where millisActions :: IShares -> [TaskCont String (Task String)] millisActions shrs | any ((==) "millis" o isharedName) shrs = - [ action "Millis +100" $ addMillis 100 - , action "Millis +1000" $ addMillis 1000 + [ action "t +100ms" $ addMillis 100 $> () + , action "t +1s" $ addMillis 1000 $> () + , action "Toggle running / 1s" $ + ((forever $ waitForTimer 0 >>| addMillis 1000 >>| step $> ()) <<@ NoUserInterface) + >>* [OnAction (Action "Stop") (always (return ()))] ] | 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} + + 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") + + 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} |