1 module Tree where 2 3 import Core_datatype 4 5 import Vtslib 6 7 import Edlib 8 9 import Type_defs 10 11 import X_interface 12 13 data TREE a b c 14 = Tree a 15 [TREE a b c] 16 ( Option b ) 17 ( c -> TREE a b c -> TREE a b c ) 18 ( Option ( TREE a b c )) 19 20 21 data Tree_state a b c 22 = TreeSt ( TREE a b c ) 23 [( Int , TREE a b c )] 24 c 25 26 {- 27 (******************************************************************************) 28 (* All tree editor functions are of type *) 29 (* X.xinterface -> ('a,'b,'c) tree_state -> ('a,'b'c) tree_state *) 30 (******************************************************************************) 31 -} 32 33 {- 34 (******************************************************************************) 35 (* Take a function of type ('a tree -> 'a) tree and turn it into a tree *) 36 (* editor function *) 37 (******************************************************************************) 38 -} 39 40 41 42 lift_non_io_tree_fn tree_fn t@(TreeSt tr tr_st gst) 43 = tree_fn tr |.| 44 ( \ res -> reTurn ( TreeSt res tr_st gst )) 45 `handle` 46 failtest t 47 48 49 50 51 52 {- 53 (******************************************************************************) 54 (* Take a function of type (xinterface -> 'a tree -> 'a) tree and turn *) 55 (* it into a tree editor function *) 56 (******************************************************************************) 57 -} 58 59 lift_io_tree_fn tree_fn t@(TreeSt tr tr_st gst) 60 = tree_fn tr /./ 61 ( \ fn_res -> reTurn ( TreeSt fn_res tr_st gst )) 62 `handle` 63 failtest t 64 65 66 67 lift_non_io_tree_st_fn tree_fn tr_tr_st 68 = tree_fn tr_tr_st |.| 69 reTurn 70 `handle` 71 failtest tr_tr_st 72 73 74 75 lift_io_tree_st_fn tree_fn tr_tr_st 76 = tree_fn tr_tr_st 77 `handle` 78 (\ _ -> reTurn tr_tr_st ) 79 80 81 failtest t s 82 = x_error s /./ 83 ( \ _ -> reTurn t ) 84 85 86 87 88 replace :: b -> Int -> [b] -> MayBe [b] String 89 90 replace = replace' [] 91 92 93 94 replace' :: [b] -> b -> Int -> [b] -> MayBe [b] String 95 96 replace' rl x 0 (_ : l) = Ok ( rl ++ (x : l)) 97 98 replace' rl x i (y : l) = replace' (rl <: y) x (i-1) l 99 100 replace' _ x i l = Bad " Match" 101 102 103 104 105 106 undo (Tree _ _ _ _ (SOME tr)) = tr 107 108 undo tr@(Tree _ _ _ _ NONE) = tr 109 110 111 112 113 114 down i (TreeSt tr@(Tree _ trL _ _ _) tr_st gst) 115 = TreeSt (trL!!i) ((i,tr) : tr_st) gst 116 117 118 119 120 up (TreeSt tr ( (i, Tree x trL dn vf tropt) : tr_st) gst) 121 = replace tr i trL ||| 122 exp 123 where 124 exp rl = Ok ( TreeSt tr2 tr_st gst ) 125 where 126 tr2 = if done && not (is_complete tr) 127 then if is_complete tr 128 then tr1 129 else mk_incomplete tr1 130 else (vf gst tr1 ) --`handle` \ _ -> tr1) 131 tr1 = Tree x rl dn vf tropt 132 done = is_complete tr1 133 134 up tr_st = Ok tr_st 135 136 137 138 139 is_complete (Tree _ _ NONE _ _) = False 140 141 is_complete (Tree _ _ (SOME _) _ _) = True 142 143 144 145 146 mk_incomplete (Tree x trL _ vf tropt) 147 = Tree x trL NONE vf tropt 148 149 150 151 152 top (tr_st@(TreeSt _ (_:_) gst)) 153 = up tr_st ||| top 154 155 top tr_st = Ok tr_st 156 157 158 159 160 search p f t = search_tree p f t [] 161 162 search_tree p f t@(Tree _ l _ _ _) il 163 = if p t 164 then (if f then search_sub_tree p f l 0 il else []) ++ [(il,t)] 165 else search_sub_tree p f l 0 il 166 167 168 169 170 search_sub_tree p f [] _ _ = [] 171 172 search_sub_tree p f (t:l) i il 173 = search_tree p f t (i:il) ++ search_sub_tree p f l (i+1) il 174 175 176 177 178 goto [] tr_st = tr_st 179 180 goto (i:il) tr_st = goto il (down i tr_st) 181 182 183 184 tree_undo = lift_non_io_tree_fn ( mk_ok undo ) 185 tree_top = lift_non_io_tree_st_fn top 186 tree_up = lift_non_io_tree_st_fn up 187 tree_down = lift_non_io_tree_st_fn . mk_ok . down 188 tree_search p f t = search p f t 189 tree_goto a b = goto a b