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, 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 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 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) CBEmpty
	gen (t >>> rs) = CBIf (gen t) (gen rs) CBEmpty
	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
		, fresh  = 0
		, type   = CTVoid
		, name   = "t" +++ name
		}

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

instance gen [NamedRule] CProg
where
	gen 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
Start _ = printToString (genp example_score)
where
	genp :: (a -> CProg) | gen a CProg
	genp = gen

example_score :: [NamedRule]
example_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 :: [NamedRule]
example_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