a8/mart/skeleton8.icl

   1 module skeleton8
   2
   3 import StdList, StdInt, Data.Tuple, StdClass, iTasks._Framework.Generic, Text.JSON, Data.Functor, Control.Applicative, Control.Monad, Data.Void
   4 import qualified iTasks
   5 import qualified Text
   6 from Text import class Text, instance Text String
   7 from StdFunc import o
   8 from StdTuple import fst
   9 from Data.Map import :: Map, put, get, newMap
  10 import Data.Either
  11 import qualified Data.List as List
  12
  13 :: Element :== Sem Int
  14 :: Set :== Sem [Int]
  15 :: Val = I Int | S [Int] | B Bool
  16 :: State :== Map String Val
  17 :: Sem a = Sem (State -> (Either String a, State))
  18
  19 unsem :: (Sem a) -> (State -> (Either String a, State))
  20 unsem (Sem a) = a
  21
  22 instance Functor Sem where
  23         fmap :: (a -> b) (Sem a) -> Sem b
  24         fmap f s = Sem \st.let (a, st`) = unsem s st in (fmap f a, st`)
  25
  26 instance Applicative Sem where
  27         pure :: a -> Sem a
  28         pure s = Sem \st.(pure s, st)
  29         (<*>) infixl 4  :: (Sem (a -> b)) (Sem a) -> Sem b
  30         (<*>) a f = ap a f
  31
  32 instance Monad Sem where
  33         bind :: (Sem a) (a -> Sem b) -> Sem b
  34         bind (Sem s) f = Sem \st.case s st of
  35                 (Right v, st`) = unsem (f v) st`
  36                 (Left e, st`) = (Left e, st`)
  37
  38 store :: String Val -> Sem Val
  39 store i v = Sem \st.(pure v, put i v st)
  40
  41 read :: String -> Sem Val
  42 read i = Sem \st.case get i st of
  43                 (Just v) = (Right v, st)
  44                 _ = unsem (fail "variable not found") st
  45
  46 fail :: String -> Sem a
  47 fail s = Sem \st.(Left s,st)
  48
  49 instance + Element where (+) s1 s2 = fmap (+) s1 <*> s2
  50 instance - Element where (-) s1 s2 = fmap (-) s1 <*> s2
  51 instance * Element where (*) s1 s2 = fmap (*) s1 <*> s2
  52
  53 integer :: Int -> Element
  54 integer i = return i
  55
  56 size :: Set -> Element
  57 size s = fmap length s
  58
  59 new :: Set
  60 new = return []
  61
  62 insert :: Element Set -> Set
  63 insert e s = union (fmap (\x.[x]) e) s
  64
  65 delete :: Element Set -> Set
  66 delete e s = difference (fmap (\x.[x]) e) s
  67
  68 union :: Set Set -> Set
  69 union s1 s2 = fmap 'List'.union s1 <*> s2
  70
  71 difference :: Set Set -> Set
  72 difference s1 s2 = fmap 'List'.difference s1 <*> s2
  73
  74 intersection :: Set Set -> Set
  75 intersection s1 s2 = fmap 'List'.intersect s1 <*> s2
  76
  77 class eval a :: (Sem a) -> (Either String a, State)
  78
  79 instance eval Element where
  80         eval (Sem e) = e newMap
  81
  82 instance eval Set where
  83         eval (Sem s) = s newMap
  84
  85 instance eval Int where
  86         eval (Sem s) = s newMap
  87
  88 instance eval [Int] where
  89         eval (Sem s) = s newMap
  90
  91 class variable a :: String -> a
  92
  93 instance variable Element where
  94         variable k = Sem \st.case get k st of
  95                 (Just (I v)) = (Right v, st)
  96                 (Just _) = (Left "Wrong type, expected Int", st)
  97                 _ = (Left "Variable not found", st)
  98
  99 instance variable Set where
 100         variable k = Sem \st.case get k st of
 101                 (Just (S v)) = ((Right v), st)
 102                 (Just _) = (Left "Wrong type, expected Set", st)
 103                 _ = (Left "Variable not found", st)
 104
 105 class (=.) infix 2 a :: String a -> a
 106
 107 instance =. Element where
 108         (=.) k (Sem v) = Sem \st.case v st of
 109                 (Right v, st) = (Right v, put k (I v) st)
 110                 (Left e, st) = (Left e, st)
 111
 112 instance =. Set where
 113         (=.) k (Sem v) = Sem \st.case v st of
 114                 (Right v, st) = (Right v, put k (S v) st)
 115                 (Left e, st) = (Left e, st)
 116
 117 (:.) infixl 1 :: (Sem a) (Sem b) -> (Sem b)
 118 (:.) s1 s2 = s1 >>| s2
 119
 120 (==.) infix 4 :: (Sem a) (Sem a) -> (Sem Bool) | == a
 121 (==.) s1 s2 = fmap (==) s1 <*> s2
 122
 123 (<.) infix 4 :: (Sem a) (Sem a) -> (Sem Bool) | < a
 124 (<.) s1 s2 = fmap (<) s1 <*> s2
 125
 126 IF :: (Sem Bool) THEN (Sem a) ELSE (Sem a) -> Sem a
 127 IF c _ t _ e = c >>= \c.if c t e
 128
 129 WHILE :: (Sem Bool) DO (Sem a) -> Sem Int
 130 WHILE c _ b = c >>= \c`.if c` (fmap ((+) 1) (b >>| WHILE c DO b)) (return 0)
 131
 132 :: THEN = THEN
 133 :: ELSE = ELSE
 134 :: DO = DO
 135
 136 // examples
 137 expr1 :: Element
 138 expr1 = integer 2
 139
 140 expr2 :: Element
 141 expr2 = expr1 + expr1
 142
 143 expr3 :: Element
 144 expr3 = expr1 + expr1 * integer 3
 145
 146 expr4 :: Set
 147 expr4 = union new (insert expr1 (insert expr3 new))
 148
 149 expr5 :: Set
 150 expr5 =
 151     x =. expr4 :.
 152     variable x
 153
 154 expr6 :: Element
 155 expr6 =
 156     x =. insert (integer 11) new :.
 157     x =. size (variable x) :.
 158     variable x
 159
 160 expr7 :: Set
 161 expr7 =
 162     x =. insert (integer 11) new :.
 163     y =. variable x
 164
 165 expr8 :: Set
 166 expr8 =
 167     x =. insert (integer 11) new :.
 168     x =. insert (size (variable x)) (variable x) :.
 169     variable x
 170
 171 expr9 :: Set
 172 expr9 =
 173     x =. insert (integer 0) new :.
 174     IF (size (variable x) ==. integer 0) THEN
 175         (x =. insert (integer 0) (variable x))
 176     ELSE
 177         (x =. delete (integer 0) (variable x)) :.
 178     variable x
 179
 180 expr10 :: Set
 181 expr10 =
 182         z =. integer 7 :.
 183         x =. new :.
 184         x =. insert (variable z) (variable x) :.
 185         y =. union (variable x) (variable x) :.
 186         WHILE (size (variable x) <. integer 5) DO
 187                 (x =. insert (size (variable x)) (variable x)) :.
 188         z =. difference (variable x) (intersection (variable x) (insert (variable z) new))
 189
 190 x = "x"
 191 y = "y"
 192 z = "z"
 193
 194 Start = (eval expr10)