feat: a lot of stuff

src/lib/solvers/csolver.ml

@@ -0,0 +1,28 @@
+
+open Hsim.Types
+open Hsim.Solver
+open Zls
+
+module type Csolver =
+  sig
+    type ('a, 'b) state
+    type session
+    type vec
+    val csolve : ((session, vec) state, carray, carray) csolver
+  end
+
+module type CsolverC =
+  sig
+    type ('a, 'b) state
+    type session
+    type vec
+    val csolve : ((session, vec) state, carray, carray) csolver_c
+  end
+
+module CsolverOfC =
+  functor (S : CsolverC) -> (struct
+    type ('a, 'b) state = ('a, 'b) S.state
+    type session = S.session
+    type vec = S.vec
+    let csolve = d_of_dc S.csolve
+  end : Csolver)

src/lib/solvers/dune

@@ -1,4 +1,8 @@
-(env (dev (flags (:standard -w -9-27-32))))
+(env (dev (flags (:standard -w -32))))
 
 (library
-  (name solvers))
+  (name solvers)
+  (libraries
+    hsim
+    ;sundialsml
+    ))

src/lib/solvers/illinois.ml

@@ -27,7 +27,7 @@ let get_check_root rdir =
   let check_down   x0 x1 = if x0 > 0.0 && x1 <= 0.0 then -1l else 0l in
   let check_either x0 x1 = if x0 < 0.0 && x1 >= 0.0 then  1l else
                            if x0 > 0.0 && x1 <= 0.0 then -1l else 0l in
-  let no_check x0 x1 = 0l in
+  let no_check _x0 _x1 = 0l in
 
   match rdir with
   | Up     -> check_up
@@ -118,7 +118,7 @@ type t = {
   }
 
 (* Called from find when bothf_valid = false to initialise f1. *)
-let reinitialize ({ g; f1 = f1; t1 = t1 } as s) t c =
+let reinitialize ({ g; f1 = f1; t1 = t1; _ } as s) t c =
   s.t1 <- t;
   g t1 c f1;   (* fill f1, because it is immediately copied into f0 by next_mesh *)
   if !debug then (printf "z|---------- init(%.24e, ... ----------@." t;
@@ -148,10 +148,10 @@ let initialize nroots g c =
   s
 
 
-let num_roots { f0 } = Zls.length f0
+let num_roots { f0; _ } = Zls.length f0
 
 (* f0/t0 take the previous values of f1/t1, f1/t1 are refreshed by g *)
-let step ({ g; f0 = f0; f1 = f1; t1 = t1 } as s) t c =
+let step ({ g; f0 = f0; f1 = f1; t1 = t1; _ } as s) t c =
   (* swap f0 and f1; f0 takes the previous value of f1 *)
   s.f0 <- f1;
   s.t0 <- t1;
@@ -184,7 +184,7 @@ let resolve_intervals r1 r2 =
                    (possible) zero-crossing in (f_mid, f_right]
  *)
 let check_interval calc_zc f_left f_mid =
-  let check i r x0 x1 =
+  let check _i r x0 x1 =
     let rv = calc_zc x0 x1 in
     let r' = if rv = 0l then SearchRight
              else if x1 = 0.0 then FoundMid
@@ -340,17 +340,17 @@ let find s (dky, c) roots = find s (dky, c) roots
 
 (* is there a root? [has_root s: bool] is true is there is a change in sign *)
 (* for one component [i in [0..length f0 - 1]] beetwen [f0.(i)] and [f1.(i)] *)
-let has_roots { bothf_valid = bothf_valid; t0; f0; t1; f1; calc_zc = calc_zc }
-  = bothf_valid && (check_interval calc_zc f0 f1 <> SearchRight)
+let has_roots { bothf_valid; f0; f1; calc_zc; _ } =
+  bothf_valid && (check_interval calc_zc f0 f1 <> SearchRight)
 
-let takeoff { bothf_valid = bothf_valid; f0; f1 } =
+let takeoff { bothf_valid; f0; f1; _ } =
   bothf_valid && (takeoff f0 f1)
 
 (* returns true if a signal has moved from zero to a stritly positive value *)
 (* Added by MP. Ask Tim if this code is necessary, that is, what happens *)
 (* with function [find] when the signal is taking off from [0.0] to a *)
 (* strictly positive value *)
-let find_takeoff ({ f0; f1 } as s) roots =
+let find_takeoff ({ f0; f1; _ } as s) roots =
   let calc_zc x0 x1 =
     if (x0 = 0.0) && (x1 > 0.0) then 1l else 0l in
   let b = update_roots calc_zc f0 f1 roots in

src/lib/solvers/odexx.ml

@@ -156,7 +156,7 @@ struct (* {{{1 *)
   (* NB: y must be the initial state vector (y_0)
    *     k(0) must be the initial deriviatives vector (dy_0) *)
   let initial_stepsize { initial_step_size; abs_tol; rel_tol; max_step;
-                         time; y; hmax; k } =
+                         time; y; hmax; k; _ } =
     let hmin = 16.0 *. epsilon_float *. abs_float time in
     match initial_step_size with
     | Some h -> minmax hmin max_step h
@@ -168,7 +168,8 @@ struct (* {{{1 *)
       in
       max hmin (if hmax *. rh > 1.0 then 1.0 /. rh else hmax)
 
-  let reinitialize ?rhsfn ({ stop_time; min_step; max_step; sysf } as s) t ny =
+  let reinitialize
+      ?rhsfn ({ stop_time; min_step; max_step; sysf; _ } as s) t ny =
     Bigarray.Array1.blit ny s.y;
     s.time      <- t;
     s.last_time <- t;
@@ -250,9 +251,9 @@ struct (* {{{1 *)
 
   (* TODO: add stats: nfevals, nfailed, nsteps *)
   let step s t_limit user_y =
-    let { stop_time; min_step; abs_tol; rel_tol;
+    let { stop_time; abs_tol; rel_tol;
           sysf = f; time = t; h = h; hmax = hmax;
-          k = k; y = y; yold = ynew; } = s in
+          k = k; y = y; yold = ynew; _ } = s in
 
     (* First Same As Last (FSAL) swap; doing it after the previous
        step invalidates the interpolation routine. *)
@@ -323,7 +324,7 @@ struct (* {{{1 *)
     s.h <- nexth;
     s.time
 
-  let get_dky { last_time = t; time = t'; h = h; yold = y; k = k } yi ti kd =
+  let get_dky { last_time = t; time = t'; yold = y; k; _ } yi ti kd =
 
     if kd > 0 then
       failwith
@@ -355,11 +356,11 @@ struct (* {{{1 *)
     done
 
   (* copy functions *)
-  let copy ({ last_time; time; h; yold; k } as s) =
+  let copy ({ last_time; time; h; yold; k; _ } as s) =
     { s with last_time; time; h; yold = Zls.copy yold; k = Zls.copy_matrix k }
 
-  let blit { last_time = l1; time = t1; h = h1; yold = yhold1; k = k1 }
-      ({ last_time; time; h; yold; k } as s2) =
+  let blit { last_time = l1; time = t1; yold = yhold1; k = k1; _ }
+      ({ yold; k; _ } as s2) =
     s2.last_time <- l1; s2.time <- t1;
     Zls.blit yhold1 yold; Zls.blit_matrix k1 k
 

src/lib/solvers/statefulRK45.ml

@@ -0,0 +1,69 @@
+
+open Hsim.Types
+open Hsim.Solver
+open Zls
+
+module Functional : Csolver.CsolverC =
+  struct
+    type ('state, 'vec) state = { state: 'state; vec: 'vec }
+    type session = Odexx.Ode45.t
+    type vec = carray
+
+    let csolve : ((session, vec) state, carray, carray) csolver_c =
+      let open Odexx.Ode45 in
+
+      let init _ =
+        let v = Zls.cmake 0 in
+        let state = initialize (fun _ _ _ -> ()) (vec v) in
+        set_stop_time state 1.0; { state; vec=v } in
+
+      let reset { fder; init; stop; _ } _ = 
+        let fder t cvec dvec = Zls.blit (fder t cvec) dvec in
+        let state = initialize fder (vec init) in
+        set_stop_time state stop;
+        { state; vec = init } in
+
+      let step ({ state ; vec=v } as s) h =
+        let y_nv = vec v in
+        let h = step state h y_nv in
+        let state = copy state in
+        let dky t = get_dky state y_nv t 0; unvec y_nv in
+        (h, dky), s in
+
+      let copy { state; vec } = { state; vec } in
+
+      DNodeC { init; step; reset; copy }
+  end
+
+module InPlace : Csolver.CsolverC =
+  struct
+    type ('state, 'vec) state = { mutable state: 'state; mutable vec : 'vec }
+    type session = Odexx.Ode45.t
+    type vec = carray
+
+    let csolve : ((session, vec) state, carray, carray) csolver_c =
+      let open Odexx.Ode45 in
+
+      let init _ =
+        let v = Zls.cmake 0 in
+        let state = initialize (fun _ _ _ -> ()) (vec v) in
+        set_stop_time state 1.0;
+        { state; vec=v } in
+
+      let reset { fder; init; stop; _ } s =
+        let fder t cvec dvec =
+          let dvec' = fder t cvec in Zls.blit dvec' dvec in
+        let state = initialize fder (vec init) in
+        set_stop_time state stop; s.state <- state ; s.vec <- init; s in
+
+      let step ({ state; vec=v } as s) h =
+        let y_nv = vec v in
+        let h = step state h y_nv in
+        let get_dky t = get_dky state y_nv t 0; unvec y_nv in
+        (h, get_dky), s in
+
+      let copy { state; vec } =
+        { state = copy state; vec = Zls.copy vec } in
+
+      DNodeC { init; reset; step; copy }
+  end

src/lib/solvers/statefulSundials.ml

@@ -0,0 +1,71 @@
+(*
+open Hsim.Types
+open Hsim.Solver
+open Zls
+
+module Functional : Csolver.Csolver =
+  struct
+    type ('state, 'vec) state = { state : 'state; vec : 'vec }
+    type session = (Sundials_RealArray.t, Nvector_serial.kind) Cvode.session
+    type vec = carray
+
+    let csolve : ((session, vec) state, carray, carray) csolver =
+      let open Cvode in
+
+      let init { size; fder=_; _ } =
+        let vec = cmake size in
+        let state = init Adams default_tolerances (fun _ _ _ -> ()) 0.
+                         (Nvector_serial.wrap vec) in
+        set_stop_time state 1.0;
+        { state; vec } in
+
+      let reset { init=i; fder; stop; _ } { vec; _ } =
+        let fder t cvec dvec =
+          let dvec' = fder t cvec in blit dvec' dvec in
+        let state =
+          Cvode.init Adams default_tolerances fder 0. (Nvector_serial.wrap i) in
+        set_stop_time state stop;
+        { state; vec } in
+
+      let step ({ state; vec } as s) h =
+        let y = Nvector_serial.wrap vec in
+        let h, _ = solve_one_step state h y in
+        let f t = get_dky state y t 0; Nvector_serial.unwrap y in
+        (h, f), s in
+
+      DNode { init; reset; step }
+  end
+
+module InPlace : Csolver.Csolver =
+  struct
+    type ('state, 'vec) state = { mutable state: 'state; mutable vec : 'vec }
+
+    type session = (Sundials_RealArray.t, Nvector_serial.kind) Cvode.session
+    type vec = carray
+
+    let csolve : ((session, vec) state, carray, carray) csolver =
+      let open Cvode in
+
+      let init { size; fder=_; _ } =
+        let vec = cmake size in
+        let state = init Adams default_tolerances (fun _ _ _ -> ()) 0.
+                         (Nvector_serial.wrap vec) in
+        set_stop_time state 1.0;
+        { state; vec } in
+
+      let reset { init=i; fder; _ } s =
+        let fder t cvec dvec =
+          let dvec' = fder t cvec in blit dvec' dvec in
+        let state =
+          Cvode.init Adams default_tolerances fder 0. (Nvector_serial.wrap i) in
+        set_stop_time state 1.0; s.state <- state; s.vec <- i; s in
+
+      let step s h =
+        let y = Nvector_serial.wrap s.vec in
+        let h, _ = solve_one_step s.state h y in
+        let f t = get_dky s.state y t 0; Nvector_serial.unwrap y in
+        (h, f), s in 
+
+      DNode { init; reset; step }
+  end
+*)

src/lib/solvers/statefulZ.ml

@@ -0,0 +1,69 @@
+
+open Hsim.Types
+open Hsim.Solver
+open Zls
+
+module Functional : Zsolver.ZsolverC =
+  struct
+
+    type ('state, 'vec) state = { state: 'state; vec: 'vec }
+    type session = Illinois.t
+    type vec = zarray
+
+    let zsolve : ((session, vec) state, carray, vec, carray) zsolver_c =
+      let open Illinois in
+
+      let init _ =
+        { state = initialize 0 (fun _ _ _ -> ()) (cmake 0);
+          vec = zmake 0 } in
+
+      let reset { fzer; init; size } { vec; _ } =
+        let fzer t cvec zout = let zout' = fzer t cvec in blit zout' zout in
+        { state = initialize size fzer init;
+          vec = if length vec = size then vec else zmake size } in
+
+      let step ({ state; vec } as s) (h, fder) =
+        let y1 = fder h in
+        let fder h _ = let y = fder h in blit y y1 in
+        step state h y1;
+        if has_roots state then
+          let h = find state (fder, y1) vec in
+          (h, Some vec), s
+        else (h, None), s in
+
+      let copy s = s in
+
+      DNodeC { init; step; reset; copy }
+  end
+
+module InPlace : Zsolver.ZsolverC =
+  struct
+    type ('state, 'vec) state = { mutable state : 'state; mutable vec : 'vec }
+    type session = Illinois.t
+    type vec = zarray
+
+    let zsolve : ((session, vec) state, carray, vec, carray) zsolver_c =
+      let open Illinois in
+
+      let init _ =
+        { state=initialize 0 (fun _ _ _ -> ()) (cmake 0);
+          vec=zmake 0 } in
+
+      let reset { size; init; fzer } s =
+        let fzer t cvec zout = let zout' = fzer t cvec in blit zout' zout in
+        s.state <- initialize size fzer init;
+        if length s.vec <> size then s.vec <- zmake size; s in
+
+      let step ({ state; vec } as s) (h, fder) =
+        let y = fder h in
+        let fder h _ = let y' = fder h in blit y' y in
+        step state h y;
+        if has_roots state then
+          let h = find state (fder, y) vec in
+          (h, Some vec), s
+        else (h, None), s in
+
+      let copy _ = raise Common.Errors.TODO in
+      
+      DNodeC { init; step; reset; copy }
+  end

src/lib/solvers/zsolver.ml

@@ -0,0 +1,28 @@
+
+open Hsim.Types
+open Hsim.Solver
+open Zls
+
+module type Zsolver =
+  sig
+    type ('a, 'b) state
+    type session
+    type vec
+    val zsolve : ((session, vec) state, carray, zarray, carray) zsolver
+  end
+
+module type ZsolverC =
+  sig
+    type ('a, 'b) state
+    type session
+    type vec
+    val zsolve : ((session, vec) state, carray, zarray, carray) zsolver_c
+  end
+
+module ZsolverOfC =
+  functor (S : ZsolverC) -> (struct
+    type ('a, 'b) state = ('a, 'b) S.state
+    type session = S.session
+    type vec = S.vec
+    let zsolve = d_of_dc S.zsolve
+  end : Zsolver)