From aee6130077ec1e7e7c8b4a46935352b802e4465d Mon Sep 17 00:00:00 2001 From: Michael Dales Date: Fri, 12 Sep 2025 11:42:55 +0100 Subject: [PATCH 1/7] Remove global state from base.ml --- src/base.ml | 83 ++++++++++++++++++++++++++++++++-------------------- src/base.mli | 3 -- 2 files changed, 51 insertions(+), 35 deletions(-) diff --git a/src/base.ml b/src/base.ml index e8dea97..7a72776 100644 --- a/src/base.ml +++ b/src/base.ml @@ -10,9 +10,6 @@ end) module PlatformKey = Keysdl module PlatformMouse = Mousesdl -let show_stats = ref false -let recording_state : Animation.recording_state_t option ref = ref None - type input_state = { keys : KeyCodeSet.t; events : Event.t list; @@ -20,6 +17,11 @@ type input_state = { mouse : Mouse.t; } +type t = { + show_stats : bool; + recording_state : Animation.recording_state_t option; +} + type boot_func = Screen.t -> Framebuffer.t type tick_func = @@ -145,7 +147,12 @@ let run title boot tick s = { keys = KeyCodeSet.empty; events = []; mouse = Mouse.create scale } in let fps_stats = ref (Stats.create ()) in - let rec loop t prev_buffer input last_t = + + let initial_internal_state = + { show_stats = false; recording_state = None } + in + + let rec loop internal_state t prev_buffer input last_t = let now = Sdl.get_ticks () in let diff = Int32.sub (Int32.of_int (1000 / 60)) (Int32.sub now last_t) @@ -162,43 +169,55 @@ let run title boot tick s = fps_stats := Stats.update ~now:(Unix.gettimeofday ()) ~tick:t !fps_stats; - show_stats := + let internal_state = List.fold_left (fun acc ev -> - match ev with Event.KeyUp Key.F1 -> not acc | _ -> acc) - !show_stats input.events; + match ev with + | Event.KeyUp Key.F1 -> + { + internal_state with + show_stats = not internal_state.show_stats; + } + | Event.KeyUp Key.F3 -> ( + Printf.printf + "Enter number of frames to record (default 500): %!"; + try + let line = read_line () in + let n = + if String.trim line = "" then + Animation.max_frames_default + else int_of_string line + in + { + internal_state with + recording_state = Some (Animation.start_recording n); + } + with Failure _ -> + Printf.printf + "Invalid input. Recording not started.\n%!"; + internal_state) + | _ -> acc) + internal_state input.events + in Screenshot.save_screenshot current_input.events s prev_buffer; - List.iter - (function - | Event.KeyDown Key.F3 -> ( - Printf.printf - "Enter number of frames to record (default 500): %!"; - try - let line = read_line () in - let n = - if String.trim line = "" then - Animation.max_frames_default - else int_of_string line - in - recording_state := Some (Animation.start_recording n) - with Failure _ -> - Printf.printf - "Invalid input. Recording not started.\n%!") - | _ -> ()) - input.events; - let updated_buffer = tick t s prev_buffer current_input in let display_buffer = - if !show_stats then Stats.render !fps_stats t s updated_buffer + if internal_state.show_stats then + Stats.render !fps_stats t s updated_buffer else updated_buffer in - recording_state := - Option.bind !recording_state (fun st -> - Animation.record_frame st s display_buffer); + let internal_state = + { + internal_state with + recording_state = + Option.bind internal_state.recording_state (fun st -> + Animation.record_frame st s display_buffer); + } + in if display_buffer != prev_buffer @@ -214,9 +233,9 @@ let run title boot tick s = (match render_texture r texture s bitmap with | Error (`Msg e) -> Sdl.log "Render error: %s" e | Ok () -> ()); - loop (t + 1) updated_buffer current_input now) + loop internal_state (t + 1) updated_buffer current_input now) in - loop 0 initial_buffer initial_input Int32.zero; + loop initial_internal_state 0 initial_buffer initial_input Int32.zero; Sdl.destroy_texture texture; Sdl.destroy_renderer r; Sdl.destroy_window w; diff --git a/src/base.mli b/src/base.mli index 0293d1b..6bf680c 100644 --- a/src/base.mli +++ b/src/base.mli @@ -11,9 +11,6 @@ module PlatformMouse : module type of Mousesdl (** A module that provides platform-specific mouse handling, based on the {!Mousesdl} module. *) -val show_stats : bool ref -(** Whether stats display is currently enabled *) - type input_state = { keys : KeyCodeSet.t; events : Event.t list; From 1aee2ecb6598cf1e57b2c1e22ea576bb9e395932 Mon Sep 17 00:00:00 2001 From: Michael Dales Date: Fri, 12 Sep 2025 16:25:36 +0100 Subject: [PATCH 2/7] Move to adding messages to a log list --- src/animation.ml | 16 ++++++----- src/animation.mli | 3 ++- src/base.ml | 38 +++++++++++++++++++------- src/screenshot.ml | 26 +++++++----------- src/screenshot.mli | 8 +++--- test/test_animation.ml | 59 +++++++++++++++++++++++++---------------- test/test_screenshot.ml | 19 +++++-------- 7 files changed, 96 insertions(+), 73 deletions(-) diff --git a/src/animation.ml b/src/animation.ml index 1a0356b..47f7211 100644 --- a/src/animation.ml +++ b/src/animation.ml @@ -10,13 +10,17 @@ type recording_state_t = { let max_frames_default = 500 let start_recording ?(max_frames = max_frames_default) (n : int) : - recording_state_t = + (recording_state_t, string) result = if max_frames <= 0 then failwith "Number of frames must be positive"; - if n <= 0 then failwith "Number of frames must be positive"; - if n > max_frames then - failwith (Printf.sprintf "Maximum %d frames allowed" max_frames_default); - Printf.printf "Started recording %d frames\n%!" n; - { frames = []; frames_to_record = n; current_frame = 0 } + match n <= 0 with + | true -> Result.Error "Number of frames must be positive" + | false -> ( + match n > max_frames with + | true -> + Result.Error + (Printf.sprintf "Maximum %d frames allowed" max_frames_default) + | false -> + Result.Ok { frames = []; frames_to_record = n; current_frame = 0 }) let stop_recording (recording_state : recording_state_t) : unit = let frames = List.rev recording_state.frames in diff --git a/src/animation.mli b/src/animation.mli index dbfdf25..dd1de0d 100644 --- a/src/animation.mli +++ b/src/animation.mli @@ -6,7 +6,8 @@ type recording_state_t = { current_frame : int; } -val start_recording : ?max_frames:int -> int -> recording_state_t +val start_recording : + ?max_frames:int -> int -> (recording_state_t, string) result (** [start_recording ?max_frames n] returns a new animation recording state that will record [n] frames. Raises [Failure] if n is non-positive or if exceeding [max_frames]. *) diff --git a/src/base.ml b/src/base.ml index 7a72776..9ee2c55 100644 --- a/src/base.ml +++ b/src/base.ml @@ -20,6 +20,7 @@ type input_state = { type t = { show_stats : bool; recording_state : Animation.recording_state_t option; + log : (string * Int32.t) list; } type boot_func = Screen.t -> Framebuffer.t @@ -149,7 +150,7 @@ let run title boot tick s = let fps_stats = ref (Stats.create ()) in let initial_internal_state = - { show_stats = false; recording_state = None } + { show_stats = false; recording_state = None; log = [] } in let rec loop internal_state t prev_buffer input last_t = @@ -178,6 +179,17 @@ let run title boot tick s = internal_state with show_stats = not internal_state.show_stats; } + | Event.KeyUp Key.F2 -> + let log_message = + match Screenshot.save_screenshot s prev_buffer with + | Result.Ok path -> + Printf.sprintf "Screenshot saved as %s" path + | Result.Error msg -> msg + in + { + internal_state with + log = (log_message, now) :: internal_state.log; + } | Event.KeyUp Key.F3 -> ( Printf.printf "Enter number of frames to record (default 500): %!"; @@ -188,20 +200,28 @@ let run title boot tick s = Animation.max_frames_default else int_of_string line in + match Animation.start_recording n with + | Result.Ok recording_state -> + { + internal_state with + recording_state = Some recording_state; + } + | Result.Error msg -> + { + internal_state with + log = (msg, now) :: internal_state.log; + } + with Failure _ -> { internal_state with - recording_state = Some (Animation.start_recording n); - } - with Failure _ -> - Printf.printf - "Invalid input. Recording not started.\n%!"; - internal_state) + log = + ("Invalid input. Recording not started.", now) + :: internal_state.log; + }) | _ -> acc) internal_state input.events in - Screenshot.save_screenshot current_input.events s prev_buffer; - let updated_buffer = tick t s prev_buffer current_input in let display_buffer = diff --git a/src/screenshot.ml b/src/screenshot.ml index be6007a..a96135f 100644 --- a/src/screenshot.ml +++ b/src/screenshot.ml @@ -1,20 +1,12 @@ open Giflib open Utils_gif -let save_screenshot (events : Event.t list) (screen : Screen.t) - (fb : Framebuffer.t) = - let take_screenshot = - List.fold_left - (fun acc ev -> match ev with Event.KeyDown Key.F2 -> true | _ -> acc) - false events - in - - if take_screenshot then ( - if Palette.size (Screen.palette screen) > 256 then - failwith "GIF only supports up to 256 colors"; - - let image = capture_frame screen fb in - let gif = GIF.from_image image in - let filename = timestamp "screenshot" ^ ".gif" in - GIF.to_file gif filename; - Printf.printf "Screenshot saved as %s\n%!" filename) +let save_screenshot (screen : Screen.t) (fb : Framebuffer.t) = + match Palette.size (Screen.palette screen) > 256 with + | true -> Result.Error "GIF only supports up to 256 colors" + | false -> + let image = capture_frame screen fb in + let gif = GIF.from_image image in + let filename = timestamp "screenshot" ^ ".gif" in + GIF.to_file gif filename; + Result.Ok filename diff --git a/src/screenshot.mli b/src/screenshot.mli index 481ed1a..eb98908 100644 --- a/src/screenshot.mli +++ b/src/screenshot.mli @@ -1,7 +1,7 @@ (** Module for handling screenshots *) -val save_screenshot : Event.t list -> Screen.t -> Framebuffer.t -> unit -(** [save_screenshot keys screen framebuffer] saves a screenshot with a - timestamped filename like "screenshot_DDMMYY_HHMMSS.gif" for uniqueness. The - output image is scaled by screen's scale factor factor Prevents multiple +val save_screenshot : Screen.t -> Framebuffer.t -> (string, string) result +(** [save_screenshot screen framebuffer] saves a screenshot with a timestamped + filename like "screenshot_DDMMYY_HHMMSS.gif" for uniqueness. The output + image is scaled by screen's scale factor factor Prevents multiple screenshots if F2 is held down. *) diff --git a/test/test_animation.ml b/test/test_animation.ml index 1bf0083..c89ec7d 100644 --- a/test/test_animation.ml +++ b/test/test_animation.ml @@ -8,56 +8,69 @@ let test_basic_recording _ = let palette = Palette.generate_vapourwave_palette 64 in let fb = Framebuffer.init (width, height) (fun x y -> x * y mod 64) in let screen = Screen.create width height scale palette in - let mut_state = ref (Some (Animation.start_recording 10)) in + let initial_state = Animation.start_recording 10 in + match initial_state with + | Result.Error _msg -> assert false + | Result.Ok state -> + let mut_state = ref (Some state) in - for _ = 1 to 10 do - match !mut_state with - | Some st -> mut_state := Animation.record_frame st screen fb - | None -> () - done; + for _ = 1 to 10 do + match !mut_state with + | Some st -> mut_state := Animation.record_frame st screen fb + | None -> () + done; - assert_equal None !mut_state + assert_equal None !mut_state let test_invalid_frame_count _ = - assert_raises (Failure "Number of frames must be positive") (fun () -> - ignore (Animation.start_recording 0)); + let res = Animation.start_recording 0 in + assert_equal (Result.Error "Number of frames must be positive") res + +let test_too_many_frames _ = let msg = Printf.sprintf "Maximum %d frames allowed" Animation.max_frames_default in - assert_raises (Failure msg) (fun () -> - ignore (Animation.start_recording (Animation.max_frames_default + 1))) + let res = Animation.start_recording (Animation.max_frames_default + 1) in + assert_equal (Result.Error msg) res let test_double_recording _ = let palette = Palette.generate_vapourwave_palette 64 in let fb = Framebuffer.init (width, height) (fun x y -> x * y mod 64) in let screen = Screen.create width height scale palette in - let mut_state = ref (Some (Animation.start_recording 10)) in + let initial_state = Animation.start_recording 10 in + match initial_state with + | Result.Error _msg -> assert false + | Result.Ok state -> + let mut_state = ref (Some state) in - mut_state := Animation.record_frame (Option.get !mut_state) screen fb; + mut_state := Animation.record_frame (Option.get !mut_state) screen fb; - let already_recording = Option.is_some !mut_state in - assert_bool "Should detect already recording state" already_recording; + let already_recording = Option.is_some !mut_state in + assert_bool "Should detect already recording state" already_recording; - ignore (Animation.stop_recording (Option.get !mut_state)); - mut_state := None + ignore (Animation.stop_recording (Option.get !mut_state)); + mut_state := None let test_palette_too_big _ = let palette = Palette.generate_mono_palette 300 in let fb = Framebuffer.init (width, height) (fun _ _ -> 42) in let screen = Screen.create width height scale palette in - let state = Animation.start_recording 10 in - - assert_raises (Failure "GIF only supports up to 256 colors") (fun () -> - ignore (Animation.record_frame state screen fb)); - assert_raises (Giflib.GIF.Error "from_images: empty image list") (fun () -> - ignore (Animation.stop_recording state)) + let initial_state = Animation.start_recording 10 in + match initial_state with + | Result.Error _msg -> assert false + | Result.Ok state -> + assert_raises (Failure "GIF only supports up to 256 colors") (fun () -> + ignore (Animation.record_frame state screen fb)); + assert_raises (Giflib.GIF.Error "from_images: empty image list") + (fun () -> ignore (Animation.stop_recording state)) let suite = "animation_tests" >::: [ "Test basic recording" >:: test_basic_recording; "Test invalid frame count" >:: test_invalid_frame_count; + "Test too many frames" >:: test_too_many_frames; "Test double recording" >:: test_double_recording; "Test palette too big" >:: test_palette_too_big; ] diff --git a/test/test_screenshot.ml b/test/test_screenshot.ml index a0f55c1..3ffb6f1 100644 --- a/test/test_screenshot.ml +++ b/test/test_screenshot.ml @@ -18,7 +18,8 @@ let test_palette name palette = Framebuffer.set_dirty fb; let screen = Screen.create width height scale palette in - Screenshot.save_screenshot [ Event.KeyDown Key.F2 ] screen fb + let res = Screenshot.save_screenshot screen fb in + match res with Result.Ok _ -> () | Result.Error _msg -> assert false let test_palette_too_big _ = let palette = Palette.generate_mono_palette 300 in @@ -26,16 +27,10 @@ let test_palette_too_big _ = let fb = Framebuffer.init (width, height) (fun _ _ -> 42) in Framebuffer.set_dirty fb; let screen = Screen.create width height scale palette in - assert_raises (Failure "GIF only supports up to 256 colors") (fun () -> - Screenshot.save_screenshot [ Event.KeyDown Key.F2 ] screen fb) - -let test_palette_too_big_no_press _ = - let palette = Palette.generate_mono_palette 300 in - (* > 256 entries *) - let fb = Framebuffer.init (width, height) (fun _ _ -> 42) in - Framebuffer.set_dirty fb; - let screen = Screen.create width height scale palette in - Screenshot.save_screenshot [] screen fb + (* assert_raises (Failure "GIF only supports up to 256 colors") (fun () -> *) + let res = Screenshot.save_screenshot screen fb in + let expected = Result.Error "GIF only supports up to 256 colors" in + assert_equal expected res let () = let suite = @@ -46,8 +41,6 @@ let () = test_palette "monopalette" (Palette.generate_mono_palette 256); "raises error when palette exceeds 256 colors" >:: test_palette_too_big; - "raises error when palette exceeds 256 colors no press" - >:: test_palette_too_big_no_press; ] in From e16b11ad90373805fb72499374d57b522a837ff9 Mon Sep 17 00:00:00 2001 From: Michael Dales Date: Sat, 13 Sep 2025 10:41:08 +0100 Subject: [PATCH 3/7] Try to estimate two colours used for displaying info --- claudius.opam | 1 + dune-project | 2 +- src/base.ml | 20 +++ src/dune | 2 +- src/palette.ml | 335 ++++++++++++++++++++++++++----------------- src/palette.mli | 2 + src/stats.ml | 23 +-- test/test_palette.ml | 8 +- 8 files changed, 248 insertions(+), 145 deletions(-) diff --git a/claudius.opam b/claudius.opam index 4691e80..92d122e 100644 --- a/claudius.opam +++ b/claudius.opam @@ -30,6 +30,7 @@ depends: [ "giflib" {>= "1.0.3"} "imagelib" {>= "20221222"} "crunch" {>= "4.0.0"} + "hsluv" {>= "0.1.0"} "ocamlformat" {>= "0.27.0" & with-dev-setup} ] build: [ diff --git a/dune-project b/dune-project index c718935..1a3e116 100644 --- a/dune-project +++ b/dune-project @@ -21,7 +21,7 @@ (name claudius) (synopsis "A retro-style graphics library") (description "A 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)) (imagelib (>= 20221222)) (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)) (hsluv (>= 0.1.0)) (ocamlformat (and (>= 0.27.0) :with-dev-setup ))) (tags (graphics rendering paletted))) diff --git a/src/base.ml b/src/base.ml index 9ee2c55..808c465 100644 --- a/src/base.ml +++ b/src/base.ml @@ -106,6 +106,24 @@ let rec poll_all_events keys mouse acc = | _ -> poll_all_events keys mouse acc) | false -> (false, keys, mouse, List.rev acc) +let render_log internal_state now screen framebuffer = + let time_limit = Int32.to_int now - 5000 in + let draw_messages = + List.filter (fun (_, a) -> Int32.to_int a > time_limit) internal_state.log + in + let _, h = Screen.dimensions screen in + let font = Screen.font screen in + let pal = Screen.palette screen in + let col = Palette.size pal in + List.iteri + (fun i (a, _) -> + ignore + (Framebuffer.draw_string 10 + (h - (20 + (i * 20))) + font a (col - 1) framebuffer)) + draw_messages; + framebuffer + let run title boot tick s = let make_full = Array.to_list Sys.argv |> List.exists (fun a -> String.compare a "-f" = 0) @@ -230,6 +248,8 @@ let run title boot tick s = else updated_buffer in + ignore (render_log internal_state now s updated_buffer); + let internal_state = { internal_state with diff --git a/src/dune b/src/dune index 02e428f..a5614cf 100644 --- a/src/dune +++ b/src/dune @@ -7,4 +7,4 @@ (library (name claudius) (public_name claudius) - (libraries tsdl giflib crunch imagelib imagelib.unix)) + (libraries tsdl giflib crunch imagelib imagelib.unix hsluv)) diff --git a/src/palette.ml b/src/palette.ml index 4ae8449..307e883 100644 --- a/src/palette.ml +++ b/src/palette.ml @@ -1,34 +1,77 @@ -type t = int32 array +type t = { colors : int32 array; extremes : int * int } + +let delta_e_luv (luv1 : Hsluv.luv) (luv2 : Hsluv.luv) = + sqrt + (((luv1.l -. luv2.l) ** 2.0) + +. ((luv1.u -. luv2.u) ** 2.0) + +. ((luv1.v -. luv2.v) ** 2.0)) + +let find_most_distant_pair luv_list = + let max_dist = ref 0. in + let res = ref (0, 0) in + let count = Array.length luv_list in + for outer = 0 to count - 1 do + for inner = 0 to count - 1 do + let luv_1 = luv_list.(inner) and luv_2 = luv_list.(outer) in + let distance = delta_e_luv luv_1 luv_2 in + if distance > !max_dist then ( + max_dist := distance; + res := (inner, outer)) + done + done; + let index1, index2 = !res in + let luv1 = luv_list.(index1) and luv2 = luv_list.(index2) in + if luv1.l > luv2.l then (index2, index1) else (index1, index2) + +let v colors = + if Array.length colors == 0 then + raise (Invalid_argument "Palette size must not be zero or negative"); + let luv_colors = + Array.map + (fun col -> + let r = float_of_int (col / 65536 land 0xFF) + and g = float_of_int (col / 256 land 0xFF) + and b = float_of_int (col land 0xFF) in + let rgb : Hsluv.rgb = { r; g; b } in + Hsluv.conv_rgb_xyz rgb |> Hsluv.conv_xyz_luv) + colors + in + let extremes = find_most_distant_pair luv_colors in + let colors = Array.map Int32.of_int colors in + { colors; extremes } let generate_mono_palette (size : int) : t = if size <= 0 then raise (Invalid_argument "Palette size must not be zero or negative"); - Array.init size (fun (index : int) : int32 -> - let fi = float_of_int index and fsize = float_of_int size in - let ch = fi /. fsize *. 255.0 in - Int32.of_int - ((int_of_float ch * 65536) + (int_of_float ch * 256) + int_of_float ch)) + let colors = + Array.init size (fun (index : int) : int -> + let fi = float_of_int index and fsize = float_of_int size in + let ch = fi /. fsize *. 255.0 in + (int_of_float ch * 65536) + (int_of_float ch * 256) + int_of_float ch) + in + v colors let generate_plasma_palette (size : int) : t = if size <= 0 then raise (Invalid_argument "Palette size must not be zero or negative"); - Array.init size (fun (index : int) : int32 -> - let fi = float_of_int index and fsize = float_of_int size in - let fred = (cos (fi *. (2.0 *. Float.pi /. fsize)) *. 127.0) +. 128.0 in - let fgreen = - (cos ((fi +. (fsize /. 3.0)) *. (2.0 *. Float.pi /. fsize)) *. 127.0) - +. 128.0 - in - let fblue = - cos ((fi +. (fsize *. 2.0 /. 3.0)) *. (2.0 *. Float.pi /. fsize)) - *. 127.0 - +. 128.0 - in - - Int32.of_int - ((int_of_float fred * 65536) + let colors = + Array.init size (fun (index : int) : int -> + let fi = float_of_int index and fsize = float_of_int size in + let fred = (cos (fi *. (2.0 *. Float.pi /. fsize)) *. 127.0) +. 128.0 in + let fgreen = + (cos ((fi +. (fsize /. 3.0)) *. (2.0 *. Float.pi /. fsize)) *. 127.0) + +. 128.0 + in + let fblue = + cos ((fi +. (fsize *. 2.0 /. 3.0)) *. (2.0 *. Float.pi /. fsize)) + *. 127.0 + +. 128.0 + in + (int_of_float fred * 65536) + (int_of_float fgreen * 256) - + int_of_float fblue)) + + int_of_float fblue) + in + v colors let generate_linear_palette (color1 : int) (color2 : int) (size : int) : t = if size <= 0 then @@ -40,18 +83,21 @@ let generate_linear_palette (color1 : int) (color2 : int) (size : int) : t = let red2 = color2 / 65536 land 0xFF in let green2 = color2 / 256 land 0xFF in let blue2 = color2 land 0xFF in - Array.init size (fun index -> - let ratio = float_of_int index /. float_of_int (size - 1) in + let colors = + Array.init size (fun index -> + let ratio = float_of_int index /. float_of_int (size - 1) in - let red = int_of_float (float red1 +. (float (red2 - red1) *. ratio)) in - let green = - int_of_float (float green1 +. (float (green2 - green1) *. ratio)) - in - let blue = - int_of_float (float blue1 +. (float (blue2 - blue1) *. ratio)) - in + let red = int_of_float (float red1 +. (float (red2 - red1) *. ratio)) in + let green = + int_of_float (float green1 +. (float (green2 - green1) *. ratio)) + in + let blue = + int_of_float (float blue1 +. (float (blue2 - blue1) *. ratio)) + in - Int32.of_int (red * 65536 lor (green * 256) lor blue)) + red * 65536 lor (green * 256) lor blue) + in + v colors let generate_vapourwave_palette (size : int) : t = let pastel_purple = 0x7f3b8f in @@ -64,91 +110,103 @@ let generate_microsoft_vga_palette () : t = (* This palette is by SZIEBERTH Ádám, found on Lospec: https://lospec.com/palette-list/microsoft-vga Renamed here to match the original name: "MICROSOFT VGA Palette". *) - Array.of_list - [ - 0x000000l; - 0x800000l; - 0x008000l; - 0x808000l; - 0x000080l; - 0x800080l; - 0x008080l; - 0xc0c0c0l; - 0x808080l; - 0xff0000l; - 0x00ff00l; - 0xffff00l; - 0x0000ffl; - 0xff00ffl; - 0x00ffffl; - 0xffffffl; - ] + let colors = + Array.of_list + [ + 0x000000; + 0x800000; + 0x008000; + 0x808000; + 0x000080; + 0x800080; + 0x008080; + 0xc0c0c0; + 0x808080; + 0xff0000; + 0x00ff00; + 0xffff00; + 0x0000ff; + 0xff00ff; + 0x00ffff; + 0xffffff; + ] + in + v colors let generate_classic_vga_palette () : t = - Array.of_list - [ - 0x000000l; - 0x0000AAl; - 0x00AA00l; - 0x00AAAAl; - 0xAA0000l; - 0xAA00AAl; - 0xAA5500l; - 0xAAAAAAl; - 0x555555l; - 0x5555FFl; - 0x55FF55l; - 0x55FFFFl; - 0xFF5555l; - 0xFF55FFl; - 0xFFFF55l; - 0xFFFFFFl; - ] + let colors = + Array.of_list + [ + 0x000000; + 0x0000AA; + 0x00AA00; + 0x00AAAA; + 0xAA0000; + 0xAA00AA; + 0xAA5500; + 0xAAAAAA; + 0x555555; + 0x5555FF; + 0x55FF55; + 0x55FFFF; + 0xFF5555; + 0xFF55FF; + 0xFFFF55; + 0xFFFFFF; + ] + in + v colors let generate_sweetie16_palette () : t = (* This palette is by GrafxKid, found on Lospec: https://lospec.com/palette-list/sweetie-16 Renamed here to match the original name: "Sweetie 16". *) - Array.of_list - [ - 0x1a1c2cl; - 0x5d275dl; - 0xb13e53l; - 0xef7d57l; - 0xffcd75l; - 0xa7f070l; - 0x38b764l; - 0x257179l; - 0x29366fl; - 0x3b5dc9l; - 0x41a6f6l; - 0x73eff7l; - 0xf4f4f4l; - 0x94b0c2l; - 0x566c86l; - 0x333c57l; - ] + let colors = + Array.of_list + [ + 0x1a1c2c; + 0x5d275d; + 0xb13e53; + 0xef7d57; + 0xffcd75; + 0xa7f070; + 0x38b764; + 0x257179; + 0x29366f; + 0x3b5dc9; + 0x41a6f6; + 0x73eff7; + 0xf4f4f4; + 0x94b0c2; + 0x566c86; + 0x333c57; + ] + in + v colors let generate_mac_palette () : t = - Array.of_list - [ - 0xffffffl; - 0xfcf400l; - 0xff6400l; - 0xdd0202l; - 0xf00285l; - 0x4600a5l; - 0x0000d5l; - 0x00aee9l; - 0x1ab90cl; - 0x006407l; - 0x572800l; - 0x917135l; - 0xc1c1c1l; - 0x818181l; - 0x3e3e3el; - 0x000000l; - ] + let colors = + Array.of_list + [ + 0xffffff; + 0xfcf400; + 0xff6400; + 0xdd0202; + 0xf00285; + 0x4600a5; + 0x0000d5; + 0x00aee9; + 0x1ab90c; + 0x006407; + 0x572800; + 0x917135; + 0xc1c1c1; + 0x818181; + 0x3e3e3e; + 0x000000; + ] + in + v colors let string_to_chunks (x : string) (size : int) : string list = let rec loop sofar remainder = @@ -165,10 +223,12 @@ let string_to_chunks (x : string) (size : int) : string list = List.rev (loop [] x) let chunks_to_colors (raw : string list) : t = - Array.map - (fun (colorstr : string) : int32 -> - Int32.of_int (int_of_string ("0x" ^ colorstr))) - (Array.of_list raw) + let colors = + Array.map + (fun (colorstr : string) : int -> int_of_string ("0x" ^ colorstr)) + (Array.of_list raw) + in + v colors let load_tic80_palette (raw : string) : t = let parts = String.split_on_char ':' raw in @@ -177,8 +237,7 @@ let load_tic80_palette (raw : string) : t = else raise (Invalid_argument "Palette size must not be zero or negative") let of_list (rgb_list : int list) : t = - if List.length rgb_list > 0 then - Array.of_list (List.map Int32.of_int rgb_list) + if List.length rgb_list > 0 then v (Array.of_list rgb_list) else raise (Invalid_argument "Palette size must not be zero or negative") let load_lospec_palette (s : string) : t = @@ -205,44 +264,54 @@ let load_lospec_palette (s : string) : t = (Invalid_argument "Palette size must not be zero or invalid HEX values"); of_list color_list -let size (palette : t) : int = Array.length palette +let size (palette : t) : int = Array.length palette.colors let index_to_rgb (palette : t) (index : int) : int32 = - let palsize = Array.length palette in + let palsize = Array.length palette.colors in let index = index mod palsize in - palette.(if index >= 0 then index else index + palsize) + palette.colors.(if index >= 0 then index else index + palsize) let to_list (palette : t) : int list = - List.map Int32.to_int (Array.to_list palette) + List.map Int32.to_int (Array.to_list palette.colors) let circle_palette (pal : t) (offset : int) : t = - let size = Array.length pal in - Array.init size (fun index -> - (* Calculate new index ensuring it is positive *) - let raw = index + offset in - let new_index = if raw < 0 then (raw mod size) + size else raw mod size in - pal.(new_index)) + let size = Array.length pal.colors in + let colors = + Array.init size (fun index -> + (* Calculate new index ensuring it is positive *) + let raw = index + offset in + let new_index = + if raw < 0 then (raw mod size) + size else raw mod size + in + pal.colors.(new_index)) + in + { pal with colors } let updated_entry (pal : t) (index : int) (new_color : int * int * int) : t = - if index < 0 || index >= Array.length pal then + let palsize = Array.length pal.colors in + if index < 0 || index >= palsize then raise (Invalid_argument "Invalid palette index") else let r, g, b = new_color in - let new_int = Int32.of_int (r * 65536 lor (g * 256) lor b) in - let new_pal = Array.copy pal in + let new_int = r * 65536 lor (g * 256) lor b in + let new_pal = Array.init palsize (fun i -> Int32.to_int pal.colors.(i)) in new_pal.(index) <- new_int; - new_pal + v new_pal let concat (palettes : t list) : t = let total_len = - List.fold_left (fun acc pal -> acc + Array.length pal) 0 palettes + List.fold_left (fun acc pal -> acc + Array.length pal.colors) 0 palettes in - let result = Array.make total_len 0l in + let result = Array.make total_len 0 in let _ = List.fold_left (fun offset pal -> - Array.iteri (fun i v -> result.(offset + i) <- v) pal; - offset + Array.length pal) + Array.iteri + (fun i v -> result.(offset + i) <- Int32.to_int v) + pal.colors; + offset + Array.length pal.colors) 0 palettes in - result + v result + +let extremes t = t.extremes diff --git a/src/palette.mli b/src/palette.mli index 7780e09..d2d97dd 100644 --- a/src/palette.mli +++ b/src/palette.mli @@ -86,3 +86,5 @@ val updated_entry : t -> int -> int * int * int -> t val concat : t list -> t (** [concat palettes] merges a list of palettes into a single palette. *) + +val extremes : t -> int * int diff --git a/src/stats.ml b/src/stats.ml index ec1a9f2..232b568 100644 --- a/src/stats.ml +++ b/src/stats.ml @@ -13,11 +13,20 @@ let update ~now ~tick previous = } else previous +let draw_string x y font msg fg_col bg_col fb = + for j = -1 to 1 do + for i = -1 to 1 do + ignore (Framebuffer.draw_string (x + i) (y + j) font msg bg_col fb) + done + done; + ignore (Framebuffer.draw_string x y font msg fg_col fb) + let render fps_stats tick screen framebuffer = let framebuffer = Framebuffer.map (fun i -> i) framebuffer in let width, height = Screen.dimensions screen and font = Screen.font screen - and colour_count = Palette.size (Screen.palette screen) in + and colour_count = Palette.size (Screen.palette screen) + and bg_col, fg_col = Palette.extremes (Screen.palette screen) in let info = [ @@ -38,21 +47,17 @@ let render fps_stats tick screen framebuffer = 0 info in - let palette_max = colour_count - 1 in - List.iteri (fun i (k, v) -> let y_offset = 4 + (14 * i) in - ignore (Framebuffer.draw_string 4 y_offset font k palette_max framebuffer); - ignore - (Framebuffer.draw_string (max_key_width + 10) y_offset font v - palette_max framebuffer)) + draw_string 4 y_offset font k fg_col bg_col framebuffer; + draw_string (max_key_width + 10) y_offset font v fg_col bg_col framebuffer) info; let columns = width / 10 in - let rows = (palette_max / columns) + 1 in + let rows = (colour_count / columns) + 1 in let offset = height - (10 * rows) in - for i = 0 to palette_max do + for i = 0 to colour_count - 1 do Framebuffer.filled_rect (i mod columns * 10) (offset + (i / columns * 10)) diff --git a/test/test_palette.ml b/test/test_palette.ml index 6accfe7..3a5e62f 100644 --- a/test/test_palette.ml +++ b/test/test_palette.ml @@ -1,6 +1,8 @@ open Claudius open OUnit2 +let extreme_print (a, b) = Printf.sprintf "%d, %d" a b + let test_basic_palette_of_ints _ = let cols = [ 0x000000; 0xFF0000; 0x00FF00; 0x0000FF; 0xFFFFFF ] in let pal = Palette.of_list cols in @@ -11,7 +13,9 @@ let test_basic_palette_of_ints _ = assert_equal ~msg:"Colour match" (Int32.of_int c) v) cols; let rev = Palette.to_list pal in - assert_equal ~msg:"Back to ints" cols rev + assert_equal ~msg:"Back to ints" cols rev; + let extremes = Palette.extremes pal in + assert_equal ~msg:"Colour extremes" ~printer:extreme_print (3, 1) extremes let test_generate_mac_palette_creation _ = let pal = Palette.generate_mac_palette () in @@ -72,6 +76,8 @@ let test_mono_palette_creation _ = assert_equal ~msg:"Start with black" Int32.zero (Palette.index_to_rgb pal 0); assert_equal ~msg:"Wrap around to black" Int32.zero (Palette.index_to_rgb pal 16); + let extremes = Palette.extremes pal in + assert_equal ~msg:"Colour extremes" ~printer:extreme_print (0, 15) extremes; (* I originally tested that we ended on white, but due to rounding errors we might be slightly off *) List.iter (fun c -> From 8057e415d10fc84ab4ecfe748c07216f3950fe4f Mon Sep 17 00:00:00 2001 From: Michael Dales Date: Sat, 13 Sep 2025 13:23:53 +0100 Subject: [PATCH 4/7] Move logging into the stats module --- src/base.ml | 61 ++++++++++++--------------- src/stats.ml | 112 ++++++++++++++++++++++++++++++++------------------ src/stats.mli | 5 ++- 3 files changed, 103 insertions(+), 75 deletions(-) diff --git a/src/base.ml b/src/base.ml index 808c465..f84be4f 100644 --- a/src/base.ml +++ b/src/base.ml @@ -20,7 +20,7 @@ type input_state = { type t = { show_stats : bool; recording_state : Animation.recording_state_t option; - log : (string * Int32.t) list; + status : Stats.t; } type boot_func = Screen.t -> Framebuffer.t @@ -106,24 +106,6 @@ let rec poll_all_events keys mouse acc = | _ -> poll_all_events keys mouse acc) | false -> (false, keys, mouse, List.rev acc) -let render_log internal_state now screen framebuffer = - let time_limit = Int32.to_int now - 5000 in - let draw_messages = - List.filter (fun (_, a) -> Int32.to_int a > time_limit) internal_state.log - in - let _, h = Screen.dimensions screen in - let font = Screen.font screen in - let pal = Screen.palette screen in - let col = Palette.size pal in - List.iteri - (fun i (a, _) -> - ignore - (Framebuffer.draw_string 10 - (h - (20 + (i * 20))) - font a (col - 1) framebuffer)) - draw_messages; - framebuffer - let run title boot tick s = let make_full = Array.to_list Sys.argv |> List.exists (fun a -> String.compare a "-f" = 0) @@ -165,10 +147,13 @@ let run title boot tick s = let initial_input = { keys = KeyCodeSet.empty; events = []; mouse = Mouse.create scale } in - let fps_stats = ref (Stats.create ()) in let initial_internal_state = - { show_stats = false; recording_state = None; log = [] } + { + show_stats = false; + recording_state = None; + status = Stats.create (); + } in let rec loop internal_state t prev_buffer input last_t = @@ -184,9 +169,15 @@ let run title boot tick s = { keys = new_keys; events = unified_events; mouse = new_mouse } in if exit then () - else ( - fps_stats := - Stats.update ~now:(Unix.gettimeofday ()) ~tick:t !fps_stats; + else + let internal_state = + { + internal_state with + status = + Stats.update ~now:(Unix.gettimeofday ()) ~tick:t + internal_state.status; + } + in let internal_state = List.fold_left @@ -206,7 +197,7 @@ let run title boot tick s = in { internal_state with - log = (log_message, now) :: internal_state.log; + status = Stats.log internal_state.status log_message; } | Event.KeyUp Key.F3 -> ( Printf.printf @@ -227,14 +218,14 @@ let run title boot tick s = | Result.Error msg -> { internal_state with - log = (msg, now) :: internal_state.log; + status = Stats.log internal_state.status msg; } with Failure _ -> { internal_state with - log = - ("Invalid input. Recording not started.", now) - :: internal_state.log; + status = + Stats.log internal_state.status + "Invalid input. Recording not started."; }) | _ -> acc) internal_state input.events @@ -242,14 +233,14 @@ let run title boot tick s = let updated_buffer = tick t s prev_buffer current_input in + let stats_buffer = + Stats.render internal_state.status internal_state.show_stats t s + updated_buffer + in let display_buffer = - if internal_state.show_stats then - Stats.render !fps_stats t s updated_buffer - else updated_buffer + match stats_buffer with None -> updated_buffer | Some b -> b in - ignore (render_log internal_state now s updated_buffer); - let internal_state = { internal_state with @@ -273,7 +264,7 @@ let run title boot tick s = (match render_texture r texture s bitmap with | Error (`Msg e) -> Sdl.log "Render error: %s" e | Ok () -> ()); - loop internal_state (t + 1) updated_buffer current_input now) + loop internal_state (t + 1) updated_buffer current_input now in loop initial_internal_state 0 initial_buffer initial_input Int32.zero; Sdl.destroy_texture texture; diff --git a/src/stats.ml b/src/stats.ml index 232b568..efa4d4c 100644 --- a/src/stats.ml +++ b/src/stats.ml @@ -1,6 +1,13 @@ -type t = { last_update : float; last_tick_count : int; average_fps : int } +type t = { + last_update : float; + last_tick_count : int; + average_fps : int; + log : (string * float) list; +} + +let create () = + { last_update = 0.0; last_tick_count = 0; average_fps = 0; log = [] } -let create () = { last_update = 0.0; last_tick_count = 0; average_fps = 0 } let fps t = t.average_fps let update ~now ~tick previous = @@ -10,9 +17,14 @@ let update ~now ~tick previous = last_update = now; last_tick_count = tick; average_fps = tick - previous.last_tick_count; + log = previous.log; } else previous +let log previous msg = + let log = (msg, previous.last_update) :: previous.log in + { previous with log } + let draw_string x y font msg fg_col bg_col fb = for j = -1 to 1 do for i = -1 to 1 do @@ -21,47 +33,69 @@ let draw_string x y font msg fg_col bg_col fb = done; ignore (Framebuffer.draw_string x y font msg fg_col fb) -let render fps_stats tick screen framebuffer = - let framebuffer = Framebuffer.map (fun i -> i) framebuffer in - let width, height = Screen.dimensions screen - and font = Screen.font screen - and colour_count = Palette.size (Screen.palette screen) - and bg_col, fg_col = Palette.extremes (Screen.palette screen) in +let render_log messages screen framebuffer = + let _, h = Screen.dimensions screen in + let font = Screen.font screen in + let pal = Screen.palette screen in + let bg_col, fg_col = Palette.extremes pal in + List.iteri + (fun i (a, _) -> + draw_string 10 (h - (20 + (i * 20))) font a fg_col bg_col framebuffer) + messages - let info = - [ - ("Tick:", string_of_int tick); - ("FPS:", string_of_int fps_stats.average_fps); - ("Resolution:", Printf.sprintf "%dx%d" width height); - ("Colours:", string_of_int colour_count); - ] +let render fps_stats show_all tick screen framebuffer = + let log_threshold = fps_stats.last_update -. 5.0 in + let latest_messages = + List.filter (fun (_, a) -> a > log_threshold) fps_stats.log in + let show_log = List.length latest_messages > 0 in - let max_key_width = - List.fold_left - (fun acc (k, _) -> - let width = - Framebuffer.draw_string (-1000) (-1000) font k 0 framebuffer + match (show_all, show_log) with + | false, false -> None + | _, _ -> + let framebuffer = Framebuffer.map (fun i -> i) framebuffer in + let width, height = Screen.dimensions screen + and font = Screen.font screen + and colour_count = Palette.size (Screen.palette screen) + and bg_col, fg_col = Palette.extremes (Screen.palette screen) in + + if show_all then ( + let info = + [ + ("Tick:", string_of_int tick); + ("FPS:", string_of_int fps_stats.average_fps); + ("Resolution:", Printf.sprintf "%dx%d" width height); + ("Colours:", string_of_int colour_count); + ] in - if width > acc then width else acc) - 0 info - in - List.iteri - (fun i (k, v) -> - let y_offset = 4 + (14 * i) in - draw_string 4 y_offset font k fg_col bg_col framebuffer; - draw_string (max_key_width + 10) y_offset font v fg_col bg_col framebuffer) - info; + let max_key_width = + List.fold_left + (fun acc (k, _) -> + let width = + Framebuffer.draw_string (-1000) (-1000) font k 0 framebuffer + in + if width > acc then width else acc) + 0 info + in - let columns = width / 10 in - let rows = (colour_count / columns) + 1 in - let offset = height - (10 * rows) in - for i = 0 to colour_count - 1 do - Framebuffer.filled_rect - (i mod columns * 10) - (offset + (i / columns * 10)) - 10 10 i framebuffer - done; + List.iteri + (fun i (k, v) -> + let y_offset = 4 + (14 * i) in + draw_string 4 y_offset font k fg_col bg_col framebuffer; + draw_string (max_key_width + 10) y_offset font v fg_col bg_col + framebuffer) + info; + + let columns = width / 10 in + let rows = (colour_count / columns) + 1 in + let offset = height - (10 * rows) in + for i = 0 to colour_count - 1 do + Framebuffer.filled_rect + (i mod columns * 10) + (offset + (i / columns * 10)) + 10 10 i framebuffer + done); + if show_log then render_log latest_messages screen framebuffer; - framebuffer + Some framebuffer diff --git a/src/stats.mli b/src/stats.mli index cfe53b0..e2e0731 100644 --- a/src/stats.mli +++ b/src/stats.mli @@ -11,5 +11,8 @@ val fps : t -> int val update : now:float -> tick:int -> t -> t (** Calculate the updated stats based on current time/tick *) -val render : t -> int -> Screen.t -> Framebuffer.t -> Framebuffer.t +val log : t -> string -> t + +val render : + t -> bool -> int -> Screen.t -> Framebuffer.t -> Framebuffer.t option (** Draw stats on the provided framebuffer *) From 9ca70262a9f5259707c06f66983a86d8f62c74e9 Mon Sep 17 00:00:00 2001 From: Michael Dales Date: Sat, 13 Sep 2025 13:45:27 +0100 Subject: [PATCH 5/7] Rename distinct pair --- src/palette.ml | 52 +++++++++++++++++++++++++++----------------- src/palette.mli | 4 +++- src/stats.ml | 4 ++-- test/test_palette.ml | 10 +++++---- 4 files changed, 43 insertions(+), 27 deletions(-) diff --git a/src/palette.ml b/src/palette.ml index 307e883..634721b 100644 --- a/src/palette.ml +++ b/src/palette.ml @@ -1,44 +1,56 @@ -type t = { colors : int32 array; extremes : int * int } +type t = { colors : int32 array; distinctive_pair : int * int } -let delta_e_luv (luv1 : Hsluv.luv) (luv2 : Hsluv.luv) = +let delta_e (luv1 : Hsluv.luv) (luv2 : Hsluv.luv) = sqrt (((luv1.l -. luv2.l) ** 2.0) +. ((luv1.u -. luv2.u) ** 2.0) +. ((luv1.v -. luv2.v) ** 2.0)) -let find_most_distant_pair luv_list = +let find_most_distant_pair colors = + (* To find the most visually distinct colours we project the + colours from RGB into the LUV colour space: + + https://en.wikipedia.org/wiki/CIELUV + + Once in this colour space you can calculate the "delta E", the + geometric distance between the colours, and that distance + corresponds to visual distance. + *) + let luv_colors = + Array.map + (fun col -> + let r = float_of_int (col / 65536 land 0xFF) + and g = float_of_int (col / 256 land 0xFF) + and b = float_of_int (col land 0xFF) in + let rgb : Hsluv.rgb = { r; g; b } in + Hsluv.conv_rgb_xyz rgb |> Hsluv.conv_xyz_luv) + colors + in let max_dist = ref 0. in let res = ref (0, 0) in - let count = Array.length luv_list in + let count = Array.length luv_colors in for outer = 0 to count - 1 do for inner = 0 to count - 1 do - let luv_1 = luv_list.(inner) and luv_2 = luv_list.(outer) in - let distance = delta_e_luv luv_1 luv_2 in + let luv_1 = luv_colors.(inner) and luv_2 = luv_colors.(outer) in + let distance = delta_e luv_1 luv_2 in if distance > !max_dist then ( max_dist := distance; res := (inner, outer)) done done; + + (* In order to put some consistency on things, list the colours + based on the most dark colour first. *) let index1, index2 = !res in - let luv1 = luv_list.(index1) and luv2 = luv_list.(index2) in + let luv1 = luv_colors.(index1) and luv2 = luv_colors.(index2) in if luv1.l > luv2.l then (index2, index1) else (index1, index2) let v colors = if Array.length colors == 0 then raise (Invalid_argument "Palette size must not be zero or negative"); - let luv_colors = - Array.map - (fun col -> - let r = float_of_int (col / 65536 land 0xFF) - and g = float_of_int (col / 256 land 0xFF) - and b = float_of_int (col land 0xFF) in - let rgb : Hsluv.rgb = { r; g; b } in - Hsluv.conv_rgb_xyz rgb |> Hsluv.conv_xyz_luv) - colors - in - let extremes = find_most_distant_pair luv_colors in + let distinctive_pair = find_most_distant_pair colors in let colors = Array.map Int32.of_int colors in - { colors; extremes } + { colors; distinctive_pair } let generate_mono_palette (size : int) : t = if size <= 0 then @@ -314,4 +326,4 @@ let concat (palettes : t list) : t = in v result -let extremes t = t.extremes +let distinctive_pair t = t.distinctive_pair diff --git a/src/palette.mli b/src/palette.mli index d2d97dd..1fd8c5f 100644 --- a/src/palette.mli +++ b/src/palette.mli @@ -87,4 +87,6 @@ val updated_entry : t -> int -> int * int * int -> t val concat : t list -> t (** [concat palettes] merges a list of palettes into a single palette. *) -val extremes : t -> int * int +val distinctive_pair : t -> int * int +(** [distintive_pair palette] returns two colours that are the most visually + distinct in the palette. *) diff --git a/src/stats.ml b/src/stats.ml index efa4d4c..c812e09 100644 --- a/src/stats.ml +++ b/src/stats.ml @@ -37,7 +37,7 @@ let render_log messages screen framebuffer = let _, h = Screen.dimensions screen in let font = Screen.font screen in let pal = Screen.palette screen in - let bg_col, fg_col = Palette.extremes pal in + let bg_col, fg_col = Palette.distinctive_pair pal in List.iteri (fun i (a, _) -> draw_string 10 (h - (20 + (i * 20))) font a fg_col bg_col framebuffer) @@ -57,7 +57,7 @@ let render fps_stats show_all tick screen framebuffer = let width, height = Screen.dimensions screen and font = Screen.font screen and colour_count = Palette.size (Screen.palette screen) - and bg_col, fg_col = Palette.extremes (Screen.palette screen) in + and bg_col, fg_col = Palette.distinctive_pair (Screen.palette screen) in if show_all then ( let info = diff --git a/test/test_palette.ml b/test/test_palette.ml index 3a5e62f..5411cd8 100644 --- a/test/test_palette.ml +++ b/test/test_palette.ml @@ -14,8 +14,9 @@ let test_basic_palette_of_ints _ = cols; let rev = Palette.to_list pal in assert_equal ~msg:"Back to ints" cols rev; - let extremes = Palette.extremes pal in - assert_equal ~msg:"Colour extremes" ~printer:extreme_print (3, 1) extremes + let distinctive_pair = Palette.distinctive_pair pal in + assert_equal ~msg:"Colour distinctive_pair" ~printer:extreme_print (3, 1) + distinctive_pair let test_generate_mac_palette_creation _ = let pal = Palette.generate_mac_palette () in @@ -76,8 +77,9 @@ let test_mono_palette_creation _ = assert_equal ~msg:"Start with black" Int32.zero (Palette.index_to_rgb pal 0); assert_equal ~msg:"Wrap around to black" Int32.zero (Palette.index_to_rgb pal 16); - let extremes = Palette.extremes pal in - assert_equal ~msg:"Colour extremes" ~printer:extreme_print (0, 15) extremes; + let distinctive_pair = Palette.distinctive_pair pal in + assert_equal ~msg:"Colour distinctive_pair" ~printer:extreme_print (0, 15) + distinctive_pair; (* I originally tested that we ended on white, but due to rounding errors we might be slightly off *) List.iter (fun c -> From aa23c6eb22a02ef42126848b1bc81be3548ebcc0 Mon Sep 17 00:00:00 2001 From: Michael Dales Date: Sat, 13 Sep 2025 15:43:11 +0100 Subject: [PATCH 6/7] Review/tidying --- src/animation.mli | 2 +- src/base.ml | 12 ++--- src/screenshot.mli | 4 +- src/stats.ml | 104 ++++++++++++++++++++++--------------------- src/stats.mli | 1 + test/test_palette.ml | 21 +++++++++ 6 files changed, 84 insertions(+), 60 deletions(-) diff --git a/src/animation.mli b/src/animation.mli index dd1de0d..7f53561 100644 --- a/src/animation.mli +++ b/src/animation.mli @@ -9,7 +9,7 @@ type recording_state_t = { val start_recording : ?max_frames:int -> int -> (recording_state_t, string) result (** [start_recording ?max_frames n] returns a new animation recording state that - will record [n] frames. Raises [Failure] if n is non-positive or if + will record [n] frames, or an error result if n is non-positive or if exceeding [max_frames]. *) val stop_recording : recording_state_t -> unit diff --git a/src/base.ml b/src/base.ml index f84be4f..1ecb6cb 100644 --- a/src/base.ml +++ b/src/base.ml @@ -10,6 +10,12 @@ end) module PlatformKey = Keysdl module PlatformMouse = Mousesdl +type t = { + show_stats : bool; + recording_state : Animation.recording_state_t option; + status : Stats.t; +} + type input_state = { keys : KeyCodeSet.t; events : Event.t list; @@ -17,12 +23,6 @@ type input_state = { mouse : Mouse.t; } -type t = { - show_stats : bool; - recording_state : Animation.recording_state_t option; - status : Stats.t; -} - type boot_func = Screen.t -> Framebuffer.t type tick_func = diff --git a/src/screenshot.mli b/src/screenshot.mli index eb98908..c48eb98 100644 --- a/src/screenshot.mli +++ b/src/screenshot.mli @@ -3,5 +3,5 @@ val save_screenshot : Screen.t -> Framebuffer.t -> (string, string) result (** [save_screenshot screen framebuffer] saves a screenshot with a timestamped filename like "screenshot_DDMMYY_HHMMSS.gif" for uniqueness. The output - image is scaled by screen's scale factor factor Prevents multiple - screenshots if F2 is held down. *) + image is scaled by screen's scale factor factor. Returns either the path of + the image or an error with reason message. *) diff --git a/src/stats.ml b/src/stats.ml index c812e09..3fab722 100644 --- a/src/stats.ml +++ b/src/stats.ml @@ -21,9 +21,9 @@ let update ~now ~tick previous = } else previous -let log previous msg = - let log = (msg, previous.last_update) :: previous.log in - { previous with log } +let log t msg = + let log = (msg, t.last_update) :: t.log in + { t with log } let draw_string x y font msg fg_col bg_col fb = for j = -1 to 1 do @@ -43,59 +43,61 @@ let render_log messages screen framebuffer = draw_string 10 (h - (20 + (i * 20))) font a fg_col bg_col framebuffer) messages -let render fps_stats show_all tick screen framebuffer = - let log_threshold = fps_stats.last_update -. 5.0 in - let latest_messages = - List.filter (fun (_, a) -> a > log_threshold) fps_stats.log +let render_stats status tick screen framebuffer = + let width, height = Screen.dimensions screen + and font = Screen.font screen + and colour_count = Palette.size (Screen.palette screen) + and bg_col, fg_col = Palette.distinctive_pair (Screen.palette screen) in + let info = + [ + ("Tick:", string_of_int tick); + ("FPS:", string_of_int status.average_fps); + ("Resolution:", Printf.sprintf "%dx%d" width height); + ("Colours:", string_of_int colour_count); + ] in - let show_log = List.length latest_messages > 0 in - match (show_all, show_log) with - | false, false -> None - | _, _ -> - let framebuffer = Framebuffer.map (fun i -> i) framebuffer in - let width, height = Screen.dimensions screen - and font = Screen.font screen - and colour_count = Palette.size (Screen.palette screen) - and bg_col, fg_col = Palette.distinctive_pair (Screen.palette screen) in - - if show_all then ( - let info = - [ - ("Tick:", string_of_int tick); - ("FPS:", string_of_int fps_stats.average_fps); - ("Resolution:", Printf.sprintf "%dx%d" width height); - ("Colours:", string_of_int colour_count); - ] + let max_key_width = + List.fold_left + (fun acc (k, _) -> + let width = + Framebuffer.draw_string (-1000) (-1000) font k 0 framebuffer in + if width > acc then width else acc) + 0 info + in - let max_key_width = - List.fold_left - (fun acc (k, _) -> - let width = - Framebuffer.draw_string (-1000) (-1000) font k 0 framebuffer - in - if width > acc then width else acc) - 0 info - in + List.iteri + (fun i (k, v) -> + let y_offset = 4 + (14 * i) in + draw_string 4 y_offset font k fg_col bg_col framebuffer; + draw_string (max_key_width + 10) y_offset font v fg_col bg_col framebuffer) + info; - List.iteri - (fun i (k, v) -> - let y_offset = 4 + (14 * i) in - draw_string 4 y_offset font k fg_col bg_col framebuffer; - draw_string (max_key_width + 10) y_offset font v fg_col bg_col - framebuffer) - info; + let columns = width / 10 in + let rows = (colour_count / columns) + 1 in + let offset = height - (10 * rows) in + for i = 0 to colour_count - 1 do + Framebuffer.filled_rect + (i mod columns * 10) + (offset + (i / columns * 10)) + 10 10 i framebuffer + done - let columns = width / 10 in - let rows = (colour_count / columns) + 1 in - let offset = height - (10 * rows) in - for i = 0 to colour_count - 1 do - Framebuffer.filled_rect - (i mod columns * 10) - (offset + (i / columns * 10)) - 10 10 i framebuffer - done); - if show_log then render_log latest_messages screen framebuffer; +let render status show_all tick screen framebuffer = + let log_messages = + match show_all with + | false -> + let log_threshold = status.last_update -. 5.0 in + List.filter (fun (_, a) -> a > log_threshold) status.log + | true -> status.log + in + let show_log = List.length log_messages > 0 in + match (show_all, show_log) with + | false, false -> None + | _, _ -> + let framebuffer = Framebuffer.map (fun i -> i) framebuffer in + if show_all then render_stats status tick screen framebuffer; + if show_log then render_log log_messages screen framebuffer; Some framebuffer diff --git a/src/stats.mli b/src/stats.mli index e2e0731..f9fc017 100644 --- a/src/stats.mli +++ b/src/stats.mli @@ -12,6 +12,7 @@ val update : now:float -> tick:int -> t -> t (** Calculate the updated stats based on current time/tick *) val log : t -> string -> t +(** Add a log message for display *) val render : t -> bool -> int -> Screen.t -> Framebuffer.t -> Framebuffer.t option diff --git a/test/test_palette.ml b/test/test_palette.ml index 5411cd8..323e14b 100644 --- a/test/test_palette.ml +++ b/test/test_palette.ml @@ -18,6 +18,25 @@ let test_basic_palette_of_ints _ = assert_equal ~msg:"Colour distinctive_pair" ~printer:extreme_print (3, 1) distinctive_pair +let test_single_entry_palette _ = + let cols = [ 0x000000 ] in + let pal = Palette.of_list cols in + assert_equal ~msg:"Palette size" (List.length cols) (Palette.size pal); + List.iteri + (fun i c -> + let v = Palette.index_to_rgb pal i in + assert_equal ~msg:"Colour match" (Int32.of_int c) v) + cols; + let rev = Palette.to_list pal in + assert_equal ~msg:"Back to ints" cols rev; + let distinctive_pair = Palette.distinctive_pair pal in + assert_equal ~msg:"Colour distinctive_pair" ~printer:extreme_print (0, 0) + distinctive_pair + +let test_zero_entry_palette _ = + assert_raises (Invalid_argument "Palette size must not be zero or negative") + (fun () -> Palette.of_list []) + let test_generate_mac_palette_creation _ = let pal = Palette.generate_mac_palette () in assert_equal ~msg:"Palette size" 16 (Palette.size pal) @@ -221,6 +240,8 @@ let suite = "PaletteTests" >::: [ "Test simple palette set up" >:: test_basic_palette_of_ints; + "Test single entry palette set up" >:: test_single_entry_palette; + "Test zero entry palette" >:: test_zero_entry_palette; "Test generate mac palette" >:: test_generate_mac_palette_creation; "Test generate sweetie16 palette" >:: test_generate_sweetie16_palette; "Test linear palette" >:: test_generate_linear_palette; From f4349254df32b28def3520098cb3422105c83a96 Mon Sep 17 00:00:00 2001 From: Michael Dales Date: Sat, 13 Sep 2025 16:24:33 +0100 Subject: [PATCH 7/7] Remove commented out code --- test/test_screenshot.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/test/test_screenshot.ml b/test/test_screenshot.ml index 3ffb6f1..05f74ac 100644 --- a/test/test_screenshot.ml +++ b/test/test_screenshot.ml @@ -27,7 +27,6 @@ let test_palette_too_big _ = let fb = Framebuffer.init (width, height) (fun _ _ -> 42) in Framebuffer.set_dirty fb; let screen = Screen.create width height scale palette in - (* assert_raises (Failure "GIF only supports up to 256 colors") (fun () -> *) let res = Screenshot.save_screenshot screen fb in let expected = Result.Error "GIF only supports up to 256 colors" in assert_equal expected res