feat: support for model-requested horizons

src/lib/common/utils.ml

@@ -1,9 +0,0 @@
-
-exception TODO
-
-let pair = fun a b -> a, b
-
-let uncurry = fun f (a, b) -> f a b
-
-let (@.) = fun f g x -> f @@ g x
-

src/lib/hsim/sim.ml

@@ -11,39 +11,39 @@ module Sim (S : SimState) =
       let ms, ss, zin = get_mstate s, get_sstate s, get_zin s in
       let ms = match zin with Some z -> zset ms z | None -> ms in
       let i, now, stop = get_input s, get_now s, get_stop s in
-      let o, ms = step ms (i.u now) in
+      let o, ms = step ms now (i.u now) in
       let s =
-        let s = set_zin None s in
         let h = hor ms in
         if h <= 0.0 then set_mstate ms s
         else if now >= stop then set_idle s
         else if jump ms then begin
           let init = cget ms and stop = stop -. now in
-          let fder t = fder ms (Utils.offset i.u now t) in
-          let fzer t = fzer ms (Utils.offset i.u now t) in
+          let fder t = fder ms t (Utils.offset i.u now t) in
+          let fzer t = fzer ms t (Utils.offset i.u now t) in
           let ivp = { fder; stop; init; size=csize } in
           let zc = { init; fzer; size=zsize } in
           let ss = reset (ivp, zc) ss in
-          let i = { i with h=i.h -. now; u=Utils.offset i.u now } in
+          let input = { i with h=i.h -. now; u=Utils.offset i.u now } in
           let mode, stop, now = Continuous, i.h, 0.0 in
-          update ms ss (set_running ~mode ~input:i ~stop ~now s)
+          update ms ss (set_running ~mode ~input ~stop ~now s)
         end else set_running ~mode:Continuous s in
-      Utils.dot o, s
+      Utils.dot o, (set_zin None s)
 
     let step_continuous s step cset fout hor =
       let ms, ss = get_mstate s, get_sstate s in
       let i, now, stop = get_input s, get_now s, get_stop s in
       let stop = min stop (hor ms) in
       let (h, f, z), ss = step ss (min stop (hor ms)) in
+      let h = min h (min stop (hor ms)) in
       let ms = cset ms (f h) in
       let fy t = f (now +. t) in
       let fms t = cset ms (fy t) in
-      let fout t = fout ms (i.u (now +. t)) (fy t) in
+      let fout t = fout ms t (i.u (now +. t)) (fy t) in
       let s, c = match z with
       | None ->
           if h >= stop
           then set_running ~mode:Discrete ~now:h s, Discontinuous
-          else set_running ~now: h s, Continuous
+          else set_running ~now:h s, Continuous
       | Some _ -> set_running ~mode:Discrete ~now:h s, Discontinuous in
       let h = h -. now in
       { h; u=fout; c }, update ms ss (set_zin z s), { h; c; u=fms }

src/lib/hsim/solver.ml

@@ -60,8 +60,10 @@ let solver (DNode csolver : ('y, 'yder) csolver)
     : ('y, 'yder, 'zin, 'zout) solver =
   let state = csolver.state, zsolver.state in
   let step (cstate, zstate) h =
-    let (h, f), cstate = csolver.step cstate h in
-    let (h, z), zstate = zsolver.step zstate (h, f) in
+    let (h', f), cstate = csolver.step cstate h in
+    let h = min h h' in
+    let (h', z), zstate = zsolver.step zstate (h, f) in
+    let h = min h h' in
     (h, f, z), (cstate, zstate) in
   let reset (ivp, zc) (cstate, zstate) =
     csolver.reset ivp cstate, zsolver.reset zc zstate in
@@ -73,9 +75,10 @@ let solver_c (DNodeC csolver : ('y, 'yder) csolver_c)
     : ('y, 'yder, 'zin, 'zout) solver_c =
   let state = csolver.state, zsolver.state in
   let step (cstate, zstate) h =
-    let (h, f), cstate = csolver.step cstate h in
-    let (h, z), zstate = zsolver.step zstate (h, f) in
-    (h, f, z), (cstate, zstate) in
+    let (h', f), cstate = csolver.step cstate h in
+    let h = min h h' in
+    let (h', z), zstate = zsolver.step zstate (h, f) in
+    (h', f, z), (cstate, zstate) in
   let reset (ivp, zc) (cstate, zstate) =
     csolver.reset ivp cstate, zsolver.reset zc zstate in
   let copy (cstate, zstate) =

src/lib/hsim/types.ml

@@ -35,16 +35,16 @@ type ('p, 'a, 'b) dnode_c =
 
 type ('s, 'p, 'a, 'b, 'y, 'yder, 'zin, 'zout) hrec =
   { state: 's;
-    step : 's -> 'a -> 'b * 's;        (** Discrete step function.            *)
-    fder : 's -> 'a -> 'y -> 'yder;    (** Continuous derivative function.    *)
-    fout : 's -> 'a -> 'y -> 'b;       (** Continuous output function.        *)
-    fzer : 's -> 'a -> 'y -> 'zout;    (** Continuous zero-crossing function. *)
-    reset : 'p -> 's -> 's;            (** Reset function.                    *)
-    horizon : 's -> time;              (** Next integration horizon.          *)
-    jump : 's -> bool;                 (** Discontinuity flag.                *)
-    cget : 's -> 'y;                   (** Get continuous state.              *)
-    cset : 's -> 'y -> 's;             (** Set continuous state.              *)
-    zset : 's -> 'zin -> 's;           (** Set zero-crossing state.           *)
+    step : 's -> time -> 'a -> 'b * 's;     (** Step function.                *)
+    fder : 's -> time -> 'a -> 'y -> 'yder; (** Derivative function.          *)
+    fout : 's -> time -> 'a -> 'y -> 'b;    (** Output function.              *)
+    fzer : 's -> time -> 'a -> 'y -> 'zout; (** Zero-crossing function.       *)
+    reset : 'p -> 's -> 's;                 (** Reset function.               *)
+    horizon : 's -> time;                   (** Next integration horizon.     *)
+    jump : 's -> bool;                      (** Discontinuity flag.           *)
+    cget : 's -> 'y;                        (** Get continuous state.         *)
+    cset : 's -> 'y -> 's;                  (** Set continuous state.         *)
+    zset : 's -> 'zin -> 's;                (** Set zero-crossing state.      *)
     csize : int;
     zsize : int }
 

src/lib/hsim/utils.ml

@@ -78,3 +78,14 @@ let map f =
   let step () = function None -> None, () | Some v -> Some (f v), () in
   let reset () () = () in
   DNode { state; step; reset }
+
+let ignore _ n =
+  let state = () in
+  let step () = function
+    | None -> None, ()
+    | Some _ -> Some (), () in
+  let reset () () = () in
+  let i = DNode { state; step; reset } in
+  let DNode n = compose n i in
+  DNode { n with reset=fun p -> n.reset (p, ()) }
+

src/lib/solvers/odexx.ml

@@ -52,8 +52,8 @@ struct (* {{{1 *)
   open Bigarray
 
   let debug () =
-    false
-    (* !Common.Debug.debug *)
+    (* false *)
+    !Common.Debug.debug
 
   let pow = 1.0 /. float(Butcher.order)
 

src/lib/std/dune

@@ -0,0 +1,3 @@
+(library
+ (name std)
+ (libraries hsim solvers))

src/lib/std/lift.ml

@@ -0,0 +1,155 @@
+
+open Hsim.Types
+open Solvers.Zls
+open Ztypes
+
+type ('s, 'a) state =
+  { mutable state : 's; mutable input : 'a option; mutable time : time }
+
+let lift f =
+  let cstate =
+    { cvec = cmake 0; dvec = cmake 0; cindex = 0; zindex = 0;
+      cend = 0; zend = 0; cmax = 0; zmax = 0;
+      zinvec = zmake 0; zoutvec = cmake 0;
+      major = false; horizon = max_float } in
+  let Node { alloc=f_alloc; step=f_step; reset=f_reset } = f cstate in
+  let state = { state = f_alloc (); input = None; time = 0.0 } in
+  let csize, zsize = cstate.cmax, cstate.zmax in
+  let no_roots_in  = zmake zsize in
+  let no_roots_out = cmake zsize in
+  let ignore_der   = cmake csize in
+  let cstates      = cmake csize in
+  cstate.cvec <- cstates;
+  f_reset state.state;
+
+  let no_time = -1.0 in
+
+  (* the function that compute the derivatives *)
+  let fder { state; time; _ } offset input y =
+    cstate.major <- false;
+    cstate.zinvec <- no_roots_in;
+    cstate.zoutvec <- no_roots_out;
+    cstate.cvec <- y;
+    cstate.dvec <- ignore_der;
+    cstate.cindex <- 0;
+    cstate.zindex <- 0;
+    ignore (f_step state (time +. offset, input));
+    cstate.dvec in
+
+  (* the function that compute the zero-crossings *)
+  let fzer { state; time; _ } offset input y =
+    cstate.major <- false;
+    cstate.zinvec <- no_roots_in;
+    cstate.dvec <- ignore_der;
+    cstate.zoutvec <- no_roots_out;
+    cstate.cvec <- y;
+    cstate.cindex <- 0;
+    cstate.zindex <- 0;
+    ignore (f_step state (time +. offset, input));
+    cstate.zoutvec in
+
+  (* the function which compute the output during integration *)
+  let fout { state; time; _ } offset input y =
+    cstate.major <- false;
+    cstate.zoutvec <- no_roots_out;
+    cstate.dvec <- ignore_der;
+    cstate.zinvec <- no_roots_in;
+    cstate.cvec <- y;
+    cstate.cindex <- 0;
+    cstate.zindex <- 0;
+    f_step state (time +. offset, input) in
+
+  (* the function which compute a discrete step *)
+  let step ({ state; time; _ } as st) offset input =
+    st.input <- Some input;
+    st.time <- time +. offset;
+    cstate.major <- true;
+    cstate.horizon <- infinity;
+    cstate.zinvec <- no_roots_in;
+    cstate.zoutvec <- no_roots_out;
+    cstate.dvec <- ignore_der;
+    cstate.cindex <- 0;
+    cstate.zindex <- 0;
+    let o = f_step state (st.time, input) in
+    o, st in
+
+  let reset _ ({ state; _ } as st) = f_reset state; st in
+
+  (* horizon *)
+  let horizon { time; _ } =
+    (* Printf.printf "\tCalling horizon :: cstate.horizon=%.10e\ttime=%.10e\n" cstate.horizon time; *)
+    cstate.horizon -. time in
+
+  let jump _ = true in
+
+  (* the function which sets the zinvector into the *)
+  (* internal zero-crossing variables *)
+  let zset ({ state; input; _ } as st) zinvec =
+    cstate.major <- false;
+    cstate.zoutvec <- no_roots_out;
+    cstate.dvec <- ignore_der;
+    cstate.zinvec <- zinvec;
+    cstate.cindex <- 0;
+    cstate.zindex <- 0;
+    ignore (f_step state (no_time, Option.get input));
+    st in
+
+  let cset ({ state; input; _ } as st) _ =
+    cstate.major <- false;
+    cstate.horizon <- infinity;
+    cstate.zinvec <- no_roots_in;
+    cstate.zoutvec <- no_roots_out;
+    cstate.dvec <- ignore_der;
+    cstate.cindex <- 0;
+    cstate.zindex <- 0;
+    ignore (f_step state (no_time, Option.get input));
+    st in
+
+  let cget { state; input; _ } =
+    cstate.major <- false;
+    cstate.horizon <- infinity;
+    cstate.zinvec <- no_roots_in;
+    cstate.zoutvec <- no_roots_out;
+    cstate.dvec <- ignore_der;
+    cstate.cindex <- 0;
+    cstate.zindex <- 0;
+    ignore (f_step state (no_time, Option.get input));
+    cstate.cvec in
+
+  HNode
+    { state; fder; fzer; step; fout; reset;
+      horizon; cset; cget; zset; zsize; csize; jump }
+
+let lift_hsim n =
+  let Hsim {
+    alloc; step; reset; derivative; crossings; maxsize; horizon; _
+  } = n in
+  let s = alloc () in
+  let state = { state = s; input = None; time = 0.0 } in
+  let csize, zsize = maxsize s in
+  let no_roots_in = zmake zsize in
+  let no_roots_out = cmake zsize in
+  let ignore_der = cmake csize in
+  let cstates = cmake csize in
+  let no_time = -1.0 in
+  reset s;
+  let fder { state; time; _ } offset () y =
+    derivative state y ignore_der no_roots_in no_roots_out (time +. offset);
+    ignore_der in
+  let fzer { state; time; _ } offset () y =
+    crossings state y no_roots_in no_roots_out (time +. offset); no_roots_out in
+  let fout _ _ () _ = () in
+  let step { state; time; _ } offset () =
+    step state cstates ignore_der no_roots_in (time +. offset),
+    { state; time=time +. offset; input=Some () } in
+  let reset _ ({ state; _ } as st) = reset state; st in
+  let horizon { state; time; _ } = horizon state -. time in
+  let jump _ = true in
+  let cset ({ state; _ } as st) _ =
+    derivative state cstates ignore_der no_roots_in no_roots_out no_time; st in
+  let zset ({ state; _ } as st) zinvec =
+    derivative state cstates ignore_der zinvec no_roots_out no_time; st in
+  let cget { state; _ } =
+    derivative state cstates ignore_der no_roots_in no_roots_out no_time; cstates in
+
+  HNode { state; fder; fzer; fout; step; reset; horizon; jump; cget; cset; zset; csize; zsize }