diff options
| -rw-r--r-- | assignment-10/sets.icl | 104 |
1 files changed, 81 insertions, 23 deletions
diff --git a/assignment-10/sets.icl b/assignment-10/sets.icl index ecdcad6..d4cee20 100644 --- a/assignment-10/sets.icl +++ b/assignment-10/sets.icl @@ -1,8 +1,9 @@ module sets +import StdArray import StdBool import StdEnum -from StdFunc import flip, o +from StdFunc import flip, id, o import StdGeneric import StdInt import StdList @@ -15,8 +16,9 @@ import Data.Error from Data.Func import $, on, `on` import Data.Functor import qualified Data.Map as M +import Data.List import Data.Maybe -from Text import <+ +from Text import <+, class Text(concat), instance Text String instance + [a] | Eq a where + xs ys = xs - ys ++ ys instance - [a] | Eq a where - xs ys = removeMembers xs ys @@ -31,33 +33,36 @@ removeElem = removeMember hasElem :: (a [a] -> Bool) | Eq a hasElem = isMember +/** + * This Expression type is agnostic with regards to the expression type, so it + * can handle sets of booleans, sets of sets, reals, etc. Because of this, we + * only need Elem and not New and TRUE/FALSE. + */ :: Expression a - = E.b: New (Bimap a [b]) [b] - | Elem a + = Elem a | Variable Ident - | E.b: Size (Bimap a Int) (Set b) & TC b + | E.b: Size (Bimap a Int) (Set b) & TC, Print b | (+.) infixl 6 (Expression a) (Expression a) & + a - | E.b: AddElemAndSet (Bimap a [b]) (Elem b) (Set b) & TC, Eq b - | E.b: AddSetAndElem (Bimap a [b]) (Set b) (Elem b) & TC, Eq b + | E.b: AddElemAndSet (Bimap a [b]) (Elem b) (Set b) & TC, Eq, Print b + | E.b: AddSetAndElem (Bimap a [b]) (Set b) (Elem b) & TC, Eq, Print b | (-.) infixl 6 (Expression a) (Expression a) & - a - | E.b: RemoveFromSet (Bimap a [b]) (Set b) (Elem b) & TC, Eq b + | E.b: RemoveFromSet (Bimap a [b]) (Set b) (Elem b) & TC, Eq, Print b | (*.) infixl 7 (Expression a) (Expression a) & * a - | E.b: MulElemAndSet (Bimap a [b]) (Elem b) (Set b) & TC, * b + | E.b: MulElemAndSet (Bimap a [b]) (Elem b) (Set b) & TC, *, Print b | (=.) infixl 2 Ident (Expression a) | Not (Bimap a Bool) (Elem Bool) | Or (Bimap a Bool) (Elem Bool) (Elem Bool) | And (Bimap a Bool) (Elem Bool) (Elem Bool) - | E.b: In (Bimap a Bool) (Elem b) (Set b) & TC, Eq b - | E.b: Eq (Bimap a Bool) (Expression b) (Expression b) & TC, Eq b - | E.b: Le (Bimap a Bool) (Expression b) (Expression b) & TC, Ord b + | E.b: In (Bimap a Bool) (Elem b) (Set b) & TC, Eq, Print b + | E.b: Eq (Bimap a Bool) (Expression b) (Expression b) & TC, Eq, Print b + | E.b: Le (Bimap a Bool) (Expression b) (Expression b) & TC, Ord, Print b | If (Elem Bool) (Expression a) (Expression a) - | E.b c: For (Bimap a [b]) Ident (Set c) (Expression b) & TC b & TC c - | E.b: (:.) infixl 1 (Expression b) (Expression a) & TC b + | E.b c: For (Bimap a [b]) Ident (Set c) (Expression b) & TC, Print b & TC, Print c + | E.b: (:.) infixl 1 (Expression b) (Expression a) & TC, Print b // Convenience -new :== New bimapId elem :== Elem var :== Variable size :== Size bimapId @@ -92,18 +97,17 @@ read i = gets ('M'.get i) >>= \v -> case v of Nothing -> fail $ "unknown variable '" <+ i <+ "'" eval :: (Expression a) -> Sem a | TC a -eval (New bm xs) = pure $ bm.map_from xs eval (Elem x) = pure x eval (Variable id) = read id eval (Size bm s) = bm.map_from <$> length <$> eval s -eval (+. x y) = (liftA2 (+) `on` eval) x y +eval (x +. y) = (liftA2 (+) `on` eval) x y eval (AddElemAndSet bm e s) = bm.map_from <$> liftA2 addElem (eval e) (eval s) eval (AddSetAndElem bm s e) = bm.map_from <$> liftA2 addElem (eval e) (eval s) -eval (-. x y) = (liftA2 (-) `on` eval) x y +eval (x -. y) = (liftA2 (-) `on` eval) x y eval (RemoveFromSet bm s e) = bm.map_from <$> liftA2 removeElem (eval e) (eval s) -eval (*. x y) = (liftA2 (*) `on` eval) x y +eval (x *. y) = (liftA2 (*) `on` eval) x y eval (MulElemAndSet bm e s) = bm.map_from <$> liftA2 (map o (*)) (eval e) (eval s) -eval (=. id e) = eval e >>= store id +eval (id =. e) = eval e >>= store id eval (Not bm l) = bm.map_from <$> not <$> eval l eval (Or bm x y) = bm.map_from <$> (liftA2 (||) `on` eval) x y eval (And bm x y) = bm.map_from <$> (liftA2 (&&) `on` eval) x y @@ -117,6 +121,60 @@ where iterate e = mapM (\x -> store id x >>| eval e) eval (s :. t) = eval s >>| eval t +:: Print :== [String] -> [String] + +class Print a where pr :: a -> Print + +print :: (a -> String) | Print a +print = concat o flip pr [] + +between :: a b c -> Print | Print a & Print b & Print c +between a b c = pr b o pr a o pr c + +surround :: a b c -> Print | Print a & Print b & Print c +surround a b c = pr a o pr c o pr b + +parens :: (a -> Print) | Print a +parens = surround "(" ")" + +braces :: (a -> Print) | Print a +braces = surround "{" "}" + +interpr :: a [b] -> Print | Print a & Print b +interpr _ [] = id +interpr _ [x] = pr x +interpr g [x:xs] = between g x (interpr g xs) + +instance Print String where pr s = (++) (pure s) +instance Print Char where pr c = pr {#c} +instance Print Int where pr i = pr (toString i) +instance Print Bool where pr b = pr (toString b) +instance Print [a] | Print a where pr xs = surround "[" "]" (interpr "," xs) +instance Print Print where pr p = p + +instance Print (Expression a) | Print a +where + pr (Elem x) = pr x + pr (Variable x) = surround '"' '"' x + pr (Size _ xs) = surround "size (" ")" xs + pr (x +. y) = parens (between " +. " x y) + pr (AddElemAndSet _ e s) = parens (between " :+ " e s) + pr (AddSetAndElem _ s e) = parens (between " +: " s e) + pr (x -. y) = parens (between " -. " x y) + pr (RemoveFromSet _ s e) = parens (between " -: " s e) + pr (x *. y) = parens (between " *. " x y) + pr (MulElemAndSet _ e s) = parens (between " :* " e s) + pr (id =. e) = between " =. " id e + pr (Not _ l) = pr "~" o parens l + pr (Or _ x y) = parens (between " ||. " x y) + pr (And _ x y) = parens (between " &&. " x y) + pr (In _ e s) = parens (between " ∈ " e s) + pr (Eq _ x y) = parens (between " == " x y) + pr (Le _ x y) = parens (between " <= " x y) + pr (If b t e) = pr "if " o pr b o pr " " o braces t o pr " " o braces e + pr (For _ id s e) = pr "for " o between " ∈ " id s o pr " " o braces e + pr (s :. t) = between " :. " s t + /** * I did not manage to get the iTasks simulator working, because the compiler * 'cannot build a generic representation of an existential type'. @@ -125,13 +183,13 @@ eval (s :. t) = eval s >>| eval t * did not try to do this due to time constraints. */ -Start = evalStateT (eval stmt) 'M'.newMap +Start = (evalStateT (eval stmt) 'M'.newMap, print stmt) where stmt :: Expression [Int] stmt = - "x" =. new [3..10] :. + "x" =. elem [3..10] :. "y" =. elem 0 :. - elem 10 :* for "i" (new [1..5] +. var "x") ( + elem 10 :* for "i" (elem [1..5] +. var "x") ( "y" =. var "y" +. elem 1 :. var "i" *. var "y" ) |