old/afp/a9/a9.icl

   1 module a9
   2
   3 /*
   4   Advanced Progrmming 2018, Assignment 8
   5   Pieter Koopman, pieter@cs.ru.nl
   6 */
   7 import StdEnv
   8
   9
  10 import Control.Applicative
  11 import Control.Monad => qualified join
  12 import Control.Monad.State
  13 import Control.Monad.Trans
  14 import Data.Func
  15 import Data.Functor
  16 import Data.Either
  17 import Data.Maybe
  18 import Data.List
  19
  20 import Text
  21
  22 import qualified Data.List as List
  23 import qualified Data.Map as Map
  24
  25 :: Set   :== Sem [Int]
  26 :: Elem  :== Sem Int
  27 :: Ident :== String
  28
  29 // === State
  30 :: Val :== Either Int [Int]
  31 :: SemState :== 'Map'.Map String Val
  32
  33 :: Sem a =
  34         { evaluator :: StateT SemState (Either String) a
  35         , printer   :: [String] -> [String]
  36         }
  37
  38 fail :: String -> StateT SemState (Either String) a
  39 fail s = liftT (Left s)
  40
  41 //Sets
  42 integer :: Int -> Elem
  43 integer i = {evaluator=pure i,printer = \c->[toString i:c]}
  44
  45 set :: [Int] -> Set
  46 set i =
  47         { evaluator = pure (removeDup i)
  48         , printer   = \c->["[":intersperse "," (map toString i)] ++ ["]":c]
  49         }
  50
  51 size :: Set -> Elem
  52 size s =
  53         { evaluator = length <$> s.evaluator
  54         , printer   = \c->["size(":s.printer [")"]]
  55         }
  56
  57 class variable a :: String -> a
  58 instance variable Set
  59 where
  60         variable i =
  61                 { evaluator
  62                         = gets ('Map'.get i) >>= \v->case v of
  63                                 Nothing = fail ("No set with identifier " +++ i)
  64                                 Just (Left v) = fail (i +++ " is an element")
  65                                 Just (Right v) = pure v
  66                 , printer = \c->[i:c]
  67                 }
  68 instance variable Elem
  69 where
  70         variable i =
  71                 { evaluator
  72                         = gets ('Map'.get i) >>= \v->case v of
  73                                 Nothing = fail ("No element with identifier " +++ i)
  74                                 Just (Right v) = fail (i +++ " is a set")
  75                                 Just (Left v) = pure v
  76                 , printer = \c->[i:c]
  77                 }
  78 class (+.) infixl 6 a b ~c :: a b -> c
  79 instance +. Elem Elem Elem
  80 where
  81         +. a b =
  82                 { evaluator = (+) <$> a.evaluator <*> b.evaluator
  83                 , printer   = \c->a.printer ["+":b.printer c]
  84                 }
  85 instance +. Elem Set Set
  86 where
  87         +. a b =
  88                 { evaluator = 'List'.union <$> pure <$> a.evaluator <*> b.evaluator
  89                 , printer   = \c->a.printer ["+":b.printer c]
  90                 }
  91 instance +. Set Elem Set
  92 where
  93         +. a b =
  94                 { evaluator = 'List'.union <$> a.evaluator <*> (pure <$> b.evaluator)
  95                 , printer   = \c->a.printer ["+":b.printer c]
  96                 }
  97 instance +. Set Set Set
  98 where
  99         +. a b =
 100                 { evaluator = 'List'.union <$> a.evaluator <*> b.evaluator
 101                 , printer   = \c->a.printer ["+":b.printer c]
 102                 }
 103 class (-.) infixl 6 a b ~c :: a b -> c
 104 instance -. Elem Elem Elem
 105 where
 106          -. a b =
 107                 { evaluator = (-) <$> a.evaluator <*> b.evaluator
 108                 , printer   = \c->a.printer ["-":b.printer c]
 109                 }
 110 instance -. Set Elem Set
 111 where
 112          -. a b =
 113                 { evaluator = 'List'.difference <$> a.evaluator <*> (pure <$> b.evaluator)
 114                 , printer   = \c->a.printer ["-":b.printer c]
 115                 }
 116 instance -. Set Set Set
 117 where
 118          -. a b =
 119                 { evaluator = 'List'.difference <$> a.evaluator <*> b.evaluator
 120                 , printer   = \c->a.printer ["-":b.printer c]
 121                 }
 122 class (*.) infixl 6 a b ~c :: a b -> c
 123 instance *. Elem Elem Elem
 124 where
 125          *. a b =
 126                 { evaluator = (*) <$> a.evaluator <*> b.evaluator
 127                 , printer   = \c->a.printer ["*":b.printer c]
 128                 }
 129 instance *. Elem Set Set
 130 where
 131          *. a b =
 132                 { evaluator = a.evaluator >>= \x->map ((*)x) <$> b.evaluator
 133                 , printer   = \c->a.printer ["*":b.printer c]
 134                 }
 135 instance *. Set Set Set
 136 where
 137          *. a b =
 138                 { evaluator = 'List'.intersect <$> a.evaluator <*> b.evaluator
 139                 , printer   = \c->a.printer ["*":b.printer c]
 140                 }
 141
 142 class (=.) infixl 2 a :: Ident a -> a
 143 instance =. Set
 144 where
 145          =. n s =
 146                 { evaluator = s.evaluator >>= \v->modify ('Map'.put n (Right v)) *> pure v
 147                 , printer   = \c->[n,"=":s.printer c]
 148                 }
 149 instance =. Elem
 150 where
 151          =. n s =
 152                 { evaluator = s.evaluator >>= \v->modify ('Map'.put n (Left v)) *> pure v
 153                 , printer   = \c->[n,"=":s.printer c]
 154                 }
 155
 156 //Logicals
 157 :: Logical :== Sem Bool
 158 true :: Logical
 159 true = {evaluator = pure True, printer = \c->["True":c]}
 160
 161 false :: Logical
 162 false = {evaluator = pure False, printer = \c->["False":c]}
 163
 164 In :: Elem Set -> Logical
 165 In e s =
 166         { evaluator = elem <$> e.evaluator <*> s.evaluator
 167         , printer   = \c->e.printer ["In":s.printer c]
 168         }
 169
 170 class (==.) infix 4 a :: a a -> Logical
 171 instance ==. Elem
 172 where
 173          ==. a b =
 174                 {evaluator = (==) <$> a.evaluator <*> b.evaluator
 175                 ,printer   = \c->a.printer ["==":b.printer c]
 176                 }
 177 instance ==. Set
 178 where
 179          ==. a b =
 180                 {evaluator = (==) <$> a.evaluator <*> b.evaluator
 181                 ,printer   = \c->a.printer ["==":b.printer c]
 182                 }
 183
 184 class (<=.) infixl 6 a b :: a b -> Logical
 185 instance <=. Elem Elem
 186 where
 187          <=. a b =
 188                 {evaluator = (<=) <$> a.evaluator <*> b.evaluator
 189                 ,printer   = \c->a.printer ["<=":b.printer c]
 190                 }
 191 instance <=. Set Set
 192 where
 193          <=. a b =
 194                 {evaluator = ((<=) `on` length) <$> a.evaluator <*> b.evaluator
 195                 ,printer   = \c->a.printer ["<=":b.printer c]
 196                 }
 197
 198 Not :: Logical -> Logical
 199 Not a = {evaluator = not <$> a.evaluator, printer = \c->["not":a.printer c]}
 200
 201 (||.) infixr 2 :: Logical Logical -> Logical
 202 (||.) a b =
 203                 {evaluator = (||) <$> a.evaluator <*> b.evaluator
 204                 ,printer   = \c->a.printer ["||":b.printer c]
 205                 }
 206
 207 (&&.) infixr 2 :: Logical Logical -> Logical
 208 (&&.) a b =
 209                 {evaluator = (&&) <$> a.evaluator <*> b.evaluator
 210                 ,printer   = \c->a.printer ["&&":b.printer c]
 211                 }
 212
 213 //Stmts
 214 :: Stmt :== Sem ()
 215 expression :: Set -> Stmt
 216 expression e = {evaluator = e.evaluator *> pure (), printer = e.printer}
 217
 218 logical :: Logical -> Stmt
 219 logical e = {evaluator = e.evaluator *> pure (), printer = e.printer}
 220
 221 For :: String Set Stmt -> Stmt
 222 For ident bag body =
 223         { evaluator = bag.evaluator >>= \v->
 224                 foldr proc (pure ()) [ident =. integer e\\e<-v]
 225         , printer   = \c->["For",ident,"=":bag.printer ["In":body.printer c]]
 226         }
 227 where
 228         proc :: (Sem Int) (StateT SemState (Either String) ()) -> StateT SemState (Either String) ()
 229         proc e m = e.evaluator *> body.evaluator *> m
 230
 231 If :: Logical Stmt Stmt -> Stmt
 232 If l s1 s2 =
 233         { evaluator = l.evaluator >>= \b->if b s1.evaluator s2.evaluator
 234         , printer   = \c->["If":l.printer ["then":s1.printer ["else":s2.printer c]]]
 235         }
 236
 237 evalSem :: (Sem a) -> (SemState -> Either String a)
 238 evalSem s = evalStateT s.evaluator
 239
 240 printSem :: (Sem a) -> ([String] -> [String])
 241 printSem s = s.printer
 242
 243 Start =
 244         ( evalSem (integer 42 +. integer 42 +. set [] +. integer 4 +. set [42]) 'Map'.newMap
 245         , join " " $ printSem (integer 42 +. integer 42 +. set [] +. integer 4 +. set [42]) []
 246         )