
module Edit where

import Label
import ViewTypes(Loc)


infixr 9 -.-

type Paint a b = a -> (a,[b])

(-.-) :: Paint a b -> Paint a b -> Paint a b
(-.-) f g s = (u, p++q)
              where (t,p) = g s
                    (u,q) = f t


type EditSt s c      = (s, c)
type EditAction s  c = Paint (EditSt s c) s

subtreeOfEdit :: EditSt s c -> s
subtreeOfEdit (s,c) = s

-------------------------------------------------
-- trees

data Tree = Fork TreeLabel [Tree] deriving (Show,Read)

label :: Tree -> TreeLabel 
label (Fork l _) = l

children :: Tree -> [Tree]
children (Fork _ ts) = ts

childrenR :: Tree -> [Tree]
childrenR (Fork _ ts) = reverse ts

atomic :: Tree -> Bool
atomic = null . children

preorder :: Tree -> [Tree]
preorder t = t: concat (map preorder (children t))

preorderR :: Tree -> [Tree]
preorderR t = t: concat (map preorderR (childrenR t))

holes :: Int ->  [Tree]
holes n = replicate n hole

hole :: Tree
hole = Fork Hole []

template :: TreeLabel -> Tree
template l = Fork l (holes (arity l))

---------------------------------------------------
-- Huet's zipper

type SubTree = (Path,Tree)

type Path = [Layer]
type Layer = (TreeLabel,[Tree],[Tree])

embed :: Tree -> Layer -> Tree
embed t (l,left,right) = Fork l (reverse left ++ [t] ++ right)

selected :: SubTree -> Tree
selected (_,t) = t

path :: SubTree -> Path 
path (p,_) = p

host :: SubTree -> Tree
host (p,t) = foldl embed t p

root :: Tree -> SubTree
root t = ([],t)

parentLabel ((lab,_,_):_,_) = lab
parentLabel ([],_)          = error "cannot take parentLabel of root"

childno :: SubTree -> Int
childno ((_,xs,_):_,_) = length xs


atHole :: SubTree -> Bool
atHole (_,Fork h _) = isHole h


---------------------------------------------------
-- tree locations

-- type Loc = [Int]

find :: Tree -> Loc -> SubTree
find t = find' t . reverse
find' t [] = ([],t)
find' (Fork l ts) (n:ns) = (p++[(l,reverse ts0,ts1)],s)
                           where (ts0,t:ts1) = splitAt n ts
                                 (p,s) = find' t ns

location :: SubTree -> Loc
location = map (length . snd3) . fst
           where snd3 (_,x,_) = x

----------------------------------------------------
-- navigation operations

nav :: (s -> s) -> EditAction s c
nav f (s,c) = ((f s, c),[])

left :: SubTree -> SubTree
left ((lab,last:l,r):ls,sel) = ((lab,l,sel:r):ls,last)
left st@((_,[],_):_,_) = st
left st@([],_) = st

leftmost :: SubTree -> Bool
leftmost ((_,[],_):_,_) = True
leftmost ([],_) = True
leftmost _ = False

right :: SubTree -> SubTree
right ((lab,l,next:r):ls,sel) = ((lab,sel:l,r):ls,next)
right st@((_,_,[]):_,_) = st
right st@([],_) = st

rightmost :: SubTree -> Bool
rightmost ((_,_,[]):_,_) = True
rightmost ([],_) = True
rightmost _ = False

up :: SubTree -> SubTree
up (layer:above,t) = (above,embed t layer)
up st@([],_) = st

topmost :: SubTree -> Bool
topmost ([],_) = True
topmost _ = False

down :: SubTree -> SubTree
down (p,Fork lab (t:ts)) = ((lab,[],ts):p,t)
down st@(_,Fork _ []) = st

downR :: SubTree -> SubTree
downR st@(_,Fork _ [])  = st
downR (p,Fork lab tst)  = ((lab,reverse ts,[]):p,t)
                          where ts = init tst
                                t  = last tst

bottommost :: SubTree -> Bool
bottommost (_,Fork _ []) = True
bottommost _ = False

next :: SubTree -> SubTree
next st = if bottommost st then rightup st else down st

prev :: SubTree -> SubTree
prev st = if bottommost st then leftup st else downR st

rightup :: SubTree -> SubTree
rightup = right . until (\st -> topmost st || not (rightmost st)) up

leftup :: SubTree -> SubTree
leftup = left . until (\st -> topmost st || not (leftmost st)) up

nextSuchThat :: (SubTree -> Bool) -> SubTree -> SubTree
nextSuchThat p st = 
 if p st' then st' else st
  where
   st' = until (\st -> topmost st || p st) next (next st)

prevSuchThat :: (SubTree -> Bool) -> SubTree -> SubTree
prevSuchThat p st = 
 if p st' then st' else st
  where
   st' = until (\st -> topmost st || p st) prev (prev st)

childSuchThat :: (SubTree -> Bool) -> SubTree -> SubTree
childSuchThat p st =
 if p st' then st' else st
 where st' = until (\st -> rightmost st || p st) right (down st)

childSuchThatR :: (SubTree -> Bool) -> SubTree -> SubTree
childSuchThatR p st =
 if p st' then st' else st
 where st' = until (\st -> leftmost st || p st) left (downR st)

capped :: SubTree -> Bool
capped st =  (not (topmost st) && cap (parentLabel st))

forward :: SubTree -> SubTree
forward st = if atHole st' then st' else upToCap st
             where st' = nextSuchThat atHole st

backward :: SubTree -> SubTree
backward st = if atHole st' then st' else upToCap st
              where st' = prevSuchThat atHole st


upToCap :: SubTree -> SubTree
upToCap  = until (\st -> (cap .  label . selected) st || topmost st) up . up


toChild :: Int -> SubTree -> SubTree
toChild n st@(p,Fork l ts) = if n < length ts
                                then ((l,reverse ts0,ts1):p,t)
                                else st
                                where (ts0,t:ts1) = splitAt n ts




-- TREE MODIFICATION

type Edit0 = EditAction SubTree  [Tree]

holeSel (st,c) = atHole st
sel (st,c) = selected st

-- replacement

replace :: Tree -> Edit0
replace s ((p,t),c) = ( ((p,s),c) , [(p,s)] )

flatass :: Edit0
flatass e@((_,Fork l ts),_) = if associative l
                              then replace (Fork l (concat (map f ts))) e
                              else (e,[])
                              where f t@(Fork m ss) = if m==l then ss else [t]
                                              

cutChild :: Int -> Edit0
cutChild m e@((_,Fork l ts),_)  = replace (Fork l (ts0++ts1))  e
                                  where (ts0,t:ts1) = splitAt m ts

flatChild :: Int -> Edit0
flatChild n e@((_,Fork l ts),_) = replace (Fork l (ts0++ts1++ts2)) e
                                  where (ts0,Fork _ ts1 : ts2) = splitAt n ts
                                                                   

replaceFlat :: Tree -> Edit0
replaceFlat t e@(st,_) = if (not (topmost st) && parentLabel st ==  tl && associative tl)
                         then (flatChild (childno st) -.- nav up -.- replace t) e 
                         else replace  t e
                         where tl = label t

kill ::  Edit0
kill = replace hole

promote :: Edit0
promote e@((_,t),_)        = (replace t -.- nav up) e

demote :: Edit0
demote e@((_,Fork l ts),_) = replace (Fork l cs) e
                             where cs = if null ts then [] else children (head ts)

demoteR :: Edit0
demoteR e@((_,Fork l ts),_) = replace (Fork l cs) e
                              where cs = if null ts then [] else children (last ts)


paste :: Edit0
paste e@(st,c) = if atHole st 
                 then if not (topmost st) && associative pl
                      then replaceFlat (Fork pl c) e
                      else if not (null c)
                           then replace (head c) e
                           else (e,[])
                 else (e,[])
                 where pl = parentLabel st


cut :: Edit0
cut e@(st,_) = if topmost st then replace hole e else (nav (comp n right . down) -.- cutChild n -.- nav up) e
               where n = childno st


cutR :: Edit0
cutR e@(st,c) = if topmost st then replace hole e else (nav (comp m left . downR) -.- cutChild n ) (st',c)
                where n = childno st
                      st' = up st
                      m = length (children (selected st')) - n - 1

comp 0 f = id
comp (n+1) f = f. comp n f

-- insertion


insert :: TreeLabel -> Edit0
insert = treeinsert . template

insertR :: TreeLabel -> Edit0
insertR = treeinsertR . template

treeinsert :: Tree -> Edit0
treeinsert t st = if holeSel st then replaceFlat t st
		          else (replaceFlat (sel st) -.- nav (childSuchThat atHole) -.- replaceFlat t) st

treeinsertR :: Tree -> Edit0
treeinsertR t st = if holeSel st then replaceFlat t st
                   else (replaceFlat (sel st) -.- nav (childSuchThatR atHole) -.- replaceFlat t) st

enter :: TreeLabel -> Edit1
enter l = nav (nextSuchThat' atHole)  -.- lift (insert l)

enterR :: TreeLabel -> Edit1
enterR l = nav (prevSuchThat' atHole) -.- lift (insertR l)
  
entry :: TreeLabel -> Edit1
entry l = enter l -.- lift (nav (reduce l))

entryR :: TreeLabel -> Edit1
entryR l = enterR l -.- lift (nav (reduceR l))

reduce :: TreeLabel -> SubTree -> SubTree
reduce l = until (irreducible l) up

reduceR :: TreeLabel -> SubTree -> SubTree
reduceR l = until (irreducibleR l) up

irreducible :: TreeLabel -> SubTree -> Bool
irreducible l st = atHole st || topmost st || (not . rightmost) st ||
		           (not . producable l . label . selected . up) st

irreducibleR :: TreeLabel -> SubTree -> Bool
irreducibleR l st = atHole st || topmost st || (not . leftmost) st ||
		            (not . producableR l . label . selected . up) st

producable :: TreeLabel -> TreeLabel -> Bool
producable op2 op1 = ( op1 ==  op2 && assl op1) || prec op1 > prec op2

producableR :: TreeLabel -> TreeLabel -> Bool
producableR op2 op1 = ( op1 ==  op2 && assr op1) || prec op1 > prec op2


-- bracketing

type Bracket = ([Path],Tree)

type Edit1 = EditAction Bracket  [Tree]

nav1 :: (SubTree -> SubTree) -> Edit1
nav1 = nav . liftnav

empty :: Bracket
empty = ([],hole)

flatten :: Bracket -> SubTree
flatten (ps,t) = (concat ps,t)

bwrap :: SubTree -> Bracket
bwrap (p,t) = ([p],t)

lift :: Edit0 -> Edit1
lift f ((p:ps,t),c) = (((q:ps,s),d),[ (p':ps,t') | (p',t') <- ts ]) 
                      where (((q,s),d),ts) = f ((p,t),c)
lift f (([],t),c)   = ((([q],s),d), [ ([p'],t') | (p',t') <- ts ]) 
                      where (((q,s),d),ts) = f (([],t),c)

liftnav :: (SubTree -> SubTree) -> (Bracket -> Bracket)
liftnav f (p:ps,t) = (q:ps,s) where (q,s) = f (p,t)
liftnav f ([],t)   = ([q],s) where (q,s) = f ([],t)


selected' :: Bracket -> Tree
selected' (_,t) = t

atHole' :: Bracket -> Bool
atHole' (_,Fork l _) = isHole l

topmost' :: Bracket -> Bool
topmost' ([],_) = True
topmost' ([[]],_) = True
topmost' _ = False

lft0 :: (SubTree -> a) -> Bracket -> a
lft0 f ([],t) = f ([],t)
lft0 f (p:ps,t) = f (p,t)


right',up' :: Bracket -> Bracket
right' = liftnav right
up' = liftnav up
left' = liftnav left
down' = liftnav down

toRoot' :: Bracket -> Bracket
toRoot' (ps,t) = ([],host (concat ps,t))

open :: Edit1
open ((p,t),c) = ((([]:p,t),c),[])

close :: Edit1
close = nav close'
        where close'  (p:ps,t) = nextSuchThat' atHole (ps,s) where s = host (p,t)
              close' t         = t

closeR :: Edit1
closeR = nav closeR' 
         where close' (p:ps,t) = prevSuchThat' atHole (ps,s) where s = host (p,t)
               closeR'  t      = t

nextSuchThat' :: (SubTree -> Bool) -> Bracket -> Bracket
nextSuchThat' p  = closeAt . liftnav (nextSuchThat p) . openAt cap

prevSuchThat' :: (SubTree -> Bool) -> Bracket -> Bracket
prevSuchThat' p  = closeAt . liftnav (prevSuchThat p) . openAt cap

openAt :: (TreeLabel -> Bool) -> Bracket -> Bracket
openAt c (p:ps,s) = (p0:p1:ps,s)
                    where (p0,p1) = span (not . c . lab) p
                          lab (l,x,y) = l
openAt c ([],s)   = ([],s)

closeAt :: Bracket -> Bracket
closeAt (p:q:ps,s) = ((p++q):ps,s)
closeAt ([],s) = ([],s)

bracket :: Loc -> Edit1
bracket l e@(st,c) = if sibling st l && associative (lft0 parentLabel st)
                     then lift (selectChild (length x) -.- replace t' -.- nav up) e
                     else (e,[])
                     where (((pl,x,y):_):_,s) = st
                           (y0,t:y1) = splitAt n y
                           n = head l - lft0 childno st -1
                           t' = Fork pl (reverse x ++ [Fork pl ([s]++y0++[t])] ++ y1)
          
selectChild :: Int -> Edit0          
selectChild n ((p,Fork l ts),c) = ( ( ((l,reverse ts0,ts1):p,t), c), [])
                                  where (ts0,t:ts1) = splitAt n ts
                              
sibling :: Bracket -> Loc -> Bool
sibling st l = not (null l) && not (null lst) && tail lst == tail l && head l > head lst
               where lst = location (flatten st)

navigate :: Loc -> Edit1
navigate l e@(st,c) = (((bwrap . flip find l . host . flatten) st, c),[])

---------------------------------------------------------------------------------------------------------------
-- clipboard operations

type ClipBoard       = [Tree]

copy :: Edit1
copy (st@(_,t),c) = ((st,c++[t]),[])

clear :: Edit1
clear (st,c) = ((st,[]),[])

idEdit :: Edit1
idEdit (st,c) = ((st,c),[])



