bin/bench/dune

@@ -7,6 +7,7 @@
    DissimilarityLib 
    RandomDissimilarity 
    Recognition
+   ChainLib
    core core_unix.command_unix core_bench
  )
 )

bin/bench/robench.ml

@@ -2,7 +2,7 @@ open! Core_bench
 open! CopointLib
 open! RandomDissimilarity
 open! DissimilarityLib
-
+open! ChainLib
 
 let imperative_copoint_algorithm diss =
   diss
@@ -19,6 +19,12 @@ let pivotpair_algorithm diss =
   Recognition.Pivotpair.algo diss (fun i -> i)
   |> ignore
 
+let chain_insertion_algorithm diss = 
+  diss 
+  |> RobinsonByChain.find_compatible_order 
+  |> ignore
+  
+
 
 let toeplitz ~k dim = 
   Toeplitz.toeplitz012 ~n:dim ~k:(min k (dim-2))
@@ -45,7 +51,8 @@ let algorithms =
   [
     Y ("copoint-imp", imperative_copoint_algorithm);
     Y ("copoint-fun", functional_copoint_algorithm);
-    Y ("pivotpair", pivotpair_algorithm)
+    Y ("pivotpair", pivotpair_algorithm);
+    Y ("chain-insertion", chain_insertion_algorithm)
   ]
 
 

bin/dune

 (executable
  (public_name copoint)
  (name main)
- (libraries RobinsonLib CopointLib DissimilarityLib Recognition))
+ (libraries RobinsonLib CopointLib DissimilarityLib Recognition ChainLib))

bin/main.ml

@@ -46,4 +46,5 @@ let _main =
   let _algo1 diss = RobinsonCCNP.find_compatible_order diss in 
   let _algo2 diss = ImperativeCCNP.find_compatible_order diss |> Option.map Array.to_list in 
   let _algo3 diss = Recognition.Pivotpair.algo diss (fun i -> i) in
-  _from_stdin _algo1 
+  let _algo4 diss = ChainLib.RobinsonByChain.find_compatible_order diss in 
+  _from_stdin _algo3

lib/chain/dune

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

lib/chain/robinsonByChain.ml

+open DissimilarityLib 
+open PqTreeLib 
+open Dissimilarity
+
+let find_compatible_order dissimilarity = 
+  let insert_chain pqtree_option s = match pqtree_option with 
+  | None -> None 
+  | Some pqtree -> 
+      PqChainInsertion.refine_by_distances s (fun u -> dissimilarity.d s u) pqtree 
+  in
+  let initial_tree = 
+    PqTree.(P (List.map (fun x -> Leaf x) dissimilarity.elements))
+  in 
+  List.fold_left insert_chain (Some initial_tree) dissimilarity.elements 
+  |> Option.map PqTree.frontier

lib/chain/robinsonByChain.mli

+
+open DissimilarityLib 
+
+val find_compatible_order : 'elt Dissimilarity.t -> 'elt list option

lib/copoint/imperativeCCNP.ml

@@ -160,6 +160,8 @@ let find_compatible_order (type elt) diss =
   let module D = struct type t = elt let d = diss.d end in 
   let module M = Make(D) in 
   try 
-    Some (M.find_compatible_order (Array.of_list diss.elements))
+    let order = M.find_compatible_order (Array.of_list diss.elements) in 
+    if Dissimilarity.is_compatible_order diss (Array.to_list order) then Some order
+    else None 
   with 
     | M.Not_Robinson -> None 

lib/copoint/robinsonCCNP.ml

@@ -175,6 +175,8 @@ let find_compatible_order (type elt) diss =
   in 
   let module M = Make(D) in 
   try
-    Some (M.find_compatible_order diss.elements)
+    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

lib/datastruct/deQueue.ml

@@ -20,9 +20,9 @@ sig
 
   val reverse : 'elt t -> 'elt t 
 
-  val push_all_left : 'elt list -> 'elt t -> 'elt t 
+  val append_to_left : 'elt t -> 'elt t -> 'elt t 
 
-  val push_all_right : 'elt t -> 'elt list -> 'elt t 
+  val append_to_right : 'elt t -> 'elt t -> 'elt t 
 end 
 
 
@@ -59,11 +59,15 @@ struct
 
   let reverse (prefix, suffix) = (suffix, prefix)
 
-  let push_all_left list queue =
-    List.fold_left (fun queue elt -> push_left elt queue) queue list 
+  let rec append_to_left left right =
+    match view_left right with 
+    | None -> left 
+    | Some (e,q) -> append_to_left (push_right left e) q
 
-  let push_all_right queue list = 
-    List.fold_left push_right queue list
+  let rec append_to_right left right = 
+    match view_right left with 
+    | None -> right 
+    | Some (q,e) -> append_to_right q (push_left e right)
 end
 
 
@@ -72,5 +76,69 @@ include NaiveQueue
 
 let singleton elt = push_right empty elt 
 
-let (@>) = push_all_left 
-let (@<) = push_all_right 
+let (@>) = append_to_right
+let (@<) = append_to_left
+
+
+let map f queue = 
+  let rec map_k k queue =
+    match view_left queue with 
+    | None -> k empty
+    | Some (first, others) -> map_k (fun res -> k (push_left (f first) res)) others
+  in 
+  map_k (fun q -> q) queue 
+
+let first queue = match view_left queue with 
+| None -> invalid_arg "first on empty DeQueue"
+| Some (e,_) -> e 
+
+let last queue = match view_right queue with 
+| None -> invalid_arg "last on empty Dequeue"
+| Some (_,e) -> e 
+
+let pop_first queue = match view_left queue with 
+| None -> invalid_arg "pop_first on empty DeQueue" 
+| Some (_,q) -> q 
+
+let pop_last queue = match view_right queue with 
+| None -> invalid_arg "pop_last on empty DeQueue"
+| Some (q,_) -> q 
+
+
+
+let rec fold_lr f accu queue = match view_left queue with 
+| None -> accu 
+| Some (e,q) -> fold_lr f (f accu e) q 
+ 
+let rec fold_rl f queue accu = match view_right queue with 
+| None -> accu 
+| Some (q,e) -> fold_rl f q (f e accu)
+
+
+let filter test queue = 
+  fold_lr (fun q e -> if test e then push_right q e else q) empty queue 
+
+
+let concat_map f queue = 
+  fold_lr (fun q e -> append_to_left q (f e)) empty queue 
+
+
+let rec for_all test queue = 
+  match view_left queue with 
+  | None -> true 
+  | Some (e,_) when not (test e) -> false 
+  | Some (_,q) -> for_all test q
+
+
+let zip queue1 queue2 = 
+  let rec zip_k k queue1 queue2 = 
+    match view_left queue1, view_left queue2 with 
+    | Some (e1,q1), Some (e2,q2) -> zip_k (fun res -> k (push_left (e1,e2) res)) q1 q2
+    | _,_ -> k empty 
+  in 
+  zip_k (fun q -> q) queue1 queue2 
+                                      
+
+let consecutives queue = 
+  if is_empty queue then empty 
+  else zip (pop_last queue) (pop_first queue)

lib/datastruct/deQueue.mli

@@ -18,13 +18,34 @@ val of_list : 'elt list -> 'elt t
 
 val reverse : 'elt t -> 'elt t 
 
-val push_all_left : 'elt list -> 'elt t -> 'elt t 
+val append_to_left : 'elt t -> 'elt t -> 'elt t 
+
+val append_to_right : 'elt t -> 'elt t -> 'elt t 
 
-val push_all_right : 'elt t -> 'elt list -> 'elt t 
 
 
 val singleton : 'elt -> 'elt t 
 
-val (@>) :  'elt list -> 'elt t -> 'elt t 
+val (@>) :  'elt t -> 'elt t -> 'elt t 
+
+val (@<) : 'elt t -> 'elt t -> 'elt t 
+
+
+val map : ('elt -> 'im) -> 'elt t -> 'im t
+
+val first : 'elt t -> 'elt 
+val last : 'elt t -> 'elt 
+val pop_first : 'elt t -> 'elt t 
+val pop_last : 'elt t -> 'elt t 
+
+val fold_lr : ('accu -> 'elt -> 'accu) -> 'accu -> 'elt t -> 'accu 
+val fold_rl : ('elt -> 'accu -> 'accu) -> 'elt t -> 'accu -> 'accu 
+
+val for_all : ('elt -> bool) -> 'elt t -> bool 
+
+val filter : ('elt -> bool) -> 'elt t -> 'elt t 
+
+val concat_map : ('elt -> 'im t) -> 'elt t -> 'im t 
+
+val consecutives : 'elt t -> ('elt * 'elt) t 
 
-val (@<) : 'elt t -> 'elt list -> 'elt t 

lib/pqtree/pqChainInsertion.ml → lib/pqtrees/pqChainInsertion.ml

@@ -12,18 +12,6 @@
 open DataStruct 
 
 
-let consecutives list = 
-  let rec go accu = function 
-  | [] | [_] -> List.rev accu
-  | x::((y::_) as tail) -> go ((x,y)::accu) tail
-  in 
-  go [] list
-
-let last = function 
-| [] -> invalid_arg "last on empty list"
-| h::t -> List.fold_left (fun _ e -> e) h t  
-
-
 
 module IntPair = 
 struct 
@@ -52,13 +40,14 @@ module Make =
     open Chain 
     open PqTree
 
-    let q = function 
+    let q_node subtrees = 
+      match DeQueue.to_list subtrees with 
       | [_1;_2] as children -> P children
       | children -> Q children 
 
     type external_subtree = 
       | ConstantSubtree of int * pqtree 
-      | IncreasingSubtree of int * pqtree list * int (* an increasing subtree is necessarily a Q-node *)
+      | IncreasingSubtree of int * pqtree DeQueue.t * int (* an increasing subtree is necessarily a Q-node *)
 
     let bounds = function 
     | ConstantSubtree (delta,_) -> (delta, delta)
@@ -70,34 +59,36 @@ module Make =
     | ConstantSubtree (delta, _) -> delta 
     | IncreasingSubtree (_,_,delta) -> delta 
 
-    let amplitude subtrees = (d_min (List.hd subtrees), d_max (last subtrees))
-
     let tree_of_external_tree = function 
     | ConstantSubtree (_,t) -> t 
-    | IncreasingSubtree (_, children,_) -> q children
+    | IncreasingSubtree (_, children,_) -> q_node children
 
 
     let is_increasing_sequence subtrees = 
-      List.for_all 
+      let open DeQueue in 
+      for_all 
         (fun (subtree1, subtree2) -> d_max subtree1 <= d_min subtree2)
         (consecutives subtrees)
 
     let force_increasing_sequence subtrees = 
       if is_increasing_sequence subtrees then Some subtrees 
-      else let reversed = List.rev subtrees in 
+      else let reversed = DeQueue.reverse subtrees in 
         if is_increasing_sequence reversed then Some reversed
         else None 
 
     let expand_increasing_sequence subtrees = 
       let contract = function 
-      | ConstantSubtree (_,t) -> [t]
+      | ConstantSubtree (_,t) -> DeQueue.singleton t
       | IncreasingSubtree (_, children, _) -> children
       in  
-      List.concat_map contract subtrees
+      DeQueue.concat_map contract subtrees
 
 
     let sort_into_increasing_sequence subtrees = 
-      IntPairSorter.sort ~get_key:bounds subtrees
+      subtrees 
+      |> DeQueue.to_list
+      |> IntPairSorter.sort ~get_key:bounds 
+      |> DeQueue.of_list
 
 
     type sorting_group = 
@@ -114,24 +105,22 @@ module Make =
 
     let sort_children_of_p_node children =
       let group = function 
-      | [ ConstantSubtree _ as tree ] -> [ Single tree ]
-      | (ConstantSubtree (delta,_)::_) as trees -> [ Group (delta, List.map tree_of_external_tree trees) ]
-      | trees -> List.map (fun t -> Single t) trees
+      | [ ConstantSubtree _ as tree ] -> DeQueue.singleton (Single tree)
+      | (ConstantSubtree (delta,_)::_) as trees -> 
+          DeQueue.singleton ( Group (delta, List.map tree_of_external_tree trees) )
+      | trees -> List.map (fun t -> Single t) trees |> DeQueue.of_list
       in
       children
     |> sort_into_increasing_sequence
-    |> List.concat_map group 
+    |> DeQueue.concat_map group 
 
 
     let is_increasing_group_sequence groups = 
-      List.for_all 
+      let open DeQueue in
+      for_all 
         (fun (group1, group2) -> group_d_max group1 <= group_d_min group2)
         (consecutives groups)
 
-    let groups_amplitude groups = 
-      ( group_d_min (List.hd groups), group_d_max (last groups))
-           
-
       
 
 
@@ -142,7 +131,7 @@ module Make =
 
     let tree_of_centered_tree = function 
     | Balanced (_, tree) -> tree
-    | Skew (_,children,_) -> q (DeQueue.to_list children)
+    | Skew (_,children,_) -> q_node children
 
     let bounds_centered = function 
     | Balanced (delta,_) -> (delta, delta)
@@ -160,24 +149,25 @@ module Make =
 
     type classification =
       | Unclassifiable
-      | Internal of external_subtree list * centered_subtree * external_subtree list 
-      | External of external_subtree list 
+      | Internal of external_subtree DeQueue.t * centered_subtree * external_subtree DeQueue.t 
+      | External of external_subtree DeQueue.t 
 
     let classify children =
+      let open DeQueue in 
       let rec go classification children = 
         match classification, children with 
         | _, [] -> classification
         | Unclassifiable, _
         | _, NotRepresentable::_ -> Unclassifiable
         | Internal (left, at_s, right), ExternalSubtree child::children -> 
-            go (Internal (left, at_s, child::right)) children 
+            go (Internal (left, at_s, push_right right child)) children 
         | External left_of_s, ExternalSubtree child::children ->
-            go (External (child::left_of_s)) children
+            go (External (push_right left_of_s child)) children
         | External left_of_s, CenteredSubtree centered::children ->
-            go (Internal (left_of_s, centered, [])) children 
+            go (Internal (left_of_s, centered, empty)) children 
         | Internal _, CenteredSubtree _ :: _ -> Unclassifiable 
       in 
-      go (External []) children 
+      go (External empty) children 
 
           
                        
@@ -201,13 +191,13 @@ module Make =
       | Some (child, trees) when DeQueue.is_empty trees && is_balanced queue -> 
           (queue.left_bound, child)
       | _ -> 
-          (max queue.left_bound queue.right_bound, q (DeQueue.to_list queue.trees))
+          (max queue.left_bound queue.right_bound, q_node queue.trees)
 
     let enqueue_right group queue = 
       let (trees, right_bound) = match group with  
       | Group (bound, children) -> (DeQueue.push_right queue.trees (P children), bound)
       | Single (ConstantSubtree (bound, subtree)) -> (DeQueue.push_right queue.trees subtree, bound)
-      | Single (IncreasingSubtree (_, subtrees, bound)) -> (DeQueue.push_all_right queue.trees subtrees, bound)
+      | Single (IncreasingSubtree (_, subtrees, bound)) -> DeQueue.(queue.trees @< subtrees, bound)
       in 
       { queue with trees; right_bound }
 
@@ -215,7 +205,7 @@ module Make =
       let (trees, left_bound) = match group with 
       | Group (bound, children) -> (DeQueue.push_left (P children) queue.trees, bound)
       | Single (ConstantSubtree (bound, subtree)) -> (DeQueue.push_left subtree queue.trees, bound)
-      | Single (IncreasingSubtree (_,subtrees, bound)) -> (DeQueue.push_all_left subtrees queue.trees, bound)
+      | Single (IncreasingSubtree (_,subtrees, bound)) -> DeQueue.(reverse subtrees @> queue.trees, bound)
       in
       { queue with trees; left_bound }
 
@@ -224,95 +214,103 @@ module Make =
       | Some (single, others) when DeQueue.is_empty others && is_balanced queue ->
           Balanced (queue.left_bound, single)
       | _ when is_balanced queue ->
-        Balanced (queue.left_bound, q (DeQueue.to_list queue.trees))
+        Balanced (queue.left_bound, q_node queue.trees)
       | _ ->
         Skew (queue.left_bound, queue.trees, queue.right_bound)
     
 
     let rec enqueue groups queue = 
       let max_bound = max queue.left_bound queue.right_bound in 
-      match groups with 
-      | [] -> 
+      match DeQueue.view_left groups with 
+      | None -> 
           CenteredSubtree (finalize queue)
-      | Group (dist,children) :: groups when dist >= max_bound -> 
+      | Some (Group (dist,children), groups) when dist >= max_bound -> 
           queue 
           |> collapse
           |> (fun (_,tree) -> Balanced (dist, P (tree :: children)))
           |> init_queue
           |> enqueue groups
-      | single :: groups when group_d_min single >= max_bound -> 
+      | Some (single, groups) when group_d_min single >= max_bound -> 
           queue 
           |> collapse
           |> (fun (delta, tree) -> init_queue (Balanced (delta, tree)))
           |> enqueue_right single 
           |> enqueue groups 
-      | any :: groups when group_d_min any >= queue.right_bound -> 
+      | Some (any, groups) when group_d_min any >= queue.right_bound -> 
           queue 
           |> enqueue_right any 
           |> enqueue groups 
-      | any :: groups when group_d_min any >= queue.left_bound ->
+      | Some (any, groups) when group_d_min any >= queue.left_bound ->
           queue 
           |> enqueue_left any
           |> enqueue groups
       | _ (* when group_d_min any < min queue.left_bound queue.right_bound *) -> 
           NotRepresentable
 
-    let build_p_internal left_subtrees s_subtree right_subtrees = 
-      let increasing_subtrees = 
-        sort_children_of_p_node (List.rev_append left_subtrees right_subtrees) 
-      in 
-      enqueue increasing_subtrees (init_queue s_subtree)
+
+    let build_p_internal  central_subtree external_subtrees = 
+      let increasing_subtrees = sort_children_of_p_node external_subtrees in 
+      enqueue increasing_subtrees (init_queue central_subtree)
 
 
 
+    let centered_subtree left_bound trees right_bound = 
+      if left_bound = right_bound then 
+        CenteredSubtree (Balanced (left_bound, q_node trees))
+      else 
+        CenteredSubtree (Skew (left_bound, trees, right_bound))
+
     let build_q_internal left_subtrees s_subtree right_subtrees = 
+      let open DeQueue in 
       if not (is_increasing_sequence left_subtrees && is_increasing_sequence right_subtrees) then 
         NotRepresentable
       else 
-        let (min_center, max_center) = bounds_centered s_subtree in 
-        let (min_left, max_left) = amplitude left_subtrees in 
-        let (min_right, max_right) = amplitude right_subtrees in 
+        let (left_center_bound, right_center_bound) = bounds_centered s_subtree in 
+        let check central_bound subtrees = match view_left subtrees with 
+        | None -> Some central_bound 
+        | Some (subtree,_) when d_min subtree < central_bound -> None 
+        | Some _ -> Some (d_max (last subtrees))
+        in
         let lefts = expand_increasing_sequence left_subtrees in 
         let rights = expand_increasing_sequence right_subtrees in 
-        let centered_subtree left_bound trees right_bound = 
-          if left_bound = right_bound then 
-            CenteredSubtree (Balanced (left_bound, q (DeQueue.to_list trees)))
-          else 
-            CenteredSubtree (Skew (left_bound, trees, right_bound))
-        in 
-        if max min_center max_center <= min min_left min_right then 
+        match check left_center_bound left_subtrees, check right_center_bound right_subtrees,
+              check left_center_bound right_subtrees, check right_center_bound left_subtrees
+        with 
+        | Some left_bound, Some right_bound, Some _, Some _ -> 
           centered_subtree 
-            max_left 
-            DeQueue.(lefts @> singleton (tree_of_centered_tree s_subtree) @< rights)
-            max_right
-        else if min_left >= min_center && max_center <= min_right then 
+            left_bound
+            DeQueue.(reverse lefts @> singleton (tree_of_centered_tree s_subtree) @< rights)
+            right_bound 
+        | Some left_bound, Some right_bound, _, _ -> 
           centered_subtree
-            max_left
-            DeQueue.(lefts @> of_list (contract_centered s_subtree) @< rights)
-            max_right
-        else if min_right >= min_center && max_center <= min_left then 
+            left_bound
+            DeQueue.(reverse lefts @> of_list (contract_centered s_subtree) @< rights)
+            right_bound
+        | _, _, Some left_bound, Some right_bound ->
             centered_subtree
-            max_right
-            DeQueue.(rights @> of_list (contract_centered s_subtree) @< lefts)
-            max_left
-        else NotRepresentable
+              left_bound
+              DeQueue.(reverse rights @> of_list (contract_centered s_subtree) @< lefts)
+              right_bound
+        | _,_,_,_ -> 
+            NotRepresentable
 
 
 
     let contract_group = function 
-    | Group (_, subtrees) -> [ P subtrees ]
-    | Single (ConstantSubtree (_,subtree)) -> [ subtree ]
+    | Group (_, subtrees) -> DeQueue.singleton (P subtrees)
+    | Single (ConstantSubtree (_,subtree)) -> DeQueue.singleton (subtree)
     | Single (IncreasingSubtree (_,subtrees,_)) -> subtrees 
     
     let build_p_external unsorted_subtrees = 
       let groups = sort_children_of_p_node unsorted_subtrees in 
-      match groups with
+      match DeQueue.view_left groups with
       | _ when not (is_increasing_group_sequence groups) -> NotRepresentable
-      | [ Group (delta,children) ] -> 
+      | Some (Group (delta,children),q) when DeQueue.is_empty q -> 
           ExternalSubtree (ConstantSubtree (delta, P children))
       | _ ->
-          let (delta_min, delta_max) = groups_amplitude groups in 
-          let subtrees = List.concat_map contract_group groups in 
+          let delta_min = group_d_min (DeQueue.first groups) in 
+          let delta_max = group_d_max (DeQueue.last groups) in 
+          let subtrees = DeQueue.concat_map contract_group groups in 
           ExternalSubtree (IncreasingSubtree (delta_min, subtrees, delta_max))
 
 
@@ -322,9 +320,10 @@ module Make =
       | None -> NotRepresentable
       | Some subtrees -> 
           ExternalSubtree (
-            let (delta_min, delta_max) = amplitude subtrees in 
+            let delta_min = d_min (DeQueue.first subtrees) in 
+            let delta_max = d_max (DeQueue.last subtrees) in 
             if delta_min = delta_max then 
-              ConstantSubtree (delta_min, Q (List.map tree_of_external_tree subtrees))
+              ConstantSubtree (delta_min, q_node (DeQueue.map tree_of_external_tree subtrees))
             else  
               IncreasingSubtree (delta_min, expand_increasing_sequence subtrees, delta_max)
           )
@@ -338,11 +337,11 @@ module Make =
           ExternalSubtree (ConstantSubtree (d x, Leaf x))
       | _, Unclassifiable -> NotRepresentable
       | P _, Internal (left_of_s, at_s, right_of_s) -> 
-          build_p_internal left_of_s at_s (List.rev right_of_s)
+          build_p_internal at_s (DeQueue.append_to_left left_of_s right_of_s)
       | P _, External subtrees -> 
           build_p_external subtrees 
       | Q _, Internal (left_of_s, at_s, right_of_s) ->
-          build_q_internal left_of_s at_s (List.rev right_of_s)
+          build_q_internal (DeQueue.reverse left_of_s) at_s right_of_s
       | Q _, External subtrees -> 
           build_q_external subtrees
     
@@ -361,9 +360,9 @@ module Make =
       match solve tree with 
       | NotRepresentable -> None 
       | CenteredSubtree (Balanced (_,tree)) -> Some tree 
-      | CenteredSubtree (Skew (_,trees,_)) -> Some (q (DeQueue.to_list trees))
+      | CenteredSubtree (Skew (_,trees,_)) -> Some (q_node trees)
       | ExternalSubtree (ConstantSubtree (_, tree)) -> Some tree 
-      | ExternalSubtree (IncreasingSubtree (_, trees, _)) -> Some (q trees)
+      | ExternalSubtree (IncreasingSubtree (_, trees, _)) -> Some (q_node trees)
 
 
   end