1{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 2{-# OPTIONS -fno-warn-orphans #-} 3 4-- ------------------------------------------------------------ 5 6{- | 7 Module : Data.Tree.NTree.Zipper.TypeDefs 8 Copyright : Copyright (C) 2010 Uwe Schmidt 9 License : MIT 10 11 Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) 12 Stability : stable 13 Portability: portable 14 15 Implementation of navigateble trees for 16 rose trees. The implementation is done with zippers. 17 A description and introductory tutorial about zippers 18 can be found in <http://learnyouahaskell.com/zippers> 19-} 20 21-- ------------------------------------------------------------ 22 23module Data.Tree.NTree.Zipper.TypeDefs 24{- 25 ( NTZipper 26 , NTree 27 , toNTZipper 28 , fromNTZipper 29 ) 30-} 31where 32 33import Data.Tree.Class 34 35import Data.Tree.NavigatableTree.Class 36import Data.Tree.NavigatableTree.XPathAxis ( childAxis ) 37 38import Data.Tree.NTree.TypeDefs 39 40-- ------------------------------------------------------------ 41 42-- | Zipper for rose trees 43-- 44-- A zipper consist of the current tree and the branches on the way back to the root 45 46data NTZipper a = NTZ 47 { ntree :: (NTree a) 48 , context :: (NTBreadCrumbs a) 49 } 50 deriving (Show) 51 52-- | The list of unzipped nodes from a current tree back to the root 53 54type NTBreadCrumbs a = [NTCrumb a] 55 56-- | One unzipped step consists of the left siblings, the node info and the right siblings 57 58data NTCrumb a = NTC 59 (NTrees a) -- left side 60 a -- node 61 (NTrees a) -- right side 62 deriving (Show) 63 64-- ------------------------------------------------------------ 65 66-- | Conversion of a rose tree into a navigatable rose tree 67 68toNTZipper :: NTree a -> NTZipper a 69toNTZipper t = NTZ t [] 70 71{-# INLINE toNTZipper #-} 72 73-- | Conversion of a navigatable rose tree into an ordinary rose tree. 74-- 75-- The context, the parts for moving up to the root are just removed from the tree. 76-- So when transforming a navigatable tree by moving around and by changing some nodes, 77-- one has to navigate back 78-- to the root, else that parts are removed from the result 79 80fromNTZipper :: NTZipper a -> NTree a 81fromNTZipper = ntree 82 83{-# INLINE fromNTZipper #-} 84 85-- ------------------------------------------------------------ 86 87up :: NTZipper a -> Maybe (NTZipper a) 88up z 89 | isTop z = Nothing 90 | otherwise = Just $ NTZ (up1 t bc) bcs 91 where 92 NTZ t (bc : bcs) = z 93 94{-# INLINE up #-} 95 96down :: NTZipper a -> Maybe (NTZipper a) 97down (NTZ (NTree n cs) bcs) 98 | null cs = Nothing 99 | otherwise = Just $ NTZ (head cs) (NTC [] n (tail cs) : bcs) 100 101{-# INLINE down #-} 102 103toTheRight :: NTZipper a -> Maybe (NTZipper a) 104toTheRight z 105 | isTop z 106 || 107 null rs = Nothing 108 | otherwise = Just $ NTZ t' (bc' : bcs) 109 where 110 (NTZ t (bc : bcs)) = z 111 (NTC ls n rs) = bc 112 t' = head rs 113 bc' = NTC (t : ls) n (tail rs) 114 115{-# INLINE toTheRight #-} 116 117toTheLeft :: NTZipper a -> Maybe (NTZipper a) 118toTheLeft z 119 | isTop z 120 || 121 null ls = Nothing 122 | otherwise = Just $ NTZ t' (bc' : bcs) 123 where 124 (NTZ t (bc : bcs)) = z 125 (NTC ls n rs) = bc 126 t' = head ls 127 bc' = NTC (tail ls) n (t : rs) 128 129{-# INLINE toTheLeft #-} 130 131addToTheLeft :: NTree a -> NTZipper a -> Maybe (NTZipper a) 132addToTheLeft t z 133 | isTop z = Nothing 134 | otherwise = Just $ NTZ t' (NTC (t:ls) n rs : bcs) 135 where 136 (NTZ t' (bc : bcs)) = z 137 (NTC ls n rs) = bc 138{-# INLINE addToTheLeft #-} 139 140addToTheRight :: NTree a -> NTZipper a -> Maybe (NTZipper a) 141addToTheRight t z 142 | isTop z = Nothing 143 | otherwise = Just $ NTZ t' (NTC ls n (t:rs) : bcs) 144 where 145 (NTZ t' (bc : bcs)) = z 146 (NTC ls n rs) = bc 147{-# INLINE addToTheRight #-} 148 149dropFromTheLeft :: NTZipper a -> Maybe (NTZipper a) 150dropFromTheLeft z 151 | isTop z = Nothing 152 | null ls = Nothing 153 | otherwise = Just $ NTZ t' (NTC (tail ls) n rs : bcs) 154 where 155 (NTZ t' (bc : bcs)) = z 156 (NTC ls n rs) = bc 157{-# INLINE dropFromTheLeft #-} 158 159dropFromTheRight :: NTZipper a -> Maybe (NTZipper a) 160dropFromTheRight z 161 | isTop z = Nothing 162 | null rs = Nothing 163 | otherwise = Just $ NTZ t' (NTC ls n (tail rs) : bcs) 164 where 165 (NTZ t' (bc : bcs)) = z 166 (NTC ls n rs) = bc 167{-# INLINE dropFromTheRight #-} 168 169-- ------------------------------------------------------------ 170 171isTop :: NTZipper a -> Bool 172isTop = null . context 173 174{-# INLINE isTop #-} 175 176up1 :: NTree a -> NTCrumb a -> NTree a 177up1 t (NTC ls n rs) = NTree n (foldl (flip (:)) (t : rs) ls) 178 179{-# INLINE up1 #-} 180 181-- ------------------------------------------------------------ 182 183instance Functor NTZipper where 184 fmap f (NTZ t xs) = NTZ (fmap f t) (map (fmap f) xs) 185 {-# INLINE fmap #-} 186 187instance Functor NTCrumb where 188 fmap f (NTC xs x ys)= NTC (map (fmap f) xs) (f x) (map (fmap f) ys) 189 {-# INLINE fmap #-} 190 191instance Tree NTZipper where 192 mkTree n cl = toNTZipper . mkTree n $ map ntree cl 193 194 getNode = getNode . ntree 195 {-# INLINE getNode #-} 196 getChildren = childAxis 197 {-# INLINE getChildren #-} 198 199 changeNode cf t = t { ntree = changeNode cf (ntree t) } 200 changeChildren cf t = t { ntree = setChildren (map ntree . cf . childAxis $ t) (ntree t) } 201 202 foldTree f = foldTree f . ntree 203 {-# INLINE foldTree #-} 204 205instance NavigatableTree NTZipper where 206 mvDown = down 207 {-# INLINE mvDown #-} 208 209 mvUp = up 210 {-# INLINE mvUp #-} 211 212 mvLeft = toTheLeft 213 {-# INLINE mvLeft #-} 214 215 mvRight = toTheRight 216 {-# INLINE mvRight #-} 217 218instance NavigatableTreeToTree NTZipper NTree where 219 fromTree = toNTZipper 220 {-# INLINE fromTree #-} 221 222 toTree = fromNTZipper 223 {-# INLINE toTree #-} 224 225instance NavigatableTreeModify NTZipper NTree where 226 addTreeLeft = addToTheLeft 227 {-# INLINE addTreeLeft #-} 228 229 addTreeRight = addToTheRight 230 {-# INLINE addTreeRight #-} 231 232 dropTreeLeft = dropFromTheLeft 233 {-# INLINE dropTreeLeft #-} 234 235 dropTreeRight = dropFromTheRight 236 {-# INLINE dropTreeRight #-} 237 238 substThisTree t nt = nt { ntree = t } 239 {-# INLINE substThisTree #-} 240 241-- ------------------------------------------------------------ 242