path: root/assignment-13/uFPL.icl

implementation module uFPL

import StdArray
import StdBool
import StdClass
from StdFunc import const, flip, id, o
from StdGeneric import :: Bimap{..}, bimapId; bm :== bimapId
import StdInt
from StdList import any, filter, flatten, foldl, map, instance fromString [a]
import StdMisc
import StdOverloaded
import StdString
import StdTuple

import Control.Applicative
import Control.Monad
from Data.Func import $
import Data.Functor
import Data.Maybe
from Data.List import concatMap, intersperse, foldr1
import Data.Map
import Data.Tuple
from Text import class Text(concat), instance Text String

import uFPL.Arduino
import uFPL.Bootstrap
import uFPL.C
import uFPL.Sim
import uFPL.Util

typedfun :: CType String -> String
typedfun t f = flip (+++) f case t of
	CTBool   -> "b"
	CTInt  s -> sig s +++ "i"
	CTChar s -> sig s +++ "c"
	CTLong s -> sig s +++ "l"
where
	sig :: Signedness -> String
	sig Sig = ""
	sig Unsig = "u"

append :: Shares Shares -> Shares
append NoShares ss = ss
append (Shares s ss) sss = Shares s (append ss sss)

removeDupShares :: Shares -> Shares
removeDupShares NoShares = NoShares
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: (UShared t rw) -> a | Expr t) Shares -> [a]
sharesMap _ NoShares = []
sharesMap f (Shares s ss) = [f s:sharesMap f ss]

instance allShares [t] | allShares t
where
	allShares` [] = NoShares
	allShares` [x:xs] = append (allShares` x) (allShares` xs)

instance allShares (Expr t rw) | Expr t
where
	allShares` (ELit _) = NoShares
	allShares` (EShared s) = Shares s NoShares
	allShares` (a +. b) = append (allShares` a) (allShares` b)
	allShares` (a -. b) = append (allShares` a) (allShares` b)
	allShares` (a *. b) = append (allShares` a) (allShares` b)
	allShares` (a /. b) = append (allShares` a) (allShares` b)
	allShares` (EEq  _ a b) = append (allShares` a) (allShares` b)
	allShares` (ELt  _ a b) = append (allShares` a) (allShares` b)
	allShares` (EAnd _ a b) = append (allShares` a) (allShares` b)
	allShares` (EOr  _ a b) = append (allShares` a) (allShares` b)
	allShares` (EIf  b t e) = append (allShares` b) (append (allShares` t) (allShares` e))

instance allShares Trigger
where
	allShares` (Change t) = allShares` t
	allShares` (s ?= t) = append (allShares` s) (allShares` t)
	allShares` (a ?& b) = append (allShares` a) (allShares` b)
	allShares` (a ?| b) = append (allShares` a) (allShares` b)

instance allShares Rule
where
	allShares` (s <# e) = append (allShares` s) (allShares` e)
	allShares` (When t rs) = foldr1 append [allShares` t:map allShares` rs]
	allShares` (t >>> rs) = foldr1 append [allShares` t:map allShares` rs]
	allShares` (SetCursor (c,r)) = append (allShares` c) (allShares` r)
	allShares` (Print v) = allShares` v

instance allShares NamedRule
where
	allShares` (_ :=: r) = allShares` r

instance allTriggers [t] | allTriggers t
where
	allTriggers xs = concatMap allTriggers xs

instance allTriggers Trigger where allTriggers t = [t]

instance allTriggers Rule
where
	allTriggers (_ <# _) = []
	allTriggers (When _ rs) = allTriggers rs
	allTriggers (t >>> rs) = [t:allTriggers rs]
	allTriggers (SetCursor _) = []
	allTriggers (Print _) = []

instance allTriggers NamedRule
where
	allTriggers (_ :=: r) = allTriggers r

instance Expr Int where litExpr i = CEInt i
instance Expr Bool where litExpr b = CEBool b
instance Expr Char where litExpr c = CEChar c

lit :: (t -> Expr t RO)
lit = ELit

(?) infix 5 :: (Expr Bool rwa) (Expr t rwb, Expr t rwc) -> Expr t RO
(?) b (t,e) = EIf b t e

(==.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, == t
(==.) a b = EEq bm a b

(<.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, < t
(<.) a b = ELt bm a b

(>.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, < t
(>.) a b = ELt bm b a

(&&.) infixr 3 :: (Expr Bool rwa) (Expr Bool rwb) -> Expr Bool RO
(&&.) a b = EAnd bm a b

(||.) infixr 4 :: (Expr Bool rwa) (Expr Bool rwb) -> Expr Bool RO
(||.) a b = EOr bm a b

pressed :: (Expr Bool RO) -> Trigger
pressed shr = shr ?= true

instance :. Rule   where (:.) a b = [a,b]
instance :. [Rule] where (:.) r rs = [r:rs]

instance ||| NamedRule   where (|||) a b = [a,b]
instance ||| [NamedRule] where (|||) r rs = [r:rs]

instance gen (Expr t rw) CExpr | Expr t
where
	gen (ELit v) = litExpr v
	gen (EShared s) = CEGlobal ("s" +++ s.sname +++ ".val")
	gen (a +. b) = CEInfix "+" (gen a) (gen b)
	gen (a -. b) = CEInfix "-" (gen a) (gen b)
	gen (a *. b) = CEInfix "*" (gen a) (gen b)
	gen (a /. b) = CEInfix "/" (gen a) (gen b)
	gen (EEq  _ a b) = CEInfix "==" (gen a) (gen b)
	gen (ELt  _ a b) = CEInfix "<"  (gen a) (gen b)
	gen (EAnd _ a b) = CEInfix "&&" (gen a) (gen b)
	gen (EOr  _ a b) = CEInfix "||" (gen a) (gen b)
	gen (EIf b t e) = CEIf (gen b) (gen t) (gen e)

instance gen (UShared t rw) CVar
where
	gen shr =
		{ CVar
		| name  = "s" +++ shr.sname
		, type  = CTStruct (typedfun shr.stype "share")
		, value = CEStruct
			[ ("val", shr.srepr.map_to shr.sinit)
			, ("dirty", CEInt 0)
			, ("subscriptions", CEInt 0)
			]
		}

instance gen Trigger CExpr
where
	gen (Change (EShared shr)) = CEApp (typedfun shr.stype "dirty") [CERef (CEGlobal ("s" +++ shr.sname))]
	gen (EShared shr ?= e) = CEInfix "&&" (gen (Change (EShared shr))) (CEInfix "==" (CEGlobal ("s" +++ shr.sname +++ ".val")) (gen e))
	gen (a ?& b) = CEInfix "&&" (gen a) (gen b)
	gen (a ?| b) = CEInfix "||" (gen a) (gen b)

instance gen Rule CBody
where
	gen (EShared shr <# val) = CBExpr (CEApp (typedfun shr.stype "set") [CERef (CEGlobal ("s" +++ shr.sname)), gen val])
	gen (When b rs) = CBIf (gen b) (gen rs) [] Nothing
	gen (t >>> rs) = CBIf (gen t) (gen rs) [] Nothing
	gen (SetCursor (c,r)) = CBExpr (CEApp "lcd.setCursor" [gen c, gen r])
	gen (Print e) = CBExpr (CEApp "lcd.print" [gen e])

instance gen [r] CBody | gen r CBody
where
	gen [] = CBEmpty
	gen rs = foldr1 CBSeq (map gen rs)

instance gen NamedRule CFun
where
	gen (name :=: rs) =
		{ params = []
		, body   = gen rs
		, type   = CTVoid
		, name   = "t" +++ name
		}

fun_setup :: [NamedRule] -> CFun
fun_setup rs =
	{ params = []
	, type   = CTVoid
	, name   = "setup"
	, body   =
		CBExpr (CEApp "lcd.begin" [CEInt 16, CEInt 2]) `seq`
		CBExpr (CEApp "pinMode" [CEGlobal "A0", CEGlobal "INPUT"]) `seq`
		foldr (`seq`) CBEmpty
			[CBExpr $ CEApp (typedfun t "subscribe") [CERef (CEGlobal ("s" +++ s))]
				\\ (s,t) <- flatten $ map (sharesMap \s -> (s.sname, s.stype)) $ map allShares` $ allTriggers rs]
	}

fun_loop :: [NamedRule] -> CFun
fun_loop rs =
	{ params = []
	, type   = CTVoid
	, name   = "loop"
	, body   =
		foldr (`seq`) (CBExpr $ CEApp "system" []) [CBExpr $ CEApp ("t" +++ r) [] \\ r :=: _ <- rs]
	}

fun_system :: [NamedRule] -> CFun
fun_system rs =
	{ params = []
	, type   = CTVoid
	, name   = "system"
	, body   =
		CBAssign "int val" (CEApp "analogRead" [CEGlobal "A0"]) `seq`
		CBIf
			(CEInfix "<" (CEGlobal "val") (CEInt 50))
			(CBExpr $ CEApp "bset" [CERef (CEGlobal "sb0"), CEBool True])
			[(CEInfix "<" (CEGlobal "val") (CEInt t),
				CBExpr $ CEApp "bset" [CERef (CEGlobal b), CEBool True])
				\\ (t,b) <- [(190,"sb1"),(380,"sb2"),(555,"sb3"),(790,"sb4")]]
			Nothing `seq`
		CBExpr (CEApp "ulset" [CERef (CEGlobal "smillis"), CEApp "millis" []])
	}

instance gen NamedRule CProg
where
	gen r = combinePrograms zero
		{ bootstrap = ""
		, globals   = sharesMap gen (allShares r)
		, funs      = [gen r, fun_setup [r], fun_loop [r], fun_system [r]]
		}

instance gen [NamedRule] CProg
where
	gen rs = combinePrograms {zero & funs=[fun_setup rs, fun_loop rs, fun_system rs]} $
		foldr (combinePrograms o gen) zero rs

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 = foldl (\dis c -> next $ write c dis) 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 & vars=put s.sname {shr & dirty=n-1} st.vars} <$> 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

example_score :: (String, [NamedRule])
example_score = ("score",
		"a" :=: pressed b0 >>> [scorea <# scorea +. lit 1]
	||| "b" :=: pressed b1 >>> [scoreb <# scoreb +. lit 1]
	||| "r" :=: pressed b2 >>> [scorea <# lit 0, scoreb <# lit 0]
	||| "print" :=: (Change scorea ?| Change scoreb) >>> (
		SetCursor (lit 0, lit 0) :.
		Print scorea :.
		Print (lit '-') :.
		Print scoreb
	))
where
	scorea = rwInt "scorea" 0
	scoreb = rwInt "scoreb" 0

example_countdown :: (String, [NamedRule])
example_countdown = ("countdown",
		"time" :=:
			(Change millis >>> [When (millis -. DELAY >. counter) (
				counter <# counter +. DELAY :.
				seconds <# running ? (seconds -. lit 1, seconds)
			)]) :.
			seconds ?= lit -1 >>> (
				minutes <# minutes -. lit 1 :.
				seconds <# lit 59
			) :.
			minutes ?= lit -1 >>> (
				running <# false :.
				minutes <# lit 0 :.
				seconds <# lit 0
			) :.
			Change seconds >>> (
				SetCursor (lit 0, lit 0) :.
				Print minutes :.
				Print (lit ':') :.
				Print seconds
			)
	||| "setsec" :=: pressed b0 >>> [seconds <# seconds +. lit 1]
	||| "setmin" :=: pressed b1 >>> [minutes <# minutes +. lit 1]
	||| "on_off" :=: pressed b2 >>> [running <# running ? (false, true)]
	||| "reset"  :=: pressed b3 >>> (
		seconds <# lit 0 :.
		minutes <# lit 0
	))
where
	running = rwBool "running" False
	minutes = rwInt "minutes" 2
	seconds = rwInt "seconds" 0
	counter = rwULong "counter" 0 // If set to 0, this will overflow on first iteration
	DELAY = lit 1000