
-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)

module Exp where

import Cp
import BTree
import LTree
import FTree
import System.Process
import GHC.IO.Exception
import St
import List hiding (lookup)
import Data.List
import RelCalc

-- (0) Functions dependent on your OS -------------------------------------

wopen = ("start/b "++)
mopen = ("open    "++)

--1) Windows

--open = wopen

--2) Mac OS

open = mopen 

expShow fn e = do { expDisplay fn (mirrorExp e) ; system(open fn) }

-- (1) Datatype definition -----------------------------------------------------

data Exp v o =   Var v              -- expressions are either variables
               | Term o [ Exp v o ] -- or terms involving operators and
                                    -- subterms
               deriving (Show,Eq)

inExp = either Var (uncurry Term)
outExp(Var v) = i1 v
outExp(Term o l) = i2(o,l)

-- (2) Ana + cata + hylo -------------------------------------------------------

baseExp f g h = f -|- (g >< map h)

recExp x = baseExp id id x

cataExp g = g . recExp (cataExp g) . outExp

anaExp g = inExp . recExp (anaExp g) . g

hyloExp h g = cataExp h . anaExp g

-- (3) Map ---------------------------------------------------------------------

instance BiFunctor Exp
         where bmap f g = cataExp ( inExp . baseExp f g id )

-- (4) Examples ----------------------------------------------------------------

mirrorExp = cataExp (inExp . (id -|- (id><reverse)))

expLeaves :: Exp a b -> [a]
expLeaves = cataExp (either singl (concat . p2))

expOps :: Exp a b -> [b]
expOps = cataExp (either nil (cons . (id><concat)))

expWidth :: Exp a b -> Int
expWidth = length . expLeaves

expDepth :: Exp a b -> Int
expDepth = cataExp (either (const 1) (succ . (foldr max 0) . p2))

nodes :: Exp a a -> [a]
nodes = cataExp (either singl g) where g = cons . (id >< concat)

graph :: Exp (a, b) (c, d) -> Exp a c
graph = bmap fst fst

-- (5) Graphics (DOT / HTML) ---------------------------------------------------

cExp2Dot :: Exp (Maybe String) (Maybe String) -> String
cExp2Dot x = beg ++ main (deco x) ++ end where
     main b = concat $ (map f . nodes) b  ++ (map g . lnks . graph) b
     beg = "digraph G {\n    /* edge [label=0]; */\n    graph [ranksep=0.5];\n"
     end = "}\n"
     g(k1,k2) = "    " ++ show k1 ++ " -> " ++ show k2 ++ "[arrowhead=none];\n"
     f(k,Nothing) = "    " ++ show k ++ " [shape=plaintext, label=\"\"];\n"
     f(k,Just s) = "    " ++ show k ++ " [shape=circle, style=filled, fillcolor=\"#FFFF00\", label=\"" ++ s ++ "\"];\n"

dotpict t = do { writeFile "_.dot" (cExp2Dot t) ; system "open _.dot" }

exp2Html n (Var v) = [ LCell v n 1 ]
exp2Html n (Term o l) = g (expWidth (Term o l)) o (map (exp2Html (n-1)) l)
                        where g i o k = [ ICell o 1 i ] ++ (foldr (++) [] k)

expDisplay :: FilePath -> Exp String String -> IO ()
expDisplay fn = writeFile fn . exp2txt

exp2txt = concat . txtFlat . (html2Txt Str) .  (uncurry exp2Html . (split expDepth id))

type Html a = [ Cell a ]

data Cell a = ICell a Int Int | LCell a Int Int deriving Show

data Txt = Str String | Blk [ Txt ] deriving Show

inds :: [a] -> [Int]
inds [] = []
inds (h:t) = inds t ++ [succ (length t)]

seq2ff :: [a] -> [(Int,a)]
seq2ff = (uncurry zip) . (split inds id)

ff2seq m = map p2 m

txtFlat :: Txt -> [[Char]]
txtFlat (Str s) = [s]
txtFlat (Blk []) = []
txtFlat (Blk (a:l)) = txtFlat a ++ txtFlat (Blk l)

html2Txt :: (a -> Txt) -> Html a -> Txt
html2Txt f = html . table . (foldr g u) 
             where u = Str "\n</tr>"
                   g c (Str s) = g c (Blk [Str s])
                   g (ICell a x y) (Blk b) = Blk ([ cell (f a) x y ] ++ b)
                   g (LCell a x y) (Blk b) = Blk ([ cell (f a) x y,  Str "\n</tr>\n<tr>"] ++ b)
                   html t = Blk [ Str("<meta charset=\"utf-8\"/>"++"<html>\n<body bgcolor=\"#F4EFD8\" " ++
                                        "text=\"#260000\" link=\"#008000\" " ++
                                        "vlink=\"#800000\">\n"),
                                   t,
                                   Str "</html>\n"
                                 ]
                   table t = Blk [ Str "<table style=\"border-collapse:collapse;border:0.5px solid black;\" cellpadding=1 cellspacing=0>",
                               t,
                               Str "</table>\n"
                             ]
                   cell c x y = Blk [ Str("\n<td style=\"border-collapse:collapse;border:0.4px solid black;\" rowspan=" ++
                                            itoa y ++
                                            " colspan=" ++
                                            itoa x ++
                                            " align=\"left\"" ++
                                            ">\n"),
                                       c,
                                            Str "\n</td>"
                                     ]
                   itoa x = show x

-- (6) Monad -------------------------------------------------------------------

muExp  = cataExp (either id (uncurry Term))

-- (7) Auxiliary functions -----------------------------------------------------

class (Show t) => Expclass t where
      pict :: t -> IO ExitCode
--------------------------------------------------------------------------------
instance (Show v, Show o) => Expclass (Exp v o) where
    pict = expShow "_.html" . bmap show show
--------------------------------------------------------------------------------
instance (Show a) => Expclass (BTree a) where
    pict = expShow "_.html" .  cBTree2Exp . (fmap show)

cBTree2Exp :: BTree a -> Exp [Char] a
cBTree2Exp = cataBTree (either (const (Var "nil")) h)
             where h(a,(b,c)) = Term a [b,c] 
--------------------------------------------------------------------------------
instance (Show a) => Expclass [a] where
    pict = expShow "_.html" .  cL2Exp . (fmap show)

cL2Exp [] = Var " "
cL2Exp l = Term "List" (map Var l)

--------------------------------------------------------------------------------
instance (Show a) => Expclass (LTree a) where
    pict = expShow "_.html" .  cLTree2Exp . (fmap show)

cLTree2Exp = cataLTree (either Var h)
             where h(a,b) = Term "Fork" [a,b] 
--------------------------------------------------------------------------------
cFTree2Exp = cataFTree (inExp . (id -|- (id><f))) where f(a,b)=[a,b]
--------------------------------------------------------------------------------
lnks :: Exp a a -> [(a, a)]
lnks (Var n) = []
lnks (Term n x) = (x >>= lnks) ++ [ (n,m) | Term m _ <- x ] ++ [ (n,m) | Var m <- x ]
--------------------------------------------------------------------------------
deco :: Num n => Exp v o -> Exp (n, v) (n, o)
deco e = fst (st (f e) 0) where
     f (Var e) = do {n <- get ; put(n+1); return (Var(n,e)) }
     f (Term o l) = do { n <- get ; put(n+1);
                         m <- sequence (map f l);
                         return (Term (n,o) m)
                       }
--------------------------------------------------------------------------------
untar :: (Ord v, Ord o) => [([o], v)] -> [Exp v o]
untar = a . (base id id untar) . c where
   a=sort.map inExp -- algebra
   c=join.(id><collect).sep. map((p2-|-assocr).distl.(outList >< id)) -- coalgebra
   base a b y = map(b -|- a >< y)

tar = cataExp g where
   g = either v o
   v = singl . (split nil id)
   o = (>>= f ) . lstr
   f (o,l)=[(o:a,x)|(a,x)<-l]

instance (Ord v, Ord o) => Ord (Exp v o) where
   Var v <= Var u = v <= u
   Var v <= Term o x = False
   Term o x <= Var v = True
   Term o x <= Term o' x' = o >= o'

{-- instance Ord (Exp String String) where
   Var v <= Var u = v <= u
   Var v <= Term o x = False
   Term o x <= Var v = True
   Term o x <= Term o' x' = o >= o'
--}
-------------------------------------------------------------------------------
