module Data.StableTree.Types
( Depth
, ValueCount
, StableTree(..)
, Incomplete
, Complete
, Z
, S
, Tree(..)
, getDepth
, getValueCount
) where
import Data.StableTree.Key ( StableKey, SomeKey(..), Key(..), Terminal, Nonterminal )
import qualified Data.Map as Map
import Data.Map ( Map )
type Depth = Int
type ValueCount = Int
data StableTree k v = forall d. StableTree_I (Tree d Incomplete k v)
| forall d. StableTree_C (Tree d Complete k v)
data Incomplete
data Complete
data Z
data S a
data Tree d c k v where
Bottom :: (SomeKey k, v)
-> (SomeKey k, v)
-> Map (Key Nonterminal k) v
-> (Key Terminal k, v)
-> Tree Z Complete k v
IBottom0 :: Maybe (SomeKey k, v)
-> Tree Z Incomplete k v
IBottom1 :: (SomeKey k, v)
-> (SomeKey k, v)
-> Map (Key Nonterminal k) v
-> Tree Z Incomplete k v
Branch :: Depth
-> (SomeKey k, ValueCount, Tree d Complete k v)
-> (SomeKey k, ValueCount, Tree d Complete k v)
-> Map (Key Nonterminal k) (ValueCount, Tree d Complete k v)
-> (Key Terminal k, ValueCount, Tree d Complete k v)
-> Tree (S d) Complete k v
IBranch0 :: Depth
-> (SomeKey k, ValueCount, Tree d Incomplete k v)
-> Tree (S d) Incomplete k v
IBranch1 :: Depth
-> (SomeKey k, ValueCount, Tree d Complete k v)
-> Maybe (SomeKey k, ValueCount, Tree d Incomplete k v)
-> Tree (S d) Incomplete k v
IBranch2 :: Depth
-> (SomeKey k, ValueCount, Tree d Complete k v)
-> (SomeKey k, ValueCount, Tree d Complete k v)
-> Map (Key Nonterminal k) (ValueCount, Tree d Complete k v)
-> Maybe (SomeKey k, ValueCount, Tree d Incomplete k v)
-> Tree (S d) Incomplete k v
class TreeNode n where
getDepth :: n k v -> Depth
getValueCount :: n k v -> ValueCount
instance TreeNode (Tree d c) where
getDepth (Bottom _ _ _ _) = 0
getDepth (IBottom0 _) = 0
getDepth (IBottom1 _ _ _) = 0
getDepth (Branch d _ _ _ _) = d
getDepth (IBranch0 d _) = d
getDepth (IBranch1 d _ _) = d
getDepth (IBranch2 d _ _ _ _) = d
getValueCount (Bottom _ _ m _) = 3 + Map.size m
getValueCount (IBottom0 Nothing) = 0
getValueCount (IBottom0 _) = 1
getValueCount (IBottom1 _ _ m) = 2 + Map.size m
getValueCount (Branch _ (_,c1,_) (_,c2,_) nterm (_,c3,_)) =
c1 + c2 + c3 + sum (map fst $ Map.elems nterm)
getValueCount (IBranch0 _ (_,c,_)) =
c
getValueCount (IBranch1 _ (_,c,_) Nothing) =
c
getValueCount (IBranch1 _ (_,c1,_) (Just (_,c2,_))) =
c1+c2
getValueCount (IBranch2 _ (_,c1,_) (_,c2,_) m i) =
c1 + c2 + sum (map fst $ Map.elems m) + maybe 0 (\(_,c3,_)->c3) i
instance TreeNode StableTree where
getDepth (StableTree_I t) = getDepth t
getDepth (StableTree_C t) = getDepth t
getValueCount (StableTree_I t) = getValueCount t
getValueCount (StableTree_C t) = getValueCount t
instance (Eq k, Eq v) => Eq (Tree d c k v) where
(Bottom lp1 lp2 lnts lt) == (Bottom rp1 rp2 rnts rt) =
(lp1 == rp1) && (lp2 == rp2) && (lnts == rnts) && (lt == rt)
(IBottom0 l) == (IBottom0 r) = l == r
(IBottom1 lp1 lp2 lnts) == (IBottom1 rp1 rp2 rnts) =
(lp1 == rp1) && (lp2 == rp2) && (lnts == rnts)
(Branch _ lt1 lt2 lnts lt) == (Branch _ rt1 rt2 rnts rt) =
(lt1 == rt1) && (lt2 == rt2) && (lnts == rnts) && (lt == rt)
(IBranch0 _ lt) == (IBranch0 _ rt) = lt == rt
(IBranch1 _ lt li) == (IBranch1 _ rt ri) = (lt == rt) && (li == ri)
(IBranch2 _ lt1 lt2 lnts li) == (IBranch2 _ rt1 rt2 rnts ri) =
(lt1 == rt1) && (lt2 == rt2) && (lnts == rnts) && (li == ri)
_ == _ = False
instance (Eq k, Eq v) => Eq (StableTree k v) where
(StableTree_I t1) == (StableTree_I t2) = t1 `equals` t2
(StableTree_C t1) == (StableTree_C t2) = t1 `equals` t2
_ == _ = False
equals :: (Eq k, Eq v) => Tree d1 c1 k v -> Tree d2 c2 k v -> Bool
equals l@(Bottom{}) r@(Bottom{}) = l == r
equals l@(IBottom0{}) r@(IBottom0{}) = l == r
equals l@(IBottom1{}) r@(IBottom1{}) = l == r
equals (Branch ld (lk1, lv1, lt1) (lk2, lv2, lt2) lnts (lkt, lvt, ltt))
(Branch rd (rk1, rv1, rt1) (rk2, rv2, rt2) rnts (rkt, rvt, rtt)) =
(ld == rd) &&
(lk1 == rk1) && (lk2 == rk2) && (lkt == rkt) &&
(lv1 == rv1) && (lv2 == rv2) && (lvt == rvt) &&
(lt1 `equals` rt1) && (lt2 `equals` rt2) && (ltt `equals` rtt) &&
(ntEquals lnts rnts)
equals (IBranch0 ld (lk, lv, lt)) (IBranch0 rd (rk, rv, rt)) =
(ld == rd) && (lk == rk) && (lv == rv) && (lt `equals` rt)
equals (IBranch1 ld (lk, lv, lt) Nothing) (IBranch1 rd (rk, rv, rt) Nothing) =
(ld == rd) && (lk == rk) && (lv == rv) && (lt `equals` rt)
equals (IBranch1 ld (lk, lv, lt) (Just (lki, lvi, lti)))
(IBranch1 rd (rk, rv, rt) (Just (rki, rvi, rti))) =
(ld == rd) && (lk == rk) && (lv == rv) && (lki == rki) && (lvi == rvi) &&
(lt `equals` rt) && (lti `equals` rti)
equals (IBranch2 ld (lk1, lv1, lt1) (lk2, lv2, lt2) lnts Nothing)
(IBranch2 rd (rk1, rv1, rt1) (rk2, rv2, rt2) rnts Nothing) =
(ld == rd) &&
(lk1 == rk1) && (lk2 == rk2) && (lv1 == rv1) && (lv2 == rv2) &&
(lt1 `equals` rt1) && (lt2 `equals` rt2) && (ntEquals lnts rnts)
equals (IBranch2 ld (lk1, lv1, lt1) (lk2, lv2, lt2) lnts (Just (lki, lvi, lti)))
(IBranch2 rd (rk1, rv1, rt1) (rk2, rv2, rt2) rnts (Just (rki, rvi, rti))) =
(ld == rd) &&
(lk1 == rk1) && (lk2 == rk2) && (lv1 == rv1) && (lv2 == rv2) &&
(lki == rki) && (lvi == rvi) && (lti `equals` rti) &&
(lt1 `equals` rt1) && (lt2 `equals` rt2) && (ntEquals lnts rnts)
equals _ _ = False
ntEquals :: (Eq k, Eq v)
=> Map (Key Nonterminal k) (ValueCount, Tree d1 Complete k v)
-> Map (Key Nonterminal k) (ValueCount, Tree d2 Complete k v)
-> Bool
ntEquals lnts rnts =
(Map.keys lnts == Map.keys rnts) &&
(map fst (Map.elems lnts) == map fst (Map.elems rnts)) &&
(all (==True) (zipWith (\l r -> (snd l) `equals` (snd r))
(Map.elems lnts)
(Map.elems rnts)))
deriving instance (Ord k, Show k, Show v) => Show (StableTree k v)
deriving instance (Ord k, Show k, Show v) => Show (Tree d c k v)
instance (Ord k, StableKey k) => Functor (Tree d c k) where
fmap fn (Bottom (k1, v1) (k2, v2) nonterms (kt, vt)) =
Bottom (k1, fn v1) (k2, fn v2) (Map.map fn nonterms) (kt, fn vt)
fmap fn (IBottom0 mpair) =
IBottom0 (Prelude.fmap (\(k,v) -> (k, fn v)) mpair)
fmap fn (IBottom1 (k1, v1) (k2, v2) nonterms) =
IBottom1 (k1, fn v1) (k2, fn v2) (Map.map fn nonterms)
fmap fn (Branch d (k1, c1, t1) (k2, c2, t2) nonterms (kt, ct, tt)) =
Branch d
(k1, c1, fmap fn t1)
(k2, c2, fmap fn t2)
(Map.map (\(c,t) -> (c, fmap fn t)) nonterms)
(kt, ct, fmap fn tt)
fmap fn (IBranch0 d (k1, c1, t1)) =
IBranch0 d
(k1, c1, fmap fn t1)
fmap fn (IBranch1 d (k1, c1, t1) mtriple) =
IBranch1 d
(k1, c1, fmap fn t1)
(Prelude.fmap (\(k, c, t) -> (k, c, fmap fn t)) mtriple)
fmap fn (IBranch2 d (k1, c1, t1) (k2, c2, t2) nonterms mtriple) =
IBranch2 d
(k1, c1, fmap fn t1)
(k2, c2, fmap fn t2)
(Map.map (\(c, t) -> (c, fmap fn t)) nonterms)
(Prelude.fmap (\(k, c, t) -> (k, c, fmap fn t)) mtriple)
instance (Ord k, StableKey k) => Functor (StableTree k) where
fmap fn (StableTree_I i) = StableTree_I $ fmap fn i
fmap fn (StableTree_C c) = StableTree_C $ fmap fn c