Expressions

week11-reg/week11_reg.icl

+module week11_reg
+
+
+import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
+
+import Data.Functor, Control.Applicative, Control.Monad, Data.List
+import Data.Tuple
+import qualified Data.Map as Map
+
+instance Functor Sem where
+  fmap f (Sem g) = Sem \s.case g s of
+                    (Res a,s) = (Res (f a), s) 
+                    (Err e,s) = (Err e, s) 
+
+
+instance <*> Sem where
+  (<*>) (Sem f) (Sem g)
+    = Sem \s.case f s of
+      (Res f, s) = case g s of
+        (Res a,s) = (Res (f a),s)
+        (Err e,     s) = (Err e,   s)
+      (Err e,s) = (Err e,s)
+
+unres :: (Sem a) -> (State -> (Res a, State))
+unres (Sem f) = f 
+instance Monad Sem where // !(m a) (a -> m b) -> m b
+  bind (Sem f) g = Sem \s. case f s of 
+            (Res a, s) =  unres (g a) s
+            (Err e, s) = (Err e, s)
+
+
+instance pure Sem where
+  pure a = Sem \s.(pure a, s)
+
+instance pure Res where
+  pure a = (Res a)
+
+//:: SetA   :== Expression
+//:: Elem  :== Expression
+:: Ident :== String
+
+:: Res a = Res a | Err String
+:: Sem a = Sem (State -> (Res a, State))
+
+
+
+:: State = State (Map Ident Val)
+:: Val = I Int | S [Int]//('iTasks'.Set Int)
+
+
+
+:: Element :== Sem Int 
+:: Set :== Sem [Int]
+
+int :: Int -> Element
+int i = pure i
+size :: Set -> Element
+size se = fmap length se
+
+instance + Element where
+	(+) (Sem a) (Sem b) = Sem \s. case a s of 
+							(Res ares,s) = case b s of 
+								(Res bres, s) = (pure (ares+bres),s)
+								e = e
+							e = e
+
+/*instance + Set where
+	(+) (Sem a) (Sem b) = Sem \s. case a s of 
+				(Res ares,s) = case b s of 
+					(Res bres, s) = (pure (union ares bres),s)
+					e = e
+				e = e
+*/
+
+instance + Set where
+	(+) a b = (union) <$> a <*> b 
+
+instance - Element where
+	(-) (Sem a) (Sem b) = Sem \s. case a s of 
+							(Res ares,s) = case b s of 
+								(Res bres, s) = (pure (ares-bres),s)
+								e = e
+							e = e
+
+instance - Set where
+	(-) (Sem a) (Sem b) = Sem \s. case a s of 
+							(Res ares,s) = case b s of 
+								(Res bres, s) = (pure (subtractSet ares bres),s)
+								e = e
+							e = e
+
+instance * Element where
+	(*) (Sem a) (Sem b) = Sem \s. case a s of 
+							(Res ares,s) = case b s of 
+								(Res bres, s) = (pure (ares * bres),s)
+								e = e
+							e = e
+
+
+instance * Set where
+  	(*) a b = intersect <$> a <*> b
+
+class ==. a where
+	(==.) infix 4 :: !a !a -> Sem Bool
+
+instance ==. Set where
+	(==.) a b = (equalSet) <$> a <*> b
+
+
+instance ==. Element where
+	(==.) a b = (==) <$> a <*> b
+
+
+
+/*Logical
+
+iif :: Logical Statement Statement -> Bool
+iif log st1 st2 = False
+*/
+class =. a where
+	(=.) infixl 2 :: Ident (Sem a) -> (Sem a)
+
+instance =. [Int] where
+	(=.) i (Sem a) =  Sem \s. case a s of 
+							(Res ares, State s) = (pure (ares), State ('Map'.put i (S ares) s))
+							//(Res ares,s) = case b s of 
+							//	(Res bres, s) = (pure (ares * bres),s)
+							//	e = e
+							(Err e, s) = (Err e, s)
+
+instance =. Int where
+	(=.) i (Sem a) =  Sem \s. case a s of 
+							(Res ares, State s) = (pure (ares), State ('Map'.put i (I ares) s))
+							(Err e, s) = (Err e, s)
+
+
+
+//(=.) i v = Sem \(State s). (pure v, State ('Map'.put i v s))
+
+
+class Var a where
+	var :: Ident -> (Sem a) 
+
+instance Var Int where
+	var i = Sem \(State s) . case ('Map'.get i s) of
+						(Just a) -> case a of
+							(I i)  = (pure i, State s)
+							(S st) = (Err ("Expected int, found set " +++ (toString st)), State s )
+						_ -> (Err ("Could not find variable " +++ i), State s )
+
+instance Var [Int] where
+	var i = Sem \(State s) . case ('Map'.get i s) of
+						(Just a) -> case a of
+							(I i)  = (Err ("Expected set, found int " +++ (toString i)), State s )
+							(S st) = (pure st, State s)
+						_ -> (Err ("Could not find variable " +++ i), State s )
+
+
+	//(==.) infixr 3 :: Set Set -> Sem Bool
+//(==.) a b = (equalSet) <$> a <*> b
+
+/*
+(==.) infixr 3 :: Set Set -> Sem Bool
+(==.) a b = (equalSet) <$> a <*> b
+
+(==.) infixr 3 :: Element Element -> Sem Bool
+(==.) a b = (==) <$> a <*> b
+*/
+
+/*(+.) (Sem a) (Sem b) = Sem \s. case a s of 
+					(Res ares,s) = case b s of 
+						(Res bres, s) = (pure (if (elem bres ares) ares ([bres:ares])) ,s) // 
+						(Err e,s) = (Err e, s)
+					(Err e,s) = (Err e, s)
+*/
+
+
+//(+.) infixr 3 :: Set Element -> Set
+//(+.) a b = (\ares bres .( (if (elem bres ares) ares ([bres:ares]))   )) <$> a <*> b 
+
+
+//(-.) infixr 3 :: Set Element -> Set
+//(-.) a b = (\st elm .(  (if (elem elm st) (delete elm st) (st))  )) <$> a <*> b 
+
+
+subtractSet a b = foldr (\e s. delete e s) a b
+
+equalSet :: [a] [a] -> Bool | == a
+equalSet aset bset =  foldr (\a b . (elem a aset) && b) True bset && foldr (\a b . (elem a bset) && b) True aset 
+  //foldr (\a b. a && (elem b aset )) aset bset  //foldr (\a b. (a && elem b)) a b
+
+
+//Start = subtractSet [1,6,23,3,4] [1,5]
+
+
+
+//size (Sem sf) = Sem \s ->  ( length sf ,s) // pure (length s)
+
+//  M a p Ident Val,
+
+//:: State = State (Map Ident Val)
+//:: Val = I Int | S [Int]
+emptyState = State 'Map'.newMap
+
+evl :: (Sem a) State -> ((Res a),State)//-> (Res (Either Val Bool),State)
+evl vl s = let (Sem f) = vl in f s
+//evl :: Stmt State -> (Res (Either Val Bool),State)
+//evl e s = let (Sem f) = (stmteval e) in f s
+zoepzoef :: Set
+zoepzoef = pure [1,6,23,3,4]
+zof = int 8 + int 9
+
+
+zofset = pure [1,6,23,3,4] - pure[6]
+
+//zoefs :: (Sem [Int])
+zfl :: Set
+zfl = pure [9,3,2]
+zfr :: (Sem [Int])//Set
+zfr = pure [9,2,3]
+//zoefs = (zfl) ==. (zfr)
+zoefs = "A" =. (zfr)
+//zoefs = int 8 ==. int 8
+zoefss = var "A" + var "A" //pure [1,2,3]
+
+//Start = equalSet [9,2,3] [9,3,2,1] || equalSet  [9,3,2,1] [9,2,3]
+
+//Start = let ((a,b) = evl zoefs emptyState) in evl zoefss  b
+Start =  evl zoefss  (snd (evl zoefs emptyState) )
\ No newline at end of file