module Fold where
import PGF
import Data.Map as M (lookup, fromList)

--import Debug.Trace


foldable :: Map CId CId
foldable = [(CId, CId)] -> Map CId CId
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(String -> CId
mkCId String
c, String -> CId
mkCId (String
"bin_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c)) | String
c <- [String]
ops]
  where ops :: [String]
ops = String -> [String]
words String
"plus times and or xor cartesian_product intersect union"

fold :: Tree -> Tree
fold :: Tree -> Tree
fold Tree
t =
  case Tree -> Maybe (CId, [Tree])
unApp Tree
t of
    Just (CId
i,[Tree
x])  ->
        case CId -> Map CId CId -> Maybe CId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CId
i Map CId CId
foldable of
          Just CId
j -> CId -> Tree -> Tree
appFold CId
j Tree
x
          Maybe CId
_      -> CId -> [Tree] -> Tree
mkApp CId
i [Tree -> Tree
fold Tree
x]
    Just (CId
i,[Tree]
xs)   -> CId -> [Tree] -> Tree
mkApp CId
i ([Tree] -> Tree) -> [Tree] -> Tree
forall a b. (a -> b) -> a -> b
$ (Tree -> Tree) -> [Tree] -> [Tree]
forall a b. (a -> b) -> [a] -> [b]
map Tree -> Tree
fold [Tree]
xs
    Maybe (CId, [Tree])
_             -> Tree
t

appFold :: CId -> Tree -> Tree
appFold :: CId -> Tree -> Tree
appFold CId
j Tree
t =
  case Tree -> Maybe (CId, [Tree])
unApp Tree
t of
    Just (CId
i,[Tree
t,Tree
ts]) | CId -> String -> Bool
forall a. Show a => a -> String -> Bool
isPre CId
i String
"Cons"  -> CId -> [Tree] -> Tree
mkApp CId
j [Tree -> Tree
fold Tree
t, CId -> Tree -> Tree
appFold CId
j Tree
ts]
    Just (CId
i,[Tree
t,Tree
s])  | CId -> String -> Bool
forall a. Show a => a -> String -> Bool
isPre CId
i String
"Base"  -> CId -> [Tree] -> Tree
mkApp CId
j [Tree -> Tree
fold Tree
t, Tree -> Tree
fold Tree
s]
  where isPre :: a -> String -> Bool
isPre a
i String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
4 (a -> String
forall a. Show a => a -> String
show a
i) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s