Commits

bergsoe  committed ee62bf8

Another iteration of the SBL interface.

The concrete expansion methods now return a chain
of configurations to add.

The expand utilities of SBL are moved to SBLExpand.

  • Participants
  • Parent commits 93d623c

Comments (0)

Files changed (4)

File src/PaplSBL.ml

 
 type 'a pair_t = 'a * 'a
 
-type 'a expand_sampler_t = 'a -> 'a PaplSampler.t
-type 'a expand_t = 'a -> 'a option
-
-let to_expand constr expansions = ();
-  fun q ->
-    BatEnum.Exceptionless.find
-      (fun q -> PaplConstraint.accept constr q)
-      (expansions q)
-
-module RRT = struct
-  type 'a expand_sampler_t = 'a -> 'a -> 'a PaplSampler.t
-  type 'a expand_t = 'a -> 'a -> 'a option
-
-  let to_expand constr expansions = ();
-    fun qa qb ->
-      BatEnum.Exceptionless.find
-        (fun qt -> PaplConstraint.accept constr qt)
-        (expansions qa qb)
-end
+type 'a expand_t = 'a -> 'a list
 
 type kind_t = Standard | NonTransfer
 
       val make_constr : (q_t * q_t) -> PaplIncrConstraint.t
       val connect_dist : q_t PaplMetric.option_t
       val connect_constr : q_t PaplEdgeConstraint.t option
-      val expand : q_t -> q_t option
+      val expand : q_t -> q_t list
       val kind : kind_t
       val rng : PaplRandom.rng_t
     end
 
       let callback s = s.callback s
 
+      let add_all s parent qs =
+        let add_q parent q =
+          add s parent q (M.make_constr (get_q (Tree.get parent), q))
+        in List.fold_left add_q parent qs
+
       let expand s =
         callback s;
         match Index.choose_random s.index with
           | None -> None
           | Some n_tree ->
-              let q_tree = get_q (Tree.get n_tree) in
-                match M.expand q_tree with
-                  | None -> None
-                  | Some q_new ->
-                      (Some
-                         (add s n_tree q_new
-                            (M.make_constr (q_tree, q_new))))
+              match M.expand (get_q (Tree.get n_tree)) with
+                | [] -> None
+                | qs -> Some (add_all s n_tree qs)
 
       let nearest s q_attractor dist constr =
         let norm n_tree =
       val expand_dist : q_t PaplMetric.option_t
       val expand_constr : q_t PaplEdgeConstraint.t option
 
-      val expand : q_t -> q_t -> q_t option
+      val expand : q_t -> q_t -> q_t list
 
       val kind : kind_t
     end
       module Default = Unbiased.MakeSetup(
         struct
           include M
-          let expand _ = None
+          let expand _ = []
           let rng = None
         end)
 
                   | Some n_tree ->
                       let q_tree = get_q (Tree.get n_tree) in
                         match M.expand q_tree q_attractor with
-                            None -> None
-                          | Some q_new ->
-                              let ec = make_constr (q_tree, q_new) in
-                                Some (add s n_tree q_new ec)
+                          | [] -> None
+                          | qs -> Some (Default.add_all s.index n_tree qs)
 
       let add_root s q = Default.add_root s.index q
 

File src/PaplSBL.mli

   with type q_t = S.q_t
   and type target_t = S.t * S.t
 
-type 'a expand_sampler_t = 'a -> 'a PaplSampler.t
-type 'a expand_t = 'a -> 'a option
-
-val to_expand :
-  'a PaplConstraint.t ->
-  'a expand_sampler_t ->
-  'a expand_t
-
-module RRT : sig
-  type 'a expand_sampler_t = 'a -> 'a -> 'a PaplSampler.t
-  type 'a expand_t = 'a -> 'a -> 'a option
-
-  val to_expand :
-    'a PaplConstraint.t ->
-    'a expand_sampler_t ->
-    'a expand_t
-end
-
 module BruteForce : sig
 
   module Unbiased : sig
       val make_constr : (q_t * q_t) -> PaplIncrConstraint.t
       val connect_dist : q_t PaplMetric.option_t
       val connect_constr : q_t PaplEdgeConstraint.t option
-      val expand : q_t -> q_t option
+      val expand : q_t -> q_t list
       val kind : kind_t
       val rng : PaplRandom.rng_t
     end
       val connect_constr : q_t PaplEdgeConstraint.t option
       val expand_dist : q_t PaplMetric.option_t
       val expand_constr : q_t PaplEdgeConstraint.t option
-      val expand : q_t -> q_t -> q_t option
+      val expand : q_t -> q_t -> q_t list
       val kind : kind_t
     end
 

File src/PaplSBLExpand.ml

 *)
 type rng_t = PaplRandom.rng_t
 
+type 'a expand_sampler_t = 'a -> 'a PaplSampler.t
+type 'a expand_t = 'a -> 'a list
+
+let to_expand constr expansions = (); fun q ->
+  let enum = expansions q in
+  let rec loop () =
+    match BatEnum.get enum with
+        None -> []
+      | Some q ->
+          if PaplConstraint.accept constr q then [q]
+          else loop ()
+  in loop ()
+
 let random_range ?rng =
   let float_fun = PaplRandom.float ?rng in
     fun (a, b) -> a +. float_fun (b -. a)
 
 let stop () = raise BatEnum.No_more_elements
 
-type 'a expand_sampler_t = 'a PaplSBL.expand_sampler_t
-
 let make_standard_boxes scale n (lower, upper) =
   BatArray.of_enum
     (BatEnum.take n
 end
 
 module RRT = struct
-  type 'a expand_sampler_t = 'a PaplSBL.RRT.expand_sampler_t
   type box_t = float * float
+  type 'a expand_sampler_t = 'a -> 'a -> 'a PaplSampler.t
+  type 'a expand_t = 'a -> 'a -> 'a option
+
+  let random_range ?rng =
+    let float_fun = PaplRandom.float ?rng in
+      fun (a, b) -> a +. float_fun (b -. a)
+
+  let to_expand constr expansions = ();
+    fun qa qb ->
+      BatEnum.Exceptionless.find
+        (fun qt -> PaplConstraint.accept constr qt)
+        (expansions qa qb)
 
   let random_subdivide_n_helper
       float_fun n interpolate dist (lower, upper) =

File src/PaplSBLExpand.mli

 
 type rng_t = PaplRandom.rng_t
 
-type 'a expand_sampler_t = 'a PaplSBL.expand_sampler_t
+type 'a expand_sampler_t = 'a -> 'a PaplSampler.t
+type 'a expand_t = 'a -> 'a list
+
+val to_expand :
+  'a PaplConstraint.t ->
+  'a expand_sampler_t ->
+  'a expand_t
 
 module Float : sig
   type t = float
 
 module RRT : sig
   type box_t = float * float
-  type 'a expand_sampler_t = 'a PaplSBL.RRT.expand_sampler_t
+  type 'a expand_sampler_t = 'a -> 'a -> 'a PaplSampler.t
+  type 'a expand_t = 'a -> 'a -> 'a option
+
+  val to_expand :
+    'a PaplConstraint.t ->
+    'a expand_sampler_t ->
+    'a expand_t
 
   val subdivide_n :
     int -> (* n : if negative then continue to [lower]. *)