Skip to content
Snippets Groups Projects
Select Git revision
  • 097f297f513c0eef6d7646e4cc0ca587b5c5f105
  • master default protected
2 results

robinsonCCNP.ml

Blame
  • robinsonCCNP.ml 5.40 KiB
    open! DataStruct
    open DissimilarityLib 
    
    module IMap = Map.Make(Int)
    
    module Queue = FQueue 
    
    
    
    type side = Right | Left
    
    
    
    module Make = 
      functor (D: sig type t val d : t -> t -> int end) -> 
      struct 
        
    
        let refine q set = 
          let insert tree element =
            let dist = D.d q element in 
            let previous_list = IMap.find_opt dist tree |> Option.value ~default:[] in 
            IMap.add dist (List.cons element previous_list) tree
          in  
          set 
          |> List.fold_left insert IMap.empty
          |> IMap.to_seq
          |> Seq.map snd
          |> List.of_seq
    
    
        let reverse_short_distance p q subsets = 
          let is_close = function
            | x::_ -> D.d q x <= D.d p q
            | [] -> false
          in
          let (close_sets,far_sets) =
            MoreList.take_while ~f:is_close subsets 
          in
          List.rev_append close_sets far_sets 
            
    
          
        let rec recursive_refine p (inners, set, outers) =
          match inners, outers with
          | [], [] -> [set]
          | _ when List.length set <= 1 -> [set]
          | (q::ins,outs) 
          | ([] as ins, q::outs) -> 
             let subsets = refine q set in 
             let subsets' = 
               if inners = [] then 
                 reverse_short_distance p q subsets 
               else 
                 subsets 
             in
             let recurse (subset, previous_subsets, next_subsets) =
               recursive_refine p 
                 (List.rev_append (List.flatten previous_subsets) ins,
                  subset,
                  List.rev_append (List.flatten next_subsets) outs
                 ) 
             in
             subsets' 
             |> MoreList.extend
             |> List.map recurse  
             |> List.flatten 
             
             
        exception Not_Robinson
    
    
        let separate_if_separable p = function
          | [] -> []
          | (x_min::_) as copoint ->  
             let x_max = List.fold_left (fun _ last -> last) x_min copoint in 
             let diameter = D.d x_min x_max in 
             let delta = D.d x_min p in 
             if diameter <= delta then [(x_min,copoint)]
             else 
               let rec split prefix = function
                 | x::y::suffix when D.d x_min x <= delta && D.d y x_max <= delta && D.d x y >= delta ->
                    [ (x_min, x::prefix); (x_max, y::suffix) ]
                 | x::suffix -> split (x::prefix) suffix
                 | [] -> raise Not_Robinson
               in 
               split [] copoint
    
    
    
        type representant = D.t * D.t list
        type dispatch = {
            lefts : representant list;
            rights : representant list;
            pivots : (representant * side) Queue.t; 
            skipped : representant list
          }
        let insert_to_left element dispatch =
          { dispatch with 
           lefts = element::dispatch.lefts;
           pivots = Queue.enqueue dispatch.pivots (element,Left)
          }
        let insert_to_right element dispatch =
          { dispatch with
            rights = element::dispatch.rights;
            pivots = Queue.enqueue dispatch.pivots (element,Right)
          }
        let skip element dispatch = 
          { dispatch with skipped = element :: dispatch.skipped }
    
        let move_skipped_to_left dispatch = 
          { dispatch with  skipped = [] }
          |> List.fold_right insert_to_left dispatch.skipped
        let move_skipped_to_right dispatch =
          { dispatch with skipped = [] }
          |> List.fold_right insert_to_right dispatch.skipped 
        let reverse_skipped dispatch =
          { dispatch with skipped = List.rev dispatch.skipped }
    
        let get_next_pivot dispatch = 
          match Queue.view dispatch.pivots, dispatch.skipped with
          | Some ((q,side), pivots),_ -> (q, side, { dispatch with pivots })
          | None, q::skipped -> (q, Right, insert_to_right q { dispatch with skipped })
          | None, [] -> assert false
          
        let rec repeat_until ~condition ~f start = 
          if condition start then start
          else repeat_until ~condition ~f (f start)
    
        let sort_by_bipartition p set = 
          let bipart_using_pivot (q, q_side, dispatch) = 
            List.fold_left (fun dispatch x ->
                if D.d (fst x) (fst q) = D.d p (fst q) then skip x dispatch
                else if (D.d (fst x) (fst q) < D.d p (fst q)) = (q_side = Right) then 
                  dispatch |> move_skipped_to_left |> insert_to_right x
                else 
                  dispatch |> move_skipped_to_right |> insert_to_left x
              )
              { dispatch with skipped = [] }
              dispatch.skipped
          in
          let { lefts; rights; _ } =
            repeat_until
              ~condition:(fun dispatch -> dispatch.skipped = [])
              ~f:(fun dispatch ->
                get_next_pivot dispatch
                |> bipart_using_pivot 
                |> reverse_skipped            
              )
              { lefts = []; rights = []; pivots = Queue.empty; skipped = List.rev set }
          in
          List.rev_append (List.map snd lefts) ([p] :: List.map snd rights)
          |> List.flatten
    
    
          let rec find_compatible_order = function
            | [] -> []
            | p::set -> 
               let copoints = recursive_refine p ([p],set,[]) in 
               copoints 
               |> List.map find_compatible_order
               |> List.concat_map (separate_if_separable p)
               |> sort_by_bipartition p 
               
      end
    
    
    let find_compatible_order (type elt) diss = 
      let open Dissimilarity in 
      let module D = 
        struct 
          type t = elt 
          let d = diss.d 
        end 
      in 
      let module M = Make(D) in 
      try
        let order = M.find_compatible_order diss.elements in 
        if Dissimilarity.is_compatible_order diss order then Some order
        else None 
      with 
      | M.Not_Robinson -> None