Source file weight.ml

module type Weight =
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 up : w -> 'a -> w 
  val down : w -> 'a -> w
  val right : w -> 'a -> w
end


module type Weight_sig =
sig
  include Weight
  module WMap : 
  sig
    type 'a t
    val empty : 'a t
    val optimum : 'a t -> w option
    val pp : Format.formatter -> 'a t -> unit
    val add : w -> 'a -> 'a t -> 'a t
    val pop_optimum : 'a t -> ('a * w * 'a t) option
  end
end

module MapMake(W:sig include Weight val compare : w -> w -> int end)=
struct
  type w = W.w
  let pp = W.pp
  let init = W.init
  let is_better = W.is_better
  let is_equal = W.is_equal
  let up = W.up
  let down = W.down
  let right = W.right
                
  module LocalMap = Map.Make (struct type t = W.w let compare = W.compare end)

  module WMap =
    struct
      type 'a t = (W.w * ('a list LocalMap.t)) option
      let empty = None
        
      let optimum = function
        | None -> None
        | Some (w, _) -> Some w
                           
      let pp fmt = function
        | None -> Format.fprintf fmt "None"
        | Some (w, map) ->
          let pp_map fmt m =
            LocalMap.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 LocalMap.min_binding_opt map with
        | None -> None
        | Some (w', []) -> remove_empty_bindings (LocalMap.remove w' map)
        | Some (w', _) -> Some (w', map)
                            
      let add weight state map =
        match map with
        | None -> Some (weight, LocalMap.add weight [state] LocalMap.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, LocalMap.add weight [state] map)
        | Some (opt, map) when W.is_equal weight opt ->
          (* weight is opt *)
          let states = LocalMap.find opt map in
          (* Shouldn't raise a Not_found exception *)
          Some (opt, LocalMap.add opt (state :: states) map)
        | Some (opt, map) ->
          (* opt is trictly better than weight *)
          let states =
            match LocalMap.find_opt weight map with
            | None -> [state]
            | Some previous_states -> state :: previous_states in
          Some (opt, LocalMap.add weight states map)
            
      let pop_optimum m =
        match m with
        | None -> None
        | Some (w_opt, map) ->
          (match LocalMap.min_binding_opt 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 (LocalMap.remove w' map))
           | Some (w', s :: states) ->
             Some (s, w', Some (w', LocalMap.add w' states map)))
          
    end
end

module Weight_as_Depth_init =
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 up w _ = w - 1 
  let down w _ = w + 1
  let right w _ = w
  (*  let left w _ = w *)
  let compare a b = a - b
end

module Weight_as_Depth = MapMake (Weight_as_Depth_init)

module Weight_as_Depth_and_Size_init =
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 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 }
  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

module Weight_as_Depth_and_Size = MapMake (Weight_as_Depth_and_Size_init)