diff options
| -rw-r--r-- | assignment-13/uFPL.dcl | 37 | ||||
| -rw-r--r-- | assignment-13/uFPL.icl | 113 | ||||
| -rw-r--r-- | assignment-13/uFPL/Bootstrap.dcl | 2 | ||||
| -rw-r--r-- | assignment-13/uFPL/Bootstrap.icl | 19 | ||||
| -rw-r--r-- | assignment-13/uFPL/Sim.dcl | 37 | ||||
| -rw-r--r-- | assignment-13/uFPL/Sim.icl | 179 |
6 files changed, 279 insertions, 108 deletions
diff --git a/assignment-13/uFPL.dcl b/assignment-13/uFPL.dcl index c061119..55c9c66 100644 --- a/assignment-13/uFPL.dcl +++ b/assignment-13/uFPL.dcl @@ -1,7 +1,10 @@ definition module uFPL from StdGeneric import :: Bimap -from StdOverloaded import class +, class -, class *, class /, class ==, class < +from StdOverloaded import class +, class -, class *, class /, class ==, class <, class toString + +from Data.Map import :: Map +from Data.Maybe import :: Maybe from uFPL.C import :: CType, :: CExpr, :: CBody, :: CVar, :: CFun, :: CProg @@ -75,9 +78,9 @@ lit :: (t -> Expr t RO) | E.rw: When (Expr Bool rw) [Rule] | (>>>) infixr 2 Trigger [Rule] | E.rwa rwb: SetCursor (Expr Int rwa, Expr Int rwb) - | E.t rw: Print (Expr t rw) & Expr t + | E.t rw: Print (Expr t rw) & Expr, toString t -:: NamedRule = E.r: (:=:) infix 1 String r & gen r CBody & allShares r & TC r +:: NamedRule = E.r: (:=:) infix 1 String r & gen r CBody & run, allShares, TC r class gen f t :: f -> t @@ -97,3 +100,31 @@ instance gen [r] CBody | gen r CBody instance gen NamedRule CFun instance gen NamedRule CProg instance gen [NamedRule] CProg + +:: ShareState = + { val :: Dynamic + , dirty :: Int + , subscriptions :: Int + } + +:: Display = + { size :: (Int, Int) + , cursor :: (Int, Int) + , text :: Map (Int, Int) Char + } + +instance toString Display + +:: State = + { vars :: Map String ShareState + , display :: Display + } + +display :: String Display -> Display +eval :: (Expr t rw) State -> Maybe t | Expr t +evalTrigger :: Trigger State -> Maybe (Bool, State) + +class run r :: r -> State -> Maybe State +instance run [r] | run r +instance run Rule +instance run NamedRule diff --git a/assignment-13/uFPL.icl b/assignment-13/uFPL.icl index 23bf85c..b87538e 100644 --- a/assignment-13/uFPL.icl +++ b/assignment-13/uFPL.icl @@ -6,14 +6,21 @@ import StdClass from StdFunc import const, flip, id, o from StdGeneric import :: Bimap{..}, bimapId; bm :== bimapId import StdInt -import StdList +from StdList import any, map, instance fromString [a] import StdMisc import StdOverloaded import StdString import StdTuple +import Control.Applicative +import Control.Monad from Data.Func import $ -import Data.List +import Data.Functor +import Data.Maybe +from Data.List import intersperse, foldr1 +import Data.Map +import Data.Tuple +from Text import class Text(concat), instance Text String import uFPL.Arduino import uFPL.Bootstrap @@ -172,20 +179,7 @@ where , name = "t" +++ name } -instance gen [NamedRule] String -where - gen rs = foldl1 (+++) $ - [rts] ++ - ["\n" +++ printToString var \\ var <- sharesMap genv (allShares rs)] ++ - ["\n" +++ printToString (genf rule) \\ rule <- rs] - where - genf :: (NamedRule -> CFun) - genf = gen - - genv :: ((UShared t rw) -> CVar) - genv = gen - -instance gen NamedRule CProg +instance gen NamedRule CProg where gen r = combinePrograms zero { bootstrap = "" @@ -197,7 +191,83 @@ instance gen [NamedRule] CProg where gen rs = foldr (combinePrograms o gen) zero rs -Start w = startEngine (simulate example_countdown) w +instance toString Display +where + toString d = concat $ intersperse "\n" + [{char c r \\ c <- [0..cols - 1]} \\ r <- [0..rows - 1]] + where + (cols,rows) = d.size + + char :: Int Int -> Char + char c r = case get (c,r) d.text of + Just c -> c + Nothing -> ' ' + +display :: String Display -> Display +display s dis = foldr (\c -> next o write c) dis (fromString s) +where + write :: Char Display -> Display + write v dis = {dis & text=put dis.cursor v dis.text} + + next :: Display -> Display + next dis = {dis & cursor=(nc,nr)} + where + (c,r) = dis.cursor + (cols,rows) = dis.size + nc = if (c == cols - 1) 0 (c + 1) + nr = if (c == cols - 1) (if (r == rows - 1) 0 (r + 1)) r + +eval :: (Expr t rw) State -> Maybe t | Expr t +eval (ELit l) _ = Just l +eval (EShared s) st = case get s.sname st.vars of + Just {val=v :: t^} -> Just v + _ -> Nothing +eval (a +. b) st = onEval (+) st a b +eval (a -. b) st = onEval (-) st a b +eval (a *. b) st = onEval (*) st a b +eval (a /. b) st = onEval (/) st a b +eval (EEq bm a b) st = bm.map_from <$> onEval (==) st a b +eval (ELt bm a b) st = bm.map_from <$> onEval (<) st a b +eval (EAnd bm a b) st = bm.map_from <$> onEval (&&) st a b +eval (EOr bm a b) st = bm.map_from <$> onEval (||) st a b +eval (EIf b t e) st = liftA3 (\b t e -> if b t e) (eval b st) (eval t st) (eval e st) + +onEval :: (t u -> v) State (Expr t rwa) (Expr u rwb) -> Maybe v | Expr t & Expr u +onEval f st a b = liftA2 f (eval a st) (eval b st) + +evalTrigger :: Trigger State -> Maybe (Bool, State) +evalTrigger (Change (EShared s)) st = case get s.sname st.vars of + Just shr=:{dirty=n} | n > 0 -> Just (True, {st & vars=put s.sname {shr & dirty=n-1} st.vars}) + 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 -> Just (False, st) + _ -> Nothing +where + equals :: Dynamic t -> Maybe Bool | ==, TC t + equals (v :: t^) x = Just (v == x) + equals _ _ = Nothing +evalTrigger (a ?& b) st = evalTrigger a st >>= \(a,st) -> appFst ((&&) a) <$> evalTrigger b st +evalTrigger (a ?| b) st = evalTrigger a st >>= \(a,st) -> appFst ((||) a) <$> evalTrigger b st + +instance run [r] | run r where run rs = flip (foldM (flip run)) rs + +instance run Rule +where + run (EShared s <# e) = \st -> eval e st >>= \e -> case get s.sname st.vars of + Just shr -> Just {st & vars=put s.sname {shr & val=dynamic e, dirty=shr.subscriptions} st.vars} + Nothing -> Nothing + run (When b rs) = \st -> eval b st >>= \b -> if b (run rs) Just st + run (t >>> rs) = \st -> evalTrigger t st >>= \(b,st) -> if b (run rs) Just st + run (SetCursor (c,r)) = \st -> eval c st >>= \c -> eval r st >>= \r -> Just {State | st & display.cursor=(c,r)} + run (Print e) = \st -> eval e st >>= \e -> Just {State | st & display=display (toString e) st.State.display} + +instance run NamedRule +where + run (_ :=: r) = run r + +Start w = simulate example_countdown w Start _ = printToString (genp example_score) where genp :: (a -> CProg) | gen a CProg @@ -220,14 +290,15 @@ where example_countdown :: [NamedRule] example_countdown = "time" :=: - When (millis -. DELAY >. counter) - (counter <# counter +. DELAY :. + When (millis -. DELAY >. counter) ( + counter <# counter +. DELAY :. seconds <# seconds -. lit 1 :. SetCursor (lit 0, lit 0) :. Print minutes :. Print (lit ':') :. - Print seconds) - :. When (seconds ==. lit 0) (seconds <# lit 60 :. minutes <# minutes -. lit 1) + Print seconds + ) :. + When (seconds ==. lit 0) (seconds <# lit 60 :. minutes <# minutes -. lit 1) ||| "status" :=: When (seconds ==. lit 60 &&. minutes ==. lit 0) [running <# false] where diff --git a/assignment-13/uFPL/Bootstrap.dcl b/assignment-13/uFPL/Bootstrap.dcl index 201957c..583dc75 100644 --- a/assignment-13/uFPL/Bootstrap.dcl +++ b/assignment-13/uFPL/Bootstrap.dcl @@ -32,6 +32,8 @@ millis :: Expr Int RO false :: Expr Bool RO true :: Expr Bool RO +predefShares :: Shares + rts :: String instance zero CProg diff --git a/assignment-13/uFPL/Bootstrap.icl b/assignment-13/uFPL/Bootstrap.icl index b0ccf66..1ca75ac 100644 --- a/assignment-13/uFPL/Bootstrap.icl +++ b/assignment-13/uFPL/Bootstrap.icl @@ -1,10 +1,12 @@ implementation module uFPL.Bootstrap -from StdFunc import const +from StdFunc import const, o import StdGeneric from StdMisc import undef import StdString +from Data.Func import $ + import uFPL.Arduino import uFPL.C import uFPL @@ -72,6 +74,19 @@ false = lit False true :: Expr Bool RO true = lit True +predefShares :: Shares +predefShares + = share b0 + $ share b1 + $ share b2 + $ share b3 + $ share b4 + $ share millis + NoShares +where + share :: ((Expr t rw) Shares -> Shares) | Expr t + share = Shares o (\(EShared s) -> s) + rts :: String rts = "#include <LiquidCrystal.h>" +: @@ -117,4 +132,4 @@ where " return 0;" +: "}" -instance zero CProg where zero = {bootstrap=rts, globals=[], funs=[]} +instance zero CProg where zero = {bootstrap=rts, globals=sharesMap gen predefShares, funs=[]} diff --git a/assignment-13/uFPL/Sim.dcl b/assignment-13/uFPL/Sim.dcl index f30e107..b4d8528 100644 --- a/assignment-13/uFPL/Sim.dcl +++ b/assignment-13/uFPL/Sim.dcl @@ -2,8 +2,6 @@ definition module uFPL.Sim from Data.Map import :: Map -import iTasks - import uFPL from uFPL.C import :: Signedness @@ -11,12 +9,10 @@ from uFPL.C import :: Signedness = LiftException String | NoShareException ISharedRef | WriteToROShare ISharedRef + | RunException instance toString UFPLException -class lift a :: a -> Task Dynamic -class unlift a b :: b -> a - :: ReadOrWrite = ReadOnly | ReadWrite :: IShared @@ -60,26 +56,17 @@ class unlift a b :: b -> a :: INamedRule = Rule String [IRule] -:: IState = - { isvalues :: Map String Int - , uisvalues :: Map String Int - , lsvalues :: Map String Int - , ulsvalues :: Map String Int - , bsvalues :: Map String Bool +:: IShareState t = + { isval :: t + , isdirty :: Int + , issubscriptions :: Int } -derive class iTask Signedness, CType, ReadOrWrite, IShared, IExpr, ITrigger, - IRule, INamedRule, IState - -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 ITrigger -instance unlift ITrigger Trigger -instance lift IRule -instance unlift IRule Rule -instance lift INamedRule -instance unlift INamedRule NamedRule +:: IState = + { isvalues :: Map String (IShareState Int) + , csvalues :: Map String (IShareState Char) + , bsvalues :: Map String (IShareState Bool) + , display :: Display + } -simulate :: [NamedRule] -> Task () +simulate :: [NamedRule] -> *World -> *World 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} |