Initial commit

lib/pqtree/pqTree.mli

+type 'elt t =
+ | Leaf of 'elt
+ | P of 'elt t list 
+ | Q of 'elt t list 
+
+val length : 'elt t -> int 
+
+val enumerate_permutation : 'elt t -> 'elt list Seq.t 
+
+val count_permutations : 'elt t -> Big_int_Z.big_int
+
+val sample_permutation : 'elt t -> 'elt list 
+
+val sample_interval : 'elt t -> 'elt list
+
+val frontier : 'elt t -> 'elt list 
+
+val shrink : 'elt t -> 'elt t Seq.t
+
+val shuffle : 'elt t -> 'elt t 
+
+val is_well_formed : 'elt t -> bool
+
+module Skeleton :
+sig  
+  type skeleton = 
+    | Hole 
+    | HoledP of skeleton list 
+    | HoledQ of skeleton list 
+
+  val to_pqtree : skeleton -> int t
+end
+
+
+module type EnumerateSig = 
+sig 
+  type elt
+  include FeatCore.EnumSig.ENUM
+  val enumeration : elt t enum 
+end
+
+module MakeEnumerate : functor (RND : FeatCore.RandomSig.S) -> EnumerateSig with type elt = int 
+
+module Enum : EnumerateSig with type elt = int
+
+val sample : int -> int t 
+
+
+
+module type CanonicalSig = 
+  sig 
+    type elt 
+    val canonical : elt t -> elt t 
+    val compare : elt t -> elt t -> int 
+    val compare' : elt t -> elt t -> int 
+    type nonrec t = elt t 
+  end 
+
+
+module MakeCanonical : functor (C : Map.OrderedType) -> CanonicalSig with type elt = C.t 
+
+
+module type EltMap = 
+sig
+  type key 
+  type 'value t
+
+  val empty : 'value t
+  val add : key -> 'value -> 'value t -> 'value t
+  val find_opt : key -> 'value t -> 'value option 
+  val equal : ('value -> 'value -> bool) -> 'value t -> 'value t -> bool
+end
+
+
+module type CheckPermutationSig = 
+  sig
+    type elt 
+    type checker
+    val checker : elt t -> checker
+    val checks : checker -> elt list -> bool 
+    val contains_permutation : elt t -> elt list -> bool
+  end 
+
+module MakeCheckPermutation : functor(M : EltMap) -> CheckPermutationSig with type elt = M.key
+
+
+module type PrintableType = sig 
+  type t
+  val print : Format.formatter -> t -> unit
+end
+
+module MakePrinter : functor (Prt : PrintableType) -> PrintableType with type t = Prt.t t 
+          
+
+

lib/randomdissimilarity/dune

+(library
+ (name RandomDissimilarity)
+ (libraries DataStruct Combi PqTreeLib DissimilarityLib)
+ (instrumentation (backend landmarks))
+)

lib/randomdissimilarity/fromModel.ml

+open DissimilarityLib
+
+let from_points_in_rectangle ~width ~height ~count =
+  let random_point _ = (Random.float width, Random.float height) in 
+  let dist (x1,y1) (x2,y2) = 
+    hypot (x1 -. x2) (y1 -. y2) |> ceil |> Float.to_int 
+  in 
+  let points = Array.init count random_point in 
+  let matrix = 
+    Array.init count 
+      (fun i -> 
+        Array.init count 
+          (fun j -> dist points.(i) points.(j))
+      )
+  in 
+  let elements = DataStruct.MoreList.range 0 (count-1) in 
+  let d i j = matrix.(i).(j) in 
+  Dissimilarity.({ elements; d})
+  

lib/randomdissimilarity/fromModel.mli

+open DissimilarityLib
+
+val from_points_in_rectangle : width:float -> height: float -> count:int -> int Dissimilarity.t 

lib/randomdissimilarity/fromPqtree.ml

+open PqTreeLib
+open DissimilarityLib 
+open PqTree 
+
+
+
+let from_pqtree pqtree =
+  let n = PqTree.length pqtree in 
+  let array = Array.init n (fun _ -> Array.make n (-1)) in 
+  for i = 0 to n-1 do array.(i).(i) <- 0 done; 
+  let set i j delta = 
+    array.(i).(j) <- delta;
+    array.(j).(i) <- delta;
+  in 
+  let (>>|) l f = List.iter f l in 
+  let annotate_p delta children =
+    DataStruct.MoreList.extend children >>| fun (child,_,post) ->
+    child >>| fun i -> 
+    post >>| fun child2 ->
+    child2 >>| fun j -> 
+    set i j delta 
+  in 
+  let annotate_q delta children =
+    DataStruct.MoreList.extend children >>| fun (child,_,post) -> 
+    child >>| fun i -> 
+    match post with 
+    | [] -> ();
+    | next_child::others -> 
+       (next_child >>| fun j -> set i j delta);
+       others >>| fun child2 -> 
+       child2 >>| fun j -> 
+       set i j (delta + 1)
+  in 
+  let rec go = function 
+    | Leaf i -> (0, [i]) 
+    | Q children -> 
+       let res = List.map go children in 
+       let frontiers = List.map snd res in 
+       let delta = 1 + List.fold_left max 0 (List.map fst res) in 
+       annotate_q delta frontiers;
+       (delta+1, List.concat frontiers) 
+    | P children -> 
+       let res = List.map go children in 
+       let frontiers = List.map snd res in 
+       let delta = 1 + List.fold_left max 0 (List.map fst res) in 
+       annotate_p delta frontiers;
+       (delta, List.concat frontiers) 
+  in 
+  ignore (go pqtree);
+  let elements = DataStruct.MoreList.range 0 (n-1) in
+  let d i j = array.(i).(j)  in
+  Dissimilarity.({ elements; d})
+          
+
+let uniform n = 
+  from_pqtree (PqTree.sample n)
+
+  
+
+
+let pqtree_from_intervals ~n ~k =
+  let pqtree = P (DataStruct.MoreList.range 0 (n-1) |> List.map (fun i -> Leaf i)) in 
+  let index i = i in 
+  let algo = ImperativeBL.get_algorithms pqtree index in
+  let insert_interval () =
+    algo.get () 
+    |> PqTree.sample_interval
+    |> algo.insert 
+    |> ignore
+  in 
+  for _ = 1 to k do insert_interval () done;
+  algo.get ()
+              
+
+let from_intervals ~n ~k = 
+  from_pqtree (pqtree_from_intervals ~n ~k)
+       
+

lib/randomdissimilarity/fromPqtree.mli

+open DissimilarityLib
+open PqTreeLib
+
+val from_pqtree : int PqTree.t -> int Dissimilarity.t 
+
+val uniform : int -> int Dissimilarity.t
+
+val pqtree_from_intervals : n:int -> k:int -> int PqTree.t 
+
+val from_intervals : n:int -> k:int -> int Dissimilarity.t 

lib/randomdissimilarity/incrementing.ml

+open DissimilarityLib 
+
+
+
+let random prng_state n = 
+  Random.set_state prng_state; 
+  let elements = DataStruct.MoreList.range 0 (n-1) in 
+  let array = Array.init n (fun _ -> Array.make n 0) in 
+  for i = 0 to n-2 do 
+    array.(i).(i+1) <- 1;
+    array.(i+1).(i) <- 1;
+  done;
+  for k = 2 to n-1 do 
+    for i = 0 to n-k-1 do
+      let j = i + k in 
+      array.(i).(j) <- 
+        max array.(i+1).(j) array.(i).(j-1)
+        + Random.int 2;
+      array.(j).(i) <- array.(i).(j);
+    done 
+  done;
+  let d i j = array.(i).(j) in 
+  Dissimilarity.({ elements; d}) 
+    
+   

lib/randomdissimilarity/incrementing.mli

+open DissimilarityLib 
+
+val random : Random.State.t -> int -> int Dissimilarity.t

lib/randomdissimilarity/toeplitz.ml

+open DissimilarityLib
+
+let toeplitz diagonals =
+  if diagonals = [] then 
+    invalid_arg "toeplitz []";
+  let coefs =
+    ((1,0) :: diagonals)
+    |> List.map (fun (l,coef) -> Array.make l coef) 
+    |> Array.concat
+  in 
+  let n = Array.length coefs in 
+  let elements = DataStruct.MoreList.range 0 (n-1) in 
+  let d i j =  coefs.(abs (i-j)) in
+  Dissimilarity.({ elements; d })
+
+
+let toeplitz012 ~n ~k = 
+  toeplitz [(k,1); (n-k-1,2)]
+
+
+

lib/randomdissimilarity/toeplitz.mli

+open DissimilarityLib
+
+val toeplitz : (int * int) list -> int Dissimilarity.t
+
+
+val toeplitz012 : n:int -> k:int -> int Dissimilarity.t

lib/robinson/dune

+(library
+ (name Recognition)
+ (libraries PqTreeLib DissimilarityLib)
+)

lib/robinson/pivotpair.ml

+open DissimilarityLib.Dissimilarity
+open PqTreeLib 
+
+
+let quadruples list = 
+  let rec go k = function 
+    | x1::( (x2::_) as tail) -> 
+       Seq.append 
+         (k (x1,x2) tail)
+         (go k tail)
+    | _ -> Seq.empty 
+  in
+  go
+    (fun xpair -> go (fun ypair _ -> Seq.return (xpair,ypair)))
+    list 
+
+let find_incompatible_triples diss order = 
+  order
+  |> quadruples
+  |> Seq.filter_map 
+       (fun ((x1,x2),(y1,y2)) -> 
+         if diss.d x1 y1 > diss.d x1 y2 then 
+           Some (x1, y1, y2)
+         else if diss.d x2 y2 > diss.d x1 y2 then 
+           Some (x1,x2,y2)
+         else None 
+       )
+    
+  
+let tripartition f set   =
+  let bigger,rest = List.partition (fun w -> f w > 0) set in 
+  let equal,smaller = List.partition (fun w -> f w = 0) rest in 
+  (bigger,equal,smaller)
+
+let main_seq list =
+  ( List.concat list ::
+      ( DataStruct.MoreList.strict_factors list 
+        |> List.map List.concat 
+      )
+  ) 
+  |> List.filter (function [_] -> false | _ -> true)
+
+
+let partition diss p q = 
+  let d = diss.d in 
+  let l, rest = List.partition (fun x -> d x q > max (d x p) (d p q)) diss.elements in 
+  let m, rest = List.partition (fun x -> d p q > max (d p x) (d x q)) rest in 
+  let r, rest = List.partition (fun x -> d p x > max (d p q) (d q x)) rest in 
+  let x, rest = List.partition (fun x -> x = p || (d x q = d p q && d x p < d p q)) rest in
+  let y, rest = List.partition (fun x -> x = q || (d p x = d p q && d x q < d p q)) rest in 
+  let a_eq, a_circ = List.partition (fun x -> d x p = d p q) rest in 
+  let ll, lm, lr = tripartition (fun x -> d x p - d p q) l in
+  let ml, mm, mr = tripartition (fun x -> d x p - d x q) m in
+  let rr, rm, rl = tripartition (fun x -> d x q - d p q) r in 
+  ((ll,lm,lr), x, (ml,mm,mr), y, (rl,rm,rr), a_eq, a_circ)
+
+let find_blocks diss p q = 
+  let d = diss.d in 
+  let l, rest = List.partition (fun x -> d x q > max (d x p) (d p q)) diss.elements in 
+  let m, rest = List.partition (fun x -> d p q > max (d p x) (d x q)) rest in 
+  let r, rest = List.partition (fun x -> d p x > max (d p q) (d q x)) rest in 
+  let x, rest = List.partition (fun x -> x = p || (d x q = d p q && d x p < d p q)) rest in
+  let y, rest = List.partition (fun x -> x = q || (d p x = d p q && d x q < d p q)) rest in 
+  let a_eq, _a_circ = List.partition (fun x -> d x p = d p q) rest in 
+  let _ll, lm, lr = tripartition (fun x -> d x p - d p q) l in
+  (* let _ml, _mm, _mr = tripartition (fun x -> d x p - d x q) m in  *)
+  let _rr, rm, rl = tripartition (fun x -> d x q - d p q) r in 
+  let (@@) = List.rev_append in 
+  let big = lm @@ lr @@ x @@ m @@ a_eq @@ y @@ rl @@ rm in 
+  match lr = [], m = [], rl = [] with 
+  | false, false, false -> None 
+  | true, true, true -> 
+     Some (main_seq [x @@ y @@ a_eq] @@ [x; y; big])
+  | true, true, false ->
+     Some (main_seq  [x @@ a_eq; y; rl] @@ [x; big])
+  | true, false, true ->
+     Some (main_seq [ x @@ m @@ y @@ a_eq] @@ [x; m; y; big])
+  | true, false, false ->
+     Some (main_seq [a_eq; x; m; y; rl] @@ [big])
+  | false, true, true ->
+     Some (main_seq [lr; x; y @@ a_eq] @@ [y; big])
+  | false, true, false ->
+     Some (main_seq [lr; x; a_eq; y; rl] @@ [big])
+  | false, false, true ->
+     Some (main_seq [lr; x; m; y; a_eq] @@ [big])
+
+
+
+(* let discriminates p q x blocks =
+ *   List.mem p blocks 
+ *   && List.mem q blocks
+ *   && not (List.mem x blocks)  *)
+
+let pivot diss pqtree p q = 
+  Option.map 
+    (fun blocks -> 
+      (* assert (List.exists (discriminates p q x) blocks); *)
+      List.for_all ImperativeBL.(pqtree.insert) blocks
+    )
+    (find_blocks diss p q)
+  
+
+
+let algo (type elt) diss index =
+  let module Canonical = 
+    PqTree.MakeCanonical(struct type t = elt let compare a b = compare (index a) (index b) end)
+  in
+  let initial_pqtree = 
+    PqTree.(P (List.map (fun l -> Leaf l) diss.elements))
+  in
+  let pqtree = ImperativeBL.get_algorithms initial_pqtree index in 
+  let rec go () =
+    let tree = pqtree.get () in 
+    let order = PqTree.frontier tree in
+    match find_incompatible_triples diss order () with
+    | Seq.Nil -> Some order  
+    | Seq.Cons ((x,_,z),_) -> 
+       if pivot diss pqtree x z = Some true then 
+         go () 
+       else None
+  in 
+  go ()
+    

lib/robinson/pivotpair.mli

+open DissimilarityLib
+
+val partition :
+  'elt Dissimilarity.t -> 'elt -> 'elt -> 
+  ('elt list * 'elt list * 'elt list) 
+  * 'elt list 
+  * ('elt list * 'elt list * 'elt list) 
+  * 'elt list 
+  * ('elt list * 'elt list * 'elt list)
+  * 'elt list * 'elt list
+
+val find_blocks :
+  'elt Dissimilarity.t -> 'elt -> 'elt -> 'elt list list option
+
+
+val algo : 'elt Dissimilarity.t -> ('elt -> int) -> 'elt list option
+
+
+

matrices/mat1

+0 63 11 66 52 12 69 16 11 9
+63 0 53 5 12 74 8 78 52 57
+11 53 0 56 41 22 59 27 8 5
+66 5 56 0 15 77 3 82 56 60
+52 12 41 15 0 63 18 67 42 46
+12 74 22 77 63 0 80 7 23 18
+69 8 59 3 18 80 0 84 59 63
+16 78 27 82 67 7 84 0 27 23
+11 52 8 56 42 23 59 27 0 10
+9 57 5 60 46 18 63 23 10 0

readme.txt

+0) Need OCaml installed. Easy way: 
+sudo apt-get install opam
+opam init
+eval `opam env`
+opam install utop dune core feat core_bench qcheck <add more packages to the list if necessary>
+
+
+see https://ocaml.org/learn/tutorials/up_and_running.html
+
+1) compile:
+dune build
+
+2) execute: 
+cat my_matrix | dune exec copoint 
+cat instance_1 | sed "s/,\|\[\|]//g" | dune exec copoint
+
+
+Run test:
+dune runtest
+
+
+Run benchmark:
+dune exec robench
+
+
+Open a toplevel: (useful for testing algorithms)
+dune utop

robinson.opam

+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Algorithms for Robinson Dissimilarities"
+description: "A longer description"
+maintainer: ["Guyslain Naves"]
+authors: ["Guyslain Naves"]
+license: "LICENSE"
+tags: ["topics" "to describe" "your" "project"]
+homepage: "https://github.com/username/reponame"
+doc: "https://url/to/documentation"
+bug-reports: "https://github.com/username/reponame/issues"
+depends: [
+  "ocaml"
+  "dune" {>= "3.0"}
+  "fix"
+  "feat"
+  "RobinsonLib"
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/username/reponame.git"

test/dune

+(test
+ (name copoint_recognition)
+ (libraries RobinsonLib)
+)

test/pqtree.ml

+open RobinsonLib
+open PqTree 
+
+let is_in interval i = List.mem i interval 
+
+let test_naive tree interval = 
+  Naive_pqtree.add_interval (is_in interval) (List.length interval) tree
+
+let test1 = 
+  ( P [Q [Leaf 1; Leaf 2; Leaf 3]; Leaf 4; Leaf 5],
+    [3;4],
+    P [Q [Leaf 1; Leaf 2; Leaf 3; Leaf 4]; Leaf 5]
+  )
+
+
+
+let test2 =
+  ( P [Leaf 1; Leaf 2; Leaf 3; Leaf 4; Leaf 5],
+    [1;3;5],
+    P [P [Leaf 1; Leaf 3; Leaf 5]; Leaf 2; Leaf 4]
+  )
+
+
+let test3 = 
+  ( P [ Leaf 1; P [ Leaf 2; Leaf 3; Leaf 4; Leaf 5]],
+    [1;2;5],
+    Q [P [Leaf 3; Leaf 4]; P [Leaf 2; Leaf 5]; Leaf 1]
+  )
+

test/profiling/dune

+(executable 
+ (name permutation_checker) 
+ (public_name prof_perm_check)
+ (libraries RobinsonLib RobinsonTest PqTreeLib landmarks)
+ (instrumentation (backend landmarks))
+ (preprocess (pps landmarks-ppx --auto))
+)
+
+(env 
+ (_ (env-vars ("OCAML_LANDMARKS" "auto")))
+)