From: Mart Lubbers Date: Wed, 5 Dec 2018 12:14:57 +0000 (+0100) Subject: Merge branch 'master' of git.martlubbers.net:clean-tests X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=d26be584859f046d29708d03c41861d421cefc6d;hp=f97a5bd0b5f76a04c484555f7ff16b0f3ba152bb;p=clean-tests.git Merge branch 'master' of git.martlubbers.net:clean-tests --- 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 fabad8c..1da0267 100644 --- a/afp/a10/a10.icl +++ b/afp/a10/a10.icl @@ -7,6 +7,7 @@ import Control.Applicative import Control.Monad import Data.Maybe import Data.Error +import Text => qualified join :: BM a b = {t :: a->b, f :: b->a, t2 :: A.c t:(t c a)->t c b, f2 :: A.c t:(t b c)->t a c} bm = {t = id, f = id, t2 = id, f2 = id} @@ -14,11 +15,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,8 +71,8 @@ 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 @@ -85,3 +86,49 @@ opt (a :. b) = opt a :. opt b opt x = x Start = opt (moveToShip :. wait :. moveDown) +//print :: (Action i f) [String] -> [String] +//print (MoveToShip _ _) s = ["Move to ship":s] +//print (MoveToQuay _ _) s = ["Move to quay":s] +//print (MoveUp _ _) s = ["Move up":s] +//print (MoveDown _ _) s = ["Move down":s] +//print (Lock _ _) s = ["Lock":s] +//print (Unlock _ _) s = ["Unlock":s] +//print (Wait _) s = ["Wait":s] +//print (a :. b) s = print a ["\n":print b s] +//print (WhileContainerBelow _ a) s +// = ["While container below (":indent ["\n":print a [")":s]]] +//where +// indent s = map (\s->if (s.[0] == '\n') (s +++ "\t") s) +// + +print :: (Action i f) String [String] -> [String] +print (MoveToShip _ _) i s = [i,"Move to ship":s] +print (MoveToQuay _ _) i s = [i,"Move to quay":s] +print (MoveUp _ _) i s = [i,"Move up":s] +print (MoveDown _ _) i s = [i,"Move down":s] +print (Lock _ _) i s = [i,"Lock":s] +print (Unlock _ _) i s = [i,"Unlock":s] +print (Wait _) i s = [i,"Wait":s] +print (a :. b) i s = print a i ["\n":print b i s] +print (WhileContainerBelow _ a) i s + = [i,"While container below (\n":print a ("\t"+++i) ["\n",i,")":s]] + +Start = print loadShip "" [] + +p1 = moveToShip :. moveDown + +//p2 = moveToShip :. wait :. lock // the required type error + +loadShip = + whileContainerBelow ( + moveDown:. + lock:. + moveUp:. + moveToShip:. + wait:. + moveDown:. + wait:. + unlock:. + moveUp:. + moveToQuay + ) :. wait diff --git a/funcdeps/test.icl b/funcdeps/test.icl index f9ef764..56022e9 100644 --- a/funcdeps/test.icl +++ b/funcdeps/test.icl @@ -1,6 +1,6 @@ module test -import StdMisc +import StdEnv :: Zero = Zero :: Succ a = Succ a @@ -20,3 +20,9 @@ where Start :: Int Start = 42 + +class fmap t :: (a -> b) (t a) -> t b + +instance fmap ((,)a) where fmap f (a, b) = (a, f b) + +Start = fmap inc (42, 37) 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