path: root/assignment-13/uFPL/Sim.icl

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

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, 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{|*|}

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

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 = 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

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)  = 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)
		_ -> 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

instance lift ISharedUInt
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
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) = getShared s >>= \s -> case s of
		(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)
		_ -> 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) = 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)
		_ -> 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 = 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
	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)