summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--assignment-13/uFPL.dcl8
-rw-r--r--assignment-13/uFPL.icl85
-rw-r--r--assignment-13/uFPL/C.dcl5
-rw-r--r--assignment-13/uFPL/C.icl14
-rw-r--r--assignment-13/uFPL/Sim.dcl2
-rw-r--r--assignment-13/uFPL/Sim.icl17
6 files changed, 102 insertions, 29 deletions
diff --git a/assignment-13/uFPL.dcl b/assignment-13/uFPL.dcl
index fee3c26..4d69076 100644
--- a/assignment-13/uFPL.dcl
+++ b/assignment-13/uFPL.dcl
@@ -39,6 +39,12 @@ instance allShares Trigger
instance allShares Rule
instance allShares NamedRule
+class allTriggers t :: t -> [Trigger]
+instance allTriggers [t] | allTriggers t
+instance allTriggers Trigger
+instance allTriggers Rule
+instance allTriggers NamedRule
+
class Expr t | TC t where litExpr :: t -> CExpr
instance Expr Int
instance Expr Bool
@@ -82,7 +88,7 @@ pressed :: (Expr Bool RO) -> Trigger
| E.rwa rwb: SetCursor (Expr Int rwa, Expr Int rwb)
| E.t rw: Print (Expr t rw) & Expr, toString t
-:: NamedRule = E.r: (:=:) infixr 1 String r & gen r CBody & run, allShares, TC r
+:: NamedRule = E.r: (:=:) infixr 1 String r & gen r CBody & run, allShares, allTriggers, TC r
class gen f t :: f -> t
diff --git a/assignment-13/uFPL.icl b/assignment-13/uFPL.icl
index 881a11f..607eabd 100644
--- a/assignment-13/uFPL.icl
+++ b/assignment-13/uFPL.icl
@@ -6,7 +6,7 @@ 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]
+from StdList import any, filter, flatten, foldl, map, instance fromString [a]
import StdMisc
import StdOverloaded
import StdString
@@ -17,7 +17,7 @@ import Control.Monad
from Data.Func import $
import Data.Functor
import Data.Maybe
-from Data.List import intersperse, foldr1
+from Data.List import concatMap, intersperse, foldr1
import Data.Map
import Data.Tuple
from Text import class Text(concat), instance Text String
@@ -91,6 +91,24 @@ 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
@@ -162,8 +180,8 @@ where
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 (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])
@@ -177,22 +195,61 @@ where
gen (name :=: rs) =
{ params = []
, body = gen rs
- , fresh = 0
, 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]
+ , funs = [gen r, fun_setup [r], fun_loop [r], fun_system [r]]
}
instance gen [NamedRule] CProg
where
- gen rs = foldr (combinePrograms o gen) zero rs
+ gen rs = combinePrograms {zero & funs=[fun_setup rs, fun_loop rs, fun_system rs]} $
+ foldr (combinePrograms o gen) zero rs
instance toString Display
where
@@ -270,10 +327,10 @@ instance run NamedRule
where
run (_ :=: r) = run r
-Start w = simulate example_score w
+Start w = simulate example_countdown w
-example_score :: [NamedRule]
-example_score =
+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]
@@ -282,13 +339,13 @@ example_score =
Print scorea :.
Print (lit '-') :.
Print scoreb
- )
+ ))
where
scorea = rwInt "scorea" 0
scoreb = rwInt "scoreb" 0
-example_countdown :: [NamedRule]
-example_countdown =
+example_countdown :: (String, [NamedRule])
+example_countdown = ("countdown",
"time" :=:
(Change millis >>> [When (millis -. DELAY >. counter) (
counter <# counter +. DELAY :.
@@ -315,7 +372,7 @@ example_countdown =
||| "reset" :=: pressed b3 >>> (
seconds <# lit 0 :.
minutes <# lit 0
- )
+ ))
where
running = rwBool "running" False
minutes = rwInt "minutes" 2
diff --git a/assignment-13/uFPL/C.dcl b/assignment-13/uFPL/C.dcl
index f9d3595..3b25183 100644
--- a/assignment-13/uFPL/C.dcl
+++ b/assignment-13/uFPL/C.dcl
@@ -33,14 +33,14 @@ from uFPL.Util import class print
:: CBody
= CBReturn (Maybe CExpr)
- | CBIf CExpr CBody CBody
+ | CBIf CExpr CBody [(CExpr, CBody)] (Maybe CBody)
| CBWhile CExpr CBody
| CBAssign String CExpr
| CBSeq CBody CBody
| CBEmpty
| CBExpr CExpr
-(`seq`) infix 0 :: CBody CBody -> CBody
+(`seq`) infixr 0 :: CBody CBody -> CBody
:: CVar =
{ name :: String
@@ -51,7 +51,6 @@ from uFPL.Util import class print
:: CFun =
{ params :: [(Int, CType)]
, body :: CBody
- , fresh :: Int
, type :: CType
, name :: String
}
diff --git a/assignment-13/uFPL/C.icl b/assignment-13/uFPL/C.icl
index 763774c..87f8573 100644
--- a/assignment-13/uFPL/C.icl
+++ b/assignment-13/uFPL/C.icl
@@ -15,7 +15,7 @@ import Data.Tuple
import uFPL.Arduino
import uFPL.Util
-(`seq`) infix 0 :: CBody CBody -> CBody
+(`seq`) infixr 0 :: CBody CBody -> CBody
(`seq`) CBEmpty cb = cb
(`seq`) cb CBEmpty = cb
(`seq`) a b = CBSeq a b
@@ -68,10 +68,14 @@ instance print CBody
where
print (CBReturn Nothing) = print "return;"
print (CBReturn (Just e)) = print "return " o print e o print ";"
- print (CBIf c t e) = print "if (" o print c o print ") {" o indent o nl
- o print t o unindent o nl
- o print "} else {" o indent o nl
- o print e o unindent o nl o print "}"
+ print (CBIf c t eifs e) =
+ prsperse "} else " [print "if (" o print c o print ") {" o indent o nl o print t o unindent o nl \\ (c,t) <- [(c,t):eifs]]
+ o case e of
+ Just e ->
+ print "} else {" o indent o nl
+ o print e o unindent o nl o print "}"
+ Nothing ->
+ print "}"
print (CBWhile e b) = print "while (" o print e o print ") {" o nl o print b o nl o print "}"
print (CBAssign v e) = print v o print " = " o print e o print ";"
print (CBSeq a b) = print a o nl o print b
diff --git a/assignment-13/uFPL/Sim.dcl b/assignment-13/uFPL/Sim.dcl
index b4d8528..96527db 100644
--- a/assignment-13/uFPL/Sim.dcl
+++ b/assignment-13/uFPL/Sim.dcl
@@ -69,4 +69,4 @@ instance toString UFPLException
, display :: Display
}
-simulate :: [NamedRule] -> *World -> *World
+simulate :: (String, [NamedRule]) -> *World -> *World
diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl
index 5fccd8e..892708c 100644
--- a/assignment-13/uFPL/Sim.icl
+++ b/assignment-13/uFPL/Sim.icl
@@ -1,5 +1,6 @@
implementation module uFPL.Sim
+import StdFile
from StdFunc import flip, seq
from Data.Func import $
@@ -8,6 +9,7 @@ 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
@@ -289,8 +291,8 @@ where
, display = st.State.display
}
-simulate :: [NamedRule] -> *World -> *World
-simulate rs = startEngine $
+simulate :: (String, [NamedRule]) -> *World -> *World
+simulate (progName, rs) = startEngine $
(setupShares >>| sim)
-&&- ((
whileUnchanged (irules >*< ishares) (uncurry newShares)
@@ -369,9 +371,14 @@ where
millisActions shrs ++
[ action "Step" $ step
, OnAction (Action "Generate code") $ ifOk $ get irules >>= lift >>= \rs -> case rs of
- (rs :: [NamedRule]) -> viewInformation (Title "Generated code")
- [ViewUsing id (textArea <<@ sizeAttr (ExactSize 500) (ExactSize 600) <<@ styleAttr "font-size:11px;")]
- (printToString (genp rs)) >>| check
+ (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
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-16 07:56:33 +0000