From 30bc21aba80d546267a080f21c62e1572cce768a Mon Sep 17 00:00:00 2001 From: essa237 Date: Mon, 14 Apr 2025 17:37:35 +0100 Subject: [PATCH 1/6] Add unit test for run loop created a seperate module and interface to for mocking sdl --- src/sdl_api.mli | 38 ++++++++++++++++++++++++++++++++++++++ src/sdl_mock.ml | 30 ++++++++++++++++++++++++++++++ test/test_run_loop.ml | 30 ++++++++++++++++++++++++++++++ 3 files changed, 98 insertions(+) create mode 100644 src/sdl_api.mli create mode 100644 src/sdl_mock.ml create mode 100644 test/test_run_loop.ml diff --git a/src/sdl_api.mli b/src/sdl_api.mli new file mode 100644 index 0000000..14486c7 --- /dev/null +++ b/src/sdl_api.mli @@ -0,0 +1,38 @@ +module type SDL_API = sig + + (*These types will represents abstract sdl object*) + + type window + type event + type renderer + type texture + + val init : int -> string -> bool -> (window * renderer, string) result + (**This handle the initialization of SDL + arguments width, height, window title and fullscreen flag and onsuccess, this returns a window and a renderer and on failure we have an error message + *) + + val create_texture : renderer -> Sdl.Pixel.format -> width:int -> height:int -> Sdl.Texture.access -> (texture, string) result + (* Create a texture, given a renderer, a pixel format and dimension of width and height if successful, a texture is returned else an error*) + + val update_texture : renderer -> BigArray.Array1.t -> int -> (unit, string) result + (* Update texture with pixel data from BigArray the integer parameter, represents pixel width *) + + val renderer_clear : renderer -> (unit, string) result + (* Clears renderer drawing target*) + + val renderer_copy : renderer -> texture -> Sdl.Rect.t option -> (unit, string) result + (* Copies a texture to a renderer's target indicating where to place the texture*) + + val renderer_present : renderer -> (unit, string) result + (* Present the content of the renderer to the sting.*) + + val poll_event : unit -> event option + (* Polls an SDL event returns event if available*) + + val delay : int -> unit + (* delays execution for a number of milliseconds*) + + val log : string -> unit + (*logs messages *) +end \ No newline at end of file diff --git a/src/sdl_mock.ml b/src/sdl_mock.ml new file mode 100644 index 0000000..56e8a70 --- /dev/null +++ b/src/sdl_mock.ml @@ -0,0 +1,30 @@ +module MockSDL : SDL_API = struct + + (*Here, we define abstract types as trivial. For test, since real values are not used, we use [unit] + and for events, [string] since events are represented as string*) + + type window = unit + type event = string + type renderer = unit + type texture = unit + + let init _width _height _title _fullscreen = Ok ((),()) + (*Ignores parameter and return a dummy window.*) + + let create_texture _renderer _format ~width:_ ~height:_ _access = Ok () + (*Ignores parameter and returns dummy texture*) + + let update_texture _renderer _texture _bitmap _width = Ok () + + let renderer_clear _renderer = Ok () + + let renderer_copy _renderer _texture ~dist:_ = Ok () + + let renderer_present _renderer = Ok () + + let poll_event () = None + + let delay _ = () + + let log s = Printf.printf "MockSDL.log: %s\n" s +end \ No newline at end of file diff --git a/test/test_run_loop.ml b/test/test_run_loop.ml new file mode 100644 index 0000000..c601768 --- /dev/null +++ b/test/test_run_loop.ml @@ -0,0 +1,30 @@ +open OUnit2 +open Claudius +open Tsdl + +module TestRunLoop = MakeRunLoop(MockSDL) + +let dummy_tick (t : int) (_screen : Screen.t) (prev_fb : Framebuffer.t) (_input : input_state) : Framebuffer.t = + prev_fb + +let test_always_fail _ = + let test_always_fail _ = + assert_equal ~msg:"This should fail" 1 2assert_equal ~msg:"This should fail" 1 2 + +(* Test that the run loop with a dummy tick (no update) returns a framebuffer equal + to the initial one.*) + +let test_run_loop_no_update _ = + let screen = Screen.create 320 240 1 (Palette.generate_mono_palette 16) in + let initial_fb = Framebuffer.init (320, 240) (fun _x _y -> 0) in + let result_fb = TestRunLoop.run "TestRun" None dummy_tick screen in + assert_equal (Framebuffer.to_array initial_fb) (Framebuffer.to_array result_fb) + +let suite = + "Run Loop Unit Tests" >::: [ + "Test fail" >:: test_always_fail; + "Test run loop with dummy tick (no update)" >:: test_run_loop_no_update; + ] + +let () = + run_test_tt_main suite \ No newline at end of file From 20497b0cf38675ff0a090c12d700971f4e60a23c Mon Sep 17 00:00:00 2001 From: essa237 Date: Mon, 14 Apr 2025 17:49:50 +0100 Subject: [PATCH 2/6] Add unit test for run loop created a seperate module and interface to for mocking sdl --- src/dune | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/dune b/src/dune index e5bd2de..2819c31 100644 --- a/src/dune +++ b/src/dune @@ -7,4 +7,9 @@ (library (name claudius) (public_name claudius) +<<<<<<< HEAD (libraries tsdl giflib crunch)) +======= + (libraries tsdl giflib) + (modules_without_implementation sdl_api)) +>>>>>>> 264fc8e (Add unit test for run loop created a seperate module and interface to for mocking sdl) From f7d546ede614c80496ec53adbe80d128519c06fc Mon Sep 17 00:00:00 2001 From: essa237 Date: Tue, 15 Apr 2025 08:38:29 +0100 Subject: [PATCH 3/6] Add unit test for run loop created a seperate module and interface to for mocking sdl --- src/sdl_api.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/sdl_api.mli b/src/sdl_api.mli index 14486c7..56cb33f 100644 --- a/src/sdl_api.mli +++ b/src/sdl_api.mli @@ -1,3 +1,5 @@ +open Tsdl + module type SDL_API = sig (*These types will represents abstract sdl object*) From 48cad264b5f92faf2eee2ab1973ed52d243ed04f Mon Sep 17 00:00:00 2001 From: essa237 Date: Tue, 15 Apr 2025 08:56:45 +0100 Subject: [PATCH 4/6] Add unit test for run loop created a seperate module and interface to for mocking sdl --- src/sdl_api.mli | 25 +++++++++++++------------ src/sdl_mock.ml | 4 +++- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/src/sdl_api.mli b/src/sdl_api.mli index 56cb33f..9e0e4dd 100644 --- a/src/sdl_api.mli +++ b/src/sdl_api.mli @@ -1,28 +1,29 @@ open Tsdl module type SDL_API = sig - (*These types will represents abstract sdl object*) - type window - type event type renderer type texture + type event - val init : int -> string -> bool -> (window * renderer, string) result - (**This handle the initialization of SDL - arguments width, height, window title and fullscreen flag and onsuccess, this returns a window and a renderer and on failure we have an error message + + val init : int -> int -> string -> bool -> (window * renderer, string) result + (**This handle the initialization of SDL + arguments width, height, window title and fullscreen flag and onsuccess, + this returns a window and a renderer and on failure we have an error message *) - + val create_texture : renderer -> Sdl.Pixel.format -> width:int -> height:int -> Sdl.Texture.access -> (texture, string) result - (* Create a texture, given a renderer, a pixel format and dimension of width and height if successful, a texture is returned else an error*) - - val update_texture : renderer -> BigArray.Array1.t -> int -> (unit, string) result + (* Create a texture, given a renderer, a pixel format and dimension of width and + height if successful, a texture is returned else an error*) + + val update_texture : renderer -> texture -> Bigarray.Array1.t -> int -> (unit, string) result (* Update texture with pixel data from BigArray the integer parameter, represents pixel width *) val renderer_clear : renderer -> (unit, string) result (* Clears renderer drawing target*) - + val renderer_copy : renderer -> texture -> Sdl.Rect.t option -> (unit, string) result (* Copies a texture to a renderer's target indicating where to place the texture*) @@ -31,7 +32,7 @@ module type SDL_API = sig val poll_event : unit -> event option (* Polls an SDL event returns event if available*) - + val delay : int -> unit (* delays execution for a number of milliseconds*) diff --git a/src/sdl_mock.ml b/src/sdl_mock.ml index 56e8a70..5112547 100644 --- a/src/sdl_mock.ml +++ b/src/sdl_mock.ml @@ -1,3 +1,5 @@ +open Tsdl + module MockSDL : SDL_API = struct (*Here, we define abstract types as trivial. For test, since real values are not used, we use [unit] @@ -27,4 +29,4 @@ module MockSDL : SDL_API = struct let delay _ = () let log s = Printf.printf "MockSDL.log: %s\n" s -end \ No newline at end of file +end From 609ab4f8a344dec43018590cb09d073012d449e1 Mon Sep 17 00:00:00 2001 From: essa237 Date: Tue, 15 Apr 2025 15:18:26 +0100 Subject: [PATCH 5/6] Add unit test for run loop created a seperate module and interface to for mocking sdl --- src/base.ml | 1 + src/dune | 5 -- src/mock_sdl.ml | 24 ++++++++++ src/run_loop.ml | 103 ++++++++++++++++++++++++++++++++++++++++++ src/sdl_api.mli | 47 ++++++++----------- src/sdl_mock.ml | 32 ------------- test/test_run_loop.ml | 25 ++++++---- 7 files changed, 163 insertions(+), 74 deletions(-) create mode 100644 src/mock_sdl.ml create mode 100644 src/run_loop.ml delete mode 100644 src/sdl_mock.ml diff --git a/src/base.ml b/src/base.ml index d7a683a..3d7058e 100644 --- a/src/base.ml +++ b/src/base.ml @@ -1,5 +1,6 @@ (* base.ml *) open Tsdl +open Key module KeyCodeSet = Set.Make(struct type t = Key.t diff --git a/src/dune b/src/dune index 2819c31..e5bd2de 100644 --- a/src/dune +++ b/src/dune @@ -7,9 +7,4 @@ (library (name claudius) (public_name claudius) -<<<<<<< HEAD (libraries tsdl giflib crunch)) -======= - (libraries tsdl giflib) - (modules_without_implementation sdl_api)) ->>>>>>> 264fc8e (Add unit test for run loop created a seperate module and interface to for mocking sdl) diff --git a/src/mock_sdl.ml b/src/mock_sdl.ml new file mode 100644 index 0000000..05b4b35 --- /dev/null +++ b/src/mock_sdl.ml @@ -0,0 +1,24 @@ +module MockSDL : Sdl_api.SDL_API = struct + (* Define abstract types as [unit] since no real values are needed during tests. *) + type window = unit + type renderer = unit + type texture = unit + type event = string (* We'll represent events simply as strings in testing *) + + type bitmap_t = (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t + + (* Simulate initializing SDL by ignoring input parameters and returning a dummy window and renderer. *) + let init _width _height _title _fullscreen = Ok ((), ()) + + (* Simulate texture creation by returning a dummy texture. *) + let create_texture _renderer _format ~width:_ ~height:_ _access = Ok () + + (* Simulate texture updating by doing nothing and returning success. *) + let update_texture _renderer _texture _bitmap _width = Ok () + + (* Simulate clearing the renderer. *) + let renderer_clear _renderer = Ok () + + (* Simulate copying a texture to the renderer's target. *) + let renderer_copy _renderer _texture ~dst:_ = Ok () +end diff --git a/src/run_loop.ml b/src/run_loop.ml new file mode 100644 index 0000000..73996ce --- /dev/null +++ b/src/run_loop.ml @@ -0,0 +1,103 @@ +open Tsdl +open Bigarray +open Base + +module MakeRunLoop (SDL : Sdl_api.SDL_API) = struct + + let run (title : string) (boot : Base.boot_func option) (tick : Base.tick_func) (s : Screen.t) = + let make_full = Array.to_list Sys.argv |> List.exists (fun a -> (String.compare a "-f") = 0) in + let s = + match make_full with + | false -> s + | true -> + let w, h = Screen.dimensions s and p = Screen.palette s in + (match Screen.font s with + | None -> Screen.create w h 1 p + | Some f -> Screen.create_with_font w h 1 f p) + in + let width, height = Screen.dimensions s and scale = Screen.scale s in + match Base.sdl_init (width * scale) (height * scale) title make_full with + | Error (`Msg e) -> + Sdl.log "Init error: %s" e; + exit 1 + | Ok (w, r) -> + match Sdl.create_texture r Sdl.Pixel.format_rgb888 ~w:width ~h:height Sdl.Texture.access_streaming with + | Error (`Msg e) -> + Sdl.log "texture error: %s" e; + exit 1 + | Ok texture -> + let bitmap = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout (width * height) in + let initial_buffer = + match boot with + | None -> Framebuffer.init (width, height) (fun _x _y -> 0) + | Some bfunc -> bfunc s + in + let e = Sdl.Event.create () in + let input = { keys = KeyCodeSet.empty; mouse = Mouse.create scale } in + let rec loop (t : int) (prev_buffer : Framebuffer.t) (input : input_state) last_t = + let now = Sdl.get_ticks () in + let diff = Int32.(sub (of_int (1000 / 60)) (sub now last_t)) in + if Int32.(compare diff zero) > 0 then Sdl.delay diff; + let keys = KeyCodeSet.elements input.keys in + Screenshot.save_screenshot keys s prev_buffer; + let updated_buffer = tick t s prev_buffer input in + let input = { input with mouse = Mouse.clear_events input.mouse } in + if (updated_buffer != prev_buffer) + || (Framebuffer.is_dirty updated_buffer) + || (Screen.is_dirty s) + then ( + framebuffer_to_bigarray s updated_buffer bitmap; + (match render_texture r texture s bitmap with + | Error (`Msg e) -> Sdl.log "Boot error: %s" e + | Ok () -> ()); + Framebuffer.clear_dirty updated_buffer; + Screen.clear_dirty s + ); + match render_texture r texture s bitmap with + | Error (`Msg e) -> Sdl.log "Boot error: %s" e + | Ok () -> + let exit, input = + match Sdl.poll_event (Some e) with + | true -> + (match Sdl.Event.(enum (get e typ)) with + | `Quit -> (true, input) + | `Key_down -> + let key = + PlatformKey.of_backend_keycode (Sdl.Event.(get e keyboard_keycode)) + in + (false, { input with keys = KeyCodeSet.add key input.keys }) + | `Key_up -> + let key = + PlatformKey.of_backend_keycode (Sdl.Event.(get e keyboard_keycode)) + in + (false, { input with keys = KeyCodeSet.remove key input.keys }) + | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel -> + let mouse = PlatformMouse.handle_event e input.mouse in + (false, { input with mouse }) + | _ -> (false, input)) + | false -> (false, input) + in + if exit then () + else loop (t + 1) updated_buffer input now + in + let _ = loop 0 initial_buffer input Int32.zero in + Sdl.destroy_texture texture; + Sdl.destroy_renderer r; + Sdl.destroy_window w; + Sdl.quit () + ;; + + let run_functional (title : string) (tick_f : functional_tick_func) (s : Screen.t) : Framebuffer.t = + let wrap_tick (t : int) (screen : Screen.t) (prev_fb : Framebuffer.t) (input : input_state) : Framebuffer.t = + let primitives = tick_f t screen input in + if primitives = [] then prev_fb + else + let width, height = Screen.dimensions screen in + let new_fb = Framebuffer.init (width, height) (fun _x _y -> 0) in + Framebuffer.render new_fb primitives; + new_fb + in + run title None wrap_tick s + ;; + +end diff --git a/src/sdl_api.mli b/src/sdl_api.mli index 9e0e4dd..bd07827 100644 --- a/src/sdl_api.mli +++ b/src/sdl_api.mli @@ -1,41 +1,34 @@ open Tsdl module type SDL_API = sig - (*These types will represents abstract sdl object*) +(*These types will represents abstract sdl object*) type window type renderer type texture type event - - val init : int -> int -> string -> bool -> (window * renderer, string) result - (**This handle the initialization of SDL - arguments width, height, window title and fullscreen flag and onsuccess, + type bitmap_t = (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t + + (**This handle the initialization of SDL + parameters width, height, window title and fullscreen flag and onsuccess, this returns a window and a renderer and on failure we have an error message *) - - val create_texture : renderer -> Sdl.Pixel.format -> width:int -> height:int -> Sdl.Texture.access -> (texture, string) result - (* Create a texture, given a renderer, a pixel format and dimension of width and - height if successful, a texture is returned else an error*) - - val update_texture : renderer -> texture -> Bigarray.Array1.t -> int -> (unit, string) result - (* Update texture with pixel data from BigArray the integer parameter, represents pixel width *) - - val renderer_clear : renderer -> (unit, string) result - (* Clears renderer drawing target*) - - val renderer_copy : renderer -> texture -> Sdl.Rect.t option -> (unit, string) result - (* Copies a texture to a renderer's target indicating where to place the texture*) + val init : int -> int -> string -> bool -> (window * renderer, string) Stdlib.result - val renderer_present : renderer -> (unit, string) result - (* Present the content of the renderer to the sting.*) +(* Create a texture, given a renderer, a pixel format and dimension of width and + height if successful, a texture is returned else an error*) + val create_texture : renderer -> int -> width:int -> height:int -> Sdl.Texture.access -> (texture, string) Stdlib.result - val poll_event : unit -> event option - (* Polls an SDL event returns event if available*) + (* Update texture with pixel data from [bitmap] the integer parameter, represents pixel width *) + val update_texture : renderer -> texture -> bitmap_t -> int -> (unit, string) Stdlib.result - val delay : int -> unit - (* delays execution for a number of milliseconds*) + (* [renderer_clear renderer] clears the renderer’s drawing target. + Returns unit on success. + *) + val renderer_clear : renderer -> (unit, string) Stdlib.result - val log : string -> unit - (*logs messages *) -end \ No newline at end of file + (* [renderer_copy renderer texture dst] copies the [texture] to the renderer’s target. + [dst] is an optional destination rectangle. + *) + val renderer_copy : renderer -> texture -> dst:Sdl.rect option -> (unit, string) Stdlib.result +end diff --git a/src/sdl_mock.ml b/src/sdl_mock.ml deleted file mode 100644 index 5112547..0000000 --- a/src/sdl_mock.ml +++ /dev/null @@ -1,32 +0,0 @@ -open Tsdl - -module MockSDL : SDL_API = struct - - (*Here, we define abstract types as trivial. For test, since real values are not used, we use [unit] - and for events, [string] since events are represented as string*) - - type window = unit - type event = string - type renderer = unit - type texture = unit - - let init _width _height _title _fullscreen = Ok ((),()) - (*Ignores parameter and return a dummy window.*) - - let create_texture _renderer _format ~width:_ ~height:_ _access = Ok () - (*Ignores parameter and returns dummy texture*) - - let update_texture _renderer _texture _bitmap _width = Ok () - - let renderer_clear _renderer = Ok () - - let renderer_copy _renderer _texture ~dist:_ = Ok () - - let renderer_present _renderer = Ok () - - let poll_event () = None - - let delay _ = () - - let log s = Printf.printf "MockSDL.log: %s\n" s -end diff --git a/test/test_run_loop.ml b/test/test_run_loop.ml index c601768..add7cbb 100644 --- a/test/test_run_loop.ml +++ b/test/test_run_loop.ml @@ -1,30 +1,35 @@ +(* test_run_loop.ml *) + open OUnit2 -open Claudius +open Claudius (* This should provide Screen, Framebuffer, Palette, etc. *) open Tsdl +(* Instantiate the run loop with our mock SDL implementation *) module TestRunLoop = MakeRunLoop(MockSDL) +(* A dummy tick function that performs no updates: + It simply returns the framebuffer unchanged. +*) let dummy_tick (t : int) (_screen : Screen.t) (prev_fb : Framebuffer.t) (_input : input_state) : Framebuffer.t = prev_fb -let test_always_fail _ = - let test_always_fail _ = - assert_equal ~msg:"This should fail" 1 2assert_equal ~msg:"This should fail" 1 2 - -(* Test that the run loop with a dummy tick (no update) returns a framebuffer equal - to the initial one.*) - +(* Test that using the dummy tick function leaves the framebuffer unchanged *) let test_run_loop_no_update _ = + (* Create a test screen with a simple monochrome palette *) let screen = Screen.create 320 240 1 (Palette.generate_mono_palette 16) in + (* Create an initial framebuffer filled with zeroes *) let initial_fb = Framebuffer.init (320, 240) (fun _x _y -> 0) in + (* Run the test run loop once; dummy_tick should return the initial framebuffer *) let result_fb = TestRunLoop.run "TestRun" None dummy_tick screen in + (* Compare the underlying pixel arrays of the initial and resulting framebuffers *) assert_equal (Framebuffer.to_array initial_fb) (Framebuffer.to_array result_fb) +(* Group the tests into a suite *) let suite = "Run Loop Unit Tests" >::: [ - "Test fail" >:: test_always_fail; "Test run loop with dummy tick (no update)" >:: test_run_loop_no_update; ] +(* Execute the test suite *) let () = - run_test_tt_main suite \ No newline at end of file + run_test_tt_main suite From 439dc70411ee170e0ae0ac839bbf9f1417d53925 Mon Sep 17 00:00:00 2001 From: essa237 Date: Wed, 7 May 2025 18:03:29 +0100 Subject: [PATCH 6/6] deleted the abstracted sd file and now started implemetation inthe base ml file --- src/base.ml | 80 +++++++++++++++++++++++++++++++++++-- src/mock_sdl.ml | 24 ----------- src/run_loop.ml | 103 ------------------------------------------------ src/sdl_api.mli | 34 ---------------- 4 files changed, 77 insertions(+), 164 deletions(-) delete mode 100644 src/mock_sdl.ml delete mode 100644 src/run_loop.ml delete mode 100644 src/sdl_api.mli diff --git a/src/base.ml b/src/base.ml index 3d7058e..7ea5d4d 100644 --- a/src/base.ml +++ b/src/base.ml @@ -1,6 +1,5 @@ (* base.ml *) open Tsdl -open Key module KeyCodeSet = Set.Make(struct type t = Key.t @@ -18,8 +17,76 @@ type input_state = { type boot_func = Screen.t -> Framebuffer.t type tick_func = int -> Screen.t -> Framebuffer.t -> input_state -> Framebuffer.t + type functional_tick_func = int -> Screen.t -> input_state -> Primitives.t list +(* SDL operation signature*) +module type SDL_ops = sig + type window + type renderer + type texture + type event + + type bitmap_t = (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t + + (**This handle the initialization of SDL + parameters width, height, window title and fullscreen flag and onsuccess, + this returns a window and a renderer and on failure we have an error message + *) + val init : int -> int -> string -> bool -> (window * renderer, string) Stdlib.result + +(* Create a texture, given a renderer, a pixel format and dimension of width and + height if successful, a texture is returned else an error*) + val create_texture : renderer -> int -> width:int -> height:int -> Sdl.Texture.access -> (texture, string) Stdlib.result + + (* Update texture with pixel data from [bitmap] the integer parameter, represents pixel width *) + val update_texture : renderer -> texture -> bitmap_t -> int -> (unit, string) Stdlib.result + val renderer_clear : renderer -> (unit, string) Stdlib.result + val render_copy : renderer -> texture -> dst:Sdl.rect option -> (unit, string) Stdlib.result + + val render_present : renderer -> unit + val poll_event_opt : unit -> event option + val get_ticks : unit -> int32 + val delay : int32 -> unit + val mk_event : unit -> event +end + +module type Screenshot_ops = sig + val save : Event.t list -> Screen.t -> Framebuffer.t -> unit +end + +(** SDL binding, wiring through existing Tsdl calls *) +module SDL_impl : SDL_ops = struct + type window = Sdl.window + type renderer = Sdl.renderer + type texture = Sdl.texture + type event = Sdl.event + + let init w h title fs = + Sdl.init Sdl.Init.(video + events) >>= fun () -> + Sdl.create_window ~w ~h title Sdl.Window.(if fs then fullscreen else windowed) >>= fun win -> + Sdl.create_renderer ~flags:Sdl.Renderer.(accelerated + presentvsync) win >|= fun r -> (win, r) + + let create_texture = Sdl.create_texture + + let render_clear r = Sdl.render_clear r + let update_texture r tx bm w = Sdl.update_texture r tx bm w + let render_copy r tx ~dst = Sdl.render_copy ~dst r tx + + let poll_event_opt () = + let e = Sdl.Event.create () in + if Sdl.poll_event (Some e) then Some e else None + + let get_ticks () = Sdl.get_ticks () + let delay d = Sdl.delay d + let mk_event () = Sdl.Event.create () +end + +(* Default screenshot implementation *) +module Screenshot_impl : Screenshot_ops = struct + let save = Screenshot.save_screenshot +end + (* ----- *) let (>>=) = Result.bind @@ -81,7 +148,14 @@ let rec poll_all_events keys mouse acc = | false -> (false, keys, mouse, List.rev acc) -let run title boot tick s = +let run + ?(sdl_ops : (module SDL_ops) = (module SDL_impl)) + ?(screenshot_ops : (module Screenshot_ops) = (module Screenshot_impl)) + title boot tick s = + + let module SDL = (val sdl_ops : SDL_ops) in + let module SS = (val screenshot_ops : Screenshot_ops) in + let make_full = Array.to_list Sys.argv |> List.exists (fun a -> String.compare a "-f" = 0) in @@ -186,4 +260,4 @@ let was_key_just_released input key = List.exists (function | Event.KeyUp k when k = key -> true | _ -> false - ) input.events + ) input.events \ No newline at end of file diff --git a/src/mock_sdl.ml b/src/mock_sdl.ml deleted file mode 100644 index 05b4b35..0000000 --- a/src/mock_sdl.ml +++ /dev/null @@ -1,24 +0,0 @@ -module MockSDL : Sdl_api.SDL_API = struct - (* Define abstract types as [unit] since no real values are needed during tests. *) - type window = unit - type renderer = unit - type texture = unit - type event = string (* We'll represent events simply as strings in testing *) - - type bitmap_t = (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t - - (* Simulate initializing SDL by ignoring input parameters and returning a dummy window and renderer. *) - let init _width _height _title _fullscreen = Ok ((), ()) - - (* Simulate texture creation by returning a dummy texture. *) - let create_texture _renderer _format ~width:_ ~height:_ _access = Ok () - - (* Simulate texture updating by doing nothing and returning success. *) - let update_texture _renderer _texture _bitmap _width = Ok () - - (* Simulate clearing the renderer. *) - let renderer_clear _renderer = Ok () - - (* Simulate copying a texture to the renderer's target. *) - let renderer_copy _renderer _texture ~dst:_ = Ok () -end diff --git a/src/run_loop.ml b/src/run_loop.ml deleted file mode 100644 index 73996ce..0000000 --- a/src/run_loop.ml +++ /dev/null @@ -1,103 +0,0 @@ -open Tsdl -open Bigarray -open Base - -module MakeRunLoop (SDL : Sdl_api.SDL_API) = struct - - let run (title : string) (boot : Base.boot_func option) (tick : Base.tick_func) (s : Screen.t) = - let make_full = Array.to_list Sys.argv |> List.exists (fun a -> (String.compare a "-f") = 0) in - let s = - match make_full with - | false -> s - | true -> - let w, h = Screen.dimensions s and p = Screen.palette s in - (match Screen.font s with - | None -> Screen.create w h 1 p - | Some f -> Screen.create_with_font w h 1 f p) - in - let width, height = Screen.dimensions s and scale = Screen.scale s in - match Base.sdl_init (width * scale) (height * scale) title make_full with - | Error (`Msg e) -> - Sdl.log "Init error: %s" e; - exit 1 - | Ok (w, r) -> - match Sdl.create_texture r Sdl.Pixel.format_rgb888 ~w:width ~h:height Sdl.Texture.access_streaming with - | Error (`Msg e) -> - Sdl.log "texture error: %s" e; - exit 1 - | Ok texture -> - let bitmap = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout (width * height) in - let initial_buffer = - match boot with - | None -> Framebuffer.init (width, height) (fun _x _y -> 0) - | Some bfunc -> bfunc s - in - let e = Sdl.Event.create () in - let input = { keys = KeyCodeSet.empty; mouse = Mouse.create scale } in - let rec loop (t : int) (prev_buffer : Framebuffer.t) (input : input_state) last_t = - let now = Sdl.get_ticks () in - let diff = Int32.(sub (of_int (1000 / 60)) (sub now last_t)) in - if Int32.(compare diff zero) > 0 then Sdl.delay diff; - let keys = KeyCodeSet.elements input.keys in - Screenshot.save_screenshot keys s prev_buffer; - let updated_buffer = tick t s prev_buffer input in - let input = { input with mouse = Mouse.clear_events input.mouse } in - if (updated_buffer != prev_buffer) - || (Framebuffer.is_dirty updated_buffer) - || (Screen.is_dirty s) - then ( - framebuffer_to_bigarray s updated_buffer bitmap; - (match render_texture r texture s bitmap with - | Error (`Msg e) -> Sdl.log "Boot error: %s" e - | Ok () -> ()); - Framebuffer.clear_dirty updated_buffer; - Screen.clear_dirty s - ); - match render_texture r texture s bitmap with - | Error (`Msg e) -> Sdl.log "Boot error: %s" e - | Ok () -> - let exit, input = - match Sdl.poll_event (Some e) with - | true -> - (match Sdl.Event.(enum (get e typ)) with - | `Quit -> (true, input) - | `Key_down -> - let key = - PlatformKey.of_backend_keycode (Sdl.Event.(get e keyboard_keycode)) - in - (false, { input with keys = KeyCodeSet.add key input.keys }) - | `Key_up -> - let key = - PlatformKey.of_backend_keycode (Sdl.Event.(get e keyboard_keycode)) - in - (false, { input with keys = KeyCodeSet.remove key input.keys }) - | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel -> - let mouse = PlatformMouse.handle_event e input.mouse in - (false, { input with mouse }) - | _ -> (false, input)) - | false -> (false, input) - in - if exit then () - else loop (t + 1) updated_buffer input now - in - let _ = loop 0 initial_buffer input Int32.zero in - Sdl.destroy_texture texture; - Sdl.destroy_renderer r; - Sdl.destroy_window w; - Sdl.quit () - ;; - - let run_functional (title : string) (tick_f : functional_tick_func) (s : Screen.t) : Framebuffer.t = - let wrap_tick (t : int) (screen : Screen.t) (prev_fb : Framebuffer.t) (input : input_state) : Framebuffer.t = - let primitives = tick_f t screen input in - if primitives = [] then prev_fb - else - let width, height = Screen.dimensions screen in - let new_fb = Framebuffer.init (width, height) (fun _x _y -> 0) in - Framebuffer.render new_fb primitives; - new_fb - in - run title None wrap_tick s - ;; - -end diff --git a/src/sdl_api.mli b/src/sdl_api.mli deleted file mode 100644 index bd07827..0000000 --- a/src/sdl_api.mli +++ /dev/null @@ -1,34 +0,0 @@ -open Tsdl - -module type SDL_API = sig -(*These types will represents abstract sdl object*) - type window - type renderer - type texture - type event - - type bitmap_t = (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t - - (**This handle the initialization of SDL - parameters width, height, window title and fullscreen flag and onsuccess, - this returns a window and a renderer and on failure we have an error message - *) - val init : int -> int -> string -> bool -> (window * renderer, string) Stdlib.result - -(* Create a texture, given a renderer, a pixel format and dimension of width and - height if successful, a texture is returned else an error*) - val create_texture : renderer -> int -> width:int -> height:int -> Sdl.Texture.access -> (texture, string) Stdlib.result - - (* Update texture with pixel data from [bitmap] the integer parameter, represents pixel width *) - val update_texture : renderer -> texture -> bitmap_t -> int -> (unit, string) Stdlib.result - - (* [renderer_clear renderer] clears the renderer’s drawing target. - Returns unit on success. - *) - val renderer_clear : renderer -> (unit, string) Stdlib.result - - (* [renderer_copy renderer texture dst] copies the [texture] to the renderer’s target. - [dst] is an optional destination rectangle. - *) - val renderer_copy : renderer -> texture -> dst:Sdl.rect option -> (unit, string) Stdlib.result -end