a7/charlie/skeleton7.icl

   1 module skeleton7
   2
   3 // Mart Lubbers s4109503
   4 // Charlie Gerhardus s3050009
   5
   6 /*import iTasks */
   7 from iTasks import always, hasValue, :: TaskValue(..), :: Task, :: Stability, :: TaskCont(..), :: Action, updateInformation, viewInformation, class descr, instance descr String, :: UpdateOption, :: ViewOption(..), -||-, -||, ||-, startEngine, class Publishable, >>*, class TFunctor, instance TFunctor Task, class TApplicative, instance TApplicative Task, instance Publishable Task, Void
   8 import Data.Tuple, StdClass, StdList, iTasks._Framework.Generic, Text.JSON, Data.Functor, Control.Applicative, Control.Monad, Data.Map
   9 import qualified iTasks
  10 import qualified Text
  11 from Text import class Text, instance Text String
  12 from StdFunc import o
  13 import StdTuple
  14
  15 // initial expression
  16 e = Insert (Integer 4) (Union (Insert (Integer 8) New) (Insert (Integer 55) New))
  17
  18 // iTasks magic
  19 derive class iTask Expression, Op, Val
  20
  21 :: Expression
  22         = New
  23         | Insert                 Element Set
  24         | Delete                 Element Set
  25         | Variable               Ident
  26         | Union                  Set    Set
  27         | Difference     Set    Set
  28         | Intersection   Set    Set
  29         | Integer                Int
  30         | Size                   Set
  31         | Oper                   Element Op Element
  32         | (=.)  infixl 2 Ident Expression
  33
  34 :: Op           =       +. | -. | *.
  35 :: Set          :== Expression
  36 :: Element      :== Expression
  37 :: Ident        :== String
  38
  39 :: Val = Error String | IVal Int | IVals [Int]
  40
  41 // for use with print
  42 instance toString Op where
  43         toString +. = " + "
  44         toString -. = " - "
  45         toString *. = " * "
  46
  47 // === State
  48 :: State :== [(String, Val)]
  49
  50 // === semantics
  51 :: *SemResult a :== (a, State)
  52 :: Sem a = Sem (State -> *SemResult a)
  53
  54 // apply f on result and preserve state
  55 execValue :: (a -> b) *(SemResult a) -> *SemResult b
  56 execValue f (x, st) = (f x, st)
  57
  58 instance Functor Sem where
  59         fmap :: (a -> b) (Sem a) -> (Sem b)
  60         fmap f (Sem g) = Sem \ st -> execValue f (g st)
  61
  62 instance Applicative Sem where
  63         pure :: a -> Sem a
  64         pure x = Sem (\ st -> (x, st))
  65
  66         (<*>) infixl 4 :: (Sem (a -> b)) (Sem a) -> Sem b
  67         (<*>) (Sem f) (Sem g) = Sem \st -> h (f st) where
  68                 h = \ (f, st1) -> execValue f (g st1)
  69 //      (<*>) (Sem f) (Sem g) = Sem (\ st -> execSem g (f st))
  70
  71 instance Monad Sem where
  72         bind :: (Sem a) (a -> Sem b) -> Sem b
  73         bind (Sem f) g = Sem \ st -> h (f st) where
  74                 h = \ (x, st) -> q st (g x)
  75                 q = \ st (Sem f) -> f st
  76
  77 // Store value
  78 store :: Ident Val -> Sem Val
  79 store id v = Sem \ st -> (v, [(id, v):st])
  80
  81 // read var
  82 read :: Ident -> Sem Val
  83 read id = Sem
  84         \ st -> (snd (hd (filter (\(id2, _) -> id == id2) st)), st)
  85
  86 // insert value into set
  87 setInsert :: Val Val -> Sem Val
  88 setInsert (IVals is) (IVal i) = Sem \st -> (IVals [i:is], st)
  89 setInsert _ _ = fail "insert fail!"
  90
  91 // remove value from set
  92 setDelete :: Val Val -> Sem Val
  93 setDelete (IVals is) (IVal i) = Sem \st -> (IVals (filter (\j -> i <> j) is), st)
  94 setDelete _ _ = fail "delete fail!"
  95
  96 // set union
  97 setUnion :: Val Val -> Sem Val
  98 setUnion (IVals is1) (IVals is2) = Sem \st -> (IVals (removeDup (is1++is2)), st)
  99 setUnion _ _ = fail "union fail!"
 100
 101 // set difference
 102 setDiff :: Val Val -> Sem Val
 103 setDiff (IVals is1) (IVals is2) = Sem \st -> (IVals (removeMembers is1 is2), st)
 104 setDiff _ _ = fail "difference fail!"
 105
 106 // set intersection
 107 setIntersect :: Val Val -> Sem Val
 108 setIntersect (IVals is1) (IVals is2) = Sem \st -> (IVals (filter f is2), st) where
 109         f = \ x -> isMember x is1
 110 setIntersect _ _ = fail "intersection fail!"
 111
 112 // set size
 113 setSize :: Val -> Sem Val
 114 setSize (IVals is) = Sem \st -> (IVal (length is), st)
 115 setSize _ = fail "size fail!"
 116
 117 // integer operator
 118 intOper :: Val Op Val -> Sem Val
 119 intOper (IVal l) +. (IVal r) = Sem \st -> (IVal (l+r), st)
 120 intOper (IVal l) -. (IVal r) = Sem \st -> (IVal (l-r), st)
 121 intOper (IVal l) *. (IVal r) = Sem \st -> (IVal (l*r), st)
 122 intOper _ _ _ = fail "invalid int operation!"
 123
 124 // error out
 125 fail :: String -> Sem Val
 126 fail msg = Sem \ st -> (Error msg, st)
 127
 128 // evalulate
 129 eval :: Expression -> Sem Val
 130 eval New = Sem \st -> (IVals [], st)
 131 eval (Insert e exp) = eval exp >>= \set -> eval e >>= \el -> setInsert set el
 132 eval (Delete e exp) = eval exp >>= \set -> eval e >>= \el -> setDelete set el
 133 eval (Union exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setUnion s1 s2
 134 eval (Difference exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setDiff s1 s2
 135 eval (Intersection exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setIntersect s1 s2
 136 eval (Integer i) = Sem \st -> (IVal i, st)
 137 eval (Variable id) = read id
 138 eval (Size exp) = eval exp >>= setSize
 139 eval (Oper exp1 op exp2) = eval exp1 >>= \l -> eval exp2 >>= \r -> intOper l op r
 140 eval (id =. exp) = eval exp >>= store id
 141
 142 // printing
 143 print :: Expression [String] -> [String]
 144 print New xs = ["New":xs]
 145 print (Insert e exp) xs = ["[":print e [":":print exp ["]":xs]]]
 146 print (Delete e exp) xs = ["del(":print e [", ":print exp [")":xs]]]
 147 print (Union exp1 exp2) xs = print exp1 [" U ":print exp2 xs]
 148 print (Difference exp1 exp2) xs = print exp1 [" \\ ":print exp2 xs]
 149 print (Intersection exp1 exp2) xs = print exp1 [" I ":print exp2 xs]
 150 print (Integer i) xs = [toString i:xs]
 151 print (Size exp) xs = print exp xs
 152 print (Oper exp1 op exp2) xs = print exp1 [toString op:print exp2 xs]
 153 print (Variable id) xs = [id:xs]
 154 print (id =. exp) xs = [id:[" = ":print exp xs]]
 155
 156 // === simulation
 157 (>>>=)     :== 'iTasks'.tbind
 158 (>>>|) a b :== 'iTasks'.tbind a (\_ -> b)
 159 treturn    :== 'iTasks'.return
 160 ActionOk   :== 'iTasks'.ActionOk
 161 ActionQuit :== 'iTasks'.ActionQuit
 162 ActionNew  :== 'iTasks'.ActionNew
 163 Action :== 'iTasks'.Action
 164
 165 // display code, value and state
 166 viewCode exp val st = viewInformation "Executed code:" [] text
 167         -|| viewInformation "Result:" [] val
 168         -|| viewInformation "State:" [] st where
 169                 text = 'Text'.concat (print exp [])
 170
 171 // run entered expression
 172 runCode st exp = superIDE exp val st1 where
 173         (Sem f) = eval exp
 174         (val, st1) = f st
 175
 176 // the main task
 177 superIDE :: Expression Val State -> Task Expression
 178 superIDE exp val st = (updateInformation "Write your code:" [] exp
 179         -|| viewCode exp val st)
 180                 >>* [OnAction ActionOk (hasValue (runCode st))]
 181
 182 Start world = startEngine (superIDE e (IVal 0) []) world