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.icl164
1 files changed, 82 insertions, 82 deletions
diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl
index d3dc9e3..09c9a3b 100644
--- a/assignment-13/uFPL/Sim.icl
+++ b/assignment-13/uFPL/Sim.icl
@@ -1,5 +1,7 @@
implementation module uFPL.Sim
+from StdFunc import seq
+
from Data.Func import $
import Data.Functor
import qualified Data.Map as M
@@ -21,9 +23,8 @@ where
toString (NoShareException s) = "No such share: " +++ s
toString (WriteToROShare s) = "Write to RO share: " +++ s
-derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, ISharedUInt,
- ISharedLong, ISharedULong, ISharedBool, IShares, IExpr, ITrigger, IRule,
- INamedRule, IState
+derive class iTask Signedness, CType, ReadOrWrite, IShared, IExpr, ITrigger,
+ IRule, INamedRule, IState
istate :: Shared IState
istate = sharedStore "istate" gDefault{|*|}
@@ -34,38 +35,16 @@ irules = sharedStore "irules" []
ishares :: Shared IShares
ishares = sharedStore "ishares" gDefault{|*|}
-getSharedInt :: ISharedRef -> Task ISharedInt
-getSharedInt n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.ishares | shr.iisname == n] of
- [] -> throw (NoShareException n)
- [s:_] -> return s
-
-getSharedUInt :: ISharedRef -> Task ISharedUInt
-getSharedUInt n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.uishares | shr.iuisname == n] of
- [] -> throw (NoShareException n)
- [s:_] -> return s
-
-getSharedLong :: ISharedRef -> Task ISharedLong
-getSharedLong n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.lshares | shr.ilsname == n] of
- [] -> throw (NoShareException n)
- [s:_] -> return s
-
-getSharedULong :: ISharedRef -> Task ISharedULong
-getSharedULong n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.ulshares | shr.iulsname == n] of
- [] -> throw (NoShareException n)
- [s:_] -> return s
-
-getSharedBool :: ISharedRef -> Task ISharedBool
-getSharedBool n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.bshares | shr.ibsname == n] of
- [] -> throw (NoShareException n)
- [s:_] -> return s
-
getShared :: ISharedRef -> Task Dynamic
-getShared n =
- catchAll (getSharedInt n >>= lift) \_ ->
- catchAll (getSharedUInt n >>= lift) \_ ->
- catchAll (getSharedLong n >>= lift) \_ ->
- catchAll (getSharedULong n >>= lift) \_ ->
- getSharedBool n >>= lift
+getShared n = get ishares >>= \shrs -> case filter ((==) n o name) 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
instance lift [a] | lift a
where
@@ -138,42 +117,55 @@ where
unlift (EOr _ a b) = IOr (unlift a) (unlift b)
unlift (EIf b t e) = IIf (unlift b) (unlift t) (unlift e)
-instance lift ISharedInt
-where
- lift s = return case s.iisrw of
- ReadOnly -> dynamic {sname=s.iisname, stype=CTInt Sig, sinit=s.iisinit, srepr=intmap} :: UShared Int RO
- ReadWrite -> dynamic {sname=s.iisname, stype=CTInt Sig, sinit=s.iisinit, srepr=intmap} :: UShared Int RW
-
-instance lift ISharedUInt
+instance lift IShared
where
- lift s = return case s.iuisrw of
- ReadOnly -> dynamic {sname=s.iuisname, stype=CTInt Unsig, sinit=s.iuisinit, srepr=intmap} :: UShared Int RO
- ReadWrite -> dynamic {sname=s.iuisname, stype=CTInt Unsig, sinit=s.iuisinit, srepr=intmap} :: UShared Int RW
-
-instance lift ISharedLong
-where
- lift s = return case s.ilsrw of
- ReadOnly -> dynamic {sname=s.ilsname, stype=CTLong Sig, sinit=s.ilsinit, srepr=longmap} :: UShared Int RO
- ReadWrite -> dynamic {sname=s.ilsname, stype=CTLong Sig, sinit=s.ilsinit, srepr=longmap} :: UShared Int RW
-
-instance lift ISharedULong
+ lift s = return case s of
+ ISharedInt n i ReadOnly -> dynamic {sname=n, stype=CTInt Sig, sinit=i, srepr=intmap, srw=RO}
+ ISharedInt n i ReadWrite -> dynamic {sname=n, stype=CTInt Sig, sinit=i, srepr=intmap, srw=RW}
+ ISharedUInt n i ReadOnly -> dynamic {sname=n, stype=CTInt Unsig, sinit=i, srepr=intmap, srw=RO}
+ ISharedUInt n i ReadWrite -> dynamic {sname=n, stype=CTInt Unsig, sinit=i, srepr=intmap, srw=RW}
+ ISharedLong n i ReadOnly -> dynamic {sname=n, stype=CTLong Sig, sinit=i, srepr=longmap, srw=RO}
+ ISharedLong n i ReadWrite -> dynamic {sname=n, stype=CTLong Sig, sinit=i, srepr=longmap, srw=RW}
+ ISharedULong n i ReadOnly -> dynamic {sname=n, stype=CTLong Unsig, sinit=i, srepr=longmap, srw=RO}
+ ISharedULong n i ReadWrite -> dynamic {sname=n, stype=CTLong Unsig, sinit=i, srepr=longmap, srw=RW}
+ ISharedBool n i ReadOnly -> dynamic {sname=n, stype=CTBool, sinit=i, srepr=boolmap, srw=RO}
+ 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.
+instance unlift IShared (UShared t rw) | Expr t
where
- lift s = return case s.iulsrw of
- ReadOnly -> dynamic {sname=s.iulsname, stype=CTLong Unsig, sinit=s.iulsinit, srepr=longmap} :: UShared Int RO
- ReadWrite -> dynamic {sname=s.iulsname, stype=CTLong Unsig, sinit=s.iulsinit, srepr=longmap} :: UShared Int RW
-
-instance lift ISharedBool
+ unlift s = case dynamic s.sinit of
+ (b :: Bool) -> ISharedBool s.sname b (rw s.srw)
+ (i :: Int) -> cons s.sname i (rw s.srw)
+ where
+ cons = case s.stype of
+ CTInt Sig -> ISharedInt
+ CTInt Unsig -> ISharedUInt
+ CTLong Sig -> ISharedLong
+ CTLong Unsig -> ISharedULong
+
+ rw :: !a -> ReadOrWrite
+ rw _ = code {
+ eq_desc e_uFPL_dRO 0 0
+ jmp_true readonly
+ fillh e_uFPL.Sim_dReadWrite 0 1
+ pop_a 1
+ .d 1 0
+ rtn
+ :readonly
+ fillh e_uFPL.Sim_dReadOnly 0 1
+ pop_a 1
+ .d 1 0
+ rtn
+ }
+
+instance unlift IShares Shares
where
- lift s = return case s.ibsrw of
- ReadOnly -> dynamic {sname=s.ibsname, stype=CTBool, sinit=s.ibsinit, srepr=boolmap} :: UShared Bool RO
- ReadWrite -> dynamic {sname=s.ibsname, stype=CTBool, sinit=s.ibsinit, srepr=boolmap} :: UShared Bool RW
-
-// NOTE: Compiler doesn't allow instances for both RW and RO, so we assume everything is RW here...
-instance unlift ISharedInt (UShared Int rw) where unlift s = {iisname =s.sname, iisinit =s.sinit, iisrw =ReadWrite}
-instance unlift ISharedUInt (UShared Int rw) where unlift s = {iuisname=s.sname, iuisinit=s.sinit, iuisrw=ReadWrite}
-instance unlift ISharedLong (UShared Int rw) where unlift s = {ilsname =s.sname, ilsinit =s.sinit, ilsrw =ReadWrite}
-instance unlift ISharedULong (UShared Int rw) where unlift s = {iulsname=s.sname, iulsinit=s.sinit, iulsrw=ReadWrite}
-instance unlift ISharedBool (UShared Bool rw) where unlift s = {ibsname =s.sname, ibsinit =s.sinit, ibsrw =ReadWrite}
+ unlift NoShares = []
+ unlift (Shares shr rest) = [unlift shr:unlift rest]
instance lift ITrigger
where
@@ -248,12 +240,12 @@ where
setupShares :: Task ()
setupShares =
set
- { ishares = [{iisname =n, iisinit =case i of (i :: Int) -> i, iisrw =ReadWrite} \\ (n,t,i) <- shrs | t=:(CTInt Sig)]
- ,uishares = [{iuisname=n, iuisinit=case i of (i :: Int) -> i, iuisrw=ReadWrite} \\ (n,t,i) <- shrs | t=:(CTInt Unsig)]
- , lshares = [{ilsname =n, ilsinit =case l of (l :: Int) -> l, ilsrw =ReadWrite} \\ (n,t,l) <- shrs | t=:(CTLong Sig)]
- ,ulshares = [{iulsname=n, iulsinit=case l of (l :: Int) -> l, iulsrw=ReadWrite} \\ (n,t,l) <- shrs | t=:(CTLong Unsig)]
- , bshares = [{ibsname =n, ibsinit =case b of (b :: Bool) -> b, ibsrw =ReadWrite} \\ (n,t,b) <- shrs | t=:CTBool]
- } ishares >>|
+ /*( [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 $>
()
where
@@ -274,17 +266,15 @@ where
newShares :: Task IState
newShares = get ishares >>= \shrs -> upd (\is ->
{ is
- & isvalues = alter (\s -> s.iisname) (\s -> s.iisinit) shrs.ishares is.isvalues
- , uisvalues = alter (\s -> s.iuisname) (\s -> s.iuisinit) shrs.uishares is.uisvalues
- , lsvalues = alter (\s -> s.ilsname) (\s -> s.ilsinit) shrs.lshares is.lsvalues
- , ulsvalues = alter (\s -> s.iulsname) (\s -> s.iulsinit) shrs.ulshares is.ulsvalues
- , bsvalues = alter (\s -> s.ibsname) (\s -> s.ibsinit) shrs.bshares is.bsvalues
+ & 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 :: (a -> k) (a -> v) [a] ('M'.Map k v) -> 'M'.Map k v | Eq, < k
- alter fn fv shrs vs = 'M'.filterWithKey (\k _ -> isMember k (map fn shrs)) $
- foldr (uncurry 'M'.alter) vs
- [(\v -> case v of Nothing -> Just (fv iis); v -> v, fn iis) \\ iis <- shrs]
+ 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
aslist = ViewAs \ist ->
map (appSnd toString) ('M'.toList ist.isvalues) ++
@@ -300,6 +290,16 @@ where
[ valueAttr (JSONString (escapeStr text))
, styleAttr (if (text == "OK") "" "color:red;font-weight:bold;")
]) UITextView])
+ >>*
+ [ OnAction (Action "Step") $ ifOk $ step >>| check
+ ]
+ where
+ ifOk :: a (TaskValue String) -> Maybe a
+ ifOk t (Value "OK" _) = Just t
+ ifOk _ _ = Nothing
+
+ step :: Task ()
+ step = return ()
// 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 01:58:40 +0000