Source file new_weight.ml

module type Weight_sig =
sig
  type w
  val pp : Format.formatter -> w -> unit
  val init : w

  val is_better : w -> w -> bool
  (** [is better w1 w2] returns [true] if [w1] is strictly better
      than [w2] *)

  val is_equal : w -> w -> bool
  (** [is better w1 w2] returns [true] if [w1=w2] *)
    
  val update : current:w -> w -> w
  val up : w -> 'a -> w 
  val down : w -> 'a -> w
  val right : w -> 'a -> w
  module WMap : Map.S with type key = w
  val optimum : 'a WMap.t -> ( w * 'a ) option
end

module Weight_as_Depth =
struct
  type w = int
  let pp fmt w = Format.fprintf fmt "depth = %d" w
  let init = 1
  let is_better a b = a < b
  let is_equal a b = a=b
  let update ~current w = if is_better current w then current else w
  let up w _ = w - 1 
  let down w _ = w + 1
  let right w _ = w
  (*  let left w _ = w *)
  module WMap = Utils.IntMap
  let optimum = WMap.min_binding_opt
end

module Weight_as_Depth_and_Size =
struct
  type w = { current : int; max : int; size : int }
  let pp fmt w = Format.fprintf fmt "depth = %d, size = %d" w.max w.size
  let init = { current = 1; max = 1; size = 1 }
  let is_better w w' =
    match w.max - w'.max with
    | 0 ->
      (match w.size - w'.size with
       | 0 -> w.current < w'.current
       | i when i < 0 -> true
       | _ -> false)
    | i when i < 0 -> true
    | _ -> false
  let is_equal w w' = w = w'
  let update ~current w = if is_better current w then current else w
  let up w _ = { w with current = w.current - 1 }
  let down w  _ =
    let current = w.current + 1 in
    { current  ; size = w.size + 1; max = max current w.max }
  let right w _ = { w with size = w.size + 1 }
  module WMap = Map.Make (
    struct
      type t = w
      let compare w w' =
        match w.max - w'.max with
        | 0 ->
          (match w.size - w'.size with
           | 0 -> w.current -w'.current
           | r -> r)
        | r -> r
    end)
  let optimum = WMap.min_binding_opt
end

module MapMake(W:Weight_sig)=
struct
  type 'a t = (W.w * ('a list W.WMap.t)) option
  let empty = None
    
  let pp fmt = function
    | None -> Format.fprintf fmt "None"
    | Some (w, map) ->
      let pp_map fmt m =
        W.WMap.iter
          (fun k v ->
             Format.fprintf
               fmt
               "@[<hov>Bindings:@[ %a -> list of length %d@]@]@ "
               W.pp
               k
               (List.length v))
          m in
      Format.fprintf
        fmt
        "@[Optimum set to: %a@ @[<v> @[%a@]@]@]"
        W.pp
        w
        pp_map
        map
        
  let rec remove_empty_bindings map = 
    match W.optimum map with
    | None -> None
    | Some (w', []) -> remove_empty_bindings (W.WMap.remove w' map)
    | Some (w', _) -> Some (w', map)
                        
  let add weight state map =
    match map with
    | None -> Some (weight, W.WMap.add weight [state] W.WMap.empty)
    | Some (opt, map) when W.is_better weight opt ->
      (* weight is strictly better than opt, hence no binding for
           weight is present *)
      Some (weight, W.WMap.add weight [state] map)
    | Some (opt, map) when W.is_equal weight opt ->
      (* weight is opt *)
      let states = W.WMap.find opt map in
      (* Shouldn't raise a Not_found exception *)
      Some (opt, W.WMap.add opt (state :: states) map)
    | Some (opt, map) ->
      (* opt is trictly better than weight *)
      let states =
        match W.WMap.find_opt weight map with
        | None -> [state]
        | Some previous_states -> state :: previous_states in
      Some (opt, W.WMap.add weight states map)
        
  let pop_optimum m =
    match m with
    | None -> None
    | Some (w_opt, map) ->
      (match W.optimum map with
       | None -> failwith "Bug: optimum is set for an empty map"
       | Some (w', _) when w' <> w_opt -> failwith "Bug: optimum is not correctly set"
       | Some (_ , [] ) -> failwith "Bug: Should not occurr"
       | Some (w', [s]) ->
         Some (s, w', remove_empty_bindings (W.WMap.remove w' map))
       | Some (w', s :: states) ->
         Some (s, w', Some (w', W.WMap.add w' states map)))
      

  

end