diff --git a/src/adam/adam.ml b/src/adam/adam.ml new file mode 100644 index 0000000..0a8cb58 --- /dev/null +++ b/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 diff --git a/src/adam/dune b/src/adam/dune new file mode 100644 index 0000000..b7557e4 --- /dev/null +++ b/src/adam/dune @@ -0,0 +1,3 @@ +(library + (name adam) + (package geometra)) diff --git a/src/dune b/src/dune index 8b70c3b..20d2be8 100644 --- a/src/dune +++ b/src/dune @@ -3,6 +3,8 @@ (package geometra) (public_name geometra) (libraries + adam + ohlog tsdl tgls.tgl4)) diff --git a/src/import.ml b/src/import.ml index 9c87c89..9c593c9 100644 --- a/src/import.ml +++ b/src/import.ml @@ -1,3 +1,5 @@ +include Adam + module Sdl = struct include Tsdl.Sdl