{-# LANGUAGE MonadComprehensions #-} 
{-# LANGUAGE FlexibleContexts #-} 

module Node
       (Node (Node),
        module Toolbox,
        module Step,
        dArcs,hArc,ind, cat,
        cats,
        preds,succs,
        lng,rng,ng,ldp,rdp,dp,lhd,rhd,hd,lmdp,rmdp,lv,le,
        lhdBy,
        up,down,root,roots,
        roles,leftRoles,rightRoles,
        headless,
        lastNode)
       where


import Control.Monad
-- import Data.Monoid
import Data.List (intercalate,intersperse,find)
import Data.Maybe (maybeToList)
import Toolbox
import Step
import Parse
import Base

data Node τ κ = Node {past :: [Step τ κ], future :: [Step τ κ]} -- deriving (Eq)
instance {- (Eq τ, Eq κ) => -} Eq (Node τ κ) where
    n₁ == n₂ = (ind n₁) == (ind n₂)
instance {- (Eq τ, Eq κ) => -} Ord (Node τ κ) where
    compare n₁ n₂ = compare (ind n₁) (ind n₂)

ind :: Node τ κ -> Ind
ind (Node (Step i _ _ _ : _) _) = i

cat :: Node τ κ -> κ
cat (Node (Step _ c _ _ : _) _) = c

cats = map cat

hArc, dArcs :: Node τ κ -> [Arc τ]
hArc (Node (Step _ _ h _ : _) _) = h
dArcs (Node (Step _ _ _ d : _) _) = d

lastNode :: Parse τ κ -> Node τ κ
lastNode p = Node p []


lng, rng :: Node τ κ -> [Node τ κ]

lng (Node (s:s':p) q)  = return (Node (s':p) (s:q))
lng _                  = mzero

rng (Node p (s:q))     = return (Node (s:p) q)
rng _                  = mzero

ng, preds, succs :: Node τ κ -> [Node τ κ]
ng = lng <> rng


preds (Node (s:s':p) q) = let prev = (Node (s':p) (s:q)) in (Node (s':p) (s:q)) : preds prev
preds _                 = []
-- preds = clo lng
succs = clo rng

lhd, rhd, hd, ldp, rdp, dp, le, lv, lmdp, rmdp, down, up, root, roots :: (Ord (Node τ κ)) => Node τ κ -> [Node τ κ]

ldp n = [ n' | n' <- preds n, Dep  _ i <- dArcs n, ind n' == i ]
rdp n = [ n' | n' <- succs n, Head _ i <- hArc n', ind n  == i ]
dp    = ldp <> rdp

lhd v = [ v' | Head _ i <- hArc v, v' <- preds v, ind v' == i ] 
rhd v = [ v' | v' <- succs v, Dep  _ i <- dArcs v', ind v  == i ]
hd    = lhd <> rhd

ldpBy,rdpBy,dpBy :: (Ord (Node τ κ)) => τ -> Node τ κ -> [Node τ κ]
ldpBy r n = [ n' | n' <- preds n, Dep r i <- dArcs n, ind n' == i ]
rdpBy r n = [ n' | n' <- succs n, Head r i <- hArc n', ind n  == i ]
dpBy r    = ldpBy r <> rdpBy r

lhdBy,rhdBy,hdBy :: (Ord (Node τ κ)) => τ -> Node τ κ -> [Node τ κ]
lhdBy r n = [ n' | n' <- preds n, Head r i <- hArc n  , ind n'  == i ]
rhdBy r n = [ n' | n' <- succs n, Dep r i <- dArcs n', ind n   == i ]
hdBy r    = lhdBy r <> rhdBy r

        
le = mrclo lmdp

lmdp = just minimum . ldp
rmdp = just maximum . rdp

lv  = mrclo lmdp  >=> lng >=> rclo lhd

down = clo dp
up = clo hd

root = mrclo hd
roots = (filter headless) . preds

headless :: (Ord (Node τ κ)) => Node τ κ -> Bool
headless = null . hd
-- roots = preds |? headless

roles, leftRoles, rightRoles :: Node τ κ -> [τ]
roles = leftRoles <> rightRoles
leftRoles v  = [ r | Dep  r _  <- dArcs v ]
rightRoles v = [ r | v' <- succs v, Head r i  <- hArc v', i==ind v ]


instance (Show τ, Show κ) => Show (Node τ κ) where
  show (Node p q) = showSteps p ++ " @ " ++ showStepsRev q ++ "\n"
    where
      showStepsRev = intercalate " * " . map show
      showSteps    = showStepsRev . reverse