diff --git a/claudius.opam b/claudius.opam index 5b16b4d..8ca0ba6 100644 --- a/claudius.opam +++ b/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} ] diff --git a/dune-project b/dune-project index 051b1bd..f0c23ed 100644 --- a/dune-project +++ b/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))) diff --git a/src/dune b/src/dune index d7eda59..02e428f 100644 --- a/src/dune +++ b/src/dune @@ -7,4 +7,4 @@ (library (name claudius) (public_name claudius) - (libraries tsdl giflib crunch)) + (libraries tsdl giflib crunch imagelib imagelib.unix)) diff --git a/src/framebuffer.ml b/src/framebuffer.ml index 4852eec..7aa9644 100644 --- a/src/framebuffer.ml +++ b/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 (* ----- *) diff --git a/src/framebuffer.mli b/src/framebuffer.mli index 94a1c42..066d4e7 100644 --- a/src/framebuffer.mli +++ b/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 diff --git a/src/palette.ml b/src/palette.ml index bde1031..4ae8449 100644 --- a/src/palette.ml +++ b/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 diff --git a/src/palette.mli b/src/palette.mli index 8b6e2a6..7780e09 100644 --- a/src/palette.mli +++ b/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. *) diff --git a/src/picture.ml b/src/picture.ml new file mode 100644 index 0000000..e13f3a7 --- /dev/null +++ b/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 } diff --git a/src/picture.mli b/src/picture.mli new file mode 100644 index 0000000..d119e9a --- /dev/null +++ b/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. *) diff --git a/src/primitives.ml b/src/primitives.ml index 9b85da6..7306c16 100644 --- a/src/primitives.ml +++ b/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 diff --git a/src/primitives.mli b/src/primitives.mli index 9e040d7..79c1346 100644 --- a/src/primitives.mli +++ b/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 diff --git a/src/screen.ml b/src/screen.ml index 4c7d26a..b958afc 100644 --- a/src/screen.ml +++ b/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 diff --git a/src/screen.mli b/src/screen.mli index 7f7a0bc..d53bd25 100644 --- a/src/screen.mli +++ b/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. *) diff --git a/test/dune b/test/dune index 3fa9419..76f6e23 100644 --- a/test/dune +++ b/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)) diff --git a/test/test_picture.ml b/test/test_picture.ml new file mode 100644 index 0000000..8a0ca88 --- /dev/null +++ b/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 diff --git a/test_assets/tetris.png b/test_assets/tetris.png new file mode 100644 index 0000000..291d3b7 Binary files /dev/null and b/test_assets/tetris.png differ diff --git a/test_assets/tetris.png:Zone.Identifier b/test_assets/tetris.png:Zone.Identifier new file mode 100644 index 0000000..b160fdc --- /dev/null +++ b/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