Skip to content
Snippets Groups Projects
Select Git revision
  • e34fa81642dd3a6171dd9b07e228acbed6e6050e
  • 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