:: Action b a
= MoveToShip (BM b High) (BM a High)
| MoveToQuay (BM b High) (BM a High)
- | MoveUp (BM b Low) (BM a High)
- | MoveDown (BM b High) (BM a Low)
- | Lock (BM b Low) (BM a Low)
- | Unlock (BM b Low) (BM a Low)
- | Wait (BM b a)
+ | MoveUp (BM b Low) (BM a High)
+ | MoveDown (BM b High) (BM a Low)
+ | Lock (BM b Low) (BM a Low)
+ | Unlock (BM b Low) (BM a Low)
+ | Wait (BM b a)
| E.i: (:.) infixl 1 (Action b i) (Action i a)
| WhileContainerBelow (BM b a) (Action a a)
:: High = High
= pure {s & onShip = [c:s.onShip], locked = Nothing}
eval (Unlock b1 b2) s=:{locked=Nothing}
= Error "Cannot unlock container, crane contains nothing"
-eval (Wait _) s = Ok s
-eval (a :. b) s = eval a s >>= eval b
+eval (Wait _) s = Ok s
+eval (a :. b) s = eval a s >>= eval b
eval (WhileContainerBelow _ action) s
| s.craneOnQuay && not (isEmpty s.onQuay) || not s.craneOnQuay && not (isEmpty s.onShip)
= eval (action :. whileContainerBelow action) s
= pure s
-Start = moveToShip :. moveDown
+Start = loadShip
+p1 = moveToShip :. moveDown
+
+//p2 = moveToShip :. wait :. lock // the required type error
+
+loadShip =
+ whileContainerBelow (
+ moveDown:.
+ lock:.
+ moveUp:.
+ moveToShip:.
+ wait:.
+ moveDown:.
+ wait:.
+ unlock:.
+ moveUp:.
+ moveToQuay
+ )
--- /dev/null
+module test
+
+import StdEnv
+
+class arith v
+where
+ lit :: a -> v a | toString a
+ plus :: (v a) (v a) -> v a | + a
+
+class rtrn v :: (v a) -> v (TaskValue a)
+
+:: Print a = P String
+unPrint :: (Print a) -> String
+unPrint (P a) = a
+
+:: Eval a = E a
+unEval :: (Eval a) -> a
+unEval (E a) = a
+
+:: TaskValue a = NoValue | Value a Bool
+
+instance arith Print
+where
+ lit a = P (toString a)
+ plus (P a) (P b) = P (a +++ "+" +++ b)
+
+instance arith Eval
+where
+ lit a = E a
+ plus (E a) (E b) = E (a + b)
+
+instance rtrn Print where rtrn (P a) = P ("Task (" +++ a +++ ")")
+instance rtrn Eval where rtrn (E a) = E (Value a True)
+
+class default a :: a
+instance default Int where default = 42
+instance default (TaskValue a) where default = NoValue
+
+listItem ::
+ (A.v: a -> v (TaskValue b) | rtrn, arith v)
+ -> (String, b)
+ | +, toString, default b & default a
+listItem mtask =
+ ( unPrint (mtask default)
+ , default //unEval (mtask default)
+ )
+
+Start :: (String, Int)
+Start = listItem \i->rtrn (lit i)
--- /dev/null
+definition module TimeGraph\r
+\r
+import iTasks.WF.Definition\r
+import iTasks.UI.JS.Encoding\r
+import Graphics.Scalable.Image\r
+\r
+:: TimeGraphOptions a\r
+ = { valueSpan :: a -> Span // turn value into rendering distance\r
+ , measures :: [TimeGraphMeasure a] // the measures that are drawn across the graph\r
+ , distance :: Span // the distance between two neighbouring values\r
+ , maxValue :: a // the maximum value that can be rendered visibly\r
+ , maxNoElts :: Int // the maximum number of elements that are rendered\r
+ }\r
+:: TimeGraphMeasure a\r
+ = { base :: a // the value at which the measure is rendered\r
+ , label :: String // the label of the measure\r
+ , left :: Bool // if True, label is rendered at left of graph, otherwise at right of graph\r
+ , font :: FontDef // the font used to render this label\r
+ }\r
+\r
+/** time_graph options values:\r
+ is a task that renders @values in a graph using @options.\r
+ The number of values that are shown is controlled by @options.maxNoElts.\r
+ The dimensions of the graph are controlled by @options.distance (the width of each bar) and the application of\r
+ the function @options.valueSpan to the displayed value (the height of each bar).\r
+ The maximum value that can be displayed is controlled by @options.maxValue.\r
+ The @options.measures show labelled lines across the bars. The position of the label is controlled by the .left\r
+ field of the measure. The height is controlled by the .base field of the measure. Each label can have a different\r
+ font, defined by the .font field of the measure.\r
+*/\r
+time_graph :: !(TimeGraphOptions a) ![a] -> Task [a] | JSEncode{|*|}, JSDecode{|*|}, iTask a\r
--- /dev/null
+implementation module TimeGraph\r
+\r
+// An example of a task that uses SVG to render a list of values and measures\r
+\r
+from iTasks.WF.Definition import class iTask\r
+import iTasks.Engine\r
+import iTasks.WF.Tasks.Interaction\r
+import iTasks.UI.Prompt\r
+import Graphics.Scalable.Image\r
+import iTasks.Extensions.SVG.SVGEditor\r
+import StdEnum, StdList\r
+from StdFunc import id, o, const\r
+\r
+// shorthand definitions for the used fonts in these examples\r
+times = normalFontDef "Times New Roman"\r
+\r
+// shorthand definitions for the used colours in these examples\r
+none = toSVGColor "none"\r
+linecolour = toSVGColor "red"\r
+backgroundcolour = toSVGColor "aliceblue"\r
+barcolour = toSVGColor "steelblue"\r
+barstrokecolour = backgroundcolour\r
+\r
+Start :: !*World -> *World\r
+Start world\r
+ = doTasks (time_graph options ([1.0..5.0] ++ [4.5,3.5..0.5])) world\r
+where\r
+ options = {TimeGraphOptions\r
+ | valueSpan = \v = px (50.0*v)\r
+ , measures = [ {TimeGraphMeasure\r
+ | base = 3.14\r
+ , label = "low"\r
+ , left = True\r
+ , font = times 8.0\r
+ }\r
+ , {TimeGraphMeasure\r
+ | base = 4.88\r
+ , label = "high"\r
+ , left = False\r
+ , font = times 8.0\r
+ }\r
+ ]\r
+ , distance = px 10.0\r
+ , maxValue = 10.0\r
+ , maxNoElts = 10\r
+ }\r
+\r
+time_graph :: !(TimeGraphOptions a) ![a] -> Task [a] | JSEncode{|*|}, JSDecode{|*|}, iTask a\r
+time_graph options values\r
+ = viewInformation "TimeGraph" [ViewUsing id (fromSVGEditor { initView = id\r
+ , renderImage = const (graph options)\r
+ , updView = \m _ = m\r
+ , updModel = \_ v = v\r
+ })] values\r
+\r
+graph :: !(TimeGraphOptions a) ![a] !*TagSource -> Image [a]\r
+graph options=:{TimeGraphOptions | valueSpan,distance,measures,maxValue,maxNoElts} values tags\r
+ = beside (repeat AtBottom) [] Nothing []\r
+ [ left_labels\r
+ , collage [(zero,height-diagram_height):[(zero,height-(valueSpan m.base)) \\ m <- measures]]\r
+ [diagram : [xline diagram_width <@< {stroke = linecolour} \\ m <- measures]]\r
+ (Host (rect diagram_width height <@< {fill = backgroundcolour} <@< {stroke = none}))\r
+ , right_labels\r
+ ] (Host (empty width height))\r
+where\r
+ left_measures = filter (\m = m.left) measures\r
+ right_measures = filter (\m = not m.left) measures\r
+ left_labels = collage [(zero,height-(valueSpan m.base)) \\ m <- left_measures] [text m.font m.label \\ m <- left_measures] (Host (empty left_labels_width height))\r
+ right_labels = collage [(zero,height-(valueSpan m.base)) \\ m <- right_measures] [text m.font m.label \\ m <- right_measures] (Host (empty right_labels_width height))\r
+ left_labels_width = maxSpan [textxspan m.font m.label \\ m <- left_measures]\r
+ right_labels_width = maxSpan [textxspan m.font m.label \\ m <- right_measures]\r
+ diagram = beside (repeat AtBottom) [] Nothing [] bars (Host (empty diagram_width height))\r
+ bars = [rect distance (valueSpan v) <@< {fill = barcolour} <@< {stroke = barstrokecolour} \\ v <- take maxNoElts values]\r
+ width = left_labels_width + diagram_width + right_labels_width\r
+ diagram_width = distance *. maxNoElts\r
+ diagram_height = maxSpan (map valueSpan values)\r
+ height = valueSpan maxValue\r
repositories / clean-tests.git / commitdiff