From: Mart Lubbers Date: Wed, 28 Nov 2018 09:14:11 +0000 (+0100) Subject: 10 X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=9b250e33701c0905600c8bd403c0d72fa76d64b8;p=clean-tests.git 10 --- diff --git a/TimeGraph.zip b/TimeGraph.zip new file mode 100644 index 0000000..63b8658 Binary files /dev/null and b/TimeGraph.zip differ diff --git a/afp/a10/a10.icl b/afp/a10/a10.icl index 77445a6..9f4a7a5 100644 --- a/afp/a10/a10.icl +++ b/afp/a10/a10.icl @@ -14,11 +14,11 @@ bm = {t = id, f = id, t2 = id, f2 = id} :: 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 @@ -70,11 +70,28 @@ eval (Unlock _ _) s=:{locked=(Just c)} = 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 + ) diff --git a/rank2/test.icl b/rank2/test.icl new file mode 100644 index 0000000..da53852 --- /dev/null +++ b/rank2/test.icl @@ -0,0 +1,49 @@ +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) diff --git a/timegraph/TimeGraph/TimeGraph.dcl b/timegraph/TimeGraph/TimeGraph.dcl new file mode 100644 index 0000000..4313cb8 --- /dev/null +++ b/timegraph/TimeGraph/TimeGraph.dcl @@ -0,0 +1,31 @@ +definition module TimeGraph + +import iTasks.WF.Definition +import iTasks.UI.JS.Encoding +import Graphics.Scalable.Image + +:: TimeGraphOptions a + = { valueSpan :: a -> Span // turn value into rendering distance + , measures :: [TimeGraphMeasure a] // the measures that are drawn across the graph + , distance :: Span // the distance between two neighbouring values + , maxValue :: a // the maximum value that can be rendered visibly + , maxNoElts :: Int // the maximum number of elements that are rendered + } +:: TimeGraphMeasure a + = { base :: a // the value at which the measure is rendered + , label :: String // the label of the measure + , left :: Bool // if True, label is rendered at left of graph, otherwise at right of graph + , font :: FontDef // the font used to render this label + } + +/** time_graph options values: + is a task that renders @values in a graph using @options. + The number of values that are shown is controlled by @options.maxNoElts. + The dimensions of the graph are controlled by @options.distance (the width of each bar) and the application of + the function @options.valueSpan to the displayed value (the height of each bar). + The maximum value that can be displayed is controlled by @options.maxValue. + The @options.measures show labelled lines across the bars. The position of the label is controlled by the .left + field of the measure. The height is controlled by the .base field of the measure. Each label can have a different + font, defined by the .font field of the measure. +*/ +time_graph :: !(TimeGraphOptions a) ![a] -> Task [a] | JSEncode{|*|}, JSDecode{|*|}, iTask a diff --git a/timegraph/TimeGraph/TimeGraph.icl b/timegraph/TimeGraph/TimeGraph.icl new file mode 100644 index 0000000..95a1992 --- /dev/null +++ b/timegraph/TimeGraph/TimeGraph.icl @@ -0,0 +1,77 @@ +implementation module TimeGraph + +// An example of a task that uses SVG to render a list of values and measures + +from iTasks.WF.Definition import class iTask +import iTasks.Engine +import iTasks.WF.Tasks.Interaction +import iTasks.UI.Prompt +import Graphics.Scalable.Image +import iTasks.Extensions.SVG.SVGEditor +import StdEnum, StdList +from StdFunc import id, o, const + +// shorthand definitions for the used fonts in these examples +times = normalFontDef "Times New Roman" + +// shorthand definitions for the used colours in these examples +none = toSVGColor "none" +linecolour = toSVGColor "red" +backgroundcolour = toSVGColor "aliceblue" +barcolour = toSVGColor "steelblue" +barstrokecolour = backgroundcolour + +Start :: !*World -> *World +Start world + = doTasks (time_graph options ([1.0..5.0] ++ [4.5,3.5..0.5])) world +where + options = {TimeGraphOptions + | valueSpan = \v = px (50.0*v) + , measures = [ {TimeGraphMeasure + | base = 3.14 + , label = "low" + , left = True + , font = times 8.0 + } + , {TimeGraphMeasure + | base = 4.88 + , label = "high" + , left = False + , font = times 8.0 + } + ] + , distance = px 10.0 + , maxValue = 10.0 + , maxNoElts = 10 + } + +time_graph :: !(TimeGraphOptions a) ![a] -> Task [a] | JSEncode{|*|}, JSDecode{|*|}, iTask a +time_graph options values + = viewInformation "TimeGraph" [ViewUsing id (fromSVGEditor { initView = id + , renderImage = const (graph options) + , updView = \m _ = m + , updModel = \_ v = v + })] values + +graph :: !(TimeGraphOptions a) ![a] !*TagSource -> Image [a] +graph options=:{TimeGraphOptions | valueSpan,distance,measures,maxValue,maxNoElts} values tags + = beside (repeat AtBottom) [] Nothing [] + [ left_labels + , collage [(zero,height-diagram_height):[(zero,height-(valueSpan m.base)) \\ m <- measures]] + [diagram : [xline diagram_width <@< {stroke = linecolour} \\ m <- measures]] + (Host (rect diagram_width height <@< {fill = backgroundcolour} <@< {stroke = none})) + , right_labels + ] (Host (empty width height)) +where + left_measures = filter (\m = m.left) measures + right_measures = filter (\m = not m.left) measures + 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)) + 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)) + left_labels_width = maxSpan [textxspan m.font m.label \\ m <- left_measures] + right_labels_width = maxSpan [textxspan m.font m.label \\ m <- right_measures] + diagram = beside (repeat AtBottom) [] Nothing [] bars (Host (empty diagram_width height)) + bars = [rect distance (valueSpan v) <@< {fill = barcolour} <@< {stroke = barstrokecolour} \\ v <- take maxNoElts values] + width = left_labels_width + diagram_width + right_labels_width + diagram_width = distance *. maxNoElts + diagram_height = maxSpan (map valueSpan values) + height = valueSpan maxValue