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

//:: Expr = New [Int]
//	| Int Int
//	| Var Ident
//	| Size Set
//	| (+.) infixl 6 Expr Expr


//class IF b where
//	IF :: (Sem Bool) (Sem b) (Sem b) -> (Sem b)
/* instance IF  a where
	IF (Sem cond) (Sem st1) (Sem st2) = Sem \s. case cond s of
					(Res a, s) = case (if a (st1) (st2) s) of
						(Res f, s) = (Res f, s)
						(Err e,s) = (Err e, s) 
					(Err e,s) = (Err e, s) */

class If a b where
	If :: (Sem Bool) (Sem a) (Sem b) -> (Sem ())

instance If a b where
	If (Sem cond) (Sem st1) (Sem st2) = Sem \s. case cond s of
					(Res a, s) = if a 
						(case st1 s of
							(Res _, s) = (Res (), s) 
							(Err e,s) = (Err e, s) 
							) 
						(case st2 s of
							(Res _, s) = (Res (), s) 
							(Err e,s) = (Err e, s) 
							)
					(Err e,s) = (Err e, s) 


/*
For :: Ident Set (Sem a) -> (Sem ())
For i (Sem st) (Sem stmt) = Sem \s. case st s of
						(Res [a:aa], s) = case stmt (State ('Map'.put i (I a) s)) of  // a  is [Int]
											(Res _, s) = case (For i (pure aa) (Sem stmt)) s of
												(Res _,s)= (Res (),s)
												(Err e,s) = (Err e, s) 
											(Err e,s) = (Err e, s) 
						(Res [], s) = (Res (),s) // a  is [Int]
						(Err e,s) = (Err e, s) 
*/

/*
For :: Ident Set (Sem a) -> (Sem ())
For i (Sem st) (Sem stmt) = Sem \s. case st s of
						(Res [a:aa], s) =   let (Sem fff, st) =  (For i (pure aa) (Sem stmt)) in
												case stmt (State ('Map'.put i (I a) st)) of  // a  is [Int]
												(Res _, s) = case fff s of
													(Res _,s)= (Res (),s)
													(Err e,s) = (Err e, s) 
												(Err e,s) = (Err e, s) 
						(Res [], s) = (Res (),s) // a  is [Int]
						(Err e,s) = (Err e, s) 
*/
/*
For :: Ident Set (Sem a) -> (Sem ())
For i (Sem st) (Sem stmt) = Sem \s. case st s of // eval the set
				(Res [a:aa], s) = case stmt (\s .State ('Map'.put i (I a) s)) s of // eval the statement after the assignment
					(Res _, s) = let (Sem fff) =  (For i (pure aa) (Sem stmt)) in
									case fff s of // eval the rest of the statements
									(Res (), s) = (Res (),s)
									(Err e,s) = (Err e, s) 

					(Err e,s) = (Err e, s) 
				(Res [], s) = (Res (),s) // a  is [Int]
				(Err e,s) = (Err e, s) 
				*/

//(=.) infixl 2 :: Ident (Sem a) -> (Sem a)



// This sucks, surely there is a sane way to do this? jfc
For :: Ident Set (Sem a) -> (Sem ())
For i (Sem st) (Sem stmt) = Sem \s. case st s of
					(Res [a:aa], State s) = case stmt (State ('Map'.put i (I a) s)) of 
						(Res _, s) = let (Sem f) =  (For i (pure aa) (Sem stmt)) in f s
						(Err e,s) = (Err e, s) 
					(Res [],s) = (Res (), s) 
					(Err e,s) = (Err e, s) 

While :: (Sem Bool) (Sem a) -> (Sem ())
While (Sem bl) (Sem stmt) = Sem \s. case bl s of
					(Res True,s) = case stmt s of 
						(Res _, s) = let (Sem f) =  (While (Sem bl) (Sem stmt)) in f s
						(Err e,s) = (Err e, s) 
					(Res False,s) = (Res (), s) 
					(Err e,s) = (Err e, s) 



  // Sem st >>= \ x. Sem \s. (Err x, s)

(In) infix 4 :: (Element) (Set) -> (Sem Bool)
(In) (Sem e) (Sem st) = Sem \s. case e s of
					(Res a, s) = case st s of
						(Res theSet, s) = (Res (elem a theSet), s)
						(Err e,s) = (Err e, s) 
					(Err e,s) = (Err e, s) 



/*Logical
*/



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)


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 )



(<=.) infix 4 :: Element Element -> Sem Bool
(<=.) e1 e2 = (<=) <$> e1 <*> e2

(||.) infixr 2 :: (Sem Bool) (Sem Bool) -> Sem Bool
(||.) e1 e2 = (||) <$> e1 <*> e2

(&&.) infixr 2 :: (Sem Bool) (Sem Bool) -> Sem Bool
(&&.) e1 e2 = (&&) <$> e1 <*> e2

Not :: (Sem Bool) -> (Sem Bool)
Not s = not <$> s

TRUE :: (Sem Bool)
TRUE = pure True

FALSE :: (Sem Bool)
FALSE = pure False


	//(==.) 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" + int 8 //var "A" //pure [1,2,3]

New :: [Int] -> Set
New s = pure s
Elem :: Int -> Element
Elem i = int i

hetProgramma = If (Elem 4 In New [1,2,3]) ("A" =. New [6]) ("B" =. Elem 6)

hetProgramma2 = If (New [4] ==. New [1,2,3]) ("A" =. New [6]) ("B" =. Elem 6)
hetProgramma3 = If ((Size (New [4])) ==. Elem 1) ("A" =. New [6]) ("B" =. Elem 6)
hetProgramma4 =   Elem 3 In New [7] ||. Elem 8 <=. Elem 7

//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) )
//Start =  evl (IF (pure True) ("A" =. zfr) ("B" =. zfr) )  emptyState
//Start =  evl (For "A" (New [1,2,3,8]) (If (Var "A" ==. Elem 3) ("Z" =. Var "A" + Elem 0) (Elem 8)))  emptyState

someSt = State ('Map'.put "A" (I 0) 'Map'.newMap)
Start = evl (While (Var "A" <=. Elem 3) ("A" =. (Var "A" + Elem 1))) someSt