[Feat]: Image loading using ocaml-imagelib library

claudius.opam

@@ -28,6 +28,7 @@ depends: [
   "ounit2" {with-test}
   "odoc" {with-doc}
   "giflib" {>= "1.0.3"}
+  "imagelib" {>= "20221222"}
   "crunch" {>= "4.0.0"}
   "ocamlformat" {>= "0.27.0" & with-dev-setup}
 ]

dune-project

@@ -19,7 +19,7 @@
  (name claudius)
  (synopsis "A retro-style graphics library")
  (description "An functional style retro-graphics library for OCaml for building generative art, demos, and games.")
- (depends (ocaml (>= 5.1)) dune (tsdl (>= 1.1.0)) (ounit2 :with-test) (odoc :with-doc) (giflib (>= 1.0.3)) (crunch (>= 4.0.0)) (ocamlformat (and (>= 0.27.0) :with-dev-setup )))
+ (depends (ocaml (>= 5.1)) dune (tsdl (>= 1.1.0)) (ounit2 :with-test) (odoc :with-doc) (giflib (>= 1.0.3)) (imagelib (>= 20221222)) (crunch (>= 4.0.0)) (ocamlformat (and (>= 0.27.0) :with-dev-setup )))
  (tags
   (graphics rendering paletted)))
 

src/dune

@@ -7,4 +7,4 @@
 (library
  (name claudius)
  (public_name claudius)
- (libraries tsdl giflib crunch))
+ (libraries tsdl giflib crunch imagelib imagelib.unix))

src/framebuffer.ml

@@ -461,6 +461,28 @@ let filled_polygon (points : (int * int) list) (col : int) (buffer : t) =
         map;
       buffer.dirty <- true
 
+let draw_picture (pic : Picture.t) ?(scale = 1.0) (offset_x : int)
+    (offset_y : int) (fb : t) : unit =
+  let src_w = Picture.original_width pic in
+  let src_h = Picture.original_height pic in
+  let dst_w = int_of_float (float src_w *. scale) in
+  let dst_h = int_of_float (float src_h *. scale) in
+  let pixels = Picture.pixels pic in
+  for y = 0 to dst_h - 1 do
+    for x = 0 to dst_w - 1 do
+      let src_x = min (src_w - 1) (int_of_float (float x /. scale)) in
+      let src_y = min (src_h - 1) (int_of_float (float y /. scale)) in
+      let idx = (src_y * src_w) + src_x in
+      let color_index = pixels.(idx) in
+
+      if color_index <> 0 then
+        let fb_x = x + offset_x in
+        let fb_y = y + offset_y in
+        pixel_write fb_x fb_y color_index fb
+    done
+  done;
+  fb.dirty <- true
+
 (* ----- *)
 
 let draw_char (x : int) (y : int) (f : Font.t) (c : char) (col : int)
@@ -559,7 +581,9 @@ let render (buffer : t) (draw : Primitives.t list) =
       | Primitives.Char (p, font, c, col) ->
           ignore (draw_char p.x p.y font c col buffer)
       | Primitives.String (p, font, s, col) ->
-          ignore (draw_string p.x p.y font s col buffer))
+          ignore (draw_string p.x p.y font s col buffer)
+      | Primitives.Picture (pos, pic) ->
+          draw_picture pic ~scale:1.0 pos.x pos.y buffer)
     draw
 
 (* ----- *)

src/framebuffer.mli

@@ -89,6 +89,11 @@ val filled_polygon : (int * int) list -> int -> t -> unit
 (** [filled_polygon points colour framebuffer] Draws a filled polygon made from
     the list of [points] in the specified [colour] into [framebuffer]. *)
 
+val draw_picture : Picture.t -> ?scale:float -> int -> int -> t -> unit
+(** [draw_picture pic ?scale x y buffer] draws [pic] onto [buffer] at position
+    (x, y). The picture is scaled uniformly by [scale], which defaults to 1.0 if
+    omitted. *)
+
 val draw_char : int -> int -> Font.t -> char -> int -> t -> int
 (** [draw_char x y font c colour framebuffer] Draws a single character [c] in
     the specified [colour] using [font]. The top left of the charcter is the

src/palette.ml

@@ -232,3 +232,17 @@ let updated_entry (pal : t) (index : int) (new_color : int * int * int) : t =
     let new_pal = Array.copy pal in
     new_pal.(index) <- new_int;
     new_pal
+
+let concat (palettes : t list) : t =
+  let total_len =
+    List.fold_left (fun acc pal -> acc + Array.length pal) 0 palettes
+  in
+  let result = Array.make total_len 0l in
+  let _ =
+    List.fold_left
+      (fun offset pal ->
+        Array.iteri (fun i v -> result.(offset + i) <- v) pal;
+        offset + Array.length pal)
+      0 palettes
+  in
+  result

src/palette.mli

@@ -83,3 +83,6 @@ val circle_palette : t -> int -> t
 val updated_entry : t -> int -> int * int * int -> t
 (** [updated_entry pal index new_color] checks for the index then returns a new
     palette with the entry at [index] updated to [new_color]. *)
+
+val concat : t list -> t
+(** [concat palettes] merges a list of palettes into a single palette. *)

src/picture.ml

@@ -0,0 +1,83 @@
+open Image
+
+type t = { palette : Palette.t; pixels : int array; width : int; height : int }
+
+let load_png_as_indexed (filepath : string) : Palette.t * int array * int * int
+    =
+  let img = ImageLib_unix.openfile filepath in
+  let w = img.width in
+  let h = img.height in
+
+  let pixels_rgba =
+    Array.init (w * h) (fun idx ->
+        let x = idx mod w in
+        let y = idx / w in
+        match img.pixels with
+        | RGB (r, g, b) ->
+            let red = Pixmap.get r x y in
+            let green = Pixmap.get g x y in
+            let blue = Pixmap.get b x y in
+            (red, green, blue, 255)
+            (* 255 means fully opaque *)
+        | RGBA (r, g, b, a) ->
+            let red = Pixmap.get r x y in
+            let green = Pixmap.get g x y in
+            let blue = Pixmap.get b x y in
+            let alpha = Pixmap.get a x y in
+            (red, green, blue, alpha)
+        | Grey p ->
+            let g = Pixmap.get p x y in
+            (g, g, g, 255)
+        | GreyA (p, a) ->
+            let g = Pixmap.get p x y in
+            let alpha = Pixmap.get a x y in
+            (g, g, g, alpha))
+  in
+
+  let module ColorMap = Map.Make (struct
+    type t = int * int * int
+
+    let compare = compare
+  end) in
+  let palette_map, palette_list, _ =
+    Array.fold_left
+      (fun (map, lst, idx) (r, g, b, a) ->
+        if a = 0 then (map, lst, idx) (* transparent pixel *)
+        else if ColorMap.mem (r, g, b) map then (map, lst, idx)
+        else (ColorMap.add (r, g, b) idx map, lst @ [ (r, g, b) ], idx + 1))
+      (ColorMap.empty, [], 1) (* index 0 is being used for transparency *)
+      pixels_rgba
+  in
+
+  let palette_rgb_24 =
+    0x000000
+    :: List.map (fun (r, g, b) -> (r lsl 16) lor (g lsl 8) lor b) palette_list
+  in
+
+  let pal = Palette.of_list palette_rgb_24 in
+
+  let indexed_pixels =
+    Array.map
+      (fun (r, g, b, a) ->
+        if a = 0 then 0 else ColorMap.find (r, g, b) palette_map)
+      pixels_rgba
+  in
+
+  (pal, indexed_pixels, w, h)
+
+(* Public API, so real img data isn't tampered *)
+
+let load (filepath : string) : t =
+  let palette, pixels, w, h = load_png_as_indexed filepath in
+  { palette; pixels; width = w; height = h }
+
+let original_width (pic : t) = pic.width
+let original_height (pic : t) = pic.height
+let pixels (pic : t) = pic.pixels
+let palette (pic : t) = pic.palette
+
+let with_palette_offset (pic : t) (offset : int) : t =
+  let shifted_pixels =
+    Array.map (fun idx -> if idx = 0 then 0 else idx + offset) pic.pixels
+  in
+  { pic with pixels = shifted_pixels }

src/picture.mli

@@ -0,0 +1,21 @@
+type t
+(** Abstract type representing a loaded picture *)
+
+val load : string -> t
+(** [load filename] loads a PNG file and returns a picture. *)
+
+val original_width : t -> int
+(** [original_width pic] returns the original width in pixels. *)
+
+val original_height : t -> int
+(** [original_height pic] returns the original height in pixels. *)
+
+val pixels : t -> int array
+(** [pixels pic] returns the indexed pixel array. *)
+
+val palette : t -> Palette.t
+(** [palette pic] returns the color palette of the picture. *)
+
+val with_palette_offset : t -> int -> t
+(** [with_palette_offset pic offset] returns a new picture with all pixel
+    indices shifted by [offset]. Palette is unchanged. *)

src/primitives.ml

@@ -15,3 +15,4 @@ type t =
   | FilledTriangle of point * point * point * int
   | Char of point * Font.t * char * int
   | String of point * Font.t * string * int
+  | Picture of point * Picture.t

src/primitives.mli

@@ -18,3 +18,4 @@ type t =
   | FilledTriangle of point * point * point * int
   | Char of point * Font.t * char * int
   | String of point * Font.t * string * int
+  | Picture of point * Picture.t

src/screen.ml

@@ -5,10 +5,11 @@ type t = {
   mutable palette : Palette.t;
   font : Font.t;
   mutable dirty : bool;
+  pictures : Picture.t array;
 }
 
-let create ?font (width : int) (height : int) (scale : int)
-    (palette : Palette.t) : t =
+let create ?font ?(image_filenames = []) (width : int) (height : int)
+    (scale : int) (palette : Palette.t) : t =
   if scale <= 0 then raise (Invalid_argument "Invalid scale");
   if width <= 0 then raise (Invalid_argument "Invalid width");
   if height <= 0 then raise (Invalid_argument "Invalid height");
@@ -30,7 +31,32 @@ let create ?font (width : int) (height : int) (scale : int)
             failwith (Printf.sprintf "Failed to load default font: %s" e))
   in
 
-  { width; height; scale; palette; font; dirty = true }
+  let pictures, all_palettes =
+    let init_offset = Palette.size palette in
+    let init_acc = ([], init_offset, [ palette ]) in
+    let pics_rev, _, palettes_rev =
+      List.fold_left
+        (fun (pics_acc, offset_acc, palettes_acc) filename ->
+          let pic = Picture.load filename in
+          let shifted = Picture.with_palette_offset pic offset_acc in
+          let next_offset = offset_acc + Palette.size (Picture.palette pic) in
+          (shifted :: pics_acc, next_offset, Picture.palette pic :: palettes_acc))
+        init_acc image_filenames
+    in
+    (List.rev pics_rev |> Array.of_list, List.rev palettes_rev)
+  in
+
+  let final_palette = Palette.concat all_palettes in
+
+  {
+    width;
+    height;
+    scale;
+    palette = final_palette;
+    font;
+    dirty = true;
+    pictures;
+  }
 
 let update_palette (screen : t) (new_palette : Palette.t) : unit =
   screen.palette <- new_palette;
@@ -46,3 +72,4 @@ let font (screen : t) : Font.t = screen.font
 let scale (screen : t) : int = screen.scale
 let is_dirty (screen : t) : bool = screen.dirty
 let clear_dirty (screen : t) : unit = screen.dirty <- false
+let pictures (screen : t) : Picture.t array = screen.pictures

src/screen.mli

@@ -6,13 +6,22 @@ type t
 
 (** {1 Initializations} *)
 
-val create : ?font:Font.t -> int -> int -> int -> Palette.t -> t
+val create :
+  ?font:Font.t ->
+  ?image_filenames:string list ->
+  int ->
+  int ->
+  int ->
+  Palette.t ->
+  t
 (** [create font width height scale palette] Creates a new screen of the
     specified size [width] x [height], and it will be rendered in a window
     scaled up by the [scale] factor provided. The framebuffers used when running
     will be indexed into the [palette] provided here. Raises [Invalid_argument]
     if the dimensions or scale are either zero or negative. If no [font] is
-    provided then a default font is used. *)
+    provided then a default font is used. If [image_filenames] is provided, the
+    images will be loaded and their palettes merged into the screen's global
+    palette.*)
 
 val update_palette : t -> Palette.t -> unit
 (**[update screen new_palette] creates a new screen with updated palette and
@@ -44,3 +53,6 @@ val is_dirty : t -> bool
 
 val clear_dirty : t -> unit
 (** [clear_dirty screen] returns a new screen with the dirty flag cleared. *)
+
+val pictures : t -> Picture.t array
+(** [pictures screen] returns the array of pictures loaded into the screen. *)

test/dune

@@ -10,5 +10,8 @@
   test_screenshot
   test_events
   test_stats
-  test_animation)
+  test_animation
+  test_picture)
+ (deps
+  (source_tree ../test_assets))
  (libraries claudius ounit2))

test/test_picture.ml

@@ -0,0 +1,74 @@
+open OUnit2
+open Claudius
+open Picture
+
+let test_valid_png _ =
+  (* Credits for tetris.png: https://publicdomainvectors.org/en/free-clipart/3D-Tetris-blocks-vector-illustration/6089.html *)
+  let pic = load "../test_assets/tetris.png" in
+  assert_bool "width > 0" (original_width pic > 0);
+  assert_bool "height > 0" (original_height pic > 0);
+  assert_bool "has pixels" (Array.length (pixels pic) > 0)
+
+let test_scaled_dimensions _ =
+  let pic = load "../test_assets/tetris.png" in
+  let w = original_width pic in
+  let h = original_height pic in
+  assert_equal w (Array.length (pixels pic) / h)
+
+let test_draw_picture_normal _ =
+  let pic = load "../test_assets/tetris.png" in
+  let pal = palette pic in
+  assert_bool "palette has entries" (Palette.size pal > 0);
+  assert_bool "pixels reference palette" (pixels pic |> Array.exists (( <> ) 0))
+
+let test_draw_picture_negative_offset _ =
+  let pic = load "../test_assets/tetris.png" in
+  let shifted = with_palette_offset pic (-1) in
+  Array.iteri
+    (fun i idx ->
+      if idx = 0 then assert_equal 0 (pixels shifted).(i)
+      else assert_equal (idx - 1) (pixels shifted).(i))
+    (pixels pic)
+
+let test_draw_picture_scaled _ =
+  let pic = load "../test_assets/tetris.png" in
+  let w = original_width pic in
+  let h = original_height pic in
+  assert_equal (w * h) (Array.length (pixels pic))
+
+let test_load_png_as_indexed_transparent _ =
+  let pic = Picture.load "../test_assets/tetris.png" in
+  let pal = Picture.palette pic in
+  let pixels = Picture.pixels pic in
+  let w = Picture.original_width pic in
+  let h = Picture.original_height pic in
+  assert_bool "image has width > 0" (w > 0);
+  assert_bool "image has height > 0" (h > 0);
+  (* palette[0] reserved for transparency *)
+  assert_equal 0x000000l (Palette.index_to_rgb pal 0);
+  assert_bool "transparent pixel present" (Array.exists (( = ) 0) pixels)
+
+let test_with_palette_offset _ =
+  let pic = load "../test_assets/tetris.png" in
+  let shifted = with_palette_offset pic 10 in
+  Array.iteri
+    (fun i idx ->
+      if idx = 0 then assert_equal 0 (pixels shifted).(i)
+        (* transparency stays 0 *)
+      else assert_equal (idx + 10) (pixels shifted).(i))
+    (pixels pic)
+
+let suite =
+  "Picture tests"
+  >::: [
+         "valid_png" >:: test_valid_png;
+         "scaled_dimensions" >:: test_scaled_dimensions;
+         "draw_picture_normal" >:: test_draw_picture_normal;
+         "draw_picture_negative_offset" >:: test_draw_picture_negative_offset;
+         "draw_picture_scaled" >:: test_draw_picture_scaled;
+         "load_png_as_indexed transparent"
+         >:: test_load_png_as_indexed_transparent;
+         "with_palette_offset" >:: test_with_palette_offset;
+       ]
+
+let () = run_test_tt_main suite

test_assets/tetris.png:Zone.Identifier

@@ -0,0 +1,4 @@
+[ZoneTransfer]
+ZoneId=3
+ReferrerUrl=https://publicdomainvectors.org/en/free-clipart/3D-Tetris-blocks-vector-illustration/6089.html
+HostUrl=https://publicdomainvectors.org/photos/Tetris_block.png