diff --git a/src/base.ml b/src/base.ml index d7a683a..7ea5d4d 100644 --- a/src/base.ml +++ b/src/base.ml @@ -17,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 @@ -80,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 @@ -185,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/test/test_run_loop.ml b/test/test_run_loop.ml new file mode 100644 index 0000000..add7cbb --- /dev/null +++ b/test/test_run_loop.ml @@ -0,0 +1,35 @@ +(* test_run_loop.ml *) + +open OUnit2 +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 + +(* 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 run loop with dummy tick (no update)" >:: test_run_loop_no_update; + ] + +(* Execute the test suite *) +let () = + run_test_tt_main suite