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

implementation module uFPL.Sim

from StdFunc import seq

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

getShared :: ISharedRef -> Task Dynamic
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
	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 IShared
where
	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
	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
	unlift NoShares = []
	unlift (Shares shr rest) = [unlift shr:unlift rest]

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
			/*(  [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
		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 = 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

		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])
		>>*
		[ 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}
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)