117 lines
3.2 KiB
Haskell
117 lines
3.2 KiB
Haskell
{-# 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
|