--<Pre>

import ST

---------------------------------------------
-- Some Monad type constructors

data Id x = Id x 
data Exception x = Ok x | Fail
data Env e x = Env (e -> x)
data Mult x = Mult [x]
data Store s x = St(s -> (x,s)) 
data Output x = OP(x,String)

-- Some Instance declarations

instance Monad Id where
  return x = Id x
  (>>=) (Id x) f = f x
 
instance Monad Exception where
  return x = Ok x
  (>>=) (Ok x) f = f x
  (>>=) Fail f = Fail
 
instance Monad (Env e) where
  return x = Env(\ e -> x)
  (>>=) x yf = let Env f = x
                   h e = let x = f e
                             Env g = yf x
                         in g e
               in Env h 

instance Monad (Store s) where
  return x = St(\ s -> (x,s))
  (>>=) x yf = let St f = x
                   h s1 = let (x,s2) = f s1
                              St g = yf x
                              (y,s3) = g s2
                          in (y,s3)
               in St h
               
instance Monad Mult where
  return x = Mult[x]
  (>>=) x yf = let Mult xs = x
                   ys = map yf xs
               in Mult (concat[ z | Mult z <- ys ])
               
instance Monad Output where
  return x = OP(x,"")
  (>>=) (OP(x,s1)) f = let OP(y,s2) = f x in OP(y,s1 ++ s2)               

--- A few non-standard morphisms (the interface of the ADT)

type Map = [(String,Value)]   

getEnv :: String -> (Env Map Value)
getEnv nm = Env(\ s -> find s)
  where find [] = error ("Name: "++nm++" not found")
        find ((s,n):m) = if s==nm then n else find m

runInNewEnv :: String -> Int -> (Env Map Value) -> (Env Map Value)
runInNewEnv s n (Env g) = Env(\ m -> g ((s,n):m))
                                    
getStore :: String -> (Store Map Value)
getStore nm = St(\ s -> find s s)
  where find w [] = (0,w)
        find w ((s,n):m) = if s==nm then (n,w) else find w m

putStore :: String -> Value -> (Store Map ())
putStore nm n = (St(\ s -> ((),build s)))
  where build [] = [(nm,n)]
        build ((s,v):zs) = 
           if s==nm then (s,n):zs else (s,v):(build zs)
 
printOutput:: String -> Output ()
printOutput s = OP((),s)

-------------------------------------------------------------------
-- A much richer monad combining many of the elements of the above

type Value = Int
type Maps x = [(String,x)]
data M v x = M(Maps v -> Maps v -> (Maybe x,String,Maps v))

instance Monad (M v) where
 return x = M(\ st env -> (Just x,[],st))
 (>>=) (M f) g = M h
   where h st env = compare env (f st env)
         compare env (Nothing,op1,st1)  = (Nothing,op1,st1)
         compare env (Just x, op1,st1)  = next env op1 st1 (g x)
         next env op1 st1 (M f2)        = compare2 op1 (f2 st1 env)
         compare2 op1 (Nothing,op2,st2) = (Nothing,op1++op2,st2)
         compare2 op1 (Just y, op2,st2) = (Just y, op1++op2,st2)


--- Sub classes of Monad for generic evaluation


class Monad m => Eval e v m where
  eval :: e -> m v

class Monad m => Failure m where
  fails :: m a
  
class Monad m => HasEnv m v where
  inNewEnv :: String -> v -> m v -> m v
  getfromEnv :: String -> m v
  
class Monad m => HasStore m v where   
  getfromStore :: String -> m v
  putinStore :: String -> v -> m v
    
class (Monad m,Show v) => Prints m v where
  write :: String -> v -> m v  

---------------------------------------------------------------
-- Instance declarations for the rich monad

instance Failure (M v) where
  fails = M(\ st env -> (Nothing,[],st))

get name ((a,b):m) = if a==name then b else get name m

instance HasEnv (M v) v where
  inNewEnv name v (M f) = M(\ st env -> f st ((name,v):env))
  getfromEnv name = M h
     where h st env = (Just(get name env),[],st)
           
instance HasStore (M v) v where
  getfromStore name = M h
     where h st env = (Just(get name st),[],st)
  putinStore name v = M h
     where h st env = (Just v,[],(name,v):st)
     
instance Show v => Prints (M v) v where
  write message v = M h
     where h st env = (Just v,message++(show v),st)

--------------------------------------------------------------
-- A state based algorithm

data Tree a = Tip | Node (Tree a) a (Tree a)

number :: Tree a -> Int -> (Tree (a,Int), Int)
number Tip n = (Tip, n)
number (Node l x r) n = (Node l' (x,n) r', n'')
  where (l',n')  = number l (n+1)
        (r',n'') = number r n'
        
---------------------------------------------------------------
-- Another example

data Aop = Multiply | Add | Sub

data Exp 
  = Num Int 
  | Var String
  | Oper (Exp, Aop, Exp )
  | Let (String, Exp, Exp)

e2 = Let("x",Num 5,
         Oper(Var "x", Add,
              Oper(Num 4,Multiply,Num 2)))
              
-- free variables

freeV :: Exp -> [ String]
freeV term = freevars [] term []
 where
  freevars bound x free = case x of
    Num(i) -> free
    Var(s) ->  if any (==s) bound
                  then free else add s free  
    Oper(x,y,z) ->freevars bound x (freevars bound z free)
    Let(s,e,body) -> 
       freevars (s:bound) body (freevars bound e free)
 
add x [] = [x]
add x xs = if any (==x) xs then xs else x:xs

rename n x = x ++ (show n)

find s [] = s
find s ((t,v):xs) = if s==t then v else find s xs

renameE x = snd(rnE [] 0 x)
 where rnE bnd n x = case x of
          Num(i) ->(n,Num i)
          Var(s) -> (n,Var(find s bnd))
          Oper(x,y,z) -> let (n1,x') = rnE bnd n x
                             (n2,z') = rnE bnd n1 z
                         in (n2,Oper(x',y,z'))
          Let(s,e,b) ->  
             let s' = rename n s
                 (n1,b') = rnE ((s,s'):bnd) (n+1) b
                 (n2,e') = rnE bnd n1 e
             in (n2,Let(s',e',b'))
             
e3 = 
 Let("x", Oper(Var "z",Multiply,Num 2),
     Let("q",
         Oper(Var "x",Add,Var "w"),
         Oper(Var "x",Sub,
              Oper(Var "q",
                   Multiply,Var "v"))))


e4 = renameE e3
{- 
 Let ("x0", Oper (Var "z",Multiply,Num 2),
      Let ("q1",
          Oper (Var "x0",Add,Var "w"),
          Oper (Var "x0",Sub,
                Oper (Var "q1",
                      Multiply,Var "v"))))
-}             

------------------------------------------------------
-- State in Haskell

swap :: STRef s a -> STRef s a -> ST s ()
swap v w = do { x <- readSTRef v
              ; y <- readSTRef w
              ; writeSTRef w x
              ; writeSTRef v y
              }
              
-- The Monadic Renaming Example

rn bnd (Num i) v = return(Num i)
rn bnd (Var s)v  = return(Var(find s bnd))
rn bnd (Oper(x,y,z)) v =
   do { x' <- rn bnd x v
      ; z' <- rn bnd z v
      ; return(Oper(x',y,z')) }
rn bnd (Let(s,e,b)) v = 
   do { n <- readSTRef v
      ; writeSTRef v (n+1)
      ; s' <- return(rename n s)
      ; b' <- rn ((s,s'):bnd) b v
      ; e' <- rn bnd e v
      ; return(Let(s',e',b')) }
              

re x = runST(do { v <- newSTRef 0; rn [] x v })
   
e5 =  Let("x", Oper(Var "z",Multiply,Num 2),
          Let("q", Oper(Var "x",Add,Var "w"),
              Oper(Var "x", Sub, 
                   Oper(Var "q",Multiply,Var"v"))))
e6 = re e5
 
----------------------------------------------------------
-- Updateable linked lists

type UpdList s a = STRef s (ListVar s a, ListVar s a)

type ListVar s a = STRef s (ListElt s a)
data ListElt s a = Nil
                 | Cons a (ListVar s a)
newList :: ST s (UpdList s a)
newList = do {f <- newSTRef Nil; newSTRef (f,f)}

frontList :: UpdList s a -> ST s a
frontList l = do {(f,b) <- readSTRef l;
                  Cons x f' <- readSTRef f;
                  writeSTRef l (f',b);
                  return x}

backList :: UpdList s a -> a -> ST s ()
backList l x = do {(f,b) <- readSTRef l;
                   b' <- newSTRef Nil;
                   writeSTRef b (Cons x b');
                   writeSTRef l (f,b')}

emptyList :: UpdList s a -> ST s Bool
emptyList l = do {(f,b) <- readSTRef l; return (f == b)}
--</Pre>