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