1. bergsoe
  2. papl

Source

papl / src / PaplIncrEdgeConstraint.ml

(*
  Copyright (c) 2012 Anders Lau Olsen.
  See LICENSE file for terms and conditions.
*)

type 'a create_t = 'a PaplEdge.t PaplIncrConstraint.create_t

type state_t = {
  mutable cost : float;
  mutable level : int;
}

let make_state cost level = { cost = cost; level = level }

(* The number of levels for an edge of length 'len' and segments of len 'eps'.

   (This computation should be moved to PaplSubdivision.)
*)
let levels len eps =
  let rec loop len eps acc =
    if len <= eps
    then acc
    else loop (len /. 2.0) eps (acc + 1)
  in loop len eps 0

let constrain_by_subdivision constr interpolate (metric, eps) =
  if eps <= 0.
  then invalid_arg "eps <= 0"
  else
    let create (a, b) =
      let ip = interpolate a b in
      let len = metric a b in
      let last_level = levels len eps in
      let state = make_state len 1 in
      let reject () =
        if state.level > last_level
        then None (* OK - and nothing more to check *)
        else
          let positions = PaplSubdivision.standard_cached state.level in
          let bad pos =
            let q = ip pos in
              PaplConstraint.reject constr q
          in let result = Some (List.exists bad positions) in
            state.level <- state.level + 1;
            state.cost <- state.cost /. 2.;
            result
      in
      let cost () = state.cost
      in PaplIncrConstraint.make_reject ~reject ~cost
    in
      create

let constrain_path create path =
  match path with
      [] -> invalid_arg "constrain_path: empty path."
    | [_] -> invalid_arg "constrain_path: one-element path."
    | _ ->
        let rec build xs =
          match xs with
              x0 :: x1 :: rest ->
                create (x0, x1) :: build (x1 :: rest)
            | _ -> []
        in
          PaplIncrConstraint.prioritized (BatList.enum (build path))