create "Adam" math library

src/adam/adam.ml

@@ -0,0 +1,294 @@
+module type Copy = sig
+  type t
+  val copy : src:t -> t -> unit
+end
+
+module type Show = sig
+  type t
+  val pp : Format.formatter -> t -> unit
+end
+
+module Float_infix = struct
+  let ( + ) = ( +. )
+  let ( - ) = ( -. )
+  let ( * ) = ( *. )
+  let ( / ) = ( /. )
+  let ( ~- ) = ( ~-. )
+  let ( = ) = Float.equal
+  let[@inline] ( < ) x y = Float.compare x y < 0
+  let[@inline] ( <= ) x y = Float.compare x y <= 0
+  let[@inline] ( > ) x y = Float.compare x y > 0
+  let[@inline] ( >= ) x y = Float.compare x y >= 0
+  let[@inline] ( <> ) x y = not (x = y)
+  let flt = Float.of_int
+  let int = Int.of_float
+end
+
+module Int_infix = struct
+  let ( + ) = ( + )
+  let ( - ) = ( - )
+  let ( * ) = ( * )
+  let ( / ) = ( / )
+  let ( ~- ) = ( ~- )
+  let ( = ) = Int.equal
+  let[@inline] ( < ) x y = Int.compare x y < 0
+  let[@inline] ( <= ) x y = Int.compare x y <= 0
+  let[@inline] ( > ) x y = Int.compare x y > 0
+  let[@inline] ( >= ) x y = Int.compare x y >= 0
+  let[@inline] ( <> ) x y = not (x = y)
+  let flt = Float.of_int
+  let int = Int.of_float
+end
+
+module Vec2 = struct
+  type t = {
+    mutable x : float;
+    mutable y : float;
+  }
+
+  let pp ppf { x; y } =
+    Format.fprintf ppf "[%.1f; %.1f]" x y
+
+  let[@inline] make (x : float) (y : float) : t =
+    { x; y }
+
+  let[@inline] set ~x ~y t =
+    begin
+      t.x <- x;
+      t.y <- y;
+    end
+
+  let[@inline] copy ~src dst =
+    begin
+      dst.x <- src.x;
+      dst.y <- src.y;
+    end
+end
+
+type vec2 = Vec2.t
+
+let vec2 = Vec2.make
+
+module Mat2A = struct
+  open Float_infix
+
+  type t = {
+    mutable a0 : float;
+    mutable a1 : float;
+    mutable a2 : float;
+    mutable a3 : float;
+    mutable a4 : float;
+    mutable a5 : float;
+  }
+
+  let pp ppf { a0; a1; a2; a3; a4; a5 } =
+    Format.fprintf ppf "[%.1f %.1f %.1f; %.1f %.1f %.1f]" a0 a1 a2 a3 a4 a5
+
+  let[@inline] make (tx : float) (ty : float) (sx : float) (sy : float) : t =
+    { a0 = sx; a1 = 0.0; a2 = tx; a3 = 0.0; a4 = sy; a5 = ty }
+
+  (* TODO: rotation *)
+
+  let[@inline] set ~tx ~ty ~sx ~sy t =
+    begin
+      t.a0 <- sx;
+      t.a1 <- 0.0;
+      t.a2 <- tx;
+      t.a3 <- 0.0;
+      t.a4 <- sy;
+      t.a5 <- ty;
+    end
+
+  let[@inline] copy ~src dst =
+    begin
+      dst.a0 <- src.a0;
+      dst.a1 <- src.a1;
+      dst.a2 <- src.a2;
+      dst.a3 <- src.a3;
+      dst.a4 <- src.a4;
+      dst.a5 <- src.a5;
+    end
+
+  (*
+  let[@inline] mul (lhs : t) (rhs : t) : unit =
+    let { a0; a1; a2; a3; a4; a5 } = lhs in
+    begin
+      lhs.a0 <- (a0 * rhs.a0) + (a1 * rhs.a3);
+      lhs.a1 <- (a0 * rhs.a1) + (a1 * rhs.a4);
+      lhs.a2 <- (a0 * rhs.a2) + (a1 * rhs.a5) + a2;
+      lhs.a3 <- (a3 * rhs.a0) + (a4 * rhs.a3);
+      lhs.a4 <- (a3 * rhs.a1) + (a4 * rhs.a4);
+      lhs.a5 <- (a3 * rhs.a2) + (a4 * rhs.a5) + a5;
+    end
+
+  let[@inline] tra (dst : t) ~(tx : float) ~(ty : float) =
+    begin
+      dst.a2 <- (dst.a0 * tx) + (dst.a1 * ty) + dst.a2;
+      dst.a5 <- (dst.a3 * tx) + (dst.a4 * ty) + dst.a5;
+    end
+
+  let[@inline] sca (dst : t) ~(sx : float) ~(sy : float) =
+    begin
+      dst.a0 <- dst.a0 * sx;
+      dst.a1 <- dst.a1 * sy;
+      dst.a3 <- dst.a3 * sx;
+      dst.a4 <- dst.a4 * sy;
+    end
+
+  let inv (dst : t) (src : t) =
+    begin
+      let { a0; a1; a2; a3; a4; a5 } = src in
+      let b2 = (a1 * a5) - (a2 * a4) in
+      let b5 = (a2 * a3) - (a0 * a5) in
+      let det = (a0 * a4) - (a1 * a3) in
+      dst.a0 <- a4 / det;
+      dst.a1 <- a1 / -det;
+      dst.a2 <- b2 / det;
+      dst.a3 <- a3 / -det;
+      dst.a4 <- a0 / det;
+      dst.a5 <- b5 / det;
+    end
+*)
+
+  let apply (t : t) (v : vec2) =
+    let Vec2.{ x; y } = v in
+    begin
+      v.x <- (t.a0 * x) + (t.a1 * y) + t.a2;
+      v.y <- (t.a3 * x) + (t.a4 * y) + t.a5;
+    end
+
+  let apply_inv (t : t) (v : vec2) =
+    let Vec2.{ x; y } = v in
+    let b2 = (t.a1 * t.a5) - (t.a2 * t.a4) in
+    let b5 = (t.a2 * t.a3) - (t.a0 * t.a5) in
+    let det = (t.a0 * t.a4) - (t.a1 * t.a3) in
+    begin
+      v.x <- ((t.a4 * x) - (t.a1 * y) + b2) / det;
+      v.y <- ((t.a0 * y) - (t.a3 * x) + b5) / det;
+    end
+end
+
+type mat2a = Mat2A.t
+
+let mat2a = Mat2A.make
+
+module Color = struct
+  open Float_infix
+
+  type t = {
+    mutable r : float;
+    mutable g : float;
+    mutable b : float;
+    mutable a : float;
+    (* alpha is pre-multiplied *)
+  }
+
+  let pp ppf { r; g; b; a } =
+    let byte x =
+      let y = Float.round (x * 255.0) in
+      if y < 0.0 then 0
+      else if y > 255.0 then 255
+      else int y
+    in
+    let hex r g b =
+      (byte r lsl 16) lor (byte g lsl 8) lor byte b
+    in
+    if a < 1.0 then
+      let rgb = hex (r / a) (g / a) (b / a) in
+      Format.fprintf ppf "#%06x" rgb
+    else
+      let rgb = hex r g b in
+      Format.fprintf ppf "#%06x;%.2f" rgb a
+
+  let invisible () = { r = 0.0; g = 0.0; b = 0.0; a = 0.0 }
+  let black ?(a = 1.) () = { r = 0.0; g = 0.0; b = 0.0; a }
+  let white ?(a = 1.) () = { r = a; g = a; b = a; a }
+
+  let[@inline] set_white ?(a = 1.) t =
+    begin
+      t.r <- a;
+      t.g <- a;
+      t.b <- a;
+      t.a <- a;
+    end
+
+  let[@inline] set_rgb24 ?(a = 1.) t vv =
+    let r = (vv lsr 16) land 0xff in
+    let g = (vv lsr 8)  land 0xff in
+    let b = vv          land 0xff in
+    begin
+      t.r <- flt r / 255.0 * a;
+      t.g <- flt g / 255.0 * a;
+      t.b <- flt b / 255.0 * a;
+      t.a <- a;
+    end
+
+  let[@inline] copy ~src dst =
+    begin
+      dst.r <- src.r;
+      dst.g <- src.g;
+      dst.b <- src.b;
+      dst.a <- src.a;
+    end
+
+  let[@inline] rgb24 ?(a = 1.) v =
+    let dst = invisible () in
+    set_rgb24 dst v ~a;
+    dst
+
+  let[@inline] mul ?(r = 1.) ?(g = 1.) ?(b = 1.) ?(a = 1.) (t : t) =
+    begin
+      t.r <- t.r * r * a;
+      t.g <- t.g * g * a;
+      t.b <- t.b * b * a;
+      t.a <- t.a * a;
+    end
+end
+
+type color = Color.t
+
+let rgb24 = Color.rgb24
+
+module AABB = struct
+  open Float_infix
+
+  type t = {
+    mutable x0 : float;
+    mutable y0 : float;
+    mutable x1 : float;
+    mutable y1 : float;
+  }
+
+  let pp ppf { x0; y0; x1; y1 } =
+    Format.fprintf ppf "[%.1f; %.1f; %.1f; %.1f]" x0 y0 x1 y1
+
+  let[@inline] make (x0 : float) (y0 : float) (x1 : float) (y1 : float) : t =
+    { x0; y0; x1; y1 }
+
+  let[@inline] set ?(x0 = 0.0) ?(y0 = 0.0) ?(x1 = 0.0) ?(y1 = 0.0) dst =
+    begin
+      dst.x0 <- x0;
+      dst.y0 <- y0;
+      dst.x1 <- x1;
+      dst.y1 <- y1;
+    end
+
+  let[@inline] copy ~src dst =
+    begin
+      dst.x0 <- src.x0;
+      dst.y0 <- src.y0;
+      dst.x1 <- src.x1;
+      dst.y1 <- src.y1;
+    end
+
+  let mem (t : t) (v : vec2) : bool =
+    v.x >= t.x0 && v.y >= t.y0 &&
+    v.x <= t.x1 && v.y <= t.y1
+
+  let is_empty (t : t) : bool =
+    t.x1 <= t.x0 || t.y1 <= t.y0
+end
+
+type aabb = AABB.t
+
+let aabb = AABB.make

src/adam/dune

@@ -0,0 +1,3 @@
+(library
+ (name adam)
+ (package geometra))

src/dune

@@ -3,6 +3,8 @@
  (package geometra)
  (public_name geometra)
  (libraries
+   adam
+
    ohlog
    tsdl
    tgls.tgl4))

src/import.ml

@@ -1,3 +1,5 @@
+include Adam
+
 module Sdl = struct
   include Tsdl.Sdl