diff options
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | assignment-13/uFPL.dcl | 12 | ||||
| -rw-r--r-- | assignment-13/uFPL.icl | 13 | ||||
| -rw-r--r-- | assignment-13/uFPL.prj.default | 59 | ||||
| -rw-r--r-- | assignment-13/uFPL/Sim.dcl | 78 | ||||
| -rw-r--r-- | assignment-13/uFPL/Sim.icl | 180 |
6 files changed, 333 insertions, 12 deletions
@@ -7,7 +7,8 @@ a.out assignment-5/skeleton5 assignment-6/multiplechoice assignment-8/skeleton8 -assignment-8/skeleton8.prj +assignment-13/run +*.prj # TeX *-blx.bib diff --git a/assignment-13/uFPL.dcl b/assignment-13/uFPL.dcl index 1bd3df4..dd9c047 100644 --- a/assignment-13/uFPL.dcl +++ b/assignment-13/uFPL.dcl @@ -8,7 +8,7 @@ from uFPL.C import :: CType, :: CExpr, :: CBody, :: CVar, :: CFun, :: CProg :: RO = RO :: RW = RW -:: Shared t w = +:: UShared t w = { sname :: String , stype :: CType , sinit :: t @@ -17,7 +17,7 @@ from uFPL.C import :: CType, :: CExpr, :: CBody, :: CVar, :: CFun, :: CProg :: Shares = NoShares - | E.t rw: Shares (Shared t rw) Shares + | E.t rw: Shares (UShared t rw) Shares removeDupShares :: Shares -> Shares @@ -34,14 +34,14 @@ instance allShares Trigger instance allShares Rule instance allShares NamedRule -class Expr t where litExpr :: t -> CExpr +class Expr t | TC t where litExpr :: t -> CExpr instance Expr Int instance Expr Bool instance Expr Char :: Expr t rw = ELit t - | EShared (Shared t rw) + | EShared (UShared t rw) | E.rwa rwb: (+.) infixl 6 (Expr t rwa) (Expr t rwb) & + t | E.rwa rwb: (-.) infixl 6 (Expr t rwa) (Expr t rwb) & - t | E.rwa rwb: (*.) infixl 7 (Expr t rwa) (Expr t rwb) & * t @@ -75,7 +75,7 @@ lit :: (t -> Expr t RO) | E.rwa rwb: SetCursor (Expr Int rwa, Expr Int rwb) | E.t rw: Print (Expr t rw) & Expr t -:: NamedRule = E.r: (:=:) infix 1 String r & gen r CBody & allShares r +:: NamedRule = E.r: (:=:) infix 1 String r & gen r CBody & allShares r & TC r class gen f t :: f -> t @@ -88,7 +88,7 @@ instance ||| NamedRule instance ||| [NamedRule] instance gen (Expr t rw) CExpr | Expr t -instance gen (Shared t rw) CVar +instance gen (UShared t rw) CVar instance gen Trigger CExpr instance gen Rule CBody instance gen [r] CBody | gen r CBody diff --git a/assignment-13/uFPL.icl b/assignment-13/uFPL.icl index 2499da5..3104595 100644 --- a/assignment-13/uFPL.icl +++ b/assignment-13/uFPL.icl @@ -18,6 +18,7 @@ import Data.List import uFPL.Arduino import uFPL.Bootstrap import uFPL.C +import uFPL.Sim import uFPL.Util typedfun :: CType String -> String @@ -41,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: (Shared t rw) -> a) Shares -> [a] +sharesMap :: (A.t rw: (UShared t rw) -> a) Shares -> [a] sharesMap _ NoShares = [] sharesMap f (Shares s ss) = [f s:sharesMap f ss] @@ -128,10 +129,11 @@ where gen (EOr _ a b) = CEInfix "||" (gen a) (gen b) gen (EIf b t e) = CEIf (gen b) (gen t) (gen e) -instance gen (Shared t rw) CVar +instance gen (UShared t rw) CVar where gen shr = - { name = "s" +++ shr.sname + { CVar + | name = "s" +++ shr.sname , type = CTStruct (typedfun shr.stype "share") , value = CEStruct [ ("val", shr.srepr.map_to shr.sinit) @@ -180,7 +182,7 @@ where genf :: (NamedRule -> CFun) genf = gen - genv :: ((Shared t rw) -> CVar) + genv :: ((UShared t rw) -> CVar) genv = gen instance gen NamedRule CProg @@ -195,7 +197,8 @@ instance gen [NamedRule] CProg where gen rs = foldr (combinePrograms o gen) zero rs -Start = printToString (genp example_score) +Start w = startEngine (simulate example_countdown) w +Start _ = printToString (genp example_score) where genp :: (a -> CProg) | gen a CProg genp = gen diff --git a/assignment-13/uFPL.prj.default b/assignment-13/uFPL.prj.default new file mode 100644 index 0000000..4bd7872 --- /dev/null +++ b/assignment-13/uFPL.prj.default @@ -0,0 +1,59 @@ +Version: 1.4 +Global + ProjectRoot: . + Target: iTasks + Exec: {Project}/run + CodeGen + CheckStacks: False + CheckIndexes: True + Application + HeapSize: 167772160 + StackSize: 1048576 + ExtraMemory: 81920 + IntialHeapSize: 204800 + HeapSizeMultiplier: 4096 + ShowExecutionTime: False + ShowGC: False + ShowStackSize: False + MarkingCollector: False + DisableRTSFlags: False + StandardRuntimeEnv: True + Profile + Memory: False + MemoryMinimumHeapSize: 0 + Time: False + Stack: False + Dynamics: True + DescExL: False + Output + Output: ShowConstructors + Font: Monaco + FontSize: 9 + WriteStdErr: False + Link + LinkMethod: Static + GenerateRelocations: False + GenerateSymbolTable: False + GenerateLinkMap: False + LinkResources: False + ResourceSource: + GenerateDLL: False + ExportedNames: + Paths + Path: {Project} + Precompile: + Postlink: +MainModule + Name: uFPL + Dir: {Project} + Compiler + NeverMemoryProfile: False + NeverTimeProfile: False + StrictnessAnalysis: True + ListTypes: StrictExportTypes + ListAttributes: True + Warnings: True + Verbose: True + ReadableABC: False + ReuseUniqueNodes: True + Fusion: False diff --git a/assignment-13/uFPL/Sim.dcl b/assignment-13/uFPL/Sim.dcl new file mode 100644 index 0000000..6ee6e14 --- /dev/null +++ b/assignment-13/uFPL/Sim.dcl @@ -0,0 +1,78 @@ +definition module uFPL.Sim + +import iTasks + +import uFPL +from uFPL.C import :: Signedness + +:: UFPLException + = LiftException String + | NoShareException ISharedRef + | WriteToROShare ISharedRef + +instance toString UFPLException + +class lift a :: a -> Task Dynamic +class unlift a b :: b -> a + +:: ReadOrWrite = ReadOnly | ReadWrite + +:: ISharedInt = + { iisname :: String + , iisinit :: Int + , iisrw :: ReadOrWrite + } + +:: ISharedRef :== String + +:: IShares = + { ishares :: [ISharedInt] + } + +:: IExpr + = ILitInt Int + | ILitBool Bool + | ILitChar Char + | IShared ISharedRef + | IAdd IExpr IExpr + | ISub IExpr IExpr + | IMul IExpr IExpr + | IDiv IExpr IExpr + | IEq IExpr IExpr + | ILt IExpr IExpr + | IAnd IExpr IExpr + | IOr IExpr IExpr + | IIf IExpr IExpr IExpr + +:: ITrigger + = IChange ISharedRef + | IBecomes ISharedRef IExpr + | ITAnd ITrigger ITrigger + | ITOr ITrigger ITrigger + +:: IRule + = IAssign ISharedRef IExpr + | IWhen IExpr [IRule] + | ITrigger ITrigger [IRule] + | ISetCursor (IExpr, IExpr) + | IPrint IExpr + +:: INamedRule = Rule String [IRule] + +derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, IShares, IExpr, + ITrigger, IRule, INamedRule + +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 ISharedInt +instance unlift ISharedInt (UShared Int rw) +instance lift ITrigger +instance unlift ITrigger Trigger +instance lift IRule +instance unlift IRule Rule +instance lift INamedRule +instance unlift INamedRule NamedRule + +simulate :: [NamedRule] -> Task () diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl new file mode 100644 index 0000000..ac42046 --- /dev/null +++ b/assignment-13/uFPL/Sim.icl @@ -0,0 +1,180 @@ +implementation module uFPL.Sim + +import Data.Functor +import Data.Maybe + +import iTasks + +import uFPL +import uFPL.Bootstrap +import uFPL.C + +derive class iTask UFPLException +instance toString UFPLException +where + toString (LiftException s) = "Lift exception: " +++ s + 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 + +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 + +instance lift [a] | lift a +where + lift xs = dynamicList <$> allTasks (map lift xs) + where + dynamicList :: [Dynamic] -> Dynamic + dynamicList ds = list (reverse ds) (dynamic [] :: A.a: [a]) + where + list :: [Dynamic] Dynamic -> Dynamic + list [(d :: t):r] (l :: [t]) = list r (dynamic [d:l]) + +instance unlift [a] [b] | unlift a b where unlift xs = map unlift xs + +instance lift IExpr +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 (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) + _ -> throw (LiftException "IAdd") + lift (ISub 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) + _ -> throw (LiftException "ISub") + lift (IMul 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) + _ -> throw (LiftException "IMul") + lift (IDiv 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) + _ -> throw (LiftException "IDiv") + lift (IEq 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 Bool RO) + (a :: Expr Char rwa, b :: Expr Char rwb) -> return (dynamic a ==. b :: Expr Bool RO) + (a :: Expr Bool rwa, b :: Expr Bool rwb) -> return (dynamic a ==. b :: Expr Bool RO) + _ -> throw (LiftException "IEq") + lift (ILt 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 Bool RO) + (a :: Expr Char rwa, b :: Expr Char rwb) -> return (dynamic a <. b :: Expr Bool RO) + _ -> throw (LiftException "ILt") + lift (IAnd a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of + (a :: Expr Bool rwa, b :: Expr Bool rwb) -> return (dynamic a &&. b :: Expr Bool RO) + _ -> throw (LiftException "IAnd") + lift (IOr a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of + (a :: Expr Bool rwa, b :: Expr Bool rwb) -> return (dynamic a ||. b :: Expr Bool RO) + _ -> throw (LiftException "IOr") + lift (IIf b t e) = lift b >>= \b -> lift t >>= \t -> lift e >>= \e -> case (b,t,e) of + (b :: Expr Bool rwa, t :: Expr Int rwb, e :: Expr Int rwc) -> return (dynamic b ? (t,e) :: Expr Int RO) + (b :: Expr Bool rwa, t :: Expr Char rwb, e :: Expr Char rwc) -> return (dynamic b ? (t,e) :: Expr Char RO) + (b :: Expr Bool rwa, t :: Expr Bool rwb, e :: Expr Bool rwc) -> return (dynamic b ? (t,e) :: Expr Bool RO) + _ -> throw (LiftException "IIf") + +instance unlift IExpr (Expr t rw) | Expr t +where + unlift (ELit v) = case dynamic v of + (i :: Int) -> ILitInt i + (c :: Char) -> ILitChar c + (b :: Bool) -> ILitBool b + unlift (EShared s) = IShared s.sname + unlift (a +. b) = IAdd (unlift a) (unlift b) + unlift (a -. b) = ISub (unlift a) (unlift b) + unlift (a *. b) = IMul (unlift a) (unlift b) + unlift (a /. b) = IDiv (unlift a) (unlift b) + unlift (EEq _ a b) = IEq (unlift a) (unlift b) + unlift (ELt _ a b) = ILt (unlift a) (unlift b) + unlift (EAnd _ a b) = IAnd (unlift a) (unlift b) + 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 + +// 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 lift ITrigger +where + lift (IChange s) = getSharedInt s >>= lift >>= \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 + (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 + (a :: Trigger, b :: Trigger) -> return (dynamic a ?& b) + _ -> throw (LiftException "ITAnd") + lift (ITOr a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of + (a :: Trigger, b :: Trigger) -> return (dynamic a ?| b) + _ -> throw (LiftException "ITOr") + +instance unlift ITrigger Trigger +where + unlift (Change (EShared s)) = IChange s.sname + unlift (EShared s ?= e) = IBecomes s.sname (unlift e) + unlift (a ?& b) = ITAnd (unlift a) (unlift b) + unlift (a ?| b) = ITOr (unlift a) (unlift b) + +instance lift IRule +where + lift (IAssign s e) = getSharedInt s >>= lift >>= \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) + _ -> 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) + _ -> throw (LiftException "IWhen") + lift (ITrigger t rs) = lift t >>= \t -> lift rs >>= \rs -> case (t,rs) of + (t :: Trigger, rs :: [Rule]) -> return (dynamic t >>> rs) + _ -> throw (LiftException "IWhen") + lift (ISetCursor (c,r)) = lift c >>= \c -> lift r >>= \r -> case (c,r) of + (c :: Expr Int rwa, r :: Expr Int rwb) -> return (dynamic SetCursor (c,r)) + _ -> throw (LiftException "ISetCursor") + lift (IPrint e) = lift e >>= \e -> case e of + (e :: Expr Int rw) -> return (dynamic Print e) + (e :: Expr Char rw) -> return (dynamic Print e) + (e :: Expr Bool rw) -> return (dynamic Print e) + _ -> throw (LiftException "IPrint") + +instance unlift IRule Rule +where + unlift (EShared s <# e) = IAssign s.sname (unlift e) + unlift (When e rs) = IWhen (unlift e) (unlift rs) + unlift (t >>> rs) = ITrigger (unlift t) (unlift rs) + unlift (SetCursor (c,r)) = ISetCursor (unlift c, unlift r) + unlift (Print e) = IPrint (unlift e) + +instance lift INamedRule +where + lift (Rule s rs) = lift rs >>= \rs -> case rs of + (rs :: [Rule]) -> return (dynamic s :=: rs) + +instance unlift INamedRule NamedRule +where + unlift (s :=: rs) = case dynamic rs of + (r :: Rule) -> Rule s [unlift r] + (rs :: [Rule]) -> Rule s (unlift rs) + +simulate :: [NamedRule] -> Task () +simulate rs = update >>= \rs -> viewInformation (Title "Your rules") [] rs $> () +where + update :: Task [INamedRule] + update = updateInformation (Title "Rules") [] (unlift rs) |