-- 
-- This file Copyright 2001 Jeffrey B Putnam
-- Please Contact me - jefu@eou.edu - for information 
-- 
import Random 
import List 

--
-- LParen, RParen, Empty
-- are not really part of Combinator, but they're included 
-- here to simplify the parsing 
-- 

data Combinator = S | K | Var Char | Apply Combinator Combinator | Empty | LParen | RParen 

instance Eq   Combinator where
   (==) K K = True
   (==) S S = True 
   (==) (Apply x y) (Apply z zz) = ((==) x z) && ((==) y zz)
   (==) (Var x) (Var y) = (==) x y 
   (==) Empty Empty = True 
   (==) LParen LParen = True 
   (==) RParen RParen = True 
   (==) _ _ = False 

instance Show Combinator where
   show K = "K" 
   show S = "S"
   show (Apply x y) = "(" ++ show x ++ show y ++ ")" 
   show (Var x)     = [ x ]
   show Empty       = "-" 
   show LParen      = "<"
   show RParen      = ">"

instance Ord Combinator where 
   x <  y   = (show x) < (show y) 
   x <= y   = (show x) <= (show y) 

rewrite (Apply (Apply K x) y ) = x 
rewrite (Apply (Apply (Apply S x) y ) z) = (Apply (Apply x z) (Apply y z))
rewrite (Apply x y) = Apply (rewrite x) (rewrite y)
rewrite x = x 

randomCombinator :: RandomGen a => Int -> a -> (Combinator , a) 

randomCombinator 0 rgen =   (t,rgen2) 
                         where 
	                    (i, rgen1) = randomR (0,1) rgen 
                            (t, rgen2) = pickOne i 0 rgen1 

randomCombinator depth rgen =   (t,rgen2) 
                              where 
	                        (i,rgen1) = randomR (0,2) rgen
	                        (t,rgen2) = pickOne i (depth-1) rgen1 

pickOne :: RandomGen g => Int -> Int -> g -> (Combinator, g)

pickOne 0 d rgen = (K, rgen) 
pickOne 1 d rgen = (S, rgen)
pickOne 2 d rgen =   ((Apply s t), rgen2) 
                   where 
                     (s,rgen1) = (randomCombinator d rgen)
	             (t,rgen2) = (randomCombinator d rgen1)

gen = mkStdGen 9998

rclist rg =   x:(rclist rg1) 
           where 
	      (x,rg1) = randomCombinator 10 rg 

rcs = rclist gen
 
rewriteAll x =    z
	        where 
	          y = rewrite x 
		  z = if y == x 
                      then y 
                      else rewriteAll y 

-- limitedRewrite n x  = last (take n (rewriteAll x))

step l =   l2 
         where 
           xp = [ (x,y) | x <- l, y <- l]
           l1 = map (rewriteAll.(uncurry Apply)) xp 
	   l2 = best l 

basicListSize :: Int 
basicListSize = 10

r1 = take basicListSize rcs 

steps r =   l
	  where 
            l = r:(map step l) 

count l = reverse (map (\x-> (length x, head x)) (group (sort l))) 
best l  = take basicListSize (map snd (count l)) 

rsteps = steps r1 

---- 

xstep l =   l2 
         where 
            xp = [ (x,y) | x <- l, y <- l]
            l1 = map (rewriteAll.(uncurry Apply)) xp 
            l2 = take basicListSize (map head (group (sort l1)))

xsteps r =  l 
           where  
	    l = r:(map xstep l)

rxsteps = xsteps r1 

----

fixedPoint r1 =   z 
               where 
	          y = step r1 
                  z = if y == r1 
	              then y 
                      else fixedPoint y  

parse :: String -> Combinator 
parse s =  parseHelper (map transchar s) []

transchar :: Char -> Combinator 
transchar 's' = S
transchar 'k' = K 
transchar '(' = LParen
transchar ')' = RParen 
transchar c   = Var c 

parseHelper (c:cs)  l   
	|  c == RParen   =    parseHelper cs (closeParen l )
        |  c == LParen   =    parseHelper cs (LParen:l)
        |  otherwise     =    parseHelper cs (maybeCombine c l)
                           where 
                              maybeCombine c [] = [c] 
                              maybeCombine c l@(LParen:xs) = c:l
                              maybeCombine c (x:xs) = (Apply x c):xs 

	                      closeParen [] = [] 
                              closeParen [LParen] = [] 
                              closeParen [x] = [x] 
                              closeParen (LParen:xs) = xs
	                      closeParen (x:LParen:xs) = (Apply (head xs) x):(tail xs) 
                              closeParen (x:y:xs) = (Apply y x):xs


parseHelper [] (c:cs)    =  c 

second = Apply (Apply (Apply S  K) (Var 'x')) (Var 'y')
ident  = Apply (Apply S K) (Var 'x') 
ifty   = Apply (Apply (Apply S (Apply S K)) (Apply S (Apply S (Apply S K)))) (Var 'x') 

a1 = parse "sk" 
a2 = parse "skk" 
a3 = parse "sss(kkk)"
p = parse "s(s(ks)(s(kk)(s(ks)(s(s(ks)(sk))k))))(kk)"
p1 = parse "s(s(ks)(s(kk)(s(ks)(s(s(ks)(sk))k))))(kk)xyz"

fs = foldl (++) "" (map (((++) "\n") . show ) (take 100 rsteps))

sh l = map (\x -> ("   " ++ (show x) ++ "\n")) l

main1 = do
	 putStr fs

xfs = foldl (++) "" (map (((++) "\n") . show ) (take 100 rxsteps))

main = do 
	putStr xfs

--        foldr (++) "" (map sh (take 100 rsteps)))