Source file sharedForest.ml

open UtilsLib
open TreeContext

module Log = Xlog.Make (struct
    let name = "NewSharedForest"
  end)
    
module Make (W : Weight.Weight_sig) = struct
  type address = (int * int) list
  (** This type is the type of addresses of forests. It is a list of
      (position in the forest,position as a child). *)
      
  type relative_path = int * address
  (** This is the type of relative path from one forest to another
      one. The first argument is the number of steps to move up, then
      second argument is the address to reach from this point. *)

  (** [diff add add'] returns the relative path to go from the
      forest (subtree) wich occurs at address [add] to the forest
      (subtree) wich occurs at address [add']. *)
  let diff add1 add2 =
    let rec diff_aux add1 add2 back =
      match (add1, add2) with
      | [], [] -> (back, [])
      | _, [] -> (back + List.length add1, [])
      | [], _ -> (back, add2)
      | (i, j) :: tl1, (i', j') :: tl2 when i = i' && j = j' ->
        diff_aux tl1 tl2 back
      | _ :: _, _ :: _ -> (back + List.length add1, add2) in
    diff_aux add1 add2 0

  let pp_address fmt addr =
    Format.fprintf fmt "@[[%a]@]"
      (Utils.pp_list ~sep:";" (fun fmt (i, j) ->
           Format.fprintf fmt "(%d,%d)" i j))
      addr

  let pp_address_rev fmt addr =
    Format.fprintf fmt "@[[%a]@]"
      (Utils.pp_list ~sep:"·" (fun fmt (i, j) ->
           Format.fprintf fmt "(%d,%d)" i j))
      (List.rev addr)
  [@@warning "-32"]


  let pp_path fmt (i, add) =
    Format.fprintf
      fmt
      "(%a,%a)"
      (fun fmt i ->
         if i = 0 then
           Format.fprintf fmt "%d" 0
         else
           Format.fprintf fmt "-%d" i)
      i
      pp_address
      add

  type weight = W.w
  let pp_weight = W.pp

  type 'a focused_list =  'a ListContext.focused_list

  type 'a forest = 'a forest_tree list
  and 'a forest_tree = Node of ('a * 'a child list)
  and 'a child =
    | Forest of 'a forest
    | Link_to of relative_path        

  let label (Node (a, _)) = a

  type 'a childList_context =
    { siblings: 'a child focused_list;
      parent_label : 'a;
      focus: 'a child;}
  
  type 'a forest_context_info =
    { label : 'a;
      (* label is the label of the node from which the context was
         made *)
      children : 'a child ListContext.focused_list;
      (* the focused list of children of the tree. Just as for tree
         zippers *)
      alternatives: 'a forest_tree ListContext.focused_list;
      (* the focused list of the focused children: a forest *)
      alt_num : int;
      (* the position of the tree under focus in the current forest *)
      context : 'a forest_context;
      (* the forest context *)
      suspended_computation :  (('a forest_context * 'a forest_tree) * 'a childList_context) option;
      (* a local context describing the state from which the current
         focused forest was reach after following a [Link_to]
         specification. Because when moving up (or right) from such
         node, we should take into account the forest tree whose the
         [Link_to] was a child (and its context), not the current one.
         *)
      address : address ;
      (* The (absolute) address of the current hole for forest_tree
         (**** IN THE REVERSE ORDER ****)*)
    }
  and 'a forest_context =
    | Top of ('a forest_tree ListContext.focused_list * int * (('a forest_context * 'a forest_tree) * 'a childList_context) option)
    (* invariant: the second element should be the position of the
       current focused tree of the forest) *)
    | Zip of 'a forest_context_info

  let alt_position = function
    | Top (_, pos, _) -> pos
    | Zip infos -> infos.alt_num

  type 'a focused_forest = 'a forest_context * 'a forest_tree
  (** Type definition for the focused forests: a forest context and
      the tree on which it is being focused *)
                             
  type move = Up | Down | Right
              
  exception Move_failure of move

  exception Not_well_defined
  exception Bad_address

  (** [forest_up_absolute z t] goes up in the shared forest context
     [z], currently focused on [t] and returns the new context and the
     new focused forest. Potential suspended computations are not
     taken into account because the move should be absolute in the
     shared forest. *)
  let forest_up_absolute z t =
    match z with
    | Top _ -> raise (Move_failure Up)
    | Zip { label;
            children = (l, r);
            alternatives = (ctx, alt);
            alt_num = _;
            context = z';
            suspended_computation =_ ;
            address = (_ :: _) ;
          } ->
      let new_alternatives = ListContext.zip_up ctx (t :: alt) in
      let new_children = ListContext.zip_up l ((Forest new_alternatives) :: r) in
      (z', Node (label, new_children))
    | _ -> (* The address is empty, it should only occur when at Top *)
      let () = Log.debug (fun m -> m "The address is empty, it should only occur when at Top") in
      raise Bad_address
      
      
  (** Type definition for computational states: encodes the current
      position in the forest and the current tree being built. Allows
      for changing from one computation state to another and continue
      the computation *)
  type 'a state = { f_forest : 'a focused_forest;
                    (* The forest at the position it is being
                       explored, together with its context *)
                    f_tree : 'a TreeContext.focused_tree;
                    (* The tree that has been build so far while
                       moving to the current position in the forest,
                       together with its context *)
                  }
                  
  
  (** This module implements the mapping from weights to states, i.e.,
      current computation states, sorted according to the weight [W]
      module *)
  module Weight_to_states = W.WMap
                              
  module Resumptions = Resumptions.Make(W)(struct type 'a computation = 'a state end)
      
  let get_forest_address = function
    | Top _ -> []
    | Zip infos -> infos.address

  let extend_address ~from a = a :: from
    
  (** [focus_on_alt j_alt (z,t)] returns [(z', t')] where [t'] is the
     [j_alt]-th sibling of [t] in the forest list (starting from the
     leftmost one *)
  let focus_on_alt j_alt (z, t) =
    match z with
    | Top (_, pos, _) when pos = j_alt -> (z, t)
    | Top (focused_list, pos, suspended_c) ->
      (let alternatives = ListContext.forward_insert t focused_list in
      match ListContext.forward ~step:(j_alt - pos) alternatives with
      | _, [] -> raise Bad_address
      | ctx, t' :: l -> (Top ((ctx, l), j_alt, suspended_c), t'))
    | Zip infos when infos.alt_num = j_alt -> (z,t)
    | Zip infos ->
      ((* first put back t into the alternatives *)
        let alternatives = ListContext.forward_insert t infos.alternatives in
        match ListContext.forward ~step:(j_alt - infos.alt_num) alternatives with
        | _, [] -> raise Bad_address
        | ctx, t' :: l -> (Zip {infos with alternatives = (ctx, l); alt_num = j_alt},
                           t'))
      
  (** [move_to add (z,t)] returns [(z',t'), f] where [(z,t)] and
      [(z',t')] are focused_forest describing the same forest [f0] and
      such that the (absolute, in the right order, i.e. reverse of the
      forest address of z') address of [f] in [f0] is [add] and such
      that the forest tree [t'] is one of the forest tree of [f]. *)
  let rec move_to add (z, t) =
    match add with
    | [] ->
      (* we need to extract [f] from the current forest described by z *)
      (match z with
       | Top ((ctx, l), _, _) ->
         (z, t), ListContext.zip_up ctx (t::l)
       | Zip {alternatives=(ctx, l);_} -> (z, t), ListContext.zip_up ctx (t::l))
    | (j_alt, i_child) :: tl ->
      let () = Log.debug (fun m -> m "Moving along (%d, %d)" j_alt i_child ) in
      (* we need to reach the [j_alt]-th alternative in [z], and then
         move (down) along the to the [i_child]-th *)
      let z', (Node (v, children) as _t') = focus_on_alt j_alt (z, t) in
      let siblings, ith_child = ListContext.nth_context i_child children in
      match ith_child with
      | Link_to _ ->
        failwith "Bug: Should not meet a Link_to on a move_to path"
      | Forest f ->
        let alternatives, focused_tree = ListContext.nth_context 1 f in
        move_to
          tl
          (Zip {label = v;
                children = siblings;
                alternatives;
                alt_num = 1;
                context = z';
                suspended_computation = None;
                address = extend_address ~from:(get_forest_address z') (j_alt, i_child)},
           focused_tree)
  and forest_at (back, addr) (z, t) =
    if back < 0 then
      failwith "Bug: looking for a forest with a negative back parameter"
    else
      match z with
      | _ when back = 0 ->
        move_to addr (z,t)
      (* back > 0 *)
      | Top _ ->
        raise Bad_address
      | Zip _ ->
        forest_at (back-1, addr) (forest_up_absolute z t)

  (** [visit_forest forest] consider each of the element of the forest
     [forest] the focused element of the shared forest context (and,
     accordingly, the generated tree, so far limited to this node, as
     the focused parsing tree corresponding to the zipper and applies
     [make_forest] to it.*)
  let visit_forest ~make_context ~weight ~parsing_context:zipper forest resumptions =
    (* [is_current_computation] is a function used when sorting is not
       regular to (randomly) pick up one of the alternative and
       continue the computation with it instead of using swapping. *)
    let is_current_computation, _index =
      match Resumptions.regular_sorting resumptions with
      | true -> (fun _ _ _ -> None), None
      | false ->
        let index = 1+ Random.int (List.length forest) in
        (fun i elt w -> if i = index then Some (elt, w) else None), Some index in
    let _, new_resumptions, current_computation =
      ListContext.fold
        (ListContext.empty, forest)
        (fun (alternatives:'a forest_tree focused_list) (i, acc, cur_comp) ->
           match alternatives with
           | _, [] -> i, acc, cur_comp
           | alt_ctx, elt :: tl ->
             let new_parsing_tree = Tree.Node (label elt, []) in
             let new_context = make_context ~focus_position:i ~focused_alt:(alt_ctx,tl) in
             let computation = { f_forest = (new_context, elt);
                                 f_tree = (zipper, new_parsing_tree)} in
             (match is_current_computation i computation weight, cur_comp with
              | None, _ ->
                (* if the current focused alternative is not the
                   selected one, just add the corresponding
                   computation to the resumptions *)
                (i+1,
                 Resumptions.(extend_resumptions
                                ~computation
                                ~weight
                                acc),
                 cur_comp)
              | Some cur_comp, _ ->
                (* otherwise, keep it apart *)
                (i+1, acc, Some cur_comp)))
        (1, resumptions, None) in
    let s, w, res =
      Resumptions.swap ?current_computation new_resumptions in
    s, w, res
  
  (** [down (forest_ctx, forest_tree) (z,t)] continues building [t] by
     going down along [forest_tree] and picking one of the
     alternatives of the first child of [forest_tree]. *)
  let down (z, t) (zipper, Tree.Node (v', children)) weight resumptions =
    let () = assert (children = [] ) in (* because the tree is being
                                           built, its children are
                                           still unknown when moving
                                           down *)
    match t with
    | Node (_, []) -> raise (Move_failure Down)
    | Node (_, (Forest []) :: _) -> raise Not_well_defined
    | Node (v, (Link_to (back, add)) :: tl) ->
      let () = assert (v =v') in
      let (z', _t'), f = forest_at (back - 1, add) (z, t) in
      let suspended_computation = Some ((z, t),
                                        {
                                          siblings = (ListContext.empty, tl);
                                          parent_label = v;
                                          focus = Link_to (back, add);
                                        }) in
      let make_new_context ~focus_position ~focused_alt =
        match z' with
        | Top _ -> Top (focused_alt,
                        focus_position,
                        suspended_computation)
        | Zip infos -> Zip
                         {label = v ;
                          children = infos.children ;
                          alternatives = focused_alt ;
                          alt_num = focus_position ;
                          context = infos.context ;
                          suspended_computation ;
                          address = infos.address;
                         } in
      let parsing_context = TreeContext.Zipper (v, (ListContext.empty, []), zipper) in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.down weight v)
        ~parsing_context
        f
        resumptions
    | Node (v, (Forest l_f) :: tl) -> 
      let () = assert (v =v') in
      let make_new_context ~focus_position ~focused_alt =
        Zip {label = v;
             children = ListContext.empty, tl ;
             alternatives = focused_alt ;
             alt_num = focus_position ;
             context = z ;
             suspended_computation = None;
             address = extend_address ~from:(get_forest_address z) (alt_position z,1);
            } in
      let parsing_context = TreeContext.Zipper (v, (ListContext.empty, []), zipper) in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.down weight v)
        ~parsing_context
        l_f
        resumptions

  (* the function to get up in the context from a focused shared
     forest. In case the current context has a suspended computation,
     the latter should be returned *)
  let focused_forest_up = function
    | Top _, _ -> failwith "Bug: cannot move up in forest context"
    | Zip { suspended_computation = Some ((ctx, t), {parent_label; _}); _ }, _ ->
      let () = assert (parent_label = label t) in
      (ctx, t)
    | Zip ({alternatives = (p, n);
            children = elders, youngers;
            suspended_computation = None;
            _ } as infos), forest_tree ->
      infos.context,
      Node (infos.label,ListContext.zip_up elders ((Forest (ListContext.zip_up p (forest_tree :: n)) ):: youngers))

  (** [right add] returns the address of the right sibling from the
     address [add] *)
  let right_address = function
    | [] -> failwith "Bug: not a child, so no right sibling address can be provided"
    | (alt_i, child_j)::tl -> (alt_i, child_j +1) :: tl

  (** [right (forest_ctx, forest_tree) (z,t)] continues building [t]
     by going right from [forest_tree] in the context [forest_ctx] and
     picking one of the alternatives of the child on its
     right. Possibly needs to use suspended computation in case
     [forest_tree] was reached after a [Link_to]. *)
   let right (z, foc_t) (zipper, parsing_tree) weight resumptions =
    match z with
    | Top (_, _, None) -> raise (Move_failure Right)

    (* Right from a Top context, but there is a suspended computation
       but no right sibling *)
    | Top (_, _, Some (_, {siblings = (_, []); _})) -> raise (Move_failure Right)

    (* Right from a Top context, but there is a suspended computation
       with an actual forest for the next child *)
    | Top (_, _, Some ((z_ctx, up_tree), {siblings = (l, (Forest l_f) :: r); focus = focused_child; parent_label})) ->
      let () = assert ( up_tree = Node (parent_label, ListContext.zip_up l (focused_child :: (Forest l_f) :: r))) in
      let make_new_context ~focus_position ~focused_alt =
        Zip {label = parent_label;
             children = ListContext.push focused_child l, r;
             alternatives = focused_alt ;
             alt_num = focus_position ;
             suspended_computation = None;
             context = z_ctx;
             address = extend_address ~from:(get_forest_address z_ctx) (alt_position z_ctx, 2 + ListContext.size l)
            } in
      let parsing_context =
        match zipper with
        | TreeContext.Top -> raise (Move_failure Right)
        | TreeContext.Zipper (v, (elders, []), z') ->
          TreeContext.Zipper (v, (ListContext.push parsing_tree elders, []), z')
        | TreeContext.Zipper (_, (_, _ :: _), _) ->
          failwith "Bug: while moving to right, younger siblings \
                    should still be unkown" in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.right weight parent_label)
        ~parsing_context
        l_f
        resumptions


    (* Right from a Top context, but there is a suspended computation
       with a Link_to for the next child *)
    | Top (_, _, Some ((z_ctx, up_tree), {siblings = (l, (Link_to (back, add)) :: r); focus = focused_child; parent_label})) ->
      let () = assert ( up_tree = Node (parent_label, ListContext.zip_up l (focused_child :: (Link_to (back, add)) :: r))) in
      let (new_z, _), l_f = forest_at (back - 1, add) (z_ctx, up_tree) in
      (* Here, back-1 because we'are starting from the upper tree *)
      let suspended_comp = (z_ctx, up_tree),
                           {siblings = (ListContext.push focused_child l, r);
                            focus = Link_to (back, add);
                            parent_label} in
      let make_new_context ~focus_position ~focused_alt =
        match new_z with
        | Top _ -> Top (focused_alt,
                        focus_position,
                        Some suspended_comp)
        | Zip new_z_infos ->
          Zip {label = parent_label;
               children = new_z_infos.children;
               alternatives = focused_alt ;
               alt_num = focus_position ;
               suspended_computation = Some suspended_comp;
               context = new_z_infos.context;
               address = get_forest_address new_z
              } in
      let parsing_context =
        match zipper with
        | TreeContext.Top -> raise (Move_failure Right)
        | TreeContext.Zipper (v, (elders, []), z') ->
          TreeContext.Zipper (v, (ListContext.push parsing_tree elders, []), z')
        | TreeContext.Zipper (_, (_, _ :: _), _) ->
          failwith "Bug: while moving to right, younger siblings \
                    should still be unkown" in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.right weight parent_label)
        ~parsing_context
        l_f
        resumptions        

    (* Right from a Zip context, there is no right child *)
    | Zip {children = (_, []) ; suspended_computation = None; _} ->
      raise (Move_failure Right)

    (* Right from a Zip context with a suspended computation, but
       there is no right child in the suspended computation *)
    | Zip {suspended_computation = Some (_, { siblings = (_, []) ; _ }); _} ->
      raise (Move_failure Right)

    (* Right from a Zip context with no suspended computation, and the
       right child is an actual forest *)
    | Zip ({children = (l, (Forest l_f) :: r);
            alternatives = (p, n);
            suspended_computation = None;
            _} as infos) ->
      (* The node is a regular forest, and there is no suspended
         computation. Easiest case! *)
      let make_new_context ~focus_position ~focused_alt =
        Zip {
          label = infos.label;
          children = ListContext.(push (Forest (zip_up p (foc_t:: n))) l), r ;
          alternatives = focused_alt ;
          alt_num = focus_position ;
          context = infos.context ;
          suspended_computation = None;
          address = right_address infos.address
        } in
      let parsing_context =
        match zipper with
        | TreeContext.Top -> raise (Move_failure Right)
        | TreeContext.Zipper (v, (elders, []), z') ->
          TreeContext.Zipper (v, (ListContext.push parsing_tree elders, []), z')
        | TreeContext.Zipper (_, (_, _ :: _), _) ->
          failwith "Bug: while moving to right, younger siblings \
                    should still be unkown" in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.right weight infos.label)
        ~parsing_context
        l_f
        resumptions
        
    (* Right from a Zip context with no suspended computation, and the
       right child is Link_to *)
    | Zip ({children = (l, (Link_to (back, add)) :: r);
            alternatives = (p, n);
            suspended_computation = None ;
            _} as infos) ->
      (* The node is a Link_to, and there is no suspended
         computation. *)
      let (new_z, _), l_f = forest_at (back, add) (z, foc_t) in
      let parent_context, parent_forest_tree = focused_forest_up (z, foc_t) in
      let suspended_computation =
        Some ((parent_context, parent_forest_tree),
              (* We set the suspended computation to the parent of the
                 current node, i.e., the same as its elder sibling
                 [foc_t] *)
              {siblings = (ListContext.(push (Forest (zip_up p (foc_t:: n))) l), r);
               focus = Link_to (back, add);
               parent_label = label parent_forest_tree;
              }
             ) in
      let make_new_context ~focus_position ~focused_alt =
        match new_z with
        | Top _ -> Top (focused_alt, focus_position, suspended_computation)
        | Zip new_infos ->
          Zip {label = label parent_forest_tree;
               children = new_infos.children;
               (* we change the siblings to fit the new context *)
               alternatives = focused_alt ;
               alt_num = focus_position ;
               suspended_computation ;
               (* From new_context, when asking to go up, should reach
                  (z, foc_t).
                  
                  The actual siblings are kept in memory.*)
               context = new_infos.context ;
               address = get_forest_address new_z;
              } in
      let parsing_context =
        match zipper with
        | TreeContext.Top -> raise (Move_failure Right)
        | TreeContext.Zipper (v, (elders, []), z') ->
          TreeContext.Zipper (v, (ListContext.push parsing_tree elders, []), z')
        | TreeContext.Zipper (_, (_, _ :: _), _) ->
          failwith "Bug: while moving to right, younger siblings \
                    should still be unkown" in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.right weight infos.label)
        ~parsing_context
        l_f
        resumptions            

    (* Right from a Zip context with a suspended computation, and the
       right child is Link_to *)
    | Zip ({label = _;
            suspended_computation = Some (state, {siblings = (l, (Link_to (back, add)) :: r);
                                                  focus = focused_child; parent_label}) ;
            _}) ->
      (* The node is a Link_to, and there is a suspended computation.

         We use the siblings of the suspended_computation.  *)
      let (new_z, _), l_f = forest_at (back - 1, add) state in
      (* Here, back-1 because we'are starting from the upper tree *) 
      let suspended_computation = Some (state,
                                        {siblings = (ListContext.push focused_child l,r);
                                         parent_label ;
                                         focus = Link_to (back, add);
                                        }) in
      let make_new_context ~focus_position ~focused_alt =
        match new_z with
        | Top _ -> Top (focused_alt, focus_position, suspended_computation)
        | Zip new_infos ->
          Zip {label = parent_label;
               children = new_infos.children ;
               (* we change the siblings to fit the new context *)
               alternatives = focused_alt ;
               alt_num = focus_position ;
               suspended_computation ;
               (* From new_context, when asking to go up, should reach
                  (z, foc_t).

                  The actual siblings are kept in memory.*)
               context = new_infos.context ;
               address = get_forest_address new_z;
              } in
      let parsing_context =
        match zipper with
        | TreeContext.Top -> raise (Move_failure Right)
        | TreeContext.Zipper (v, (elders, []), z') ->
          TreeContext.Zipper (v, (ListContext.push parsing_tree elders, []), z')
        | TreeContext.Zipper (_, (_, _ :: _), _) ->
          failwith "Bug: while moving to right, younger siblings \
                    should still be unkown" in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.right weight parent_label)
        ~parsing_context
        l_f
        resumptions        

    (* Right from a Zip context with a suspended computation, and the
       right child is an actual forest *)
    | Zip ({label = _v;
            children = _;
            alternatives = _;
            suspended_computation = Some ((z_ctx, _up_tree), {parent_label;
                                                             siblings =(l, (Forest l_f) :: r); focus = focused_child}) ;
            _}) ->
      (* The next child is a regular forest *)
      let make_new_context ~focus_position ~focused_alt =
        Zip {label = parent_label;
             children = ListContext.push focused_child l, r;
             alternatives = focused_alt ;
             alt_num = focus_position ;
             suspended_computation = None;
             context = z_ctx;
             address = extend_address ~from:(get_forest_address z_ctx) (alt_position z_ctx, 2 + ListContext.size l)
            } in
      let parsing_context =
        match zipper with
        | TreeContext.Top -> raise (Move_failure Right)
        | TreeContext.Zipper (v, (elders, []), z') ->
          TreeContext.Zipper (v, (ListContext.push parsing_tree elders, []), z')
        | TreeContext.Zipper (_, (_, _ :: _), _) ->
          failwith "Bug: while moving to right, younger siblings \
                    should still be unkown" in
      visit_forest
        ~make_context:make_new_context
        ~weight:(W.right weight parent_label)
        ~parsing_context
        l_f
        resumptions        

   (** [up (forest_ctx, forest_tree) (z,t)] continues building [t] by
      going up from [(forest_ctx, forest_tree)]. Possibly needs to use
      suspended computation in case [forest_tree] was reached after a
      [Link_to]. *)
   let up (z, t) (zipper, parsing_tree) weight =
     match (z, zipper) with
     | Top (_, _, None), TreeContext.Top -> raise (Move_failure Up)
     | Top (_, _, None), TreeContext.Zipper _ ->
       failwith "Bug: both forest and tree context should be top. Only \
                 the tree context is and there is a suspended \
                 computation at Top in the context."
     | Top (_, _, Some _), TreeContext.Top ->
       failwith "Bug: both forest and tree context should be top. Only \
                 the tree context is and there is a suspended \
                 computation at Top in the context."
     | _, TreeContext.Top ->
       failwith "Bug: both forest and tree context should be top. Only \
                 the tree context is."
     | Top (_, _, Some (focused_forest, {parent_label;_})),
       TreeContext.Zipper (v', _, _)  ->
       let () = assert (parent_label = label (snd focused_forest)) in
       (focused_forest, TreeContext.up (zipper, parsing_tree), W.up weight v')
     | Zip ({suspended_computation = None;
             alternatives = (p, n);
             children = elders, youngers;
             _} as infos), TreeContext.Zipper (v', _, _)  ->
       let () = assert (infos.label = v') in
       let forest_tree = Node (infos.label,
                               ListContext.(zip_up elders ((Forest (zip_up p (t::n))) :: youngers))) in
       ((infos.context, forest_tree), TreeContext.up (zipper, parsing_tree), W.up weight infos.label)
     | Zip ({suspended_computation = Some (focused_forest, {parent_label;_}); _}), TreeContext.Zipper (_, _, _)  ->
       let () = assert (parent_label = label (snd focused_forest)) in
       (focused_forest, TreeContext.up (zipper, parsing_tree), W.up weight parent_label)

   (** [close_forest_context_up f_forest f_tree weight resumptions]
      goes up until a right move is possible (because of swapping, the
      new context might not be focusing at the same place *)
  let rec close_forest_context_up f_forest f_tree weight resumptions =
    try
      let f_forest, f_tree, weight = up f_forest f_tree weight in
      try right f_forest f_tree weight resumptions with
      | Move_failure Right ->
        (try close_forest_context_up f_forest f_tree weight resumptions with
         | Move_failure Up -> ({ f_forest; f_tree}, weight, resumptions))
    with
    | Move_failure Up -> ({f_forest; f_tree}, weight, resumptions)

  (* alternatative code for the same function *)
  let rec close_forest_context_up_2 f_forest f_tree weight resumptions =
    match up f_forest f_tree weight with
    | f_forest, f_tree, weight ->
      (match right f_forest f_tree weight resumptions with
       | {f_forest; f_tree}, weight, resumptions -> ({f_forest; f_tree}, weight, resumptions)
       | exception (Move_failure Right) ->
         (match close_forest_context_up_2 f_forest f_tree weight resumptions with
          | {f_forest; f_tree}, weight, resumptions -> ({f_forest; f_tree}, weight, resumptions)
          | exception (Move_failure Up) -> ({ f_forest; f_tree}, weight, resumptions))
      )
    | exception (Move_failure Up) -> ({f_forest; f_tree}, weight, resumptions) [@@warning "-32"]
                                     
  
  (** [build_tree_aux f_forest f_tree weight resumptions] builds a
     parsing tree (together with its context, which, at the end,
     should be Top) by walking through [f_forest] in the context of
     the focused tree [f_tree]. *)
  let rec build_tree_aux f_forest f_tree weight resumptions =
    try
      (* first try to go down *)
    let {f_forest; f_tree}, weight, resumptions =
      down f_forest f_tree weight resumptions in
    (* and build the tree from there *)
    build_tree_aux f_forest f_tree weight resumptions
    with
    | Move_failure Down ->
      (try
         (* if not possible to further go down, tries to move right *)
         let {f_forest; f_tree}, weight, resumptions = right f_forest f_tree weight resumptions in
         build_tree_aux f_forest f_tree weight resumptions
       with
       | Move_failure Right ->
         (* if not possible to move right, moves up until moving right is again possible *)
         match close_forest_context_up f_forest f_tree weight resumptions with
         | ({f_forest = (Top (_, _, None), _);
             f_tree = (TreeContext.Top,_)}, _, _) as res ->
           (* if top is reached and there is no suspended computation,
              we're done *)
           res
         | { f_forest = ((Top (_, _, Some _), _) as l_f_forest);
             f_tree = ((TreeContext.Zipper _, _) as l_f_tree)}, weight', resumptions' ->
           (* if top is reached and there is a suspended computation,
              we need to continue (the last move was right) with the
              new child *)
           build_tree_aux l_f_forest l_f_tree weight' resumptions'
         | { f_forest = ((Zip _, _) as l_f_forest);
             f_tree = ((TreeContext.Zipper _, _) as l_f_tree)}, weight', resumptions' ->
           (* if Top was not reached, just continue (the last move was
              right) with the new child! *)
           build_tree_aux l_f_forest l_f_tree weight' resumptions'
         | _ -> failwith "Bug: not representing the same tree")

  let build_tree f_forest f_tree weight resumptions =
    build_tree_aux f_forest f_tree weight resumptions
      
  let resume res =
    if Resumptions.is_empty res then
      None, res
    else
      let {f_forest; f_tree}, weight, resumptions =
        Resumptions.swap res in
      let {f_forest =_; f_tree= (_, tree)}, weight, res' =
        build_tree f_forest f_tree weight resumptions in
      (Some (tree, weight), res')
      
  let rec pp_trees pp fmt resumptions  =
    match resume resumptions with
    | None, _ -> ()
    | Some (t, weight), new_resumptions ->
      let () = Format.fprintf fmt "Current size: %a" pp_weight weight in
      let () = Tree.pp pp fmt t in
      pp_trees pp fmt new_resumptions
        
  let rec pp_forest ppf fmt forest =
    Format.fprintf
      fmt
      "@[%d alternatives:@[<v2>@,%a@]@]"
      (List.length forest)
      (Utils.pp_list_i ~sep:"@," (fun fmt (i,t) -> Format.fprintf fmt "%a :@[@ %a@]" Utils.red_pp (Printf.sprintf ">> Alt %d" i) (pp_raw_tree ppf) t))
      forest
  and pp_raw_tree ppf fmt tree =
    match tree with
    | Node (label, []) ->
      Format.fprintf
        fmt
        "@[%a@]"
        ppf
        label    
    | Node (label, children) ->
      Format.fprintf
        fmt
        "@[<v>%a@ @[<v>%a@]@]"
        ppf
        label
        (pp_children ppf)
        children
  and pp_children ppf fmt children =
    Utils.pp_list_i
      ~sep:"@,"
      (*      ~terminal:"@," *)
      (fun fmt (i, node) ->
         match node with
         | Link_to rpath -> Format.fprintf fmt "@[-- %a: Link to %a@]" Utils.blue_pp (Printf.sprintf "child %d" i) pp_path rpath
         | Forest f ->
           Format.fprintf
             fmt
             "@[-- %a: forest with @[%a@]@]"
             Utils.blue_pp
             (Printf.sprintf "child %d" i)
             (pp_forest ppf)
             f)
      fmt
      children

  let init ~alt_max ppf alt_trees =
    let _, resumptions =
      ListContext.fold
        (ListContext.empty, alt_trees)
        (fun (ctx, l) (i, acc) ->
           match l with
           | [] -> i, acc
           | (Node (v, _) as t) :: tl ->
             let state = {f_forest = (Top ((ctx, tl), i, None), t);
                          f_tree = TreeContext.Top, Tree.Node (v, [])} in
             let () = Log.debug (fun m -> m "When initiating the shared forest, I found at position %d the forest_tree @[%a@]" i (pp_raw_tree ppf) t) in
             i + 1,
             Resumptions.(extend_resumptions
                            ~weight:W.init
                            ~computation:state
                            acc))
        (1, Resumptions.empty ~alt_max) in
    resumptions
      
  
  
  
end


module SharedForest = Make (Weight.Weight_as_Depth_and_Size)