summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--assignment-13/uFPL.dcl5
-rw-r--r--assignment-13/uFPL.icl4
-rw-r--r--assignment-13/uFPL/Bootstrap.icl2
-rw-r--r--assignment-13/uFPL/Sim.dcl45
-rw-r--r--assignment-13/uFPL/Sim.icl160
5 files changed, 195 insertions, 21 deletions
diff --git a/assignment-13/uFPL.dcl b/assignment-13/uFPL.dcl
index dd9c047..1ce2ac4 100644
--- a/assignment-13/uFPL.dcl
+++ b/assignment-13/uFPL.dcl
@@ -17,9 +17,10 @@ from uFPL.C import :: CType, :: CExpr, :: CBody, :: CVar, :: CFun, :: CProg
:: Shares
= NoShares
- | E.t rw: Shares (UShared t rw) Shares
+ | E.t rw: Shares (UShared t rw) Shares & Expr t
removeDupShares :: Shares -> Shares
+sharesMap :: (A.t rw: (UShared t rw) -> a | Expr t) Shares -> [a]
class allShares t
where
@@ -29,7 +30,7 @@ where
allShares x :== removeDupShares (allShares` x)
instance allShares [t] | allShares t
-instance allShares (Expr t rw)
+instance allShares (Expr t rw) | Expr t
instance allShares Trigger
instance allShares Rule
instance allShares NamedRule
diff --git a/assignment-13/uFPL.icl b/assignment-13/uFPL.icl
index 3104595..23bf85c 100644
--- a/assignment-13/uFPL.icl
+++ b/assignment-13/uFPL.icl
@@ -42,7 +42,7 @@ removeDupShares (Shares s ss) = if exists id (Shares s) (removeDupShares ss)
where
exists = any (\s` -> s.sname == s`) (sharesMap (\s -> s.sname) ss)
-sharesMap :: (A.t rw: (UShared t rw) -> a) Shares -> [a]
+sharesMap :: (A.t rw: (UShared t rw) -> a | Expr t) Shares -> [a]
sharesMap _ NoShares = []
sharesMap f (Shares s ss) = [f s:sharesMap f ss]
@@ -51,7 +51,7 @@ where
allShares` [] = NoShares
allShares` [x:xs] = append (allShares` x) (allShares` xs)
-instance allShares (Expr t rw)
+instance allShares (Expr t rw) | Expr t
where
allShares` (ELit _) = NoShares
allShares` (EShared s) = Shares s NoShares
diff --git a/assignment-13/uFPL/Bootstrap.icl b/assignment-13/uFPL/Bootstrap.icl
index 8e00e97..fea376f 100644
--- a/assignment-13/uFPL/Bootstrap.icl
+++ b/assignment-13/uFPL/Bootstrap.icl
@@ -64,7 +64,7 @@ b4 :: Expr Bool RO
b4 = roBool "b4" False
millis :: Expr Int RO
-millis = roLong "millis" 0
+millis = roULong "millis" 0
false :: Expr Bool RO
false = lit False
diff --git a/assignment-13/uFPL/Sim.dcl b/assignment-13/uFPL/Sim.dcl
index 6ee6e14..36e4e73 100644
--- a/assignment-13/uFPL/Sim.dcl
+++ b/assignment-13/uFPL/Sim.dcl
@@ -1,5 +1,7 @@
definition module uFPL.Sim
+from Data.Map import :: Map
+
import iTasks
import uFPL
@@ -23,10 +25,38 @@ class unlift a b :: b -> a
, iisrw :: ReadOrWrite
}
+:: ISharedUInt =
+ { iuisname :: String
+ , iuisinit :: Int
+ , iuisrw :: ReadOrWrite
+ }
+
+:: ISharedLong =
+ { ilsname :: String
+ , ilsinit :: Int
+ , ilsrw :: ReadOrWrite
+ }
+
+:: ISharedULong =
+ { iulsname :: String
+ , iulsinit :: Int
+ , iulsrw :: ReadOrWrite
+ }
+
+:: ISharedBool =
+ { ibsname :: String
+ , ibsinit :: Bool
+ , ibsrw :: ReadOrWrite
+ }
+
:: ISharedRef :== String
:: IShares =
- { ishares :: [ISharedInt]
+ { ishares :: [ISharedInt]
+ , uishares :: [ISharedUInt]
+ , lshares :: [ISharedLong]
+ , ulshares :: [ISharedULong]
+ , bshares :: [ISharedBool]
}
:: IExpr
@@ -59,8 +89,17 @@ class unlift a b :: b -> a
:: INamedRule = Rule String [IRule]
-derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, IShares, IExpr,
- ITrigger, IRule, INamedRule
+:: IState =
+ { isvalues :: Map String Int
+ , uisvalues :: Map String Int
+ , lsvalues :: Map String Int
+ , ulsvalues :: Map String Int
+ , bsvalues :: Map String Bool
+ }
+
+derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, ISharedUInt,
+ ISharedLong, ISharedULong, ISharedBool, IShares, IExpr, ITrigger, IRule,
+ INamedRule, IState
instance lift [a] | lift a
instance unlift [a] [b] | unlift a b
diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl
index ac42046..d3dc9e3 100644
--- a/assignment-13/uFPL/Sim.icl
+++ b/assignment-13/uFPL/Sim.icl
@@ -1,7 +1,12 @@
implementation module uFPL.Sim
+from Data.Func import $
import Data.Functor
+import qualified Data.Map as M
import Data.Maybe
+import Data.Tuple
+from Text import <+
+import Text.HTML
import iTasks
@@ -16,8 +21,15 @@ where
toString (NoShareException s) = "No such share: " +++ s
toString (WriteToROShare s) = "Write to RO share: " +++ s
-derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, IShares, IExpr,
- ITrigger, IRule, INamedRule
+derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, ISharedUInt,
+ ISharedLong, ISharedULong, ISharedBool, IShares, IExpr, ITrigger, IRule,
+ INamedRule, IState
+
+istate :: Shared IState
+istate = sharedStore "istate" gDefault{|*|}
+
+irules :: Shared [INamedRule]
+irules = sharedStore "irules" []
ishares :: Shared IShares
ishares = sharedStore "ishares" gDefault{|*|}
@@ -27,6 +39,34 @@ getSharedInt n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.ishares | shr
[] -> 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
+
instance lift [a] | lift a
where
lift xs = dynamicList <$> allTasks (map lift xs)
@@ -35,6 +75,7 @@ where
dynamicList ds = list (reverse ds) (dynamic [] :: A.a: [a])
where
list :: [Dynamic] Dynamic -> Dynamic
+ list [] d = d
list [(d :: t):r] (l :: [t]) = list r (dynamic [d:l])
instance unlift [a] [b] | unlift a b where unlift xs = map unlift xs
@@ -44,8 +85,7 @@ where
lift (ILitInt i) = return (dynamic ELit i :: Expr Int RO)
lift (ILitBool b) = return (dynamic ELit b :: Expr Bool RO)
lift (ILitChar c) = return (dynamic ELit c :: Expr Char RO)
- lift (IShared s) = getSharedInt s >>= lift >>= \s -> case s of
- (s :: UShared Int rw) -> return (dynamic EShared s)
+ lift (IShared s) = getShared s >>= \s -> case s of (s :: UShared t rw) -> return (dynamic EShared s)
lift (IAdd a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of
(a :: Expr Int rwa, b :: Expr Int rwb) -> return (dynamic a +. b :: Expr Int RO)
(a :: Expr Char rwa, b :: Expr Char rwb) -> return (dynamic a +. b :: Expr Char RO)
@@ -104,17 +144,43 @@ where
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
-// NOTE: Compiler doesn't allow instances for both RW and RO, so we assume everything is RW here...
-instance unlift ISharedInt (UShared Int rw)
+instance lift ISharedUInt
where
- unlift s = {iisname=s.sname, iisinit=s.sinit, iisrw=ReadWrite}
+ 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
+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
+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}
instance lift ITrigger
where
- lift (IChange s) = getSharedInt s >>= lift >>= \s -> case s of
+ lift (IChange s) = getShared s >>= \s -> case s of
(s :: UShared Int rw) -> return (dynamic Change (EShared s))
_ -> throw (LiftException "IChange")
- lift (IBecomes s e) = getSharedInt s >>= lift >>= \s -> lift e >>= \e -> case (s,e) of
+ 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)
_ -> throw (LiftException "IBecomes")
lift (ITAnd a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of
@@ -133,11 +199,14 @@ where
instance lift IRule
where
- lift (IAssign s e) = getSharedInt s >>= lift >>= \s -> lift e >>= \e -> case (s,e) of
+ lift (IAssign s e) = getShared s >>= \s -> lift e >>= \e -> case (s,e) of
(s :: UShared Int RW, e :: Expr Int rw) -> return (dynamic EShared s <# e)
(s :: UShared Char RW, e :: Expr Char rw) -> return (dynamic EShared s <# e)
(s :: UShared Bool RW, e :: Expr Bool rw) -> return (dynamic EShared s <# e)
(s :: UShared t RO, _) -> throw (WriteToROShare s.sname)
+ (t :: UShared t rw, _ :: Expr u rwb) -> throw $ LiftException $
+ "IAssign: cannot assign " <+ typeCodeOfDynamic e <+
+ " to " <+ typeCodeOfDynamic s <+ " " <+ t.sname <+ "."
_ -> throw (LiftException "IAssign")
lift (IWhen e rs) = lift e >>= \e -> lift rs >>= \rs -> case (e,rs) of
(e :: Expr Bool rw, rs :: [Rule]) -> return (dynamic When e rs)
@@ -174,7 +243,72 @@ where
(rs :: [Rule]) -> Rule s (unlift rs)
simulate :: [NamedRule] -> Task ()
-simulate rs = update >>= \rs -> viewInformation (Title "Your rules") [] rs $> ()
+simulate rs = setupShares >>| run $> ()
+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 >>|
+ set (unlift rs) irules $>
+ ()
+ where
+ shrs :: [(String, CType, Dynamic)]
+ shrs = sharesMap (\shr -> (shr.sname,shr.stype,dynamic shr.sinit)) (allShares rs)
+
+ run =
+ (updateSharedInformation (Title "Rules") [] irules
+ -&&- updateSharedInformation (Title "Shares") [] ishares
+ ) -&&-
+ (sim -&&- check)
+ <<@ ArrangeHorizontal
+
+ sim :: Task IState
+ sim = whileUnchanged (irules >*< ishares) (\(_,shrs) ->
+ newShares >>| viewSharedInformation (Title "State") [aslist] istate)
+ 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
+ }) 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]
+
+ 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)
+
+ check :: Task String
+ check = whileUnchanged (irules >*< ishares) (\(rs,shrs) -> catchAll (lift rs >>| return "OK") return
+ >>= viewInformation (Title "Status")
+ [ViewUsing id $ viewComponent (\text -> 'M'.unions
+ [ valueAttr (JSONString (escapeStr text))
+ , styleAttr (if (text == "OK") "" "color:red;font-weight:bold;")
+ ]) UITextView])
+
+// From iTasks.UI.Editor.Controls
+viewComponent toAttributes type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}
where
- update :: Task [INamedRule]
- update = updateInformation (Title "Rules") [] (unlift rs)
+ genUI dp val vst
+ = (Ok (uia type (toAttributes val), FieldMask {touched = False, valid = True, state = JSONNull}),vst)
+ onEdit dp (tp,e) val mask vst
+ = (Error "Edit event for view component",val,vst)
+ onRefresh dp new old mask vst
+ = case [SetAttribute nk nv \\ ((ok,ov),(nk,nv)) <- zip ('M'.toList (toAttributes old),'M'.toList (toAttributes new)) | ok == nk && ov =!= nv] of
+ [] = (Ok (NoChange,mask),new,vst)
+ changes = (Ok (ChangeUI changes [],mask),new,vst)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-16 09:56:54 +0000