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