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

implementation module uFPL.Sim

import StdFile
from StdFunc import flip, seq

from Data.Func import $
import Data.Functor
from Data.List import concatMap
import qualified Data.Map as M
import Data.Maybe
import Data.Tuple
import System.File
from Text import <+
import Text.HTML

import iTasks
import iTasks.Extensions.DateTime
import iTasks.UI.Editor.Common
import iTasks.UI.Layout.Default

import uFPL
import uFPL.Bootstrap
import uFPL.C
import uFPL.Util

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
	toString RunException         = "Could not run"

derive class iTask Signedness, CType, ReadOrWrite, IShared, IExpr, ITrigger,
	IRule, INamedRule, IState, IShareState

gDefault{|Display|} =
	{ size   = (16, 2)
	, cursor = (0, 0)
	, text   = 'M'.newMap
	}
derive gEditor Display
derive gText Display
derive gEq Display
derive JSONEncode Display
derive JSONDecode Display

class lift a :: a -> Task Dynamic
class unlift a b :: b -> a

istate :: Shared IState
istate = sharedStore "state" gDefault{|*|}

irules :: Shared [INamedRule]
irules = sharedStore "irules" []

ishares :: Shared IShares
ishares = sharedStore "ishares" gDefault{|*|}

simulatorRunning :: Shared Bool
simulatorRunning = sharedStore "simulatorRunning" False

getShared :: ISharedRef -> Task Dynamic
getShared n = get ishares >>= \shrs -> case filter ((==) n o isharedName) shrs of
	[]    -> throw (NoShareException n)
	[s:_] -> lift s

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
	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 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
		(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)
		(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)
		_ -> 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")
	lift (IPrintS s) = return (dynamic PrintS s)

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)
	unlift (PrintS s) = IPrintS s

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)

instance lift IState
where
	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
		liftSharedState :: (IShareState t) -> ShareState | TC t
		liftSharedState st = {val=dynamic st.isval, dirty=st.isdirty, subscriptions=st.issubscriptions}

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 :: (String, [NamedRule]) -> *World -> *World
simulate (progName, rs) = startEngine $
	(setupShares >>| sim)
	-&&- ((
	whileUnchanged (irules >*< ishares) (uncurry newShares)
	) <<@ NoUserInterface)
where
	setupShares =
		set (unlift rs) irules >>|
		set (unlift (allShares rs)) ishares

	sim =
		(check -&&- show)
		-&&-
		(updateSharedInformation (Title "Rules")
			[UpdateUsing id (const id) (listEditor (Just $ const Nothing) True False Nothing ruleEditor)] irules
		-&&-
		updateSharedInformation (Title "Shares")
			[UpdateUsing id (const id) (listEditor (Just $ const Nothing) True False Nothing gEditor{|*|})] ishares
		)
		<<@ ArrangeHorizontal
	where
		ruleEditor :: Editor INamedRule
		ruleEditor = gEditor{|*|}

	newShares :: [INamedRule] IShares -> Task IState
	newShares rs shrs = get istate >>= lift >>= \ist -> case ist of
		(st :: State) -> set (unlift
			{ st & vars = 'M'.mapWithKey (\k v -> {v & subscriptions=subscriptions k rs}) $ foldr (uncurry 'M'.put) st.vars
				[(isharedName shr, {val=isharedInit shr, dirty=0, subscriptions=0}) \\ shr <- shrs]}) istate
	where
		subscriptions :: String [INamedRule] -> Int
		subscriptions s rs = length $ filter ((==) s) $ concatMap allSharedSubscriptions $ flatten [allTriggers rs` \\ Rule _ rs` <- rs]

		allTriggers :: [IRule] -> [ITrigger]
		allTriggers rs = [t \\ ITrigger t _ <- rs]

		allSharedSubscriptions :: ITrigger -> [ISharedRef]
		allSharedSubscriptions t = case t of
			IChange s -> [s]
			IBecomes s _ -> [s]
			ITAnd a b -> allSharedSubscriptions a ++ allSharedSubscriptions b
			ITOr  a b -> allSharedSubscriptions a ++ allSharedSubscriptions b

	show :: Task IState
	show = viewSharedInformation (Title "State") [viewAsLists] istate
		<<@ ApplyLayout (setUIAttributes $ minWidthAttr $ ExactBound 400)
	where
		viewAsLists = ViewUsing tolists $ container4 listView listView listView (textView <<@ styleAttr "font-family:monospace;")
		with
			listView :: Editor [(String,IShareState a)] | iTask, == a
			listView = listEditor Nothing False False Nothing itemView

			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)], String)
		tolists st = ('M'.toList st.isvalues, 'M'.toList st.csvalues, 'M'.toList st.bsvalues, toString st.IState.display)

	check :: Task String
	check = whileUnchanged (irules >*< ishares) (\(rs,shrs) -> catchAll (lift rs >>| return "OK") return
		>>= \stat -> (viewInformation (Title "Status")
		[ViewUsing id $ viewComponent (\text -> 'M'.unions
			[ valueAttr (JSONString (escapeStr text))
			, styleAttr (if (text == "OK") "" "color:red;font-weight:bold;")
			]) UITextView] stat
		>>*
		buttonActions shrs ++
		millisActions shrs ++
		[ action "Step" $ step
		, OnAction (Action "Generate code") $ ifOk $ get irules >>= lift >>= \rs -> case rs of
			(rs :: [NamedRule]) -> let prog = printToString (genp rs) in
				viewInformation (Title "Generated code")
					[ViewUsing id (textArea <<@ sizeAttr (ExactSize 500) (ExactSize 600) <<@ styleAttr "font-size:11px;")]
					prog >>*
				[ OnAction ActionContinue $ always check
				, OnAction ActionSaveAs $ always $ updateInformation (Title "Filename") [] (progName +++ ".ino") >>= \fn ->
					appWorld (snd o writeFile fn prog) >>| check
				]
		])
		<<@ ApplyLayout (sequenceLayouts
			finalizeStep
			(layoutSubUIs (SelectByType UIButtonBar) arrangeVertical))
		<<@ ApplyLayout (layoutSubUIs (SelectOR (SelectByPath []) (SelectByPath [0])) $ setUIAttributes (heightAttr WrapSize))
		)
	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

		genp :: (a -> CProg) | gen a CProg
		genp = gen

		buttonActions :: IShares -> [TaskCont String (Task String)]
		buttonActions shrs = flatten
			[ [ action ("Toggle B" <+ i) $ toggle i
			  , action ("Press B"  <+ i) $ press i
			  ] \\ i <- [0..5] | any ((==) ("b" <+ i) o isharedName) shrs]
		where
			toggle :: Int -> Task IState
			toggle 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}

			press :: Int -> Task IState
			press i = change True >>| step >>| change False
			with
				change v = get istate >>= lift >>= \st -> case st of
					(st :: State) -> set (unlift {st & vars='M'.alter (upd v) ("b" <+ i) st.vars}) istate

				upd v (Just s) = Just {s & val=dynamic v, dirty=s.subscriptions}

		millisActions :: IShares -> [TaskCont String (Task String)]
		millisActions shrs
		| any ((==) "millis" o isharedName) shrs =
			[ action "t +100ms" $ addMillis 100 $> ()
			, action "t +1s"    $ addMillis 1000 $> ()
			, action "Toggle running / 1s" $
				((forever $ waitForTimer 0 >>| addMillis 1000 >>| step $> ()) <<@ NoUserInterface)
				>>* [OnAction (Action "Stop") (always (return ()))]
			]
		| otherwise = []

	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")

	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}
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)