Select Git revision
robinsonCCNP.ml
-
Guyslain Naves authoredGuyslain Naves authored
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