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