├── .gitmodules ├── .ocamlformat ├── doc ├── dune └── index.mld ├── .DS_Store ├── test_assets ├── tetris.png └── tetris.png:Zone.Identifier ├── fonts ├── TamzenForPowerline10x20.psf ├── README.md └── LICENSE ├── dune ├── src ├── dune ├── event.ml ├── screenshot.mli ├── screenshot.ml ├── keysdl.mli ├── stats.mli ├── utils_gif.mli ├── primitives.ml ├── utils.ml ├── picture.mli ├── primitives.mli ├── mouse.ml ├── mousesdl.mli ├── mouse.mli ├── animation.mli ├── key.ml ├── event.mli ├── key.mli ├── font.mli ├── animation.ml ├── utils_gif.ml ├── screen.mli ├── base.mli ├── screen.ml ├── picture.ml ├── mousesdl.ml ├── stats.ml ├── palette.mli ├── keysdl.ml ├── font.ml ├── framebuffer.mli ├── palette.ml ├── base.ml └── framebuffer.ml ├── test ├── dune ├── test_stats.ml ├── test_utils.ml ├── test_screenshot.ml ├── test_picture.ml ├── test_animation.ml ├── test_keysdl.ml ├── test_screen.ml ├── test_framebuffer.ml ├── test_mousesdl.ml ├── test_events.ml ├── test_palette.ml └── test_primitives.ml ├── .gitignore ├── .github ├── CODE_OF_CONDUCT.md └── workflows │ └── main.yml ├── LICENSE ├── dune-project ├── claudius.opam └── README.md /.gitmodules: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.27.0 -------------------------------------------------------------------------------- /doc/dune: -------------------------------------------------------------------------------- 1 | (documentation) 2 | -------------------------------------------------------------------------------- /.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/claudiusFX/Claudius/HEAD/.DS_Store -------------------------------------------------------------------------------- /test_assets/tetris.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/claudiusFX/Claudius/HEAD/test_assets/tetris.png -------------------------------------------------------------------------------- /fonts/TamzenForPowerline10x20.psf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/claudiusFX/Claudius/HEAD/fonts/TamzenForPowerline10x20.psf -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | ;; copied for tests 2 | 3 | (rule 4 | (alias runtest) 5 | (deps fonts/TamzenForPowerline10x20.psf) 6 | (targets TamzenForPowerline10x20.psf) 7 | (action 8 | (copy fonts/TamzenForPowerline10x20.psf TamzenForPowerline10x20.psf))) 9 | -------------------------------------------------------------------------------- /test_assets/tetris.png:Zone.Identifier: -------------------------------------------------------------------------------- 1 | [ZoneTransfer] 2 | ZoneId=3 3 | ReferrerUrl=https://publicdomainvectors.org/en/free-clipart/3D-Tetris-blocks-vector-illustration/6089.html 4 | HostUrl=https://publicdomainvectors.org/photos/Tetris_block.png 5 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets builtins.ml) 3 | (deps ../fonts/TamzenForPowerline10x20.psf) 4 | (action 5 | (run ocaml-crunch -m plain -o builtins.ml ../fonts))) 6 | 7 | (library 8 | (name claudius) 9 | (public_name claudius) 10 | (libraries tsdl giflib crunch imagelib imagelib.unix hsluv)) 11 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names 3 | test_palette 4 | test_screen 5 | test_framebuffer 6 | test_primitives 7 | test_utils 8 | test_keysdl 9 | test_mousesdl 10 | test_screenshot 11 | test_events 12 | test_stats 13 | test_animation 14 | test_picture) 15 | (deps 16 | (source_tree ../test_assets)) 17 | (libraries claudius ounit2)) 18 | -------------------------------------------------------------------------------- /src/event.ml: -------------------------------------------------------------------------------- 1 | (* event.ml *) 2 | (* Unified event type. *) 3 | 4 | type t = 5 | | KeyDown of Key.t 6 | | KeyUp of Key.t 7 | | MouseButtonDown of Mouse.button * (int * int) 8 | | MouseButtonUp of Mouse.button * (int * int) 9 | | MouseMotion of (int * int) 10 | | MouseWheel of int 11 | | MouseDrag of Mouse.button * (int * int) 12 | | DropFile of string 13 | -------------------------------------------------------------------------------- /src/screenshot.mli: -------------------------------------------------------------------------------- 1 | (** Module for handling screenshots *) 2 | 3 | val save_screenshot : Screen.t -> Framebuffer.t -> (string, string) result 4 | (** [save_screenshot screen framebuffer] saves a screenshot with a timestamped 5 | filename like "screenshot_DDMMYY_HHMMSS.gif" for uniqueness. The output 6 | image is scaled by screen's scale factor factor. Returns either the path of 7 | the image or an error with reason message. *) 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # Merlin configuring file for Vim and Emacs 23 | .merlin 24 | 25 | # Dune generated files 26 | *.install 27 | 28 | # Local OPAM switch 29 | _opam/ 30 | -------------------------------------------------------------------------------- /src/screenshot.ml: -------------------------------------------------------------------------------- 1 | open Giflib 2 | open Utils_gif 3 | 4 | let save_screenshot (screen : Screen.t) (fb : Framebuffer.t) = 5 | match Palette.size (Screen.palette screen) > 256 with 6 | | true -> Result.Error "GIF only supports up to 256 colors" 7 | | false -> 8 | let image = capture_frame screen fb in 9 | let gif = GIF.from_image image in 10 | let filename = timestamp "screenshot" ^ ".gif" in 11 | GIF.to_file gif filename; 12 | Result.Ok filename 13 | -------------------------------------------------------------------------------- /fonts/README.md: -------------------------------------------------------------------------------- 1 | ## Author 2 | 3 | The Tamzen font was created by Suraj N. Kurapati ([@sunaku](https://github.com/sunaku)). 4 | 5 | # Tamzen Font 6 | 7 | Claudius includes the `TamzenForPowerline10x20.psf` bitmap font originally from the [sunaku/tamzen-font](https://github.com/sunaku/tamzen-font) repository. 8 | 9 | Only the `TamzenForPowerline10x20.psf` file is included. 10 | 11 | ## License 12 | 13 | The font is in the public domain. See the [LICENSE](./LICENSE) file for details. -------------------------------------------------------------------------------- /.github/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). 4 | 5 | # Enforcement 6 | 7 | This project follows the OCaml Code of Conduct 8 | [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). 9 | 10 | To report any violations, please contact: 11 | 12 | - Michael Dales <@mdales, michael at digitalflapjack dot com> 13 | -------------------------------------------------------------------------------- /src/keysdl.mli: -------------------------------------------------------------------------------- 1 | (** This module provides a mapping between Claudius's key representation and the 2 | backend-specific integer keycodes used by SDL. *) 3 | 4 | val of_backend_keycode : int -> Key.t 5 | (** [of_backend_keycode keycode] converts a backend-specific integer keycode 6 | into a corresponding [Key.t] representation. *) 7 | 8 | val to_backend_keycode : Key.t -> int 9 | (** [to_backend_keycode key] converts a [Key.t] representation into a 10 | backend-specific integer keycode. *) 11 | -------------------------------------------------------------------------------- /src/stats.mli: -------------------------------------------------------------------------------- 1 | (** Manages stats and other metadata for Claudius *) 2 | 3 | type t 4 | 5 | val create : unit -> t 6 | (** Create an initial stats value *) 7 | 8 | val fps : t -> int 9 | (** Get current estimated FPS *) 10 | 11 | val update : now:float -> tick:int -> t -> t 12 | (** Calculate the updated stats based on current time/tick *) 13 | 14 | val log : t -> string -> t 15 | (** Add a log message for display *) 16 | 17 | val render : 18 | t -> bool -> int -> Screen.t -> Framebuffer.t -> Framebuffer.t option 19 | (** Draw stats on the provided framebuffer *) 20 | -------------------------------------------------------------------------------- /src/utils_gif.mli: -------------------------------------------------------------------------------- 1 | (** Common utilies for screenshot and animation handling *) 2 | 3 | open Giflib 4 | 5 | val timestamp : string -> string 6 | (** [timestamp prefix] returns a filename with current timestamp *) 7 | 8 | val color_table_of_palette : Palette.t -> ColorTable.t 9 | (** [color_table_of_palette palette] converts a palette to a GIF color table. *) 10 | 11 | val capture_frame : Screen.t -> Framebuffer.t -> Image.t 12 | (** [capture_frame screen framebuffer] captures the current framebuffer contents 13 | as a compressed GIF image. Raises [Failure] if framebuffer contains invalid 14 | pixels. *) 15 | -------------------------------------------------------------------------------- /src/primitives.ml: -------------------------------------------------------------------------------- 1 | type point = { x : int; y : int } 2 | 3 | type t = 4 | | Circle of point * float * int 5 | | FilledCircle of point * float * int 6 | | Ellipse of point * float * float * int 7 | | FilledEllipse of point * float * float * int 8 | | Line of point * point * int 9 | | Pixel of point * int 10 | | Polygon of point list * int 11 | | FilledPolygon of point list * int 12 | | Rect of point * point * int 13 | | FilledRect of point * point * int 14 | | Triangle of point * point * point * int 15 | | FilledTriangle of point * point * point * int 16 | | Char of point * Font.t * char * int 17 | | String of point * Font.t * string * int 18 | | Picture of point * Picture.t 19 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | let points_to_lines points = 2 | (* The caller to this has already sorted the list, and so is sensitive to return order *) 3 | let rec last list = 4 | match list with 5 | | [] -> failwith "shouldn't get here" 6 | | [ x ] -> x 7 | | _ :: xs -> last xs 8 | in 9 | let res = 10 | match points with 11 | | [] | [ _ ] -> [] 12 | | p1 :: p2 :: ptl -> 13 | let hd = p1 in 14 | let tl = last points in 15 | let rec point_list_to_lines p1 p2 pl acc = 16 | match pl with 17 | | [] -> (p1, p2) :: acc 18 | | np :: tl -> point_list_to_lines p2 np tl ((p1, p2) :: acc) 19 | in 20 | point_list_to_lines p1 p2 ptl [ (tl, hd) ] 21 | in 22 | res 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright 2024 Michael Dales 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 8 | -------------------------------------------------------------------------------- /src/picture.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** Abstract type representing a loaded picture *) 3 | 4 | val load : string -> t 5 | (** [load filename] loads a PNG file and returns a picture. *) 6 | 7 | val dimensions : t -> int * int 8 | (** [dimensions pic] returns the width and height of the image in pixels. *) 9 | 10 | val pixels : t -> int array 11 | (** [pixels pic] returns the indexed pixel array. The pixels are arranged in 12 | consecutive rows, with the top left pixel of the image first. *) 13 | 14 | val palette : t -> Palette.t 15 | (** [palette pic] returns the color palette of the picture. *) 16 | 17 | val with_palette_offset : t -> int -> t 18 | (** [with_palette_offset pic offset] returns a new picture with all pixel 19 | indices shifted by [offset]. Palette is unchanged. *) 20 | -------------------------------------------------------------------------------- /test/test_stats.ml: -------------------------------------------------------------------------------- 1 | open Claudius 2 | open OUnit2 3 | 4 | let test_update_stats_long _ = 5 | let initial = Stats.create () in 6 | assert_equal ~msg:"FPS" 0 (Stats.fps initial); 7 | let updated = Stats.update ~now:1.1 ~tick:29 initial in 8 | assert_equal ~msg:"FPS" 29 (Stats.fps updated) 9 | 10 | let test_update_stats_short _ = 11 | let initial = Stats.create () in 12 | assert_equal ~msg:"FPS" 0 (Stats.fps initial); 13 | let updated = Stats.update ~now:0.5 ~tick:29 initial in 14 | assert_equal ~msg:"FPS" 0 (Stats.fps updated) 15 | 16 | let suite = 17 | "StatsTests" 18 | >::: [ 19 | "Test stats long update" >:: test_update_stats_long; 20 | "Test stats short update" >:: test_update_stats_short; 21 | ] 22 | 23 | let () = run_test_tt_main suite 24 | -------------------------------------------------------------------------------- /test/test_utils.ml: -------------------------------------------------------------------------------- 1 | open Claudius 2 | open OUnit2 3 | 4 | let test_points_to_lines_empty _ = 5 | let res = Utils.points_to_lines [] in 6 | assert_equal [] res 7 | 8 | let test_points_to_lines_nearly_empty _ = 9 | let res = Utils.points_to_lines [ 1 ] in 10 | assert_equal [] res 11 | 12 | let test_points_to_lines_simple_list _ = 13 | let res = Utils.points_to_lines [ 1; 2; 3 ] in 14 | assert_equal [ (2, 3); (1, 2); (3, 1) ] res 15 | 16 | let suite = 17 | "Utils tests" 18 | >::: [ 19 | "Test points to line on empty list" >:: test_points_to_lines_empty; 20 | "Test points to line on nearly empty list" 21 | >:: test_points_to_lines_nearly_empty; 22 | "Test points to line on smallest list" 23 | >:: test_points_to_lines_simple_list; 24 | ] 25 | 26 | let () = run_test_tt_main suite 27 | -------------------------------------------------------------------------------- /src/primitives.mli: -------------------------------------------------------------------------------- 1 | (** Primatives are a way to build up a list of rendering operations for the 2 | framebuffer in a functional style and then render them at once. *) 3 | 4 | type point = { x : int; y : int } 5 | 6 | type t = 7 | | Circle of point * float * int 8 | | FilledCircle of point * float * int 9 | | Ellipse of point * float * float * int 10 | | FilledEllipse of point * float * float * int 11 | | Line of point * point * int 12 | | Pixel of point * int 13 | | Polygon of point list * int 14 | | FilledPolygon of point list * int 15 | | Rect of point * point * int 16 | | FilledRect of point * point * int 17 | | Triangle of point * point * point * int 18 | | FilledTriangle of point * point * point * int 19 | | Char of point * Font.t * char * int 20 | | String of point * Font.t * string * int 21 | | Picture of point * Picture.t 22 | -------------------------------------------------------------------------------- /src/mouse.ml: -------------------------------------------------------------------------------- 1 | (* mouse input *) 2 | 3 | type button = Left | Middle | Right (** Represents a mouse button. *) 4 | 5 | type t = { 6 | position : int * int; 7 | buttons : (button * bool) list; (* current state of each button *) 8 | scale : int; (* scale factor for coordinates *) 9 | } 10 | 11 | let create scale = 12 | if scale <= 0 then invalid_arg "Invalid scale" 13 | else 14 | { 15 | position = (0, 0); 16 | buttons = [ (Left, false); (Middle, false); (Right, false) ]; 17 | scale; 18 | } 19 | 20 | let update_position t (x, y) = { t with position = (x / t.scale, y / t.scale) } 21 | 22 | let update_button t button pressed = 23 | { 24 | t with 25 | buttons = 26 | List.map 27 | (fun (b, state) -> if b = button then (b, pressed) else (b, state)) 28 | t.buttons; 29 | } 30 | 31 | let is_button_pressed t button = List.assoc button t.buttons 32 | let get_position t = t.position 33 | let get_scale t = t.scale 34 | -------------------------------------------------------------------------------- /src/mousesdl.mli: -------------------------------------------------------------------------------- 1 | (* mousesdl.mli *) 2 | open Tsdl 3 | open Mouse 4 | 5 | val of_sdl_button : int -> button 6 | (** Convert an SDL button code to a [Mouse.button]. *) 7 | 8 | val to_sdl_button : button -> int 9 | (** Convert a [Mouse.button] to its SDL representation. *) 10 | 11 | val handle_mouse_button_event : Sdl.event -> t -> t * Event.t list 12 | (** Handle an SDL mouse button event, updating the mouse state and returning 13 | unified events. *) 14 | 15 | val handle_mouse_motion_event : Sdl.event -> t -> t * Event.t list 16 | (** Handle an SDL mouse motion event, updating the mouse position and returning 17 | unified events. *) 18 | 19 | val handle_mouse_wheel_event : Sdl.event -> t -> t * Event.t list 20 | (** Handle an SDL mouse wheel event, updating the scroll state and returning 21 | unified events. *) 22 | 23 | val handle_event : Sdl.event -> t -> t * Event.t list 24 | (** Process any SDL mouse-related event, updating the mouse state and returning 25 | unified events. *) 26 | -------------------------------------------------------------------------------- /src/mouse.mli: -------------------------------------------------------------------------------- 1 | (** Mouse input handling. *) 2 | 3 | type button = Left | Middle | Right (** Represents a mouse button. *) 4 | 5 | type t 6 | (** Abstract type representing the mouse state. *) 7 | 8 | val create : int -> t 9 | (** [create scale] initializes a new mouse state with the given scale factor. *) 10 | 11 | val update_position : t -> int * int -> t 12 | (** [update_position t (x, y)] updates the mouse position to 13 | [(x / scale, y / scale)]. *) 14 | 15 | val update_button : t -> button -> bool -> t 16 | (** [update_button t b state] updates the state of button [b] (pressed or 17 | released). *) 18 | 19 | val is_button_pressed : t -> button -> bool 20 | (** [is_button_pressed t b] checks if button [b] is currently pressed. *) 21 | 22 | val get_position : t -> int * int 23 | (** [get_position t] returns the current mouse position. *) 24 | 25 | val get_scale : t -> int 26 | (** [get_events t] retrieves the list of recorded mouse events. Events are 27 | cleared every tick, so this must be called within the same tick they occur. 28 | *) 29 | -------------------------------------------------------------------------------- /src/animation.mli: -------------------------------------------------------------------------------- 1 | (** Module for handling animation recording *) 2 | 3 | type recording_state_t = { 4 | frames : Giflib.Image.t list; 5 | frames_to_record : int; 6 | current_frame : int; 7 | } 8 | 9 | val start_recording : 10 | ?max_frames:int -> int -> (recording_state_t, string) result 11 | (** [start_recording ?max_frames n] returns a new animation recording state that 12 | will record [n] frames, or an error result if n is non-positive or if 13 | exceeding [max_frames]. *) 14 | 15 | val stop_recording : recording_state_t -> unit 16 | (** [stop_recording recording_state] stops the current recording and saves the 17 | animation. Raises [Failure] if not recording. *) 18 | 19 | val record_frame : 20 | recording_state_t -> Screen.t -> Framebuffer.t -> recording_state_t option 21 | (** [record_frame recording_state screen framebuffer] records a single frame if 22 | recording is active. Automatically stops recording when the requested number 23 | of frames is reached. Raises [Failure] if the palette has more than 256 24 | colors. *) 25 | 26 | val max_frames_default : int 27 | (** Default upper bound for number of frames to be recorded when recording is 28 | started. *) 29 | -------------------------------------------------------------------------------- /src/key.ml: -------------------------------------------------------------------------------- 1 | (* keys *) 2 | 3 | type t = 4 | (* Arrow keys *) 5 | | Left 6 | | Right 7 | | Up 8 | | Down 9 | (* Modifier keys *) 10 | | Shift_L 11 | | Shift_R 12 | | Control_L 13 | | Control_R 14 | | Alt_L 15 | | Alt_R 16 | | CapsLock 17 | | NumLock 18 | | ScrollLock 19 | (* Function keys *) 20 | | F1 21 | | F2 22 | | F3 23 | | F4 24 | | F5 25 | | F6 26 | | F7 27 | | F8 28 | | F9 29 | | F10 30 | | F11 31 | | F12 32 | (* Navigation keys *) 33 | | Insert 34 | | Delete 35 | | Home 36 | | End 37 | | PageUp 38 | | PageDown 39 | (* Special keys *) 40 | | Space 41 | | Escape 42 | | Enter 43 | | Backspace 44 | | Tab 45 | | PrintScreen 46 | | Pause 47 | (* Alphabet keys (lowercase) *) 48 | | A 49 | | B 50 | | C 51 | | D 52 | | E 53 | | F 54 | | G 55 | | H 56 | | I 57 | | J 58 | | K 59 | | L 60 | | M 61 | | N 62 | | O 63 | | P 64 | | Q 65 | | R 66 | | S 67 | | T 68 | | U 69 | | V 70 | | W 71 | | X 72 | | Y 73 | | Z 74 | (* Number keys *) 75 | | Num0 76 | | Num1 77 | | Num2 78 | | Num3 79 | | Num4 80 | | Num5 81 | | Num6 82 | | Num7 83 | | Num8 84 | | Num9 85 | (* Unknown key *) 86 | | Unknown 87 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.18) 2 | 3 | (name claudius) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github claudiusFX/claudius)) 9 | 10 | (authors "3pleX-dev " "Adenuga Israel Abimbola " "Michael Dales " "Seed Lu " "Shreya Pawaskar " "Vanisha1606 " "Wah Vanessa ") 11 | 12 | (maintainers "Michael Dales " "Shreya Pawaskar ") 13 | 14 | (maintenance_intent "(latest)") 15 | 16 | (license ISC) 17 | 18 | (documentation https://github.com/claudiusFX/claudius) 19 | 20 | (package 21 | (name claudius) 22 | (synopsis "A retro-style graphics library") 23 | (description "A functional style retro-graphics library for OCaml for building generative art, demos, and games.") 24 | (depends (ocaml (>= 5.1)) dune (tsdl (>= 1.1.0)) (ounit2 :with-test) (odoc :with-doc) (giflib (>= 1.1.0)) (imagelib (>= 20221222)) (crunch (>= 4.0.0)) (hsluv (>= 0.1.0)) (ocamlformat (and (>= 0.27.0) :with-dev-setup ))) 25 | (tags 26 | (graphics rendering paletted))) 27 | 28 | ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project 29 | -------------------------------------------------------------------------------- /src/event.mli: -------------------------------------------------------------------------------- 1 | (** High-level representation of input events. *) 2 | type t = 3 | | KeyDown of Key.t 4 | (** A keyboard key was pressed down. [Key.t] identifies which key. *) 5 | | KeyUp of Key.t 6 | (** A keyboard key was released. [Key.t] identifies which key. *) 7 | | MouseButtonDown of Mouse.button * (int * int) 8 | (** A mouse button was pressed. [(button, (x,y))] where [button] is the 9 | mouse button, and [(x,y)] are the coordinates at the time of press. *) 10 | | MouseButtonUp of Mouse.button * (int * int) 11 | (** A mouse button was released. [(button, (x,y))] where [button] is the 12 | mouse button, and [(x,y)] are the coordinates at the time of release. 13 | *) 14 | | MouseMotion of (int * int) 15 | (** The mouse pointer moved. [(x,y)] are the new coordinates of the 16 | cursor. *) 17 | | MouseWheel of int 18 | (** The mouse wheel was scrolled. [int] is the scroll amount (positive for 19 | up, negative for down). *) 20 | | MouseDrag of Mouse.button * (int * int) 21 | (** A drag event with a mouse button held. [(button, (x,y))] where 22 | [button] is the button being dragged, and [(x,y)] are the current 23 | cursor coordinates. *) 24 | | DropFile of string 25 | (** A file drop event containing the dropped file path. *) 26 | -------------------------------------------------------------------------------- /src/key.mli: -------------------------------------------------------------------------------- 1 | (** The Key module defines a platform-independent representation of keyboard 2 | keys. *) 3 | 4 | type t = 5 | | Left 6 | | Right 7 | | Up 8 | | Down (** Arrow keys *) 9 | | Shift_L 10 | | Shift_R 11 | | Control_L 12 | | Control_R 13 | | Alt_L 14 | | Alt_R 15 | | CapsLock 16 | | NumLock 17 | | ScrollLock (** Modifier keys *) 18 | | F1 19 | | F2 20 | | F3 21 | | F4 22 | | F5 23 | | F6 24 | | F7 25 | | F8 26 | | F9 27 | | F10 28 | | F11 29 | | F12 (** Function keys *) 30 | | Insert 31 | | Delete 32 | | Home 33 | | End 34 | | PageUp 35 | | PageDown (** Navigation keys *) 36 | | Space 37 | | Escape 38 | | Enter 39 | | Backspace 40 | | Tab 41 | | PrintScreen 42 | | Pause (** Special keys *) 43 | | A 44 | | B 45 | | C 46 | | D 47 | | E 48 | | F 49 | | G 50 | | H 51 | | I 52 | | J 53 | | K 54 | | L 55 | | M 56 | | N 57 | | O 58 | | P 59 | | Q 60 | | R 61 | | S 62 | | T 63 | | U 64 | | V 65 | | W 66 | | X 67 | | Y 68 | | Z (** Alphabet keys (lowercase) *) 69 | | Num0 70 | | Num1 71 | | Num2 72 | | Num3 73 | | Num4 74 | | Num5 75 | | Num6 76 | | Num7 77 | | Num8 78 | | Num9 (** Number keys *) 79 | | Unknown (** Unknown key *) 80 | 81 | (** Type representing generic keys across different backends. *) 82 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Builds, tests & co 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | pull_request: 8 | 9 | env: 10 | OPAMCRITERIA: +removed,+count[version-lag,solution] 11 | OPAMFIXUPCRITERIA: +removed,+count[version-lag,solution] 12 | OPAMUPGRADECRITERIA: +removed,+count[version-lag,solution] 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | build: 18 | strategy: 19 | fail-fast: false 20 | matrix: 21 | os: 22 | - ubuntu-latest 23 | ocaml-compiler: 24 | - 5.3.0 25 | 26 | runs-on: ${{ matrix.os }} 27 | 28 | steps: 29 | - name: Checkout tree 30 | uses: actions/checkout@v4 31 | with: 32 | submodules: 'recursive' 33 | 34 | - name: Set-up OCaml ${{ matrix.ocaml-compiler }} 35 | uses: ocaml/setup-ocaml@v3 36 | with: 37 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 38 | 39 | - name: Update base system 40 | run: sudo apt update 41 | 42 | - name: Install system requirements 43 | run: sudo apt install -y libsdl2-dev 44 | 45 | - name: Install ocaml requirements 46 | run: opam install . --deps-only --with-test --with-dev-setup --with-doc 47 | 48 | - name: Build check 49 | run: opam exec -- dune build 50 | 51 | - name: Run tests 52 | run: opam exec -- dune runtest 53 | 54 | - name: Check formatting 55 | run: opam exec -- dune build @fmt 56 | 57 | - name: Build docs 58 | run: opam exec -- dune build @doc 59 | -------------------------------------------------------------------------------- /src/font.mli: -------------------------------------------------------------------------------- 1 | (** Provides the font rendering for Claudius. 2 | 3 | Doesn't render to screen - used mostly by the framebuffer draw char/string 4 | mechanisms. *) 5 | 6 | type t 7 | (** Type for a font *) 8 | 9 | module Glyph : sig 10 | type t 11 | (** Type for one entry in the font *) 12 | 13 | val dimensions : t -> int * int * int * int 14 | (** [glyph_dimensions glyph] Returns the width and height of the specified 15 | glyph. *) 16 | 17 | val bitmap : t -> bytes 18 | (** [glyph_bitmap glyph] Renders a glyph to a series of bytes. The data is 1 19 | bit per pixel, as a series of bytes per row, padded to the appropriate 20 | next byte boundary. *) 21 | end 22 | 23 | (** {1 Initializations} *) 24 | 25 | val of_file : string -> (t, string) result 26 | (** [of_file filepath] Loads a bitmap font from a PSF file, or a description of 27 | why the load failed. *) 28 | 29 | val of_bytes : Bytes.t -> (t, string) result 30 | (** [of_bytes fontdata] Loads a bitmap font from a PSF file loaded into bytes, 31 | or a description of why the load failed. *) 32 | 33 | (** {1 Using} *) 34 | 35 | val glyph_count : t -> int 36 | (** [glyph_count font] Returns a count of how many glyphs are in the font. *) 37 | 38 | val glyph_of_char : t -> Uchar.t -> Glyph.t option 39 | (** [glyph_of_char font char] Gets the glyph that maps to a given character in 40 | the font, or None if that character doesn't have an entry. *) 41 | 42 | (** {1 Debug} *) 43 | 44 | val print_header : t -> unit 45 | (** [print_header font] A utility method to dump the font's header information 46 | to stdout. *) 47 | -------------------------------------------------------------------------------- /claudius.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A retro-style graphics library" 4 | description: 5 | "A functional style retro-graphics library for OCaml for building generative art, demos, and games." 6 | maintainer: [ 7 | "Michael Dales " 8 | "Shreya Pawaskar " 9 | ] 10 | authors: [ 11 | "3pleX-dev " 12 | "Adenuga Israel Abimbola " 13 | "Michael Dales " 14 | "Seed Lu " 15 | "Shreya Pawaskar " 16 | "Vanisha1606 " 17 | "Wah Vanessa " 18 | ] 19 | license: "ISC" 20 | tags: ["graphics" "rendering" "paletted"] 21 | homepage: "https://github.com/claudiusFX/claudius" 22 | doc: "https://github.com/claudiusFX/claudius" 23 | bug-reports: "https://github.com/claudiusFX/claudius/issues" 24 | depends: [ 25 | "ocaml" {>= "5.1"} 26 | "dune" {>= "3.18"} 27 | "tsdl" {>= "1.1.0"} 28 | "ounit2" {with-test} 29 | "odoc" {with-doc} 30 | "giflib" {>= "1.1.0"} 31 | "imagelib" {>= "20221222"} 32 | "crunch" {>= "4.0.0"} 33 | "hsluv" {>= "0.1.0"} 34 | "ocamlformat" {>= "0.27.0" & with-dev-setup} 35 | ] 36 | build: [ 37 | ["dune" "subst"] {dev} 38 | [ 39 | "dune" 40 | "build" 41 | "-p" 42 | name 43 | "-j" 44 | jobs 45 | "@install" 46 | "@runtest" {with-test} 47 | "@doc" {with-doc} 48 | ] 49 | ] 50 | dev-repo: "git+https://github.com/claudiusFX/claudius.git" 51 | x-maintenance-intent: ["(latest)"] 52 | -------------------------------------------------------------------------------- /test/test_screenshot.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Claudius 3 | 4 | let width, height = (100, 100) 5 | let scale = 2 6 | 7 | let test_palette name palette = 8 | name >:: fun _ -> 9 | let size = Palette.size palette in 10 | Printf.printf "Testing palette: %s (size = %d)\n%!" name size; 11 | 12 | (* Generate framebuffer with values clamped to [0, palette_size - 1] *) 13 | let fb = 14 | Framebuffer.init (width, height) (fun x y -> 15 | let raw = (x * y) + x + y in 16 | raw mod Palette.size palette) 17 | in 18 | 19 | Framebuffer.set_dirty fb; 20 | let screen = Screen.create width height scale palette in 21 | let res = Screenshot.save_screenshot screen fb in 22 | match res with Result.Ok _ -> () | Result.Error _msg -> assert false 23 | 24 | let test_palette_too_big _ = 25 | let palette = Palette.generate_mono_palette 300 in 26 | (* > 256 entries *) 27 | let fb = Framebuffer.init (width, height) (fun _ _ -> 42) in 28 | Framebuffer.set_dirty fb; 29 | let screen = Screen.create width height scale palette in 30 | let res = Screenshot.save_screenshot screen fb in 31 | let expected = Result.Error "GIF only supports up to 256 colors" in 32 | assert_equal expected res 33 | 34 | let () = 35 | let suite = 36 | "screenshot_tests" 37 | >::: [ 38 | test_palette "vapourwave" (Palette.generate_vapourwave_palette 64); 39 | test_palette "vga" (Palette.generate_microsoft_vga_palette ()); 40 | test_palette "monopalette" (Palette.generate_mono_palette 256); 41 | "raises error when palette exceeds 256 colors" 42 | >:: test_palette_too_big; 43 | ] 44 | in 45 | 46 | run_test_tt_main suite 47 | -------------------------------------------------------------------------------- /fonts/LICENSE: -------------------------------------------------------------------------------- 1 | 2 | _____ __ _ 3 | |_ _|_ _ _ __ ___ ___ _ _ _ __ / _| ___ _ __ | |_ 4 | | |/ _` | '_ ` _ \/ __| | | | '_ \ | |_ / _ \| '_ \| __| 5 | | | (_| | | | | | \__ \ |_| | | | | | _| (_) | | | | |_ 6 | |_|\__,_|_| |_| |_|___/\__, |_| |_| |_| \___/|_| |_|\__| 7 | |___/ 8 | 9 | 10 | Copyright 2010 Scott Fial 11 | 12 | Tamsyn font is free. You are hereby granted permission to use, copy, modify, 13 | and distribute it as you see fit. 14 | 15 | Tamsyn font is provided "as is" without any express or implied warranty. 16 | 17 | The author makes no representations about the suitability of this font for 18 | a particular purpose. 19 | 20 | In no event will the author be held liable for damages arising from the use 21 | of this font. 22 | 23 | _____ __ _ 24 | |_ _|_ _ _ __ ___ _______ _ __ / _| ___ _ __ | |_ 25 | | |/ _` | '_ ` _ \|_ / _ \ '_ \ | |_ / _ \| '_ \| __| 26 | | | (_| | | | | | |/ / __/ | | | | _| (_) | | | | |_ 27 | |_|\__,_|_| |_| |_/___\___|_| |_| |_| \___/|_| |_|\__| 28 | 29 | 30 | Copyright 2011 Suraj N. Kurapati 31 | 32 | Tamzen font is free. You are hereby granted permission to use, copy, modify, 33 | and distribute it as you see fit. 34 | 35 | Tamzen font is provided "as is" without any express or implied warranty. 36 | 37 | The author makes no representations about the suitability of this font for 38 | a particular purpose. 39 | 40 | In no event will the author be held liable for damages arising from the use 41 | of this font. 42 | -------------------------------------------------------------------------------- /src/animation.ml: -------------------------------------------------------------------------------- 1 | open Giflib 2 | open Utils_gif 3 | 4 | type recording_state_t = { 5 | frames : Image.t list; 6 | frames_to_record : int; 7 | current_frame : int; 8 | } 9 | 10 | let max_frames_default = 500 11 | 12 | let start_recording ?(max_frames = max_frames_default) (n : int) : 13 | (recording_state_t, string) result = 14 | if max_frames <= 0 then failwith "Number of frames must be positive"; 15 | match n <= 0 with 16 | | true -> Result.Error "Number of frames must be positive" 17 | | false -> ( 18 | match n > max_frames with 19 | | true -> 20 | Result.Error 21 | (Printf.sprintf "Maximum %d frames allowed" max_frames_default) 22 | | false -> 23 | Result.Ok { frames = []; frames_to_record = n; current_frame = 0 }) 24 | 25 | let stop_recording (recording_state : recording_state_t) : unit = 26 | let frames = List.rev recording_state.frames in 27 | let gif = GIF.from_images frames in 28 | let filename = timestamp "animation" ^ ".gif" in 29 | GIF.to_file gif filename; 30 | Printf.printf "Animation saved as %s\n%!" filename 31 | 32 | let record_frame (recording_state : recording_state_t) (screen : Screen.t) 33 | (fb : Framebuffer.t) : recording_state_t option = 34 | if Palette.size (Screen.palette screen) > 256 then 35 | failwith "GIF only supports up to 256 colors"; 36 | let frame = capture_frame screen fb in 37 | let updated_state = 38 | { 39 | recording_state with 40 | frames = frame :: recording_state.frames; 41 | current_frame = recording_state.current_frame + 1; 42 | } 43 | in 44 | if updated_state.current_frame = updated_state.frames_to_record then ( 45 | stop_recording updated_state; 46 | None) 47 | else Some updated_state 48 | -------------------------------------------------------------------------------- /src/utils_gif.ml: -------------------------------------------------------------------------------- 1 | open Giflib 2 | open Unix 3 | 4 | let timestamp prefix = 5 | let tm = Unix.localtime (Unix.time ()) in 6 | Printf.sprintf "%s_%02d%02d%02d_%02d%02d%02d" prefix (tm.tm_year mod 100) 7 | (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec 8 | 9 | let color_table_of_palette (p : Palette.t) : ColorTable.t = 10 | Array.init (Palette.size p) (fun i -> 11 | let rgb32 = Palette.index_to_rgb p i in 12 | let rgb = Int32.to_int rgb32 in 13 | let r = (rgb lsr 16) land 0xFF in 14 | let g = (rgb lsr 8) land 0xFF in 15 | let b = rgb land 0xFF in 16 | (r, g, b)) 17 | 18 | let capture_frame (screen : Screen.t) (fb : Framebuffer.t) = 19 | let width, height = Screen.dimensions screen in 20 | let scale = Screen.scale screen in 21 | let palette = Screen.palette screen in 22 | let palette_size = Palette.size palette in 23 | 24 | let scaled_width = width * scale in 25 | let scaled_height = height * scale in 26 | 27 | let size = scaled_width * scaled_height in 28 | 29 | let colors = palette |> color_table_of_palette in 30 | 31 | let pixels = 32 | Array.init size (fun idx -> 33 | let x = idx mod scaled_width in 34 | let y = idx / scaled_width in 35 | let src_x = x / scale in 36 | let src_y = y / scale in 37 | let v = 38 | match Framebuffer.pixel_read src_x src_y fb with 39 | | Some v -> v 40 | | None -> 41 | failwith 42 | (Printf.sprintf "Invalid pixel coordinate (%d,%d)" src_x src_y) 43 | in 44 | if v < 0 || v > palette_size then 45 | failwith 46 | (Printf.sprintf "Framebuffer value %d out of byte range at (%d,%d)" 47 | v src_x src_y); 48 | v) 49 | in 50 | 51 | (* Claudius attempts to run at 60 fps, and GIF delay time is specified as multiples 52 | of 1/100th of a second, so the closest we can do is 2 (50 FPS). *) 53 | let delay_time = Some 2 in 54 | 55 | Image.of_pixels ~delay_time (scaled_width, scaled_height) colors pixels 56 | -------------------------------------------------------------------------------- /src/screen.mli: -------------------------------------------------------------------------------- 1 | (** Information about the display that can be accessed from the running code to 2 | work out screen size etc. The screen represents the window in which things 3 | will be drawn. *) 4 | 5 | type t 6 | 7 | (** {1 Initializations} *) 8 | 9 | val create : 10 | ?font:Font.t -> 11 | ?image_filenames:string list -> 12 | int -> 13 | int -> 14 | int -> 15 | Palette.t -> 16 | t 17 | (** [create font width height scale palette] Creates a new screen of the 18 | specified size [width] x [height], and it will be rendered in a window 19 | scaled up by the [scale] factor provided. The framebuffers used when running 20 | will be indexed into the [palette] provided here. Raises [Invalid_argument] 21 | if the dimensions or scale are either zero or negative. If no [font] is 22 | provided then a default font is used. If [image_filenames] is provided, the 23 | images will be loaded and their palettes merged into the screen's global 24 | palette.*) 25 | 26 | val create_with_font : int -> int -> int -> Font.t -> Palette.t -> t 27 | (** [create width height scale font palette] Deprecated: now use create with the 28 | optional font. *) 29 | 30 | (** {1 Access} *) 31 | 32 | val dimensions : t -> int * int 33 | (** [dimensions screen] Returns the width and height of the [screen]. *) 34 | 35 | val palette : t -> Palette.t 36 | (** [palette screen] Returns the palette associated with the [screen]. *) 37 | 38 | val update_palette : t -> Palette.t -> unit 39 | (**[update screen new_palette] updates the screen with provided palette and 40 | marks the screen as dirty.*) 41 | 42 | val scale : t -> int 43 | (** [scale screen] Returns the scaling factor used when drawing [screen] to a 44 | window. *) 45 | 46 | val font : t -> Font.t 47 | (** [font screen] Returns the font associated with the [screen] if one was 48 | provided, or [None] otherwise. *) 49 | 50 | val is_dirty : t -> bool 51 | (** [is_dirty screen] returns [true] if the screen is marked as dirty (needing 52 | redraw). *) 53 | 54 | val clear_dirty : t -> unit 55 | (** [clear_dirty screen] returns a new screen with the dirty flag cleared. *) 56 | 57 | val pictures : t -> Picture.t array 58 | (** [pictures screen] returns the array of pictures loaded into the screen. *) 59 | -------------------------------------------------------------------------------- /src/base.mli: -------------------------------------------------------------------------------- 1 | (** Main Claudius entry point. *) 2 | 3 | module KeyCodeSet : Set.S with type elt = Key.t 4 | (** A module representing a set of key codes. *) 5 | 6 | module PlatformKey : module type of Keysdl 7 | (** A module that provides platform-specific key handling, based on the [Keysdl] 8 | module. *) 9 | 10 | module PlatformMouse : module type of Mousesdl 11 | (** A module that provides platform-specific mouse handling, based on the 12 | {!Mousesdl} module. *) 13 | 14 | type input_state = { 15 | keys : KeyCodeSet.t; 16 | events : Event.t list; 17 | (** Accumulated unified input events for the current frame. *) 18 | mouse : Mouse.t; 19 | } 20 | (** Represents the current state of user input, including: 21 | - [keys]: The set of currently pressed keys. 22 | - [mouse]: The current state of the mouse, including position and button 23 | presses. *) 24 | 25 | type boot_func = Screen.t -> Framebuffer.t 26 | (** Function called once a start of run *) 27 | 28 | type tick_func = 29 | int -> Screen.t -> Framebuffer.t -> input_state -> Framebuffer.t 30 | (** Function called once a frame during run *) 31 | 32 | type functional_tick_func = int -> Screen.t -> input_state -> Primitives.t list 33 | (** A functional-style tick function that returns a list of primitives. *) 34 | 35 | val run : string -> boot_func option -> tick_func -> Screen.t -> unit 36 | (** [run title boot tick screen] Creates the runloop *) 37 | 38 | val run_functional : string -> functional_tick_func -> Screen.t -> unit 39 | (** [run_functional title tick_f screen] runs Claudius in a functional style. 40 | - [tick_f] screen returns a list of primitives rather than a complete 41 | framebuffer.*) 42 | 43 | (* --- Utility function signatures for input handling --- *) 44 | 45 | val is_key_pressed : input_state -> Key.t -> bool 46 | (** Returns [true] if [key] is currently pressed. *) 47 | 48 | val was_key_just_pressed : input_state -> Key.t -> bool 49 | (** Returns [true] if [key] was pressed during the current frame. *) 50 | 51 | val was_key_just_released : input_state -> Key.t -> bool 52 | (** Returns [true] if [key] was released during the current frame. *) 53 | 54 | val poll_all_events : 55 | KeyCodeSet.t -> 56 | Mouse.t -> 57 | Event.t list -> 58 | bool * KeyCodeSet.t * Mouse.t * Event.t list 59 | (** Internal method exposed for testing *) 60 | -------------------------------------------------------------------------------- /src/screen.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | width : int; 3 | height : int; 4 | scale : int; 5 | mutable palette : Palette.t; 6 | font : Font.t; 7 | mutable dirty : bool; 8 | pictures : Picture.t array; 9 | } 10 | 11 | let create ?font ?(image_filenames = []) (width : int) (height : int) 12 | (scale : int) (palette : Palette.t) : t = 13 | if scale <= 0 then raise (Invalid_argument "Invalid scale"); 14 | if width <= 0 then raise (Invalid_argument "Invalid width"); 15 | if height <= 0 then raise (Invalid_argument "Invalid height"); 16 | 17 | let font = 18 | match font with 19 | | Some f -> f 20 | | None -> ( 21 | let default_font_data = 22 | match Builtins.read "TamzenForPowerline10x20.psf" with 23 | | Some font -> font 24 | | None -> 25 | failwith 26 | (Printf.sprintf "Default font file not found in builtins.") 27 | in 28 | match Font.of_bytes (Bytes.of_string default_font_data) with 29 | | Ok f -> f 30 | | Error e -> 31 | failwith (Printf.sprintf "Failed to load default font: %s" e)) 32 | in 33 | 34 | let pictures, all_palettes = 35 | let init_offset = Palette.size palette in 36 | let init_acc = ([], init_offset, [ palette ]) in 37 | let pics_rev, _, palettes_rev = 38 | List.fold_left 39 | (fun (pics_acc, offset_acc, palettes_acc) filename -> 40 | let pic = Picture.load filename in 41 | let shifted = Picture.with_palette_offset pic offset_acc in 42 | let next_offset = offset_acc + Palette.size (Picture.palette pic) in 43 | (shifted :: pics_acc, next_offset, Picture.palette pic :: palettes_acc)) 44 | init_acc image_filenames 45 | in 46 | (List.rev pics_rev |> Array.of_list, List.rev palettes_rev) 47 | in 48 | 49 | let final_palette = Palette.concat all_palettes in 50 | 51 | { 52 | width; 53 | height; 54 | scale; 55 | palette = final_palette; 56 | font; 57 | dirty = true; 58 | pictures; 59 | } 60 | 61 | let update_palette (screen : t) (new_palette : Palette.t) : unit = 62 | screen.palette <- new_palette; 63 | screen.dirty <- true 64 | 65 | let create_with_font (width : int) (height : int) (scale : int) (font : Font.t) 66 | (palette : Palette.t) : t = 67 | create ~font width height scale palette 68 | 69 | let dimensions (screen : t) : int * int = (screen.width, screen.height) 70 | let palette (screen : t) : Palette.t = screen.palette 71 | let font (screen : t) : Font.t = screen.font 72 | let scale (screen : t) : int = screen.scale 73 | let is_dirty (screen : t) : bool = screen.dirty 74 | let clear_dirty (screen : t) : unit = screen.dirty <- false 75 | let pictures (screen : t) : Picture.t array = screen.pictures 76 | -------------------------------------------------------------------------------- /src/picture.ml: -------------------------------------------------------------------------------- 1 | open Image 2 | 3 | type t = { palette : Palette.t; pixels : int array; width : int; height : int } 4 | 5 | let load_png_as_indexed (filepath : string) : Palette.t * int array * int * int 6 | = 7 | let img = ImageLib_unix.openfile filepath in 8 | let w = img.width in 9 | let h = img.height in 10 | 11 | let pixels_rgba = 12 | Array.init (w * h) (fun idx -> 13 | let x = idx mod w in 14 | let y = idx / w in 15 | match img.pixels with 16 | | RGB (r, g, b) -> 17 | let red = Pixmap.get r x y in 18 | let green = Pixmap.get g x y in 19 | let blue = Pixmap.get b x y in 20 | (red, green, blue, 255) 21 | (* 255 means fully opaque *) 22 | | RGBA (r, g, b, a) -> 23 | let red = Pixmap.get r x y in 24 | let green = Pixmap.get g x y in 25 | let blue = Pixmap.get b x y in 26 | let alpha = Pixmap.get a x y in 27 | (red, green, blue, alpha) 28 | | Grey p -> 29 | let g = Pixmap.get p x y in 30 | (g, g, g, 255) 31 | | GreyA (p, a) -> 32 | let g = Pixmap.get p x y in 33 | let alpha = Pixmap.get a x y in 34 | (g, g, g, alpha)) 35 | in 36 | 37 | let module ColorMap = Map.Make (struct 38 | type t = int * int * int 39 | 40 | let compare = compare 41 | end) in 42 | let palette_map, palette_list, _ = 43 | Array.fold_left 44 | (fun (map, lst, idx) (r, g, b, a) -> 45 | if a = 0 then (map, lst, idx) (* transparent pixel *) 46 | else if ColorMap.mem (r, g, b) map then (map, lst, idx) 47 | else (ColorMap.add (r, g, b) idx map, lst @ [ (r, g, b) ], idx + 1)) 48 | (ColorMap.empty, [], 1) (* index 0 is being used for transparency *) 49 | pixels_rgba 50 | in 51 | 52 | let palette_rgb_24 = 53 | 0x000000 54 | :: List.map (fun (r, g, b) -> (r lsl 16) lor (g lsl 8) lor b) palette_list 55 | in 56 | 57 | let pal = Palette.of_list palette_rgb_24 in 58 | 59 | let indexed_pixels = 60 | Array.map 61 | (fun (r, g, b, a) -> 62 | if a = 0 then 0 else ColorMap.find (r, g, b) palette_map) 63 | pixels_rgba 64 | in 65 | 66 | (pal, indexed_pixels, w, h) 67 | 68 | (* Public API, so real img data isn't tampered *) 69 | 70 | let load (filepath : string) : t = 71 | let palette, pixels, w, h = load_png_as_indexed filepath in 72 | { palette; pixels; width = w; height = h } 73 | 74 | let dimensions (pic : t) = (pic.width, pic.height) 75 | let pixels (pic : t) = pic.pixels 76 | let palette (pic : t) = pic.palette 77 | 78 | let with_palette_offset (pic : t) (offset : int) : t = 79 | let shifted_pixels = 80 | Array.map (fun idx -> if idx = 0 then 0 else idx + offset) pic.pixels 81 | in 82 | { pic with pixels = shifted_pixels } 83 | -------------------------------------------------------------------------------- /test/test_picture.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Claudius 3 | open Picture 4 | 5 | let test_valid_png _ = 6 | (* Credits for tetris.png: https://publicdomainvectors.org/en/free-clipart/3D-Tetris-blocks-vector-illustration/6089.html *) 7 | let pic = load "../test_assets/tetris.png" in 8 | let width, height = dimensions pic in 9 | assert_bool "width > 0" (width > 0); 10 | assert_bool "height > 0" (height > 0); 11 | assert_bool "has pixels" (Array.length (pixels pic) > 0) 12 | 13 | let test_scaled_dimensions _ = 14 | let pic = load "../test_assets/tetris.png" in 15 | let w, h = dimensions pic in 16 | assert_equal w (Array.length (pixels pic) / h) 17 | 18 | let test_draw_picture_normal _ = 19 | let pic = load "../test_assets/tetris.png" in 20 | let pal = palette pic in 21 | assert_bool "palette has entries" (Palette.size pal > 0); 22 | assert_bool "pixels reference palette" (pixels pic |> Array.exists (( <> ) 0)) 23 | 24 | let test_draw_picture_negative_offset _ = 25 | let pic = load "../test_assets/tetris.png" in 26 | let shifted = with_palette_offset pic (-1) in 27 | Array.iteri 28 | (fun i idx -> 29 | if idx = 0 then assert_equal 0 (pixels shifted).(i) 30 | else assert_equal (idx - 1) (pixels shifted).(i)) 31 | (pixels pic) 32 | 33 | let test_draw_picture_scaled _ = 34 | let pic = load "../test_assets/tetris.png" in 35 | let w, h = dimensions pic in 36 | assert_equal (w * h) (Array.length (pixels pic)) 37 | 38 | let test_load_png_as_indexed_transparent _ = 39 | let pic = Picture.load "../test_assets/tetris.png" in 40 | let pal = Picture.palette pic in 41 | let pixels = Picture.pixels pic in 42 | let w, h = Picture.dimensions pic in 43 | assert_bool "image has width > 0" (w > 0); 44 | assert_bool "image has height > 0" (h > 0); 45 | (* palette[0] reserved for transparency *) 46 | assert_equal 0x000000l (Palette.index_to_rgb pal 0); 47 | assert_bool "transparent pixel present" (Array.exists (( = ) 0) pixels) 48 | 49 | let test_with_palette_offset _ = 50 | let pic = load "../test_assets/tetris.png" in 51 | let shifted = with_palette_offset pic 10 in 52 | Array.iteri 53 | (fun i idx -> 54 | if idx = 0 then assert_equal 0 (pixels shifted).(i) 55 | (* transparency stays 0 *) 56 | else assert_equal (idx + 10) (pixels shifted).(i)) 57 | (pixels pic) 58 | 59 | let suite = 60 | "Picture tests" 61 | >::: [ 62 | "valid_png" >:: test_valid_png; 63 | "scaled_dimensions" >:: test_scaled_dimensions; 64 | "draw_picture_normal" >:: test_draw_picture_normal; 65 | "draw_picture_negative_offset" >:: test_draw_picture_negative_offset; 66 | "draw_picture_scaled" >:: test_draw_picture_scaled; 67 | "load_png_as_indexed transparent" 68 | >:: test_load_png_as_indexed_transparent; 69 | "with_palette_offset" >:: test_with_palette_offset; 70 | ] 71 | 72 | let () = run_test_tt_main suite 73 | -------------------------------------------------------------------------------- /src/mousesdl.ml: -------------------------------------------------------------------------------- 1 | open Tsdl 2 | open Mouse 3 | open Event 4 | 5 | let of_sdl_button (button : int) : button = 6 | match button with 1 -> Left | 2 -> Middle | 3 -> Right | _ -> Left 7 | (* if an unknown button is pressed, then left button will be considered *) 8 | 9 | let to_sdl_button (button : button) : int = 10 | match button with Left -> 1 | Middle -> 2 | Right -> 3 11 | 12 | (** Handles an SDL mouse button event. Returns the updated mouse state and a 13 | list of unified events. *) 14 | let handle_mouse_button_event (event : Sdl.event) (m : Mouse.t) : 15 | Mouse.t * Event.t list = 16 | let button = 17 | of_sdl_button (Sdl.Event.get event Sdl.Event.mouse_button_button) 18 | in 19 | let x = Sdl.Event.get event Sdl.Event.mouse_button_x in 20 | let y = Sdl.Event.get event Sdl.Event.mouse_button_y in 21 | let pressed = 22 | Sdl.Event.get event Sdl.Event.mouse_button_state = Sdl.pressed 23 | in 24 | let m = Mouse.update_button m button pressed in 25 | let m = Mouse.update_position m (x, y) in 26 | if pressed then 27 | ( m, 28 | [ 29 | MouseButtonDown (button, (x / Mouse.get_scale m, y / Mouse.get_scale m)); 30 | ] ) 31 | else 32 | ( m, 33 | [ MouseButtonUp (button, (x / Mouse.get_scale m, y / Mouse.get_scale m)) ] 34 | ) 35 | 36 | (** Handles an SDL mouse motion event. Returns the updated mouse state and a 37 | list of unified events. *) 38 | let handle_mouse_motion_event (event : Sdl.event) (m : Mouse.t) : 39 | Mouse.t * Event.t list = 40 | let x = Sdl.Event.get event Sdl.Event.mouse_motion_x in 41 | let y = Sdl.Event.get event Sdl.Event.mouse_motion_y in 42 | let m = Mouse.update_position m (x, y) in 43 | let buttons = [ Left; Middle; Right ] in 44 | let pressed_buttons = 45 | List.filter (fun b -> Mouse.is_button_pressed m b) buttons 46 | in 47 | if pressed_buttons = [] then 48 | (m, [ MouseMotion (x / Mouse.get_scale m, y / Mouse.get_scale m) ]) 49 | else 50 | let drag_events = 51 | List.map 52 | (fun b -> MouseDrag (b, (x / Mouse.get_scale m, y / Mouse.get_scale m))) 53 | pressed_buttons 54 | in 55 | (m, drag_events) 56 | 57 | (** Handles an SDL mouse wheel event. Returns the updated mouse state and a list 58 | containing the wheel event. *) 59 | let handle_mouse_wheel_event (event : Sdl.event) (m : Mouse.t) : 60 | Mouse.t * Event.t list = 61 | let y = Sdl.Event.get event Sdl.Event.mouse_wheel_y in 62 | (m, [ MouseWheel y ]) 63 | 64 | (** Process any SDL mouse-related event. Returns the updated mouse state and any 65 | unified events. *) 66 | let handle_event (event : Sdl.event) (m : Mouse.t) : Mouse.t * Event.t list = 67 | let event_type = Sdl.Event.get event Sdl.Event.typ in 68 | if 69 | event_type = Sdl.Event.mouse_button_down 70 | || event_type = Sdl.Event.mouse_button_up 71 | then handle_mouse_button_event event m 72 | else if event_type = Sdl.Event.mouse_motion then 73 | handle_mouse_motion_event event m 74 | else if event_type = Sdl.Event.mouse_wheel then 75 | handle_mouse_wheel_event event m 76 | else (m, []) 77 | -------------------------------------------------------------------------------- /test/test_animation.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Claudius 3 | 4 | let width, height = (100, 100) 5 | let scale = 2 6 | 7 | let test_basic_recording _ = 8 | let palette = Palette.generate_vapourwave_palette 64 in 9 | let fb = Framebuffer.init (width, height) (fun x y -> x * y mod 64) in 10 | let screen = Screen.create width height scale palette in 11 | let initial_state = Animation.start_recording 10 in 12 | match initial_state with 13 | | Result.Error _msg -> assert false 14 | | Result.Ok state -> 15 | let mut_state = ref (Some state) in 16 | 17 | for _ = 1 to 10 do 18 | match !mut_state with 19 | | Some st -> mut_state := Animation.record_frame st screen fb 20 | | None -> () 21 | done; 22 | 23 | assert_equal None !mut_state 24 | 25 | let test_invalid_frame_count _ = 26 | let res = Animation.start_recording 0 in 27 | assert_equal (Result.Error "Number of frames must be positive") res 28 | 29 | let test_too_many_frames _ = 30 | let msg = 31 | Printf.sprintf "Maximum %d frames allowed" Animation.max_frames_default 32 | in 33 | let res = Animation.start_recording (Animation.max_frames_default + 1) in 34 | assert_equal (Result.Error msg) res 35 | 36 | let test_double_recording _ = 37 | let palette = Palette.generate_vapourwave_palette 64 in 38 | let fb = Framebuffer.init (width, height) (fun x y -> x * y mod 64) in 39 | let screen = Screen.create width height scale palette in 40 | let initial_state = Animation.start_recording 10 in 41 | match initial_state with 42 | | Result.Error _msg -> assert false 43 | | Result.Ok state -> 44 | let mut_state = ref (Some state) in 45 | 46 | mut_state := Animation.record_frame (Option.get !mut_state) screen fb; 47 | 48 | let already_recording = Option.is_some !mut_state in 49 | assert_bool "Should detect already recording state" already_recording; 50 | 51 | ignore (Animation.stop_recording (Option.get !mut_state)); 52 | mut_state := None 53 | 54 | let test_palette_too_big _ = 55 | let palette = Palette.generate_mono_palette 300 in 56 | let fb = Framebuffer.init (width, height) (fun _ _ -> 42) in 57 | let screen = Screen.create width height scale palette in 58 | 59 | let initial_state = Animation.start_recording 10 in 60 | match initial_state with 61 | | Result.Error _msg -> assert false 62 | | Result.Ok state -> 63 | assert_raises (Failure "GIF only supports up to 256 colors") (fun () -> 64 | ignore (Animation.record_frame state screen fb)); 65 | assert_raises (Giflib.GIF.Error "from_images: empty image list") 66 | (fun () -> ignore (Animation.stop_recording state)) 67 | 68 | let suite = 69 | "animation_tests" 70 | >::: [ 71 | "Test basic recording" >:: test_basic_recording; 72 | "Test invalid frame count" >:: test_invalid_frame_count; 73 | "Test too many frames" >:: test_too_many_frames; 74 | "Test double recording" >:: test_double_recording; 75 | "Test palette too big" >:: test_palette_too_big; 76 | ] 77 | 78 | let () = run_test_tt_main suite 79 | -------------------------------------------------------------------------------- /test/test_keysdl.ml: -------------------------------------------------------------------------------- 1 | open Claudius 2 | open OUnit2 3 | 4 | let test_bidirectional _ = 5 | let keycodes = 6 | [ 7 | (0x4000004F, Key.Right); 8 | (0x40000050, Key.Left); 9 | (0x40000051, Key.Down); 10 | (0x40000052, Key.Up); 11 | (0x400000E1, Key.Shift_L); 12 | (0x400000E5, Key.Shift_R); 13 | (0x400000E0, Key.Control_L); 14 | (0x400000E4, Key.Control_R); 15 | (0x400000E2, Key.Alt_L); 16 | (0x400000E6, Key.Alt_R); 17 | (0x40000039, Key.CapsLock); 18 | (0x40000053, Key.NumLock); 19 | (0x40000047, Key.ScrollLock); 20 | (0x4000003A, Key.F1); 21 | (0x4000003B, Key.F2); 22 | (0x4000003C, Key.F3); 23 | (0x4000003D, Key.F4); 24 | (0x4000003E, Key.F5); 25 | (0x4000003F, Key.F6); 26 | (0x40000040, Key.F7); 27 | (0x40000041, Key.F8); 28 | (0x40000042, Key.F9); 29 | (0x40000043, Key.F10); 30 | (0x40000044, Key.F11); 31 | (0x40000045, Key.F12); 32 | (0x40000049, Key.Insert); 33 | (0x4000007F, Key.Delete); 34 | (0x4000004A, Key.Home); 35 | (0x4000004D, Key.End); 36 | (0x4000004B, Key.PageUp); 37 | (0x4000004E, Key.PageDown); 38 | (0x00000020, Key.Space); 39 | (0x0000001B, Key.Escape); 40 | (0x00000061, Key.A); 41 | (0x00000062, Key.B); 42 | (0x00000063, Key.C); 43 | (0x00000064, Key.D); 44 | (0x00000065, Key.E); 45 | (0x00000066, Key.F); 46 | (0x00000067, Key.G); 47 | (0x00000068, Key.H); 48 | (0x00000069, Key.I); 49 | (0x0000006A, Key.J); 50 | (0x0000006B, Key.K); 51 | (0x0000006C, Key.L); 52 | (0x0000006D, Key.M); 53 | (0x0000006E, Key.N); 54 | (0x0000006F, Key.O); 55 | (0x00000070, Key.P); 56 | (0x00000071, Key.Q); 57 | (0x00000072, Key.R); 58 | (0x00000073, Key.S); 59 | (0x00000074, Key.T); 60 | (0x00000075, Key.U); 61 | (0x00000076, Key.V); 62 | (0x00000077, Key.W); 63 | (0x00000078, Key.X); 64 | (0x00000079, Key.Y); 65 | (0x0000007A, Key.Z); 66 | (0x00000030, Key.Num0); 67 | (0x00000031, Key.Num1); 68 | (0x00000032, Key.Num2); 69 | (0x00000033, Key.Num3); 70 | (0x00000034, Key.Num4); 71 | (0x00000035, Key.Num5); 72 | (0x00000036, Key.Num6); 73 | (0x00000037, Key.Num7); 74 | (0x00000038, Key.Num8); 75 | (0x00000039, Key.Num9); 76 | ] 77 | in 78 | List.iter 79 | (fun (code, key) -> 80 | assert_equal ~msg:"key mapping" key (Keysdl.of_backend_keycode code); 81 | assert_equal ~msg:"key mapping" code (Keysdl.to_backend_keycode key)) 82 | keycodes 83 | 84 | let test_unknown _ = 85 | let neg = -1 in 86 | assert_equal ~msg:"unknown key" Key.Unknown 87 | (Keysdl.of_backend_keycode 0x00000000); 88 | assert_equal ~msg:"unknown key" neg (Keysdl.to_backend_keycode Key.Unknown) 89 | 90 | let suite = 91 | "Keysdl Tests" 92 | >::: [ 93 | "test_bidirectional" >:: test_bidirectional; 94 | "test_unknown" >:: test_unknown; 95 | ] 96 | 97 | let () = run_test_tt_main suite 98 | -------------------------------------------------------------------------------- /test/test_screen.ml: -------------------------------------------------------------------------------- 1 | open Claudius 2 | open OUnit2 3 | 4 | let test_basic_screen_creation _ = 5 | let palette = Palette.generate_mono_palette 2 in 6 | let screen = Screen.create 640 480 2 palette in 7 | assert_equal ~msg:"Dimensions" (640, 480) (Screen.dimensions screen); 8 | assert_equal ~msg:"Scale" 2 (Screen.scale screen); 9 | let font = Screen.font screen in 10 | assert_bool "Font" (Font.glyph_count font > 0); 11 | assert_equal ~msg:"Palette" palette (Screen.palette screen) 12 | 13 | let test_fail_invalid_scale _ = 14 | let palette = Palette.generate_mono_palette 2 in 15 | assert_raises (Invalid_argument "Invalid scale") (fun _ -> 16 | Screen.create 640 480 (-1) palette) 17 | 18 | let test_fail_invalid_dimensions _ = 19 | let palette = Palette.generate_mono_palette 2 in 20 | assert_raises (Invalid_argument "Invalid height") (fun _ -> 21 | Screen.create 10 0 2 palette); 22 | assert_raises (Invalid_argument "Invalid width") (fun _ -> 23 | Screen.create 0 10 2 palette); 24 | assert_raises (Invalid_argument "Invalid height") (fun _ -> 25 | Screen.create 10 (-10) 2 palette); 26 | assert_raises (Invalid_argument "Invalid width") (fun _ -> 27 | Screen.create (-10) 10 2 palette) 28 | 29 | let test_update_palette _ = 30 | let initial_palette = Palette.generate_mono_palette 2 in 31 | let screen = Screen.create 640 480 2 initial_palette in 32 | Screen.clear_dirty screen; 33 | assert_equal ~msg:"Dirty flag should be false after clearing" false 34 | (Screen.is_dirty screen); 35 | let new_palette = Palette.generate_plasma_palette 2 in 36 | Screen.update_palette screen new_palette; 37 | assert_equal ~msg:"Palette should be updated" new_palette 38 | (Screen.palette screen); 39 | assert_equal ~msg:"Dirty flag should be true after update" true 40 | (Screen.is_dirty screen); 41 | Screen.clear_dirty screen; 42 | assert_equal ~msg:"Dirty flag should be cleared" false 43 | (Screen.is_dirty screen) 44 | 45 | let test_non_default_font _ = 46 | (* the default font is the powerline version that should have more glyphs *) 47 | (* after the removal of submodule, this test is made to match just the default font incase we go on to add more fonts and need to check for non-default ones*) 48 | let font = 49 | match Font.of_file "../fonts/TamzenForPowerline10x20.psf" with 50 | | Ok f -> f 51 | | Error msg -> assert_failure (Printf.sprintf "failed to load font: %s" msg) 52 | in 53 | let palette = Palette.generate_mono_palette 2 in 54 | let screen_default = Screen.create 640 480 2 palette 55 | and screen_with_font = Screen.create ~font 640 480 2 palette in 56 | let default_font = Screen.font screen_default 57 | and new_font = Screen.font screen_with_font in 58 | assert_bool "default font not our font" (font != default_font); 59 | assert_bool "non-default font is our font" (font == new_font) 60 | 61 | let suite = 62 | "Screen tests" 63 | >::: [ 64 | "Test simple screen set up" >:: test_basic_screen_creation; 65 | "Test fail with invalid scale" >:: test_fail_invalid_scale; 66 | "Test fail with invalid dimensions" >:: test_fail_invalid_dimensions; 67 | "Test update palette" >:: test_update_palette; 68 | "Test loading non-default font" >:: test_non_default_font; 69 | ] 70 | 71 | let () = run_test_tt_main suite 72 | -------------------------------------------------------------------------------- /src/stats.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | last_update : float; 3 | last_tick_count : int; 4 | average_fps : int; 5 | log : (string * float) list; 6 | } 7 | 8 | let create () = 9 | { last_update = 0.0; last_tick_count = 0; average_fps = 0; log = [] } 10 | 11 | let fps t = t.average_fps 12 | 13 | let update ~now ~tick previous = 14 | let elapsed = now -. previous.last_update in 15 | if elapsed >= 1.0 then 16 | { 17 | last_update = now; 18 | last_tick_count = tick; 19 | average_fps = tick - previous.last_tick_count; 20 | log = previous.log; 21 | } 22 | else previous 23 | 24 | let log t msg = 25 | let log = (msg, t.last_update) :: t.log in 26 | { t with log } 27 | 28 | let draw_string x y font msg fg_col bg_col fb = 29 | for j = -1 to 1 do 30 | for i = -1 to 1 do 31 | ignore (Framebuffer.draw_string (x + i) (y + j) font msg bg_col fb) 32 | done 33 | done; 34 | ignore (Framebuffer.draw_string x y font msg fg_col fb) 35 | 36 | let render_log messages screen framebuffer = 37 | let _, h = Screen.dimensions screen in 38 | let font = Screen.font screen in 39 | let pal = Screen.palette screen in 40 | let bg_col, fg_col = Palette.distinctive_pair pal in 41 | List.iteri 42 | (fun i (a, _) -> 43 | draw_string 10 (h - (20 + (i * 20))) font a fg_col bg_col framebuffer) 44 | messages 45 | 46 | let render_stats status tick screen framebuffer = 47 | let width, height = Screen.dimensions screen 48 | and font = Screen.font screen 49 | and colour_count = Palette.size (Screen.palette screen) 50 | and bg_col, fg_col = Palette.distinctive_pair (Screen.palette screen) in 51 | let info = 52 | [ 53 | ("Tick:", string_of_int tick); 54 | ("FPS:", string_of_int status.average_fps); 55 | ("Resolution:", Printf.sprintf "%dx%d" width height); 56 | ("Colours:", string_of_int colour_count); 57 | ] 58 | in 59 | 60 | let max_key_width = 61 | List.fold_left 62 | (fun acc (k, _) -> 63 | let width = 64 | Framebuffer.draw_string (-1000) (-1000) font k 0 framebuffer 65 | in 66 | if width > acc then width else acc) 67 | 0 info 68 | in 69 | 70 | List.iteri 71 | (fun i (k, v) -> 72 | let y_offset = 4 + (14 * i) in 73 | draw_string 4 y_offset font k fg_col bg_col framebuffer; 74 | draw_string (max_key_width + 10) y_offset font v fg_col bg_col framebuffer) 75 | info; 76 | 77 | let columns = width / 10 in 78 | let rows = (colour_count / columns) + 1 in 79 | let offset = height - (10 * rows) in 80 | for i = 0 to colour_count - 1 do 81 | Framebuffer.filled_rect 82 | (i mod columns * 10) 83 | (offset + (i / columns * 10)) 84 | 10 10 i framebuffer 85 | done 86 | 87 | let render status show_all tick screen framebuffer = 88 | let log_messages = 89 | match show_all with 90 | | false -> 91 | let log_threshold = status.last_update -. 5.0 in 92 | List.filter (fun (_, a) -> a > log_threshold) status.log 93 | | true -> status.log 94 | in 95 | let show_log = List.length log_messages > 0 in 96 | 97 | match (show_all, show_log) with 98 | | false, false -> None 99 | | _, _ -> 100 | let framebuffer = Framebuffer.map (fun i -> i) framebuffer in 101 | if show_all then render_stats status tick screen framebuffer; 102 | if show_log then render_log log_messages screen framebuffer; 103 | Some framebuffer 104 | -------------------------------------------------------------------------------- /src/palette.mli: -------------------------------------------------------------------------------- 1 | (** Claudius works with colour palettes, as per computers of old. This module 2 | lets you load and manipulate palettes. The palettes can be thought of simply 3 | as indexed arrays of RGB values, and you write index values to the 4 | Framebuffer rather than RGB values directly. *) 5 | 6 | type t 7 | 8 | (** {1 Initializations} *) 9 | 10 | val generate_mono_palette : int -> t 11 | (** [generate_mono_palette size] Will generate a grayscale palette going from 12 | black to white with [size] number of entries. Raises [Invalid_argument] if 13 | palette size is zero or less. *) 14 | 15 | val generate_plasma_palette : int -> t 16 | (** [generate_plasma_palette size] Will generate a plasma colour palette with 17 | [size] number of entries. Raises [Invalid_argument] if palette size is zero 18 | or less. *) 19 | 20 | val generate_linear_palette : int -> int -> int -> t 21 | (** [generate_linear_palette color1 color2 size] returns a palette (of type [t]) 22 | that linearly interpolates between [color1] and [color2] over [size] 23 | entries. Raises [Invalid_argument] if [size] is less than or equal to zero. 24 | *) 25 | 26 | val generate_vapourwave_palette : int -> t 27 | (** [generate_vapourwave_palette size] returns a vapourwave palette with [size] 28 | entries. Internally, it calls [generate_linear_palette] using pastel purple 29 | (0x7f3b8f) and pastel cyan (0x80cfcf) as endpoints. Raises 30 | [Invalid_argument] if [size] is less than or equal to zero. *) 31 | 32 | val generate_microsoft_vga_palette : unit -> t 33 | (** [generate_microsoft_vga_palette ()] returns the Microsoft VGA 16-color 34 | palette, as defined by sources such as Lospec and Wikipedia. *) 35 | 36 | val generate_classic_vga_palette : unit -> t 37 | (** [generate_classic_vga_palette ()] returns the classic IBM VGA 16-color 38 | palette, based on traditional values. *) 39 | 40 | val generate_sweetie16_palette : unit -> t 41 | (** [generate_sweet16_palette ()] returns the Sweet16 color palette as defined 42 | by the widely recognized Lospec palette by GrafxKid, found on Lospec: 43 | https://lospec.com/palette-list/sweetie-16*) 44 | 45 | val generate_mac_palette : unit -> t 46 | (** [generate_mac_palette ()] returns the Macintosh 16-color palette, as defined 47 | by sources such as Wikipedia. *) 48 | 49 | val load_tic80_palette : string -> t 50 | (** [load_tic80_palette str] Will take a string [str] of the form found in TIC80 51 | save files and load it as a palette.Raises [Invalid_argument] if palette 52 | size is zero or less, or if the data string is not correct. *) 53 | 54 | val load_lospec_palette : string -> t 55 | (** [load_lospec_palette str] Loads a palette from a Lospec-style HEX string 56 | (with or without leading #). Raises [Invalid_argument] if no valid colors 57 | are found. *) 58 | 59 | (** {1 Conversion} *) 60 | 61 | val to_list : t -> int list 62 | (** [to_list palette] Converts the provided [palette] to a list of 24bpp RGB 63 | entries. *) 64 | 65 | val of_list : int list -> t 66 | (** [of_list list] Converts the provided [list] of 24bpp RGB entries to a 67 | palette. Raises [Invalid_argument] if list size is zero. *) 68 | 69 | (** {1 Usage} *) 70 | 71 | val size : t -> int 72 | (** [size palette] Returns the number of entries in the palette. *) 73 | 74 | val index_to_rgb : t -> int -> int32 75 | (** [index_to_rgb palette index] Will return the 24bpp RGB prepesentation of a 76 | [palette] entry at position [index]. As per other fantasy console systems, 77 | the index value will be wrapped if it is above or below the palette size. *) 78 | 79 | val circle_palette : t -> int -> t 80 | (**[circle_palette pal offset] returns a new palette with entries rotated to 81 | offset*) 82 | 83 | val updated_entry : t -> int -> int * int * int -> t 84 | (** [updated_entry pal index new_color] checks for the index then returns a new 85 | palette with the entry at [index] updated to [new_color]. *) 86 | 87 | val concat : t list -> t 88 | (** [concat palettes] merges a list of palettes into a single palette. *) 89 | 90 | val distinctive_pair : t -> int * int 91 | (** [distintive_pair palette] returns two colours that are the most visually 92 | distinct in the palette. *) 93 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Claudius - A fantasy retro computer library. 2 | 3 | Claudius started out trying to be a functional library that works like a fantasy console system like [TIC-80](https://tic80.com) or [PICO-8](https://www.lexaloffle.com/pico-8.php): A way to do some retro-style demo graphics programming but in OCaml rather than in LUA. In its current form it doesn't do nearly as much as those fantasy consoles, instead just concentrates on enabling you to make graphical demos, and lacks things like audio, expressive input support, sprite editors and so forth. But if your goal is to enter something like [Tiny Code Christmas](https://tcc.lovebyte.party) or [Genuary](https://genuary.art), then Claudius is designed for that use case. 4 | 5 | ## Credits 6 | 7 | Sincere thanks from Claudius team to all those who have contributed or made suggestions - Claudius is made infinitely better for having diversity of influences! 8 | 9 | Claudius uses [Tamzen font](https://github.com/sunaku/tamzen-font) as the default text font. 10 | 11 | # Docs 12 | 13 | There are [odoc](https://github.com/ocaml/odoc) documentation for most of Claudius. You can find an online version [on the Claudius website](https://claudiusfx.org/claudius/index.html). 14 | 15 | There is also a large range of [example programs using Claudius](https://github.com/claudiusFX/claudius-examples/) that you are encouraged to experiment with: try running them and then changing the code to see what else you can get them to do! 16 | 17 | # Using Claudius 18 | 19 | Claudius is a library for OCaml to do retro-style graphics, and so you need to create a new project that uses Cladius. But because Claudius isn't currently in Opam, you'll need to add it into your project using one of the two methods: 20 | 21 | ## Using Claudius 22 | 23 | Claudius is [available via opam](https://opam.ocaml.org/packages/claudius/), and so you should be able to install it by simply running: 24 | 25 | ```shell 26 | $ opam install cladius 27 | ``` 28 | 29 | And then once that is installed, you can add it as a dependancy to your project in your dune file, like this: 30 | 31 | ``` 32 | (executable 33 | (public_name my_program) 34 | (name main) 35 | (libraries claudius)) 36 | ``` 37 | 38 | To see examples of how Claudius is used and learn how it works, we recommend you checkout the [examples library](https://github.com/claudiusFX/claudius-examples), run those, and then try editing the examples to make them do different things! 39 | 40 | ## Standard keys 41 | 42 | Mostly Claudius doesn't have any interaction points beyond those you provide, but there are a few: 43 | 44 | * F1 - Show debug overlay 45 | * F2 - Save a screenshot to a GIF 46 | * F3 - Save an animation to a GIF 47 | 48 | ## Developing Claudius 49 | 50 | If you want to make open-source contributions to Claudius, you are welcome to do so. For that you will need to use the below approach 51 | 52 | If you're working on Claudius itself, then life is a bit easier using a vendor directory to add a version you can edit and commit to: 53 | 54 | ```shell 55 | $ dune init proj myprogram 56 | $ cd myprogram 57 | $ mkdir vendor 58 | $ cd vendor 59 | $ echo "(vendored_dirs *)" > dune 60 | $ git clone https://github.com/claudiusFX/Claudius.git 61 | $ cd .. 62 | $ git submodule update --init --recursive 63 | ``` 64 | 65 | You can build that documentation with: 66 | 67 | ```shell 68 | $ dune build @doc 69 | $ open _build/default/_doc/_html/index.html 70 | ``` 71 | 72 | Or you can use whatever browser directly to open that index file. 73 | 74 | # Requirements 75 | 76 | Claudius has been tested under macOS, Linux, and Windows via WSL, and requires that you have [SDL](https://www.libsdl.org) 2 installed. 77 | 78 | It requires OCaml 5 or newer ([see here for installation instructions](https://ocaml.org/releases/5.3.0#installation-instructions)), and relies on [tsdl](https://github.com/dbuenzli/tsdl) for talking to SDL, and [ounit2](https://opam.ocaml.org/packages/ounit2/) for unit tests. 79 | 80 | # Troubleshooting 81 | 82 | Some users running programs built with Claudius on Ubuntu via WSL may experience a segmentation fault causing the SDL window to crash. It can be fixed with adding the following environment variable before running your program. In your terminal enter the following commands: 83 | 84 | ```shell 85 | $ export LIBGL_ALWAYS_SOFTWARE=1 86 | $ dune exec myprogram 87 | ``` 88 | 89 | If you are using bash, you can add the above environment variable to your bashrc file: 90 | 91 | ```shell 92 | $ echo 'export LIBGL_ALWAYS_SOFTWARE=1' >> ~/.bashrc 93 | $ source ~/.bashrc 94 | $ dune exec myprogram 95 | ``` 96 | -------------------------------------------------------------------------------- /src/keysdl.ml: -------------------------------------------------------------------------------- 1 | let of_backend_keycode (keycode : int) : Key.t = 2 | match keycode with 3 | (* Arrow Keys *) 4 | | 0x4000004F -> Key.Right 5 | | 0x40000050 -> Key.Left 6 | | 0x40000051 -> Key.Down 7 | | 0x40000052 -> Key.Up 8 | (* Modifier Keys *) 9 | | 0x400000E1 -> Key.Shift_L 10 | | 0x400000E5 -> Key.Shift_R 11 | | 0x400000E0 -> Key.Control_L 12 | | 0x400000E4 -> Key.Control_R 13 | | 0x400000E2 -> Key.Alt_L 14 | | 0x400000E6 -> Key.Alt_R 15 | | 0x40000039 -> Key.CapsLock 16 | | 0x40000053 -> Key.NumLock 17 | | 0x40000047 -> Key.ScrollLock 18 | (* Function Keys *) 19 | | 0x4000003A -> Key.F1 20 | | 0x4000003B -> Key.F2 21 | | 0x4000003C -> Key.F3 22 | | 0x4000003D -> Key.F4 23 | | 0x4000003E -> Key.F5 24 | | 0x4000003F -> Key.F6 25 | | 0x40000040 -> Key.F7 26 | | 0x40000041 -> Key.F8 27 | | 0x40000042 -> Key.F9 28 | | 0x40000043 -> Key.F10 29 | | 0x40000044 -> Key.F11 30 | | 0x40000045 -> Key.F12 31 | (* Navigation Keys *) 32 | | 0x40000049 -> Key.Insert 33 | | 0x4000007F -> Key.Delete 34 | | 0x4000004A -> Key.Home 35 | | 0x4000004D -> Key.End 36 | | 0x4000004B -> Key.PageUp 37 | | 0x4000004E -> Key.PageDown 38 | (* Common Control Keys *) 39 | | 0x00000020 -> Key.Space 40 | | 0x0000001B -> Key.Escape 41 | | 0x0000000D -> Key.Enter 42 | | 0x00000008 -> Key.Backspace 43 | | 0x00000009 -> Key.Tab 44 | | 0x40000046 -> Key.PrintScreen 45 | | 0x40000048 -> Key.Pause 46 | (* Alphabet Keys (Lowercase) *) 47 | | 0x00000061 -> Key.A 48 | | 0x00000062 -> Key.B 49 | | 0x00000063 -> Key.C 50 | | 0x00000064 -> Key.D 51 | | 0x00000065 -> Key.E 52 | | 0x00000066 -> Key.F 53 | | 0x00000067 -> Key.G 54 | | 0x00000068 -> Key.H 55 | | 0x00000069 -> Key.I 56 | | 0x0000006A -> Key.J 57 | | 0x0000006B -> Key.K 58 | | 0x0000006C -> Key.L 59 | | 0x0000006D -> Key.M 60 | | 0x0000006E -> Key.N 61 | | 0x0000006F -> Key.O 62 | | 0x00000070 -> Key.P 63 | | 0x00000071 -> Key.Q 64 | | 0x00000072 -> Key.R 65 | | 0x00000073 -> Key.S 66 | | 0x00000074 -> Key.T 67 | | 0x00000075 -> Key.U 68 | | 0x00000076 -> Key.V 69 | | 0x00000077 -> Key.W 70 | | 0x00000078 -> Key.X 71 | | 0x00000079 -> Key.Y 72 | | 0x0000007A -> Key.Z 73 | (* Number Keys *) 74 | | 0x00000030 -> Key.Num0 75 | | 0x00000031 -> Key.Num1 76 | | 0x00000032 -> Key.Num2 77 | | 0x00000033 -> Key.Num3 78 | | 0x00000034 -> Key.Num4 79 | | 0x00000035 -> Key.Num5 80 | | 0x00000036 -> Key.Num6 81 | | 0x00000037 -> Key.Num7 82 | | 0x00000038 -> Key.Num8 83 | | 0x00000039 -> Key.Num9 84 | (* Unknown Key *) 85 | | _ -> Key.Unknown 86 | 87 | let to_backend_keycode (key : Key.t) : int = 88 | match key with 89 | (* Arrow Keys *) 90 | | Key.Right -> 0x4000004F 91 | | Key.Left -> 0x40000050 92 | | Key.Down -> 0x40000051 93 | | Key.Up -> 0x40000052 94 | (* Modifier Keys *) 95 | | Key.Shift_L -> 0x400000E1 96 | | Key.Shift_R -> 0x400000E5 97 | | Key.Control_L -> 0x400000E0 98 | | Key.Control_R -> 0x400000E4 99 | | Key.Alt_L -> 0x400000E2 100 | | Key.Alt_R -> 0x400000E6 101 | | Key.CapsLock -> 0x40000039 102 | | Key.NumLock -> 0x40000053 103 | | Key.ScrollLock -> 0x40000047 104 | (* Function Keys *) 105 | | Key.F1 -> 0x4000003A 106 | | Key.F2 -> 0x4000003B 107 | | Key.F3 -> 0x4000003C 108 | | Key.F4 -> 0x4000003D 109 | | Key.F5 -> 0x4000003E 110 | | Key.F6 -> 0x4000003F 111 | | Key.F7 -> 0x40000040 112 | | Key.F8 -> 0x40000041 113 | | Key.F9 -> 0x40000042 114 | | Key.F10 -> 0x40000043 115 | | Key.F11 -> 0x40000044 116 | | Key.F12 -> 0x40000045 117 | (* Navigation Keys *) 118 | | Key.Insert -> 0x40000049 119 | | Key.Delete -> 0x4000007F 120 | | Key.Home -> 0x4000004A 121 | | Key.End -> 0x4000004D 122 | | Key.PageUp -> 0x4000004B 123 | | Key.PageDown -> 0x4000004E 124 | (* Common Control Keys *) 125 | | Key.Space -> 0x00000020 126 | | Key.Escape -> 0x0000001B 127 | | Key.Enter -> 0x0000000D 128 | | Key.Backspace -> 0x00000008 129 | | Key.Tab -> 0x00000009 130 | | Key.PrintScreen -> 0x40000046 131 | | Key.Pause -> 0x40000048 132 | (* Alphabet Keys (Lowercase) *) 133 | | Key.A -> 0x00000061 134 | | Key.B -> 0x00000062 135 | | Key.C -> 0x00000063 136 | | Key.D -> 0x00000064 137 | | Key.E -> 0x00000065 138 | | Key.F -> 0x00000066 139 | | Key.G -> 0x00000067 140 | | Key.H -> 0x00000068 141 | | Key.I -> 0x00000069 142 | | Key.J -> 0x0000006A 143 | | Key.K -> 0x0000006B 144 | | Key.L -> 0x0000006C 145 | | Key.M -> 0x0000006D 146 | | Key.N -> 0x0000006E 147 | | Key.O -> 0x0000006F 148 | | Key.P -> 0x00000070 149 | | Key.Q -> 0x00000071 150 | | Key.R -> 0x00000072 151 | | Key.S -> 0x00000073 152 | | Key.T -> 0x00000074 153 | | Key.U -> 0x00000075 154 | | Key.V -> 0x00000076 155 | | Key.W -> 0x00000077 156 | | Key.X -> 0x00000078 157 | | Key.Y -> 0x00000079 158 | | Key.Z -> 0x0000007A 159 | (* Number Keys *) 160 | | Key.Num0 -> 0x00000030 161 | | Key.Num1 -> 0x00000031 162 | | Key.Num2 -> 0x00000032 163 | | Key.Num3 -> 0x00000033 164 | | Key.Num4 -> 0x00000034 165 | | Key.Num5 -> 0x00000035 166 | | Key.Num6 -> 0x00000036 167 | | Key.Num7 -> 0x00000037 168 | | Key.Num8 -> 0x00000038 169 | | Key.Num9 -> 0x00000039 170 | (* Unknown Key *) 171 | | Key.Unknown -> -1 172 | -------------------------------------------------------------------------------- /src/font.ml: -------------------------------------------------------------------------------- 1 | (** Hello *) 2 | 3 | (* https://wiki.osdev.org/PC_Screen_Font *) 4 | 5 | type psfheader = { 6 | magic : int32; 7 | version : int32; 8 | headersize : int32; 9 | flags : int32; 10 | number_of_glyphs : int32; 11 | bytes_per_glyph : int32; 12 | height : int32; 13 | width : int32; 14 | } 15 | 16 | module Glyph = struct 17 | type t = { bitmap : bytes; width : int; height : int } 18 | 19 | let dimensions g = (g.width, g.height, 0, 0) 20 | let bitmap g = g.bitmap 21 | end 22 | 23 | type t = { 24 | header : psfheader; 25 | glyphs : bytes array; 26 | map : (Uchar.t * int) list; 27 | } 28 | 29 | type reader_t = int64 -> int -> Bytes.t -> unit 30 | 31 | (* ----- internal ----- *) 32 | 33 | let read_header (reader : reader_t) : (psfheader, string) result = 34 | let header_length = 4 * 8 in 35 | let header_buffer = Bytes.create header_length in 36 | try 37 | reader 0L header_length header_buffer; 38 | Result.ok 39 | { 40 | magic = Bytes.get_int32_le header_buffer 0; 41 | version = Bytes.get_int32_le header_buffer 4; 42 | headersize = Bytes.get_int32_le header_buffer 8; 43 | flags = Bytes.get_int32_le header_buffer 12; 44 | number_of_glyphs = Bytes.get_int32_le header_buffer 16; 45 | bytes_per_glyph = Bytes.get_int32_le header_buffer 20; 46 | height = Bytes.get_int32_le header_buffer 24; 47 | width = Bytes.get_int32_le header_buffer 28; 48 | } 49 | with Sys_error reason -> Result.error reason 50 | 51 | let load_glyphs (reader : reader_t) header : (bytes array, string) result = 52 | let bpg = Int32.to_int header.bytes_per_glyph in 53 | try 54 | Result.ok 55 | (Array.init (Int32.to_int header.number_of_glyphs) (fun i -> 56 | let buffer = Bytes.create bpg in 57 | reader 58 | (Int64.of_int (Int32.to_int header.headersize + (i * bpg))) 59 | bpg buffer; 60 | buffer)) 61 | with Sys_error reason -> Result.error reason 62 | 63 | let inner_load_map_table reader header : ((Uchar.t * int) list, string) result = 64 | try 65 | let offset : int64 ref = 66 | ref 67 | (Int64.of_int 68 | (Int32.to_int header.headersize 69 | + Int32.to_int header.number_of_glyphs 70 | * Int32.to_int header.bytes_per_glyph)) 71 | in 72 | let rec outerloop (counter : int) (tail : (Uchar.t * int) list list) : 73 | (Uchar.t * int) list list = 74 | let rec find_next_terminator (sofar : char list) : char list option = 75 | try 76 | let buffer = Bytes.create 1 in 77 | reader !offset 1 buffer; 78 | offset := Int64.add !offset 1L; 79 | let c = Bytes.get buffer 0 in 80 | match c with 81 | | '\255' -> Some sofar 82 | | _ -> find_next_terminator (c :: sofar) 83 | with 84 | | Invalid_argument _ -> None 85 | | Sys_error _ -> None 86 | in 87 | match find_next_terminator [] with 88 | | None -> tail 89 | | Some bytes_list -> 90 | let next_batch_list = List.rev bytes_list in 91 | let next_batch_buffer = Bytes.create (List.length next_batch_list) in 92 | List.iteri 93 | (fun i c -> Bytes.set next_batch_buffer i c) 94 | next_batch_list; 95 | 96 | let rec bytes_to_unicodes (offset : int) (tail : Uchar.t list) : 97 | Uchar.t list = 98 | let remaining = Bytes.length next_batch_buffer - offset in 99 | match remaining with 100 | | 0 -> tail 101 | | _ -> ( 102 | let c = Bytes.get_utf_8_uchar next_batch_buffer offset in 103 | let size = Uchar.utf_decode_length c in 104 | match Uchar.utf_decode_is_valid c with 105 | | false -> bytes_to_unicodes (offset + size) tail 106 | | true -> 107 | bytes_to_unicodes (offset + size) 108 | (Uchar.utf_decode_uchar c :: tail)) 109 | in 110 | let char_list = bytes_to_unicodes 0 [] in 111 | let this_uchars = List.map (fun c -> (c, counter)) char_list in 112 | outerloop (counter + 1) (this_uchars :: tail) 113 | in 114 | let rest = outerloop 0 [] in 115 | Result.ok (List.concat rest) 116 | with Sys_error reason -> Result.error reason 117 | 118 | let load_map_table reader header : ((Uchar.t * int) list, string) result = 119 | let flags = Int32.to_int header.flags in 120 | match flags with 121 | | 0 -> 122 | Result.ok 123 | (List.init (Int32.to_int header.number_of_glyphs) (fun i -> 124 | (Uchar.of_int i, i))) 125 | | 1 -> inner_load_map_table reader header 126 | | _ -> Result.error (Printf.sprintf "Unrecognised header flag 0x%x" flags) 127 | 128 | let ( >>= ) = Result.bind 129 | 130 | let channel_reader inc : reader_t = 131 | fun offset length buffer -> 132 | In_channel.seek inc offset; 133 | match In_channel.really_input inc buffer 0 length with 134 | | Some () -> () 135 | | None -> invalid_arg "failed to get bytes" 136 | 137 | let bytes_reader inbuf : reader_t = 138 | fun offset length outbuf -> 139 | Bytes.blit inbuf (Int64.to_int offset) outbuf 0 length 140 | 141 | let load_font reader = 142 | read_header reader >>= fun header -> 143 | load_glyphs reader header >>= fun glyphs -> 144 | load_map_table reader header >>= fun map -> Result.ok { header; glyphs; map } 145 | 146 | (* ----- public ----- *) 147 | 148 | let of_bytes data = 149 | let reader = bytes_reader data in 150 | load_font reader 151 | 152 | let of_file filename = 153 | In_channel.with_open_bin filename (fun ic -> 154 | let reader = channel_reader ic in 155 | load_font reader) 156 | 157 | let print_header (font : t) = 158 | let header = font.header in 159 | Printf.printf "Magic: 0x%08x\n" (Int32.to_int header.magic); 160 | Printf.printf "Version: %d\n" (Int32.to_int header.version); 161 | Printf.printf "Header Size: %d\n" (Int32.to_int header.headersize); 162 | Printf.printf "Flags: 0x%08x\n" (Int32.to_int header.flags); 163 | Printf.printf "Number of Glyphs: %d\n" (Int32.to_int header.number_of_glyphs); 164 | Printf.printf "Bytes per Glyph: %d\n" (Int32.to_int header.bytes_per_glyph); 165 | Printf.printf "Width: %d\n" (Int32.to_int header.width); 166 | Printf.printf "Height: %d\n" (Int32.to_int header.height) 167 | 168 | let glyph_count (font : t) : int = Int32.to_int font.header.number_of_glyphs 169 | 170 | let glyph_of_char (font : t) (u : Uchar.t) : Glyph.t option = 171 | match List.assoc_opt u font.map with 172 | | None -> None 173 | | Some index -> ( 174 | match index >= 0 && index < Array.length font.glyphs with 175 | | false -> None 176 | | true -> 177 | Some 178 | { 179 | bitmap = font.glyphs.(index); 180 | width = Int32.to_int font.header.width; 181 | height = Int32.to_int font.header.height; 182 | }) 183 | -------------------------------------------------------------------------------- /test/test_framebuffer.ml: -------------------------------------------------------------------------------- 1 | open Claudius 2 | open OUnit2 3 | 4 | let test_basic_framebuffer_creation _ = 5 | let fb = Framebuffer.init (10, 20) (fun x y -> x + (y * 10)) in 6 | let raw = Framebuffer.to_array fb in 7 | assert_equal ~msg:"Y axis size" 20 (Array.length raw); 8 | Array.iteri 9 | (fun y row -> 10 | assert_equal ~msg:"X axis size" 10 (Array.length row); 11 | Array.iteri 12 | (fun x pixel -> assert_equal ~msg:"Pixel value" (x + (y * 10)) pixel) 13 | row) 14 | raw; 15 | for y = 0 to 19 do 16 | for x = 0 to 9 do 17 | let pixel = Framebuffer.pixel_read x y fb in 18 | assert_equal ~msg:"pixel read" (Some (x + (y * 10))) pixel 19 | done 20 | done 21 | 22 | let test_fail_invalid_dimensions _ = 23 | assert_raises (Invalid_argument "Invalid width") (fun _ -> 24 | Framebuffer.init (-10, 20) (fun _ _ -> 0)); 25 | assert_raises (Invalid_argument "Invalid height") (fun _ -> 26 | Framebuffer.init (10, -20) (fun _ _ -> 0)) 27 | 28 | let test_framebuffer_write_pixel _ = 29 | let fb = Framebuffer.init (10, 20) (fun _ _ -> 0) in 30 | for y = 0 to 19 do 31 | for x = 0 to 9 do 32 | Framebuffer.pixel_write x y (x + (y * 10)) fb 33 | done 34 | done; 35 | let raw = Framebuffer.to_array fb in 36 | Array.iteri 37 | (fun y row -> 38 | Array.iteri 39 | (fun x pixel -> assert_equal ~msg:"Pixel value" (x + (y * 10)) pixel) 40 | row) 41 | raw 42 | 43 | let test_framebuffer_write_pixel_outside _ = 44 | (* Expect updates outside framebuffer to be ignored *) 45 | let fb = Framebuffer.init (10, 20) (fun _ _ -> 0) in 46 | for y = 0 to 19 do 47 | Framebuffer.pixel_write (-1) y 42 fb; 48 | Framebuffer.pixel_write 10 y 42 fb 49 | done; 50 | for x = 0 to 9 do 51 | Framebuffer.pixel_write x (-1) 42 fb; 52 | Framebuffer.pixel_write x 20 42 fb 53 | done; 54 | let raw = Framebuffer.to_array fb in 55 | Array.iter 56 | (fun row -> 57 | Array.iter (fun pixel -> assert_equal ~msg:"Pixel value" 0 pixel) row) 58 | raw 59 | 60 | let test_basic_framebuffer_shader _ = 61 | let fb = Framebuffer.init (10, 20) (fun x y -> x + (y * 10)) in 62 | let updated = Framebuffer.map (fun x -> x + 1) fb in 63 | let raw = Framebuffer.to_array updated in 64 | assert_equal ~msg:"Y axis size" 20 (Array.length raw); 65 | Array.iteri 66 | (fun y row -> 67 | assert_equal ~msg:"X axis size" 10 (Array.length row); 68 | Array.iteri 69 | (fun x pixel -> 70 | assert_equal ~msg:"Pixel value updated" (1 + x + (y * 10)) pixel) 71 | row) 72 | raw; 73 | for y = 0 to 19 do 74 | for x = 0 to 9 do 75 | let pixel = Framebuffer.pixel_read x y updated in 76 | assert_equal ~msg:"pixel read updated" (Some (1 + x + (y * 10))) pixel; 77 | let original = Framebuffer.pixel_read x y fb in 78 | assert_equal ~msg:"pixel read original" (Some (x + (y * 10))) original 79 | done 80 | done 81 | 82 | let test_basic_framebuffer_shader_inplace _ = 83 | let fb = Framebuffer.init (10, 20) (fun x y -> x + (y * 10)) in 84 | Framebuffer.map_inplace (fun x -> x + 1) fb; 85 | let raw = Framebuffer.to_array fb in 86 | assert_equal ~msg:"Y axis size" 20 (Array.length raw); 87 | Array.iteri 88 | (fun y row -> 89 | assert_equal ~msg:"X axis size" 10 (Array.length row); 90 | Array.iteri 91 | (fun x pixel -> 92 | assert_equal ~msg:"Pixel value" (1 + x + (y * 10)) pixel) 93 | row) 94 | raw; 95 | for y = 0 to 19 do 96 | for x = 0 to 9 do 97 | let pixel = Framebuffer.pixel_read x y fb in 98 | assert_equal ~msg:"pixel read" (Some (1 + x + (y * 10))) pixel 99 | done 100 | done 101 | 102 | let test_basic_framebuffer_shaderi _ = 103 | let fb = Framebuffer.init (10, 20) (fun _ _ -> 0) in 104 | let updated = Framebuffer.mapi (fun x y _ -> x + (y * 10)) fb in 105 | let raw = Framebuffer.to_array updated in 106 | assert_equal ~msg:"Y axis size" 20 (Array.length raw); 107 | Array.iteri 108 | (fun y row -> 109 | assert_equal ~msg:"X axis size" 10 (Array.length row); 110 | Array.iteri 111 | (fun x pixel -> 112 | assert_equal ~msg:"Pixel value updated" (x + (y * 10)) pixel) 113 | row) 114 | raw; 115 | for y = 0 to 19 do 116 | for x = 0 to 9 do 117 | let pixel = Framebuffer.pixel_read x y updated in 118 | assert_equal ~msg:"pixel read updated" (Some (x + (y * 10))) pixel; 119 | let original = Framebuffer.pixel_read x y fb in 120 | assert_equal ~msg:"pixel read original" (Some 0) original 121 | done 122 | done 123 | 124 | let test_basic_framebuffer_shaderi_inplace _ = 125 | let fb = Framebuffer.init (10, 20) (fun _ _ -> 0) in 126 | Framebuffer.mapi_inplace (fun x y _ -> x + (y * 10)) fb; 127 | let raw = Framebuffer.to_array fb in 128 | assert_equal ~msg:"Y axis size" 20 (Array.length raw); 129 | Array.iteri 130 | (fun y row -> 131 | assert_equal ~msg:"X axis size" 10 (Array.length row); 132 | Array.iteri 133 | (fun x pixel -> assert_equal ~msg:"Pixel value" (x + (y * 10)) pixel) 134 | row) 135 | raw; 136 | for y = 0 to 19 do 137 | for x = 0 to 9 do 138 | let pixel = Framebuffer.pixel_read x y fb in 139 | assert_equal ~msg:"pixel read" (Some (x + (y * 10))) pixel 140 | done 141 | done 142 | 143 | let test_merge_framebuffers _ = 144 | let fb1 = Framebuffer.init (10, 20) (fun x y -> (x + y) mod 2) 145 | and fb2 = Framebuffer.init (10, 20) (fun x y -> 1 - ((x + y) mod 2)) in 146 | let merged = Framebuffer.map2 (fun a b -> a + b) fb1 fb2 in 147 | let raw = Framebuffer.to_array merged in 148 | assert_equal ~msg:"Y axis size" 20 (Array.length raw); 149 | Array.iter 150 | (fun row -> 151 | assert_equal ~msg:"X axis size" 10 (Array.length row); 152 | Array.iter (fun pixel -> assert_equal ~msg:"Pixel value" 1 pixel) row) 153 | raw 154 | 155 | let test_merge_framebuffers_inplace _ = 156 | let fb1 = Framebuffer.init (10, 20) (fun x y -> (x + y) mod 2) 157 | and fb2 = Framebuffer.init (10, 20) (fun x y -> 1 - ((x + y) mod 2)) in 158 | Framebuffer.map2_inplace (fun a b -> a + b) fb1 fb2; 159 | let raw = Framebuffer.to_array fb1 in 160 | assert_equal ~msg:"Y axis size" 20 (Array.length raw); 161 | Array.iter 162 | (fun row -> 163 | assert_equal ~msg:"X axis size" 10 (Array.length row); 164 | Array.iter (fun pixel -> assert_equal ~msg:"Pixel value" 1 pixel) row) 165 | raw 166 | 167 | let test_merge_mismatched_framebuffers _ = 168 | let fb1 = Framebuffer.init (10, 20) (fun x y -> (x + y) mod 2) 169 | and fb2 = Framebuffer.init (20, 10) (fun x y -> 1 - ((x + y) mod 2)) in 170 | assert_raises 171 | (Invalid_argument 172 | "Merging framebuffers requires both to have same dimensions") (fun _ -> 173 | Framebuffer.map2 (fun a b -> a + b) fb1 fb2) 174 | 175 | let test_merge_mismatched_framebuffers_inplace _ = 176 | let fb1 = Framebuffer.init (10, 20) (fun x y -> (x + y) mod 2) 177 | and fb2 = Framebuffer.init (20, 10) (fun x y -> 1 - ((x + y) mod 2)) in 178 | assert_raises 179 | (Invalid_argument 180 | "Merging framebuffers requires both to have same dimensions") (fun _ -> 181 | Framebuffer.map2_inplace (fun a b -> a + b) fb1 fb2) 182 | 183 | let suite = 184 | "Frambuffer tests" 185 | >::: [ 186 | "Test simple framebuffer set up" >:: test_basic_framebuffer_creation; 187 | "Test fail with invalid dimensions" >:: test_fail_invalid_dimensions; 188 | "Test write pixel" >:: test_framebuffer_write_pixel; 189 | "Test write outside framebuffer" 190 | >:: test_framebuffer_write_pixel_outside; 191 | "Test simple shader" >:: test_basic_framebuffer_shader; 192 | "Test simple shader inplace" >:: test_basic_framebuffer_shader_inplace; 193 | "Test simple shaderi" >:: test_basic_framebuffer_shaderi; 194 | "Test simple shaderi inplace" 195 | >:: test_basic_framebuffer_shaderi_inplace; 196 | "Test simple merged" >:: test_merge_framebuffers; 197 | "Test simple merged inplace" >:: test_merge_framebuffers_inplace; 198 | "Test fail to merge mismatched framebuffers" 199 | >:: test_merge_mismatched_framebuffers; 200 | "Test fail to merge mismatched framebuffers inplace" 201 | >:: test_merge_mismatched_framebuffers_inplace; 202 | ] 203 | 204 | let () = run_test_tt_main suite 205 | -------------------------------------------------------------------------------- /src/framebuffer.mli: -------------------------------------------------------------------------------- 1 | (** Provides the simulated framebuffer for Claudius. 2 | 3 | The framebuffer is logically an array of memory in which you draw using 4 | palette entries, similar to say how VGA worked on old PCs. *) 5 | 6 | type t = { data : int array array; mutable dirty : bool } 7 | 8 | (** {1 Initializations} *) 9 | 10 | val init : int * int -> (int -> int -> int) -> t 11 | (** [init width height f] Creates a new framebuffer of the specified size 12 | [width] x [height] and initialises each pixel using the provided function. 13 | The function is provided the x and y coordinates of the pixel and should 14 | return the colour there. *) 15 | 16 | (** {1 Drawing operations} 17 | These operations let you modify the framebuffer with basic shapes. This list 18 | isn't exhaustive, but just some basics to let people get up and running. 19 | Shapes will be automatically clipped to fit the framebuffer. Position (0, 0) 20 | is in the top left of the screen. *) 21 | 22 | (** {2 Functional style} 23 | In functional style, you should aim to build up a transformation pipeline 24 | where you effectively have a series of steps like so: 25 | 26 | + Generate data 27 | + Advance data by time step t 28 | + Transform data to list of rendering Primitive.t elements 29 | + Pass list to Frambuffer.render *) 30 | 31 | val render : t -> Primitives.t list -> unit 32 | (** [render framebuffer primitives] Takes a list of primative shapes and calls 33 | the appropriate drawing operation for each in turn to render them into the 34 | provide framebuffer. *) 35 | 36 | (** {2 Imperative style} 37 | As an alternative to the functional style above, you can just draw directly 38 | to the framebuffer in an imperative style, one operation at a time. *) 39 | 40 | val draw_line : int -> int -> int -> int -> int -> t -> unit 41 | (** [draw_line x0 y0 x1 y1 colour framebuffer] Draws a line between ([x0], [y0]) 42 | ([x1], [y1]) specified in the specified [colour] into [framebuffer]. *) 43 | 44 | val draw_circle : int -> int -> float -> int -> t -> unit 45 | (** [draw_circle x0 y0 radius colour framebuffer] Draws the outline of a circle 46 | centred at ([x0], [y0]) with the specified [radius] in the specified 47 | [colour] into [framebuffer]. *) 48 | 49 | val filled_circle : int -> int -> float -> int -> t -> unit 50 | (** [filled_circle x0 y0 radius colour framebuffer] Draws a filled circle 51 | centred at ([x0], [y0]) with the specified [radius] in the specified 52 | [colour] into [framebuffer]. *) 53 | 54 | val draw_ellipse : int -> int -> float -> float -> int -> t -> unit 55 | (** [draw_ellipse x0 y0 a b colour framebuffer] Draws the outline of an ellipse 56 | centred at ([x0], [y0]) with horizontal radius [a] and vertical radius [b] 57 | in the specified [colour] into [framebuffer]. *) 58 | 59 | val filled_ellipse : int -> int -> float -> float -> int -> t -> unit 60 | (** [filled_ellipse x0 y0 a b colour framebuffer] Draws a filled ellipse centred 61 | at ([x0], [y0]) with horizontal radius [a] and vertical radius [b] in the 62 | specified [colour] into [framebuffer]. *) 63 | 64 | val draw_rect : int -> int -> int -> int -> int -> t -> unit 65 | (** [draw_rect x y width height colour framebuffer] Draws the outline of a 66 | rectangle aligned with the window, with the top left at ([x], [y]) and size 67 | of ([width], [height]) in the specified [colour] into [framebuffer]. *) 68 | 69 | val filled_rect : int -> int -> int -> int -> int -> t -> unit 70 | (** [filled_rect x y width height colour framebuffer] Draws a filled rectangle 71 | aligned with the window, with the top left at ([x], [y]) and size of 72 | ([width], [height]) in the specified [colour] into [framebuffer]. *) 73 | 74 | val draw_triangle : int -> int -> int -> int -> int -> int -> int -> t -> unit 75 | (** [draw_triangle x0 y0 x1 y1 x2 y2 colour framebuffer] Draws the outline of a 76 | triangle made from the points ([x0], [y0]), ([x1], [y1]), and ([x2], [y2]) 77 | in the specified [colour] into [framebuffer]. *) 78 | 79 | val filled_triangle : int -> int -> int -> int -> int -> int -> int -> t -> unit 80 | (** [filled_triangle x0 y0 x1 y1 x2 y2 colour framebuffer] Draws a filled 81 | triangle made from the points ([x0], [y0]), ([x1], [y1]), and ([x2], [y2]) 82 | in the specified [colour] into [framebuffer]. *) 83 | 84 | val draw_polygon : (int * int) list -> int -> t -> unit 85 | (** [draw_polygon points colour framebuffer] Draws the outline of a polygon made 86 | from the list of [points] in the specified [colour] into [framebuffer]. *) 87 | 88 | val filled_polygon : (int * int) list -> int -> t -> unit 89 | (** [filled_polygon points colour framebuffer] Draws a filled polygon made from 90 | the list of [points] in the specified [colour] into [framebuffer]. *) 91 | 92 | val draw_picture : Picture.t -> ?scale:float -> int -> int -> t -> unit 93 | (** [draw_picture pic ?scale x y buffer] draws [pic] onto [buffer] at position 94 | (x, y). The picture is scaled uniformly by [scale], which defaults to 1.0 if 95 | omitted. *) 96 | 97 | val draw_char : int -> int -> Font.t -> char -> int -> t -> int 98 | (** [draw_char x y font c colour framebuffer] Draws a single character [c] in 99 | the specified [colour] using [font]. The top left of the charcter is the 100 | point specified by position ([x], [y]). The return value is the number of 101 | pixels wide the character was. *) 102 | 103 | val draw_string : int -> int -> Font.t -> string -> int -> t -> int 104 | (** [draw_string x y font s colour framebuffer] Draws the string [s] in the 105 | specified [colour] using [font]. The top left of the first charcter is the 106 | point specified by position ([x], [y]). The return value is the number of 107 | pixels wide the string was. *) 108 | 109 | (** {1 Pixel operations} 110 | Rather than working with shape primatives, sometimes you want to work with 111 | pixels directly, for example creating plasma effects or drawing fractals, 112 | etc. Again, Claudius has both a functional approach for this and an 113 | imperative approach. *) 114 | 115 | (** {2 Functional style} 116 | In the functional style you can pass functions that will be called per pixel 117 | on the source, doing a full transform of the framebuffer to a new state. 118 | Some common tricks that emerge from this are examples like clearing the 119 | screen: 120 | 121 | {[ 122 | Framebuffer.map_inplace (fun _ -> 0) existing_framebuffer 123 | ]} 124 | 125 | Or to fade out the previous frame (assuming you have a palette where lower 126 | values are darker): 127 | 128 | {[ 129 | Framebuffer.map_inplace 130 | (fun x -> match pixel with 0 -> 0 | x -> x - 1) 131 | existing_framebuffer 132 | ]} 133 | 134 | All of these functions have a inplace and non_implace version: the 135 | non-implace version makes for more functional code, but if you do it a lot 136 | the memory allocations will slow things down, and in which case you may wish 137 | to consider using inplace versions. *) 138 | 139 | type shader_func = int -> int 140 | (** You pass [shader_func value] to the map functions, which call it passing in 141 | a single pixel value from which to derive a new pixel value. *) 142 | 143 | type shaderi_func = int -> int -> t -> int 144 | (** You pass [shaderi_func] to the mapi functions, which passes in both the 145 | current x y coordinates and the existing framebuffer from which you can then 146 | extract values for generating the updated value. *) 147 | 148 | val map : shader_func -> t -> t 149 | (** [map f framebuffer] Generates a new framebuffer of the same dimensions by 150 | applying the provided function [f] to each pixel value in the original to 151 | generate a new pixel in the target. *) 152 | 153 | val mapi : shaderi_func -> t -> t 154 | (** [mapi f framebuffer] Generates a new framebuffer of the same dimensions by 155 | applying the provided function [f] to each pixel value and its coordinates 156 | in the original to generate a new pixel in the target. *) 157 | 158 | val map_inplace : shader_func -> t -> unit 159 | (** [map_inplace f framebuffer] Updates a framebuffer by applying the provided 160 | function [f] to each pixel value to update its value. *) 161 | 162 | val mapi_inplace : shaderi_func -> t -> unit 163 | (** [mapi_inplace f framebuffer] Updates a framebuffer by applying the provided 164 | function [f] to each pixel value and its coordinate value to update its 165 | value. *) 166 | 167 | val map2 : (int -> int -> int) -> t -> t -> t 168 | (** [map2 f first second] Takes two framebuffers of equal size and applys the 169 | function [f] to each pixel pair in turn to generate a new framebuffer. *) 170 | 171 | val map2_inplace : (int -> int -> int) -> t -> t -> unit 172 | (** [map2_inplace f first second] Takes two framebuffers of equal size and 173 | applys the function [f] to each pixel pair in storing the result back in the 174 | first provided framebuffer. *) 175 | 176 | (** {2 Imperative style} 177 | Sometimes you don't want to transform the entire framebuffer, and so you can 178 | do per pixel calls also. *) 179 | 180 | val pixel_write : int -> int -> int -> t -> unit 181 | (** [pixel_write x y colour framebuffer] Set the pixel at the specified 182 | coordinate to palette colour in the provided framebuffer. If the coordinate 183 | is outside the framebuffer then nothing is drawn, but there is no error. *) 184 | 185 | val pixel_read : int -> int -> t -> int option 186 | (** [pixel_read x y framebuffer] Get the pixel colour at the specified 187 | coordinate in the provided framebuffer. If the coordinate is outside the 188 | framebuffer you get None, otherwise Some colour. *) 189 | 190 | (** {1 Misc} *) 191 | 192 | val to_array : t -> int array array 193 | (** [to_array framebuffer] converts the framebuffer into a 2D array. The top 194 | level array is an array of rows, and each row is an array of palette entry 195 | colours. *) 196 | 197 | (** {2 Dirty-bit support} *) 198 | 199 | val is_dirty : t -> bool 200 | (** [is_dirty framebuffer] returns [true] if the framebuffer has been marked as 201 | 'dirty'. *) 202 | 203 | val set_dirty : t -> unit 204 | (** [set_dirty framebuffer] marks the framebuffer as dirty. *) 205 | 206 | val clear_dirty : t -> unit 207 | (** [clear_dirty framebuffer] resets the dirty bit to false. *) 208 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Claudius - A fantasy retro computer library.} 2 | 3 | Claudius started out trying to be a functional library that works like a fantasy console system like {{:https://tic80.com}TIC-80} or {{:https://www.lexaloffle.com/pico-8.php}PICO-8}: A way to do some retro-style demo graphics programming but in OCaml rather than in LUA. In its current form, it doesn't do nearly as much as those fantasy consoles, instead just concentrating on enabling you to make graphical demos, and lacks things like audio, expressive input support, sprite editors and so forth. But if your goal is to enter something like {{:https://tcc.lovebyte.party}Tiny Code Christmas} or {{:https://genuary.art}Genuary}, then Claudius is designed for that use case. 4 | 5 | {1 Key concepts} 6 | 7 | As mentioned already, Claudius takes inspiration from existing fantasy console environments, whilst trying to encourage a more functional approach to working within such constraints. This section covers the basic concepts that Claudius relies on. 8 | 9 | One of the main differences is that rather than work with a memory map layout of the virtual computer (e.g., see TIC-80's {{:https://tic80.com/learn}docs} where it describes the memory layout it uses), Claudius works with a {!Claudius.Framebuffer.t} type, which is an ADT that manages the pixels in a palette based colour space. You can generate new framebuffers when you like, or recycle old ones. By not treating them as memory mapped as in TIC-80, we can encourage a more functional access approach (as described below). 10 | 11 | {2 The framebuffer} 12 | 13 | Claudius is based on the concept of a framebuffer that exists in a paletted space with a fixed number of colours, similar to how early home computers worked. Every frame (or tick, see below), you will be asked to return a framebuffer to be rendered to the screen. This is a nod to how fantasy-consoles like TIC-80 work, where they present a memory mapped framebuffer, but Claudius is trying to encourage more functional thinking, and so you are responsible for defining and returning framebuffers. 14 | 15 | This mode of operation, whilst perhaps a little odd, does have some nice properties where you can write "shader" style code that operates per pixel, either creating a new framebuffer, or by mapping over an existing framebuffer. 16 | 17 | {2 Styles of working with Claudius} 18 | 19 | To support this there's three primary modes of working with Claudius for generating visual effects and demos: 20 | 21 | - Pixel functional 22 | - Screen functional 23 | - Imperative 24 | 25 | {3 Pixel Functional} 26 | 27 | Often visual effects can be encoded as "pixel functional" - that is to draw the screen you just need to provide a function that takes the `x` and `y` coordinate of the pixel and then generates its value. A classic example of this would be a {{:https://en.wikipedia.org/wiki/Mandelbrot_set}Mandelbrot Fractal}. To encourage this, the most common way to generate a blank canvas in Claudius is: 28 | 29 | {[ 30 | let fb = Framebuffer.init (640, 480) (fun _x _y -> 0) 31 | ]} 32 | 33 | You can also modify an existing framebuffer by providing a shader style function. For example, this shader is used to fade out the previous frame: 34 | 35 | {[ 36 | let faded_fb = Framebuffer.map (fun pixel -> if pixel > 1 then (pixel - 1) else 0) fb 37 | ]} 38 | 39 | Done too much this can be expensive in memory allocations, and so there is also a `shader_inplace` variation that does an update on the provided framebuffer - this is less functional, but is sometimes a pragmatic compromise based on performance. 40 | 41 | {3 Screen Functional} 42 | 43 | Whilst pixel functional effects can be fun, they can also be quite limiting, and often you will want to build up bigger scenes to be rendered at once. For this we encourage a functional pipeline style of processing, which we refer to as "Screen Functional" - each frame is a function of time t. To support this Claudius has a primitives library, whereby you can render objects to a framebuffer: 44 | 45 | {[ 46 | let w, h = Screen.dimensions s in 47 | let palsize = Palette.size (Screen.palette s) in 48 | 49 | (* generate some points *) 50 | List.init 42 (fun _ -> (Random.int w, Random.int h)) 51 | (* Convert those circle primitives in different colours *) 52 | |> List.mapi (fun idx (x, y) -> Primitive.Circle ({x ; y } ; 3.0 ; idx mod palsize)) 53 | (* Draw to framebuffer *) 54 | |> Framebuffer.render fb 55 | ]} 56 | 57 | More complicated examples for say a 3D-style pipeline you often end up writing pipelines that look like: 58 | 59 | {[ 60 | (* generate some points for the model *) 61 | generate_model_points () 62 | (* Advance the model by time t *) 63 | |> update_points t 64 | (* Convert points to 2D *) 65 | |> project_points 66 | (* Convert to primatives *) 67 | |> convert_to_primatives 68 | (* Finally render to framebuffer *) 69 | |> Framebuffer.render fb 70 | ]} 71 | 72 | You can see an example of this in practice in {{:https://github.com/mdales/claudius-examples/day1/bin/main.ml}cladius-examples/day1}. 73 | 74 | {3 Imperative} 75 | 76 | Finally, if you just want to get some shapes on screen, then all primatives can be directly rendered to a framebuffer like so: 77 | 78 | {[ 79 | Framebuffer.draw_line x0 y0 x1 y1 col buffer 80 | ]} 81 | 82 | 83 | {2 Tick and Boot} 84 | 85 | Similar to both TIC-80, and embedded development systems like {{:https://arduino.cc}Arduino}, Claudius programs have two main entry points, functions that you must provide to Claudius: an optional one called `boot` and a mandatory one called `tick`. 86 | 87 | {3 Boot} 88 | 89 | This function is called once, and at its minimum is used to set an initial screen state, though it can also be used by your code to initialise any other state that your program maintains. If you're happy with just a blank screen (using palette entry 0, see screen details below for more on this), then you don't need to provide a `boot` function. 90 | 91 | {3 Tick} 92 | 93 | the `tick` function is mandatory, and will be called once per frame redraw by Claudius. This will be where you either generate a new set of screen contents or you can modify the old screen contents and provide that back to Claudius. The tick function will be provided with a monotomically incrementing counter `t` that can be used to derive a particular frame update. 94 | 95 | {1 Screen modes} 96 | 97 | Claudius isn't as restrictive as a dedicated fantasy console, which typically offers one or a few dedicated modes (e.g., 240x180x16 for TIC-80), but rather you specify a screen as having a resolution and palette of your choosing. Currently palettes are only configured at start-of-day, and not yet modifiable whilst an effect is running, but the ability to have palettes of arbitrary sizes does offset this limitation somewhat, but is probably something that will be addressed in a future release. 98 | 99 | {2 Palettes} 100 | 101 | Palettes are defined as sets of 24bit red, green, blue values. You can thus create a 5 entry palette of black, red, green, blue, white by doing the following: 102 | 103 | {[ 104 | let p = Palette.of_list [0x000000 ; 0xFF0000; 0x00FF00; 0x0000FF ; 0xFFFFFF] 105 | ]} 106 | 107 | To assist with some common fancy palettes, there are some helper functions that will save you some code. For instance, you can create a 256 entry monochromatic palette like so: 108 | 109 | {[ 110 | let p = Palette.generate_mono_palette 256 111 | ]} 112 | 113 | Or a plasma colour palette like this: 114 | 115 | {[ 116 | let p = Palette.generate_plasma_palette 16 117 | ]} 118 | 119 | You can also turn a palette back into a list of integers, to say create a palette that has black and white and 14 plasma colours: 120 | 121 | {[ 122 | let = p Palette.generate_plasma_palette 14 123 | |> Palette.to_list 124 | |> List.concat [0x000000;0xFFFFFF] 125 | |> Palette.of_list 126 | ]} 127 | 128 | 129 | {2 Screens} 130 | 131 | Once you have a colour palette defined, you can now create the screen mode you want to use with {!Claudius.Screen.create}: 132 | 133 | {[ 134 | let s = Screen.create 640 480 1 (Palette.generate_mono_palette 16) 135 | ]} 136 | 137 | The first two arguments are the width and height of the emulated screen mode, and final argument is the palette. The third argument is a scaling factor when displayed; if you're trying to work at resolutions like 320x200 (old-school VGA 256 colour), then things can get quite small on modern displays, so you might want to bump that up a bit, for example making it display at three times the size: 138 | 139 | {[ 140 | let s = Screen.create 320 200 3 (Palette.generate_plasma_palette 256) 141 | ]} 142 | 143 | Claudius will use this information to generate the initial framebuffer state if you don't provide a boot function, and it is used to generate and render the window Claudius will display on the screen. 144 | 145 | In retro-graphics there are many effects that are powered by updating the palette, and to allow this Claudius supports updating the palette as your program is running. For example, it is a common to rotate the palette colours to get an on screen effect rather than rewriting all the pixels with new palette values. To update the palette you provide a new palette to the screen by calling {!Claudius.Screen.update_palette}. 146 | 147 | Screens also let you load a set of images ready to use in your program. By loading them at the start of your program, Claudius can correctly allocate palette entries for the colours in the images, so the palette becomes the colours you specifed when you create the palette, plus the colours from any images you loaded. 148 | 149 | {1 Details} 150 | 151 | {1 Pulling this together} 152 | 153 | {2 Pixel Functional example} 154 | 155 | Here is a simple example of a pixel functional effect, that draws a plasma effect on the screen. 156 | 157 | {[ 158 | open Claudius 159 | 160 | let tick t s _p _i = 161 | let palsize = Palette.size (Screen.palette s) in 162 | 163 | Framebuffer.init (Screen.dimensions s) (fun x y -> 164 | let ft = (Float.of_int t) /. 10. 165 | and fx = (Float.of_int x) /. 140. 166 | and fy = (Float.of_int y) /. 140. in 167 | let z = 10. +. (sin (ft /. 1000.) *. 5.) 168 | and d = 10. +. (cos (ft /. 1000.) *. 5.) in 169 | let fc = (sin (sin ((fx +. ft) /. z)) +. sin (sin ((fy +. ft) /. d))) *. Float.of_int(palsize / 2) in 170 | let rc = ((int_of_float fc)) mod palsize in 171 | if rc >= 0 then rc else (rc + palsize) 172 | ) 173 | 174 | let () = 175 | Palette.generate_plasma_palette 1024 176 | |> Screen.create 640 480 1 177 | |> Base.run "Plasma effect" None tick 178 | ]} 179 | -------------------------------------------------------------------------------- /test/test_mousesdl.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Claudius 3 | open Tsdl 4 | 5 | let setup scale = (Sdl.Event.create (), Mouse.create scale) 6 | 7 | let test_invalid_scale _ = 8 | assert_raises (Invalid_argument "Invalid scale") (fun () -> Mouse.create 0); 9 | assert_raises (Invalid_argument "Invalid scale") (fun () -> Mouse.create (-1)) 10 | 11 | let test_of_sdl_button _ = 12 | assert_equal Mouse.Left (Mousesdl.of_sdl_button 1); 13 | assert_equal Mouse.Middle (Mousesdl.of_sdl_button 2); 14 | assert_equal Mouse.Right (Mousesdl.of_sdl_button 3); 15 | assert_equal Mouse.Left (Mousesdl.of_sdl_button 0) 16 | 17 | let test_to_sdl_button _ = 18 | assert_equal 1 (Mousesdl.to_sdl_button Mouse.Left); 19 | assert_equal 2 (Mousesdl.to_sdl_button Mouse.Middle); 20 | assert_equal 3 (Mousesdl.to_sdl_button Mouse.Right) 21 | 22 | let test_handle_mouse_button_event _ = 23 | let event, mouse = setup 1 in 24 | (* Test button down *) 25 | Sdl.Event.set event Sdl.Event.mouse_button_button 1; 26 | Sdl.Event.set event Sdl.Event.mouse_button_x 100; 27 | Sdl.Event.set event Sdl.Event.mouse_button_y 200; 28 | Sdl.Event.set event Sdl.Event.mouse_button_state Sdl.pressed; 29 | let updated_mouse, _ = Mousesdl.handle_mouse_button_event event mouse in 30 | assert_equal (100, 200) (Mouse.get_position updated_mouse); 31 | assert_equal true (Mouse.is_button_pressed updated_mouse Mouse.Left); 32 | (* Test button up *) 33 | Sdl.Event.set event Sdl.Event.mouse_button_state Sdl.released; 34 | let updated_mouse2, _ = 35 | Mousesdl.handle_mouse_button_event event updated_mouse 36 | in 37 | assert_equal false (Mouse.is_button_pressed updated_mouse2 Mouse.Left) 38 | 39 | let test_handle_mouse_motion_event _ = 40 | let event, mouse = setup 2 in 41 | 42 | Sdl.Event.set event Sdl.Event.mouse_motion_x 150; 43 | Sdl.Event.set event Sdl.Event.mouse_motion_y 250; 44 | let updated_mouse, _ = Mousesdl.handle_mouse_motion_event event mouse in 45 | (* For scale 2, (150,250) becomes (75,125) *) 46 | assert_equal (75, 125) (Mouse.get_position updated_mouse) 47 | 48 | let test_handle_mouse_wheel_event _ = 49 | let event, mouse = setup 1 in 50 | 51 | Sdl.Event.set event Sdl.Event.mouse_wheel_y 1; 52 | (* Scroll up *) 53 | let _updated_mouse, events = Mousesdl.handle_mouse_wheel_event event mouse in 54 | match events with 55 | | [ Event.MouseWheel 1 ] -> () 56 | | _ -> failwith "Expected Wheel event with positive value" 57 | 58 | (* Split test_handle_event into three separate tests *) 59 | let test_handle_event_button _ = 60 | let event, mouse = setup 1 in 61 | 62 | Sdl.Event.set event Sdl.Event.mouse_button_button 1; 63 | Sdl.Event.set event Sdl.Event.mouse_button_x 100; 64 | Sdl.Event.set event Sdl.Event.mouse_button_y 200; 65 | Sdl.Event.set event Sdl.Event.mouse_button_state Sdl.pressed; 66 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.mouse_button_down; 67 | let updated_mouse, _ = Mousesdl.handle_event event mouse in 68 | assert_equal (100, 200) (Mouse.get_position updated_mouse); 69 | assert_equal true (Mouse.is_button_pressed updated_mouse Mouse.Left) 70 | 71 | let test_handle_event_motion _ = 72 | let event, mouse = setup 1 in 73 | 74 | Sdl.Event.set event Sdl.Event.mouse_motion_x 150; 75 | Sdl.Event.set event Sdl.Event.mouse_motion_y 250; 76 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.mouse_motion; 77 | let updated_mouse, _ = Mousesdl.handle_event event mouse in 78 | assert_equal (150, 250) (Mouse.get_position updated_mouse) 79 | 80 | let test_handle_event_wheel _ = 81 | let event, mouse = setup 1 in 82 | 83 | Sdl.Event.set event Sdl.Event.mouse_wheel_y 1; 84 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.mouse_wheel; 85 | let _updated_mouse, events = Mousesdl.handle_event event mouse in 86 | match events with 87 | | [ Event.MouseWheel 1 ] -> () 88 | | _ -> failwith "Expected Wheel event with positive value" 89 | 90 | let test_drag_for_all_buttons _ = 91 | let event, mouse = setup 1 in 92 | let buttons = [ Mouse.Left; Mouse.Middle; Mouse.Right ] in 93 | 94 | List.iter 95 | (fun button -> 96 | (* Press button *) 97 | Sdl.Event.set event Sdl.Event.mouse_button_button 98 | (Mousesdl.to_sdl_button button); 99 | Sdl.Event.set event Sdl.Event.mouse_button_x 10; 100 | Sdl.Event.set event Sdl.Event.mouse_button_y 20; 101 | Sdl.Event.set event Sdl.Event.mouse_button_state Sdl.pressed; 102 | let mouse_after_press, _ = 103 | Mousesdl.handle_mouse_button_event event mouse 104 | in 105 | (* Drag motion *) 106 | Sdl.Event.set event Sdl.Event.mouse_motion_x 30; 107 | Sdl.Event.set event Sdl.Event.mouse_motion_y 40; 108 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.mouse_motion; 109 | let _mouse_after_drag, events = 110 | Mousesdl.handle_event event mouse_after_press 111 | in 112 | (* Assert Drag exists *) 113 | assert_bool 114 | (Printf.sprintf "Expected Drag event for %s button" 115 | (match button with 116 | | Mouse.Left -> "Left" 117 | | Mouse.Middle -> "Middle" 118 | | Mouse.Right -> "Right")) 119 | (List.exists 120 | (function 121 | | Event.MouseDrag (b, (30, 40)) when b = button -> true 122 | | _ -> false) 123 | events); 124 | 125 | (* Assert Motion is not present *) 126 | assert_bool "Should not contain Motion event during drag" 127 | (not 128 | (List.exists 129 | (function Event.MouseMotion _ -> true | _ -> false) 130 | events))) 131 | buttons 132 | 133 | let test_motion_after_drag_release _ = 134 | let buttons = [ Mouse.Left; Mouse.Middle; Mouse.Right ] in 135 | List.iter 136 | (fun button -> 137 | let event, mouse = setup 1 in 138 | (* Press current button *) 139 | Sdl.Event.set event Sdl.Event.mouse_button_button 140 | (Mousesdl.to_sdl_button button); 141 | Sdl.Event.set event Sdl.Event.mouse_button_state Sdl.pressed; 142 | let mouse_after_press, _ = 143 | Mousesdl.handle_mouse_button_event event mouse 144 | in 145 | (* Simulate a motion event to produce a Drag event *) 146 | Sdl.Event.set event Sdl.Event.mouse_motion_x 30; 147 | Sdl.Event.set event Sdl.Event.mouse_motion_y 40; 148 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.mouse_motion; 149 | let mouse_after_drag, _ = Mousesdl.handle_event event mouse_after_press in 150 | (* Release the button *) 151 | Sdl.Event.set event Sdl.Event.mouse_button_state Sdl.released; 152 | let mouse_after_release, _ = 153 | Mousesdl.handle_mouse_button_event event mouse_after_drag 154 | in 155 | (* Simulate another motion event → should be Motion, not Drag *) 156 | Sdl.Event.set event Sdl.Event.mouse_motion_x 50; 157 | Sdl.Event.set event Sdl.Event.mouse_motion_y 60; 158 | let _mouse_after_motion, events = 159 | Mousesdl.handle_event event mouse_after_release 160 | in 161 | assert_bool 162 | (Printf.sprintf "Expected Motion event for %s button after release" 163 | (match button with 164 | | Mouse.Left -> "Left" 165 | | Mouse.Middle -> "Middle" 166 | | Mouse.Right -> "Right")) 167 | (List.exists 168 | (function Event.MouseMotion (50, 60) -> true | _ -> false) 169 | events); 170 | 171 | assert_bool 172 | (Printf.sprintf 173 | "Should not contain Drag event for %s button after release" 174 | (match button with 175 | | Mouse.Left -> "Left" 176 | | Mouse.Middle -> "Middle" 177 | | Mouse.Right -> "Right")) 178 | (not 179 | (List.exists 180 | (function Event.MouseDrag _ -> true | _ -> false) 181 | events))) 182 | buttons 183 | 184 | let test_multiple_drag_events _ = 185 | let event = Sdl.Event.create () in 186 | let event2 = Sdl.Event.create () in 187 | let mouse = Mouse.create 1 in 188 | 189 | (* Press Left button *) 190 | Sdl.Event.set event Sdl.Event.mouse_button_button 191 | (Mousesdl.to_sdl_button Mouse.Left); 192 | Sdl.Event.set event Sdl.Event.mouse_button_x 10; 193 | Sdl.Event.set event Sdl.Event.mouse_button_y 20; 194 | Sdl.Event.set event Sdl.Event.mouse_button_state Sdl.pressed; 195 | let mouse_after_left, _ = Mousesdl.handle_mouse_button_event event mouse in 196 | (* Press Middle button using a second event *) 197 | Sdl.Event.set event2 Sdl.Event.mouse_button_button 198 | (Mousesdl.to_sdl_button Mouse.Middle); 199 | Sdl.Event.set event2 Sdl.Event.mouse_button_x 10; 200 | Sdl.Event.set event2 Sdl.Event.mouse_button_y 20; 201 | Sdl.Event.set event2 Sdl.Event.mouse_button_state Sdl.pressed; 202 | let mouse_after_middle, _ = 203 | Mousesdl.handle_mouse_button_event event2 mouse_after_left 204 | in 205 | (* Assert both buttons are pressed *) 206 | assert_bool "Expected Left button to be pressed" 207 | (Mouse.is_button_pressed mouse_after_middle Mouse.Left); 208 | assert_bool "Expected Middle button to be pressed" 209 | (Mouse.is_button_pressed mouse_after_middle Mouse.Middle); 210 | (* Simulate a drag motion *) 211 | Sdl.Event.set event Sdl.Event.mouse_motion_x 30; 212 | Sdl.Event.set event Sdl.Event.mouse_motion_y 40; 213 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.mouse_motion; 214 | let _mouse_after_drag, events = 215 | Mousesdl.handle_mouse_motion_event event mouse_after_middle 216 | in 217 | (* Check drag events for both Left and Middle buttons *) 218 | assert_bool "Expected Drag event for Left button" 219 | (List.exists 220 | (function Event.MouseDrag (Mouse.Left, (30, 40)) -> true | _ -> false) 221 | events); 222 | assert_bool "Expected Drag event for Middle button" 223 | (List.exists 224 | (function 225 | | Event.MouseDrag (Mouse.Middle, (30, 40)) -> true | _ -> false) 226 | events) 227 | 228 | let suite = 229 | "Mousesdl" 230 | >::: [ 231 | "test_invalid_scale" >:: test_invalid_scale; 232 | "test_of_sdl_button" >:: test_of_sdl_button; 233 | "test_to_sdl_button" >:: test_to_sdl_button; 234 | "test_handle_mouse_button_event" >:: test_handle_mouse_button_event; 235 | "test_handle_mouse_motion_event" >:: test_handle_mouse_motion_event; 236 | "test_handle_mouse_wheel_event" >:: test_handle_mouse_wheel_event; 237 | "test_handle_event_button" >:: test_handle_event_button; 238 | "test_handle_event_motion" >:: test_handle_event_motion; 239 | "test_handle_event_wheel" >:: test_handle_event_wheel; 240 | "test_drag_for_all_buttons" >:: test_drag_for_all_buttons; 241 | "test_motion_after_drag_release" >:: test_motion_after_drag_release; 242 | "test_multiple_drag_events" >:: test_multiple_drag_events; 243 | ] 244 | 245 | let () = run_test_tt_main suite 246 | -------------------------------------------------------------------------------- /src/palette.ml: -------------------------------------------------------------------------------- 1 | type t = { colors : int32 array; distinctive_pair : int * int } 2 | 3 | let delta_e (luv1 : Hsluv.luv) (luv2 : Hsluv.luv) = 4 | sqrt 5 | (((luv1.l -. luv2.l) ** 2.0) 6 | +. ((luv1.u -. luv2.u) ** 2.0) 7 | +. ((luv1.v -. luv2.v) ** 2.0)) 8 | 9 | let find_most_distant_pair colors = 10 | (* To find the most visually distinct colours we project the 11 | colours from RGB into the LUV colour space: 12 | 13 | https://en.wikipedia.org/wiki/CIELUV 14 | 15 | Once in this colour space you can calculate the "delta E", the 16 | geometric distance between the colours, and that distance 17 | corresponds to visual distance. 18 | *) 19 | let luv_colors = 20 | Array.map 21 | (fun col -> 22 | let r = float_of_int (col / 65536 land 0xFF) 23 | and g = float_of_int (col / 256 land 0xFF) 24 | and b = float_of_int (col land 0xFF) in 25 | let rgb : Hsluv.rgb = { r; g; b } in 26 | Hsluv.conv_rgb_xyz rgb |> Hsluv.conv_xyz_luv) 27 | colors 28 | in 29 | let max_dist = ref 0. in 30 | let res = ref (0, 0) in 31 | let count = Array.length luv_colors in 32 | for outer = 0 to count - 1 do 33 | for inner = 0 to count - 1 do 34 | let luv_1 = luv_colors.(inner) and luv_2 = luv_colors.(outer) in 35 | let distance = delta_e luv_1 luv_2 in 36 | if distance > !max_dist then ( 37 | max_dist := distance; 38 | res := (inner, outer)) 39 | done 40 | done; 41 | 42 | (* In order to put some consistency on things, list the colours 43 | based on the most dark colour first. *) 44 | let index1, index2 = !res in 45 | let luv1 = luv_colors.(index1) and luv2 = luv_colors.(index2) in 46 | if luv1.l > luv2.l then (index2, index1) else (index1, index2) 47 | 48 | let v colors = 49 | if Array.length colors == 0 then 50 | raise (Invalid_argument "Palette size must not be zero or negative"); 51 | let distinctive_pair = find_most_distant_pair colors in 52 | let colors = Array.map Int32.of_int colors in 53 | { colors; distinctive_pair } 54 | 55 | let generate_mono_palette (size : int) : t = 56 | if size <= 0 then 57 | raise (Invalid_argument "Palette size must not be zero or negative"); 58 | let colors = 59 | Array.init size (fun (index : int) : int -> 60 | let fi = float_of_int index and fsize = float_of_int size in 61 | let ch = fi /. fsize *. 255.0 in 62 | (int_of_float ch * 65536) + (int_of_float ch * 256) + int_of_float ch) 63 | in 64 | v colors 65 | 66 | let generate_plasma_palette (size : int) : t = 67 | if size <= 0 then 68 | raise (Invalid_argument "Palette size must not be zero or negative"); 69 | let colors = 70 | Array.init size (fun (index : int) : int -> 71 | let fi = float_of_int index and fsize = float_of_int size in 72 | let fred = (cos (fi *. (2.0 *. Float.pi /. fsize)) *. 127.0) +. 128.0 in 73 | let fgreen = 74 | (cos ((fi +. (fsize /. 3.0)) *. (2.0 *. Float.pi /. fsize)) *. 127.0) 75 | +. 128.0 76 | in 77 | let fblue = 78 | cos ((fi +. (fsize *. 2.0 /. 3.0)) *. (2.0 *. Float.pi /. fsize)) 79 | *. 127.0 80 | +. 128.0 81 | in 82 | (int_of_float fred * 65536) 83 | + (int_of_float fgreen * 256) 84 | + int_of_float fblue) 85 | in 86 | v colors 87 | 88 | let generate_linear_palette (color1 : int) (color2 : int) (size : int) : t = 89 | if size <= 0 then 90 | raise (Invalid_argument "Palette size must not be zero negative"); 91 | let red1 = color1 / 65536 land 0xFF in 92 | let green1 = color1 / 256 land 0xFF in 93 | let blue1 = color1 land 0xFF in 94 | 95 | let red2 = color2 / 65536 land 0xFF in 96 | let green2 = color2 / 256 land 0xFF in 97 | let blue2 = color2 land 0xFF in 98 | let colors = 99 | Array.init size (fun index -> 100 | let ratio = float_of_int index /. float_of_int (size - 1) in 101 | 102 | let red = int_of_float (float red1 +. (float (red2 - red1) *. ratio)) in 103 | let green = 104 | int_of_float (float green1 +. (float (green2 - green1) *. ratio)) 105 | in 106 | let blue = 107 | int_of_float (float blue1 +. (float (blue2 - blue1) *. ratio)) 108 | in 109 | 110 | red * 65536 lor (green * 256) lor blue) 111 | in 112 | v colors 113 | 114 | let generate_vapourwave_palette (size : int) : t = 115 | let pastel_purple = 0x7f3b8f in 116 | (* Pastel purple *) 117 | let pastel_cyan = 0x80cfcf in 118 | (* Pastel cyan *) 119 | generate_linear_palette pastel_purple pastel_cyan size 120 | 121 | let generate_microsoft_vga_palette () : t = 122 | (* This palette is by SZIEBERTH Ádám, found on Lospec: 123 | https://lospec.com/palette-list/microsoft-vga 124 | Renamed here to match the original name: "MICROSOFT VGA Palette". *) 125 | let colors = 126 | Array.of_list 127 | [ 128 | 0x000000; 129 | 0x800000; 130 | 0x008000; 131 | 0x808000; 132 | 0x000080; 133 | 0x800080; 134 | 0x008080; 135 | 0xc0c0c0; 136 | 0x808080; 137 | 0xff0000; 138 | 0x00ff00; 139 | 0xffff00; 140 | 0x0000ff; 141 | 0xff00ff; 142 | 0x00ffff; 143 | 0xffffff; 144 | ] 145 | in 146 | v colors 147 | 148 | let generate_classic_vga_palette () : t = 149 | let colors = 150 | Array.of_list 151 | [ 152 | 0x000000; 153 | 0x0000AA; 154 | 0x00AA00; 155 | 0x00AAAA; 156 | 0xAA0000; 157 | 0xAA00AA; 158 | 0xAA5500; 159 | 0xAAAAAA; 160 | 0x555555; 161 | 0x5555FF; 162 | 0x55FF55; 163 | 0x55FFFF; 164 | 0xFF5555; 165 | 0xFF55FF; 166 | 0xFFFF55; 167 | 0xFFFFFF; 168 | ] 169 | in 170 | v colors 171 | 172 | let generate_sweetie16_palette () : t = 173 | (* This palette is by GrafxKid, found on Lospec: 174 | https://lospec.com/palette-list/sweetie-16 175 | Renamed here to match the original name: "Sweetie 16". *) 176 | let colors = 177 | Array.of_list 178 | [ 179 | 0x1a1c2c; 180 | 0x5d275d; 181 | 0xb13e53; 182 | 0xef7d57; 183 | 0xffcd75; 184 | 0xa7f070; 185 | 0x38b764; 186 | 0x257179; 187 | 0x29366f; 188 | 0x3b5dc9; 189 | 0x41a6f6; 190 | 0x73eff7; 191 | 0xf4f4f4; 192 | 0x94b0c2; 193 | 0x566c86; 194 | 0x333c57; 195 | ] 196 | in 197 | v colors 198 | 199 | let generate_mac_palette () : t = 200 | let colors = 201 | Array.of_list 202 | [ 203 | 0xffffff; 204 | 0xfcf400; 205 | 0xff6400; 206 | 0xdd0202; 207 | 0xf00285; 208 | 0x4600a5; 209 | 0x0000d5; 210 | 0x00aee9; 211 | 0x1ab90c; 212 | 0x006407; 213 | 0x572800; 214 | 0x917135; 215 | 0xc1c1c1; 216 | 0x818181; 217 | 0x3e3e3e; 218 | 0x000000; 219 | ] 220 | in 221 | v colors 222 | 223 | let string_to_chunks (x : string) (size : int) : string list = 224 | let rec loop sofar remainder = 225 | let length_left = String.length remainder in 226 | if length_left >= size then 227 | loop 228 | (String.sub remainder 0 size :: sofar) 229 | (String.sub remainder size (length_left - size)) 230 | else if length_left == 0 then sofar 231 | else 232 | raise 233 | (Invalid_argument "String size not a multiple of 6 chars per colour") 234 | in 235 | List.rev (loop [] x) 236 | 237 | let chunks_to_colors (raw : string list) : t = 238 | let colors = 239 | Array.map 240 | (fun (colorstr : string) : int -> int_of_string ("0x" ^ colorstr)) 241 | (Array.of_list raw) 242 | in 243 | v colors 244 | 245 | let load_tic80_palette (raw : string) : t = 246 | let parts = String.split_on_char ':' raw in 247 | let strchunks = string_to_chunks (List.nth parts 1) 6 in 248 | if List.length strchunks > 0 then chunks_to_colors strchunks 249 | else raise (Invalid_argument "Palette size must not be zero or negative") 250 | 251 | let of_list (rgb_list : int list) : t = 252 | if List.length rgb_list > 0 then v (Array.of_list rgb_list) 253 | else raise (Invalid_argument "Palette size must not be zero or negative") 254 | 255 | let load_lospec_palette (s : string) : t = 256 | let lines = String.split_on_char '\n' s in 257 | let parse_hex line = 258 | let line = String.trim line in 259 | let hex = 260 | match (String.length line, line) with 261 | | 6, l -> l 262 | | 7, l when l.[0] = '#' -> String.sub l 1 6 263 | | _ -> 264 | raise 265 | (Invalid_argument 266 | "Palette size must not be zero or invalid HEX values") 267 | in 268 | match int_of_string_opt ("0x" ^ hex) with 269 | | Some n -> n 270 | | None -> 271 | raise (Invalid_argument ("Failed to parse hex color: \"" ^ line ^ "\"")) 272 | in 273 | let color_list = List.map parse_hex lines in 274 | if color_list = [] then 275 | raise 276 | (Invalid_argument "Palette size must not be zero or invalid HEX values"); 277 | of_list color_list 278 | 279 | let size (palette : t) : int = Array.length palette.colors 280 | 281 | let index_to_rgb (palette : t) (index : int) : int32 = 282 | let palsize = Array.length palette.colors in 283 | let index = index mod palsize in 284 | palette.colors.(if index >= 0 then index else index + palsize) 285 | 286 | let to_list (palette : t) : int list = 287 | List.map Int32.to_int (Array.to_list palette.colors) 288 | 289 | let circle_palette (pal : t) (offset : int) : t = 290 | let size = Array.length pal.colors in 291 | let colors = 292 | Array.init size (fun index -> 293 | (* Calculate new index ensuring it is positive *) 294 | let raw = index + offset in 295 | let new_index = 296 | if raw < 0 then (raw mod size) + size else raw mod size 297 | in 298 | pal.colors.(new_index)) 299 | in 300 | { pal with colors } 301 | 302 | let updated_entry (pal : t) (index : int) (new_color : int * int * int) : t = 303 | let palsize = Array.length pal.colors in 304 | if index < 0 || index >= palsize then 305 | raise (Invalid_argument "Invalid palette index") 306 | else 307 | let r, g, b = new_color in 308 | let new_int = r * 65536 lor (g * 256) lor b in 309 | let new_pal = Array.init palsize (fun i -> Int32.to_int pal.colors.(i)) in 310 | new_pal.(index) <- new_int; 311 | v new_pal 312 | 313 | let concat (palettes : t list) : t = 314 | let total_len = 315 | List.fold_left (fun acc pal -> acc + Array.length pal.colors) 0 palettes 316 | in 317 | let result = Array.make total_len 0 in 318 | let _ = 319 | List.fold_left 320 | (fun offset pal -> 321 | Array.iteri 322 | (fun i v -> result.(offset + i) <- Int32.to_int v) 323 | pal.colors; 324 | offset + Array.length pal.colors) 325 | 0 palettes 326 | in 327 | v result 328 | 329 | let distinctive_pair t = t.distinctive_pair 330 | -------------------------------------------------------------------------------- /src/base.ml: -------------------------------------------------------------------------------- 1 | (* base.ml *) 2 | open Tsdl 3 | 4 | module KeyCodeSet = Set.Make (struct 5 | type t = Key.t 6 | 7 | let compare = compare 8 | end) 9 | 10 | module PlatformKey = Keysdl 11 | module PlatformMouse = Mousesdl 12 | 13 | type t = { 14 | show_stats : bool; 15 | recording_state : Animation.recording_state_t option; 16 | status : Stats.t; 17 | } 18 | 19 | type input_state = { 20 | keys : KeyCodeSet.t; 21 | events : Event.t list; 22 | (* Accumulated unified input events for the current frame. *) 23 | mouse : Mouse.t; 24 | } 25 | 26 | type boot_func = Screen.t -> Framebuffer.t 27 | 28 | type tick_func = 29 | int -> Screen.t -> Framebuffer.t -> input_state -> Framebuffer.t 30 | 31 | type functional_tick_func = int -> Screen.t -> input_state -> Primitives.t list 32 | 33 | (* ----- *) 34 | 35 | let ( >>= ) = Result.bind 36 | let ( >|= ) v f = Result.map f v 37 | 38 | let sdl_init width height title make_fullscreen = 39 | Sdl.init Sdl.Init.(video + events) >>= fun () -> 40 | Sdl.create_window ~w:width ~h:height title 41 | Sdl.Window.(if make_fullscreen then fullscreen else windowed) 42 | >>= fun w -> 43 | Sdl.create_renderer ~flags:Sdl.Renderer.(accelerated + presentvsync) w 44 | >>= fun r -> 45 | Sdl.show_cursor (not make_fullscreen) >|= fun _ -> (w, r) 46 | 47 | let framebuffer_to_bigarray s buffer bitmap = 48 | let palette = Screen.palette s in 49 | Array.iteri 50 | (fun y row -> 51 | Array.iteri 52 | (fun x pixel -> 53 | bitmap.{x + (y * Array.length row)} <- 54 | Palette.index_to_rgb palette pixel) 55 | row) 56 | (Framebuffer.to_array buffer) 57 | 58 | let render_texture r texture s bitmap = 59 | let width, height = Screen.dimensions s in 60 | let scale = Screen.scale s in 61 | Sdl.render_clear r >>= fun () -> 62 | Sdl.update_texture texture None bitmap width >>= fun () -> 63 | let ow, oh = Result.get_ok (Sdl.get_renderer_output_size r) in 64 | let dst = 65 | Sdl.Rect.create 66 | ~x:((ow - (width * scale)) / 2) 67 | ~y:((oh - (height * scale)) / 2) 68 | ~w:(width * scale) ~h:(height * scale) 69 | in 70 | Sdl.render_copy ~dst r texture >|= fun () -> Sdl.render_present r 71 | 72 | (* Poll SDL events and build the unified event queue. 73 | Mouse events are handled by PlatformMouse.handle_event, which returns 74 | an updated mouse state along with a list of unified events. *) 75 | let rec poll_all_events keys mouse acc = 76 | let e = Sdl.Event.create () in 77 | match Sdl.poll_event (Some e) with 78 | | true -> ( 79 | match Sdl.Event.(enum (get e typ)) with 80 | | `Quit -> (true, keys, mouse, List.rev acc) 81 | | `Key_down -> 82 | let key = 83 | PlatformKey.of_backend_keycode Sdl.Event.(get e keyboard_keycode) 84 | in 85 | poll_all_events (KeyCodeSet.add key keys) mouse 86 | (Event.KeyDown key :: acc) 87 | | `Key_up -> 88 | let key = 89 | PlatformKey.of_backend_keycode Sdl.Event.(get e keyboard_keycode) 90 | in 91 | poll_all_events 92 | (KeyCodeSet.remove key keys) 93 | mouse (Event.KeyUp key :: acc) 94 | | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel -> 95 | let new_mouse, mouse_events = PlatformMouse.handle_event e mouse in 96 | poll_all_events keys new_mouse (List.rev_append mouse_events acc) 97 | | `Drop_file -> 98 | let filepath = Sdl.Event.drop_file_file e in 99 | Sdl.Event.drop_file_free e; 100 | let updated_events = 101 | match filepath with 102 | | None -> acc 103 | | Some filepath -> Event.DropFile filepath :: acc 104 | in 105 | poll_all_events keys mouse updated_events 106 | | _ -> poll_all_events keys mouse acc) 107 | | false -> (false, keys, mouse, List.rev acc) 108 | 109 | let run title boot tick s = 110 | let make_full = 111 | Array.to_list Sys.argv |> List.exists (fun a -> String.compare a "-f" = 0) 112 | in 113 | let s = 114 | match make_full with 115 | | false -> s 116 | | true -> 117 | let w, h = Screen.dimensions s in 118 | let p = Screen.palette s in 119 | let font = Screen.font s in 120 | Screen.create ~font w h 1 p 121 | in 122 | 123 | let width, height = Screen.dimensions s and scale = Screen.scale s in 124 | 125 | match sdl_init (width * scale) (height * scale) title make_full with 126 | | Error (`Msg e) -> 127 | Sdl.log "Init error: %s" e; 128 | exit 1 129 | | Ok (w, r) -> ( 130 | match 131 | Sdl.create_texture r Sdl.Pixel.format_rgb888 ~w:width ~h:height 132 | Sdl.Texture.access_streaming 133 | with 134 | | Error (`Msg e) -> 135 | Sdl.log "Texture error: %s" e; 136 | exit 1 137 | | Ok texture -> 138 | let bitmap = 139 | Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout 140 | (width * height) 141 | in 142 | let initial_buffer = 143 | match boot with 144 | | None -> Framebuffer.init (width, height) (fun _ _ -> 0) 145 | | Some bfunc -> bfunc s 146 | in 147 | let initial_input = 148 | { keys = KeyCodeSet.empty; events = []; mouse = Mouse.create scale } 149 | in 150 | 151 | let initial_internal_state = 152 | { 153 | show_stats = false; 154 | recording_state = None; 155 | status = Stats.create (); 156 | } 157 | in 158 | 159 | let rec loop internal_state t prev_buffer input last_t = 160 | let now = Sdl.get_ticks () in 161 | let diff = 162 | Int32.sub (Int32.of_int (1000 / 60)) (Int32.sub now last_t) 163 | in 164 | if Int32.compare diff Int32.zero > 0 then Sdl.delay diff; 165 | let exit, new_keys, new_mouse, unified_events = 166 | poll_all_events input.keys input.mouse [] 167 | in 168 | let current_input = 169 | { keys = new_keys; events = unified_events; mouse = new_mouse } 170 | in 171 | if exit then () 172 | else 173 | let internal_state = 174 | { 175 | internal_state with 176 | status = 177 | Stats.update ~now:(Unix.gettimeofday ()) ~tick:t 178 | internal_state.status; 179 | } 180 | in 181 | 182 | let internal_state = 183 | List.fold_left 184 | (fun acc ev -> 185 | match ev with 186 | | Event.KeyUp Key.F1 -> 187 | { 188 | internal_state with 189 | show_stats = not internal_state.show_stats; 190 | } 191 | | Event.KeyUp Key.F2 -> 192 | let log_message = 193 | match Screenshot.save_screenshot s prev_buffer with 194 | | Result.Ok path -> 195 | Printf.sprintf "Screenshot saved as %s" path 196 | | Result.Error msg -> msg 197 | in 198 | { 199 | internal_state with 200 | status = Stats.log internal_state.status log_message; 201 | } 202 | | Event.KeyUp Key.F3 -> ( 203 | Printf.printf 204 | "Enter number of frames to record (default 500): %!"; 205 | try 206 | let line = read_line () in 207 | let n = 208 | if String.trim line = "" then 209 | Animation.max_frames_default 210 | else int_of_string line 211 | in 212 | match Animation.start_recording n with 213 | | Result.Ok recording_state -> 214 | { 215 | internal_state with 216 | recording_state = Some recording_state; 217 | } 218 | | Result.Error msg -> 219 | { 220 | internal_state with 221 | status = Stats.log internal_state.status msg; 222 | } 223 | with Failure _ -> 224 | { 225 | internal_state with 226 | status = 227 | Stats.log internal_state.status 228 | "Invalid input. Recording not started."; 229 | }) 230 | | _ -> acc) 231 | internal_state input.events 232 | in 233 | 234 | let updated_buffer = tick t s prev_buffer current_input in 235 | 236 | let stats_buffer = 237 | Stats.render internal_state.status internal_state.show_stats t s 238 | updated_buffer 239 | in 240 | let display_buffer = 241 | match stats_buffer with None -> updated_buffer | Some b -> b 242 | in 243 | 244 | let internal_state = 245 | { 246 | internal_state with 247 | recording_state = 248 | Option.bind internal_state.recording_state (fun st -> 249 | Animation.record_frame st s display_buffer); 250 | } 251 | in 252 | 253 | if 254 | display_buffer != prev_buffer 255 | || Framebuffer.is_dirty display_buffer 256 | || Screen.is_dirty s 257 | then ( 258 | framebuffer_to_bigarray s display_buffer bitmap; 259 | (match render_texture r texture s bitmap with 260 | | Error (`Msg e) -> Sdl.log "Render error: %s" e 261 | | Ok () -> ()); 262 | Framebuffer.clear_dirty updated_buffer; 263 | Screen.clear_dirty s); 264 | (match render_texture r texture s bitmap with 265 | | Error (`Msg e) -> Sdl.log "Render error: %s" e 266 | | Ok () -> ()); 267 | loop internal_state (t + 1) updated_buffer current_input now 268 | in 269 | loop initial_internal_state 0 initial_buffer initial_input Int32.zero; 270 | Sdl.destroy_texture texture; 271 | Sdl.destroy_renderer r; 272 | Sdl.destroy_window w; 273 | Sdl.quit ()) 274 | 275 | let run_functional title tick_f s = 276 | let wrap_tick t screen prev_framebuffer input = 277 | let primitives = tick_f t screen input in 278 | if primitives = [] then prev_framebuffer 279 | else 280 | let width, height = Screen.dimensions screen in 281 | let new_framebuffer = Framebuffer.init (width, height) (fun _ _ -> 0) in 282 | Framebuffer.render new_framebuffer primitives; 283 | new_framebuffer 284 | in 285 | run title None wrap_tick s 286 | 287 | (* --- Utility functions for input handling --- *) 288 | 289 | let is_key_pressed input key = KeyCodeSet.mem key input.keys 290 | 291 | let was_key_just_pressed input key = 292 | List.exists 293 | (function Event.KeyDown k when k = key -> true | _ -> false) 294 | input.events 295 | 296 | let was_key_just_released input key = 297 | List.exists 298 | (function Event.KeyUp k when k = key -> true | _ -> false) 299 | input.events 300 | -------------------------------------------------------------------------------- /test/test_events.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Claudius 3 | open Tsdl 4 | 5 | let test_empty_event _ = 6 | (* create the event for test *) 7 | let event = Sdl.Event.create () in 8 | let success = Sdl.push_event event in 9 | match success with 10 | | Error (`Msg e) -> 11 | failwith 12 | (Printf.sprintf "failed to push event: %s %s" e (Sdl.get_error ())) 13 | | Ok suc -> 14 | assert_equal true suc; 15 | 16 | (* Set up other bits *) 17 | let mouse = Mouse.create 1 and keys = Base.KeyCodeSet.empty in 18 | 19 | (* call the function we're testing *) 20 | let quit, updated_keys, updated_mouse, events = 21 | Base.poll_all_events keys mouse [] 22 | in 23 | 24 | (* check the results *) 25 | assert_equal ~printer:string_of_bool ~msg:"Quit result" false quit; 26 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 27 | (Mouse.is_button_pressed updated_mouse Left); 28 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 29 | (Mouse.is_button_pressed updated_mouse Middle); 30 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 31 | (Mouse.is_button_pressed updated_mouse Right); 32 | assert_equal ~printer:string_of_int ~msg:"Events updated" 0 33 | (List.length events); 34 | assert_equal ~printer:string_of_int ~msg:"Key code set" 0 35 | (List.length (Base.KeyCodeSet.to_list updated_keys)) 36 | 37 | let test_key_down _ = 38 | (* create the event for test *) 39 | let event = Sdl.Event.create () in 40 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.key_down; 41 | Sdl.Event.set event Sdl.Event.keyboard_state Sdl.pressed; 42 | Sdl.Event.set event Sdl.Event.keyboard_keycode 43 | (Keysdl.to_backend_keycode Key.A); 44 | let success = Sdl.push_event event in 45 | match success with 46 | | Error (`Msg e) -> 47 | failwith 48 | (Printf.sprintf "failed to push event: %s %s" e (Sdl.get_error ())) 49 | | Ok suc -> ( 50 | assert_equal true suc; 51 | 52 | (* Set up other bits *) 53 | let mouse = Mouse.create 1 and keys = Base.KeyCodeSet.empty in 54 | 55 | (* call the function we're testing *) 56 | let quit, updated_keys, updated_mouse, events = 57 | Base.poll_all_events keys mouse [] 58 | in 59 | 60 | (* check the results *) 61 | assert_equal ~printer:string_of_bool ~msg:"Quit result" false quit; 62 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 63 | (Mouse.is_button_pressed updated_mouse Left); 64 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 65 | (Mouse.is_button_pressed updated_mouse Middle); 66 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 67 | (Mouse.is_button_pressed updated_mouse Right); 68 | 69 | let expected_key_code = Key.A in 70 | match events with 71 | | event :: [] -> ( 72 | match event with 73 | | Event.KeyDown k -> 74 | assert_equal 75 | ~printer:(fun k -> Int.to_string (Keysdl.to_backend_keycode k)) 76 | ~msg:"key code" expected_key_code k 77 | | _ -> ignore (assert_failure "Exected keydown")) 78 | | _ -> ( 79 | ignore (assert_failure "Expected event"); 80 | let keycodes = Base.KeyCodeSet.to_list updated_keys in 81 | match keycodes with 82 | | k :: [] -> 83 | assert_equal 84 | ~printer:(fun k -> Int.to_string (Keysdl.to_backend_keycode k)) 85 | ~msg:"key code" expected_key_code k 86 | | _ -> ignore (assert_failure "Exected single key"))) 87 | 88 | let test_key_up _ = 89 | (* create the event for test *) 90 | let event = Sdl.Event.create () in 91 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.key_up; 92 | Sdl.Event.set event Sdl.Event.keyboard_keycode 93 | (Keysdl.to_backend_keycode Key.A); 94 | let success = Sdl.push_event event in 95 | match success with 96 | | Error (`Msg e) -> 97 | failwith 98 | (Printf.sprintf "failed to push event: %s %s" e (Sdl.get_error ())) 99 | | Ok suc -> ( 100 | assert_equal true suc; 101 | 102 | (* Set up other bits *) 103 | let mouse = Mouse.create 1 104 | and keys = Base.KeyCodeSet.add Key.A Base.KeyCodeSet.empty in 105 | 106 | (* call the function we're testing *) 107 | let quit, updated_keys, updated_mouse, events = 108 | Base.poll_all_events keys mouse [] 109 | in 110 | 111 | (* check the results *) 112 | assert_equal ~printer:string_of_bool ~msg:"Quit result" false quit; 113 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 114 | (Mouse.is_button_pressed updated_mouse Left); 115 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 116 | (Mouse.is_button_pressed updated_mouse Middle); 117 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 118 | (Mouse.is_button_pressed updated_mouse Right); 119 | 120 | let expected_key_code = Key.A in 121 | match events with 122 | | event :: [] -> ( 123 | match event with 124 | | Event.KeyUp k -> 125 | assert_equal 126 | ~printer:(fun k -> Int.to_string (Keysdl.to_backend_keycode k)) 127 | ~msg:"key code" expected_key_code k 128 | | _ -> ignore (assert_failure "Exected key up")) 129 | | _ -> ( 130 | ignore (assert_failure "Expected event"); 131 | let keycodes = Base.KeyCodeSet.to_list updated_keys in 132 | match keycodes with 133 | | [] -> () 134 | | _ -> ignore (assert_failure "Exected no keys"))) 135 | 136 | let test_key_down_and_up _ = 137 | (* create the event for test *) 138 | let event = Sdl.Event.create () in 139 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.key_down; 140 | Sdl.Event.set event Sdl.Event.keyboard_state Sdl.pressed; 141 | Sdl.Event.set event Sdl.Event.keyboard_keycode 142 | (Keysdl.to_backend_keycode Key.A); 143 | let success = Sdl.push_event event in 144 | match success with 145 | | Error (`Msg e) -> 146 | failwith 147 | (Printf.sprintf "failed to push event: %s %s" e (Sdl.get_error ())) 148 | | Ok suc -> ( 149 | assert_equal true suc; 150 | let event = Sdl.Event.create () in 151 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.key_up; 152 | Sdl.Event.set event Sdl.Event.keyboard_keycode 153 | (Keysdl.to_backend_keycode Key.A); 154 | let success = Sdl.push_event event in 155 | match success with 156 | | Error (`Msg e) -> 157 | failwith 158 | (Printf.sprintf "failed to push event: %s %s" e (Sdl.get_error ())) 159 | | Ok suc -> ( 160 | assert_equal true suc; 161 | 162 | (* Set up other bits *) 163 | let mouse = Mouse.create 1 and keys = Base.KeyCodeSet.empty in 164 | 165 | (* call the function we're testing *) 166 | let quit, updated_keys, updated_mouse, events = 167 | Base.poll_all_events keys mouse [] 168 | in 169 | 170 | (* check the results *) 171 | assert_equal ~printer:string_of_bool ~msg:"Quit result" false quit; 172 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 173 | (Mouse.is_button_pressed updated_mouse Left); 174 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 175 | (Mouse.is_button_pressed updated_mouse Middle); 176 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 177 | (Mouse.is_button_pressed updated_mouse Right); 178 | 179 | let expected_key_code = Key.A in 180 | match events with 181 | | [ event1; event2 ] -> ( 182 | match event1 with 183 | | Event.KeyDown k -> 184 | assert_equal 185 | ~printer:(fun k -> 186 | Int.to_string (Keysdl.to_backend_keycode k)) 187 | ~msg:"key code" expected_key_code k 188 | | _ -> ( 189 | ignore (assert_failure "Exected key down"); 190 | match event2 with 191 | | Event.KeyUp k -> 192 | assert_equal 193 | ~printer:(fun k -> 194 | Int.to_string (Keysdl.to_backend_keycode k)) 195 | ~msg:"key code" expected_key_code k 196 | | _ -> ignore (assert_failure "Exected key up"))) 197 | | _ -> ( 198 | ignore (assert_failure "Expected event"); 199 | let keycodes = Base.KeyCodeSet.to_list updated_keys in 200 | match keycodes with 201 | | [] -> () 202 | | _ -> ignore (assert_failure "Exected no keys")))) 203 | 204 | let test_mixed_key_down_and_up _ = 205 | (* create the event for test *) 206 | let event = Sdl.Event.create () in 207 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.key_down; 208 | Sdl.Event.set event Sdl.Event.keyboard_state Sdl.pressed; 209 | Sdl.Event.set event Sdl.Event.keyboard_keycode 210 | (Keysdl.to_backend_keycode Key.B); 211 | let success = Sdl.push_event event in 212 | match success with 213 | | Error (`Msg e) -> 214 | failwith 215 | (Printf.sprintf "failed to push event: %s %s" e (Sdl.get_error ())) 216 | | Ok suc -> ( 217 | assert_equal true suc; 218 | let event = Sdl.Event.create () in 219 | Sdl.Event.set event Sdl.Event.typ Sdl.Event.key_up; 220 | Sdl.Event.set event Sdl.Event.keyboard_keycode 221 | (Keysdl.to_backend_keycode Key.A); 222 | let success = Sdl.push_event event in 223 | match success with 224 | | Error (`Msg e) -> 225 | failwith 226 | (Printf.sprintf "failed to push event: %s %s" e (Sdl.get_error ())) 227 | | Ok suc -> ( 228 | assert_equal true suc; 229 | 230 | (* Set up other bits *) 231 | let mouse = Mouse.create 1 232 | and keys = Base.KeyCodeSet.add Key.A Base.KeyCodeSet.empty in 233 | 234 | (* call the function we're testing *) 235 | let quit, updated_keys, updated_mouse, events = 236 | Base.poll_all_events keys mouse [] 237 | in 238 | 239 | (* check the results *) 240 | assert_equal ~printer:string_of_bool ~msg:"Quit result" false quit; 241 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 242 | (Mouse.is_button_pressed updated_mouse Left); 243 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 244 | (Mouse.is_button_pressed updated_mouse Middle); 245 | assert_equal ~printer:string_of_bool ~msg:"No mouse buttons" false 246 | (Mouse.is_button_pressed updated_mouse Right); 247 | 248 | match events with 249 | | [ event1; event2 ] -> ( 250 | match event1 with 251 | | Event.KeyDown k -> 252 | assert_equal 253 | ~printer:(fun k -> 254 | Int.to_string (Keysdl.to_backend_keycode k)) 255 | ~msg:"key code" Key.B k 256 | | _ -> ( 257 | ignore (assert_failure "Exected key down"); 258 | match event2 with 259 | | Event.KeyUp k -> 260 | assert_equal 261 | ~printer:(fun k -> 262 | Int.to_string (Keysdl.to_backend_keycode k)) 263 | ~msg:"key code" Key.A k 264 | | _ -> ignore (assert_failure "Exected key up"))) 265 | | _ -> ( 266 | ignore (assert_failure "Expected event"); 267 | let keycodes = Base.KeyCodeSet.to_list updated_keys in 268 | match keycodes with 269 | | k :: [] -> 270 | assert_equal 271 | ~printer:(fun k -> 272 | Int.to_string (Keysdl.to_backend_keycode k)) 273 | ~msg:"key code" Key.B k 274 | | _ -> ignore (assert_failure "Exected single key")))) 275 | 276 | let suite = 277 | "Events tests" 278 | >::: [ 279 | "Test empty event" >:: test_empty_event; 280 | "Test a key down event" >:: test_key_down; 281 | "Test a key up event" >:: test_key_up; 282 | "Test a key down and up event" >:: test_key_down_and_up; 283 | "Test a mix of key events" >:: test_mixed_key_down_and_up; 284 | ] 285 | 286 | let () = 287 | let success = Sdl.init Sdl.Init.(events) in 288 | match success with 289 | | Error (`Msg e) -> 290 | failwith (Printf.sprintf "failed to init SDL: %s %s" e (Sdl.get_error ())) 291 | | Ok _ -> 292 | (); 293 | run_test_tt_main suite 294 | -------------------------------------------------------------------------------- /test/test_palette.ml: -------------------------------------------------------------------------------- 1 | open Claudius 2 | open OUnit2 3 | 4 | let extreme_print (a, b) = Printf.sprintf "%d, %d" a b 5 | 6 | let test_basic_palette_of_ints _ = 7 | let cols = [ 0x000000; 0xFF0000; 0x00FF00; 0x0000FF; 0xFFFFFF ] in 8 | let pal = Palette.of_list cols in 9 | assert_equal ~msg:"Palette size" (List.length cols) (Palette.size pal); 10 | List.iteri 11 | (fun i c -> 12 | let v = Palette.index_to_rgb pal i in 13 | assert_equal ~msg:"Colour match" (Int32.of_int c) v) 14 | cols; 15 | let rev = Palette.to_list pal in 16 | assert_equal ~msg:"Back to ints" cols rev; 17 | let distinctive_pair = Palette.distinctive_pair pal in 18 | assert_equal ~msg:"Colour distinctive_pair" ~printer:extreme_print (3, 1) 19 | distinctive_pair 20 | 21 | let test_single_entry_palette _ = 22 | let cols = [ 0x000000 ] in 23 | let pal = Palette.of_list cols in 24 | assert_equal ~msg:"Palette size" (List.length cols) (Palette.size pal); 25 | List.iteri 26 | (fun i c -> 27 | let v = Palette.index_to_rgb pal i in 28 | assert_equal ~msg:"Colour match" (Int32.of_int c) v) 29 | cols; 30 | let rev = Palette.to_list pal in 31 | assert_equal ~msg:"Back to ints" cols rev; 32 | let distinctive_pair = Palette.distinctive_pair pal in 33 | assert_equal ~msg:"Colour distinctive_pair" ~printer:extreme_print (0, 0) 34 | distinctive_pair 35 | 36 | let test_zero_entry_palette _ = 37 | assert_raises (Invalid_argument "Palette size must not be zero or negative") 38 | (fun () -> Palette.of_list []) 39 | 40 | let test_generate_mac_palette_creation _ = 41 | let pal = Palette.generate_mac_palette () in 42 | assert_equal ~msg:"Palette size" 16 (Palette.size pal) 43 | 44 | let test_generate_sweetie16_palette _ = 45 | let pal = Palette.generate_sweetie16_palette () in 46 | assert_equal ~msg:"Palette size" 16 (Palette.size pal) 47 | 48 | let test_generate_linear_palette _ = 49 | let color1 = 0x7f3b8f in 50 | (* Pastel purple *) 51 | let color2 = 0x80cfcf in 52 | (* Pastel cyan *) 53 | let size = 16 in 54 | let pal = Palette.generate_linear_palette color1 color2 size in 55 | assert_equal ~msg:"Palette length" size (Palette.size pal); 56 | let first_color = Int32.to_int (Palette.index_to_rgb pal 0) in 57 | assert_equal ~msg:"First color should be color1" color1 first_color; 58 | let last_color = Int32.to_int (Palette.index_to_rgb pal (size - 1)) in 59 | assert_equal ~msg:"Last color should be color2" color2 last_color 60 | 61 | let test_generate_vapour_wave_creation _ = 62 | let size = 16 in 63 | let pal = Palette.generate_vapourwave_palette size in 64 | assert_equal ~msg:"Palette length" size (Palette.size pal); 65 | let pastel_purple = 0x7f3b8f in 66 | let pastel_cyan = 0x80cfcf in 67 | let first_color = Int32.to_int (Palette.index_to_rgb pal 0) in 68 | let last_color = Int32.to_int (Palette.index_to_rgb pal (size - 1)) in 69 | assert_equal ~msg:"First color should be pastel purple" pastel_purple 70 | first_color; 71 | assert_equal ~msg:"Last color should be pastel cyan" pastel_cyan last_color; 72 | let mid_color = Int32.to_int (Palette.index_to_rgb pal (size / 2)) in 73 | assert_bool "Mid color is distinct" 74 | (mid_color <> pastel_purple && mid_color <> pastel_cyan) 75 | 76 | let test_generate_classic_vga_palette_creation _ = 77 | let pal = Palette.generate_classic_vga_palette () in 78 | assert_equal ~msg:"Palette size" 16 (Palette.size pal) 79 | 80 | let test_generate_microsoft_vga_palette_creation _ = 81 | let pal = Palette.generate_microsoft_vga_palette () in 82 | assert_equal ~msg:"Palette size" 16 (Palette.size pal) 83 | 84 | let test_plasma_palette_creation _ = 85 | let pal = Palette.generate_plasma_palette 16 in 86 | assert_equal ~msg:"Palette size" 16 (Palette.size pal); 87 | List.iter 88 | (fun c -> 89 | assert_bool "Colour not black" (0x000000 <> c); 90 | assert_bool "Colour not white" (0xFFFFFF <> c)) 91 | (Palette.to_list pal) 92 | 93 | let test_mono_palette_creation _ = 94 | let pal = Palette.generate_mono_palette 16 in 95 | assert_equal ~msg:"Palette size" 16 (Palette.size pal); 96 | assert_equal ~msg:"Start with black" Int32.zero (Palette.index_to_rgb pal 0); 97 | assert_equal ~msg:"Wrap around to black" Int32.zero 98 | (Palette.index_to_rgb pal 16); 99 | let distinctive_pair = Palette.distinctive_pair pal in 100 | assert_equal ~msg:"Colour distinctive_pair" ~printer:extreme_print (0, 15) 101 | distinctive_pair; 102 | (* I originally tested that we ended on white, but due to rounding errors we might be slightly off *) 103 | List.iter 104 | (fun c -> 105 | let r = c land 0xFF 106 | and g = (c lsr 8) land 0xFF 107 | and b = (c lsr 16) land 0xFF in 108 | assert_equal ~msg:"R equals G" r g; 109 | assert_equal ~msg:"R equals B" r b) 110 | (Palette.to_list pal) 111 | 112 | let test_create_empty_palette_from_list _ = 113 | assert_raises (Invalid_argument "Palette size must not be zero or negative") 114 | (fun _ -> Palette.of_list []) 115 | 116 | let test_create_empty_plasma _ = 117 | assert_raises (Invalid_argument "Palette size must not be zero or negative") 118 | (fun () -> Palette.generate_plasma_palette 0); 119 | assert_raises (Invalid_argument "Palette size must not be zero or negative") 120 | (fun () -> Palette.generate_plasma_palette (-1)) 121 | 122 | let test_create_empty_mono _ = 123 | assert_raises (Invalid_argument "Palette size must not be zero or negative") 124 | (fun () -> Palette.generate_mono_palette 0); 125 | assert_raises (Invalid_argument "Palette size must not be zero or negative") 126 | (fun () -> Palette.generate_mono_palette (-1)) 127 | 128 | let test_load_tic80_palette _ = 129 | let cols = [ 0x000000; 0xFF0000; 0x00FF00; 0x0000FF; 0xFFFFFF ] in 130 | let pal = Palette.load_tic80_palette "000:000000FF000000FF000000FFFFFFFF" in 131 | assert_equal ~msg:"Palette size" (List.length cols) (Palette.size pal); 132 | List.iteri 133 | (fun i c -> 134 | let v = Palette.index_to_rgb pal i in 135 | assert_equal ~msg:"Colour match" (Int32.of_int c) v) 136 | cols 137 | 138 | let test_fail_with_invalid_palette_byte_count _ = 139 | assert_raises 140 | (Invalid_argument "String size not a multiple of 6 chars per colour") 141 | (fun () -> Palette.load_tic80_palette "000:000000FF000000FF000000FFFFFFF") 142 | 143 | let test_fail_load_empty_tic80_palette _ = 144 | assert_raises (Invalid_argument "Palette size must not be zero or negative") 145 | (fun () -> Palette.load_tic80_palette "000:") 146 | 147 | let test_palette_wrap_around _ = 148 | let cols = [ 0x000000; 0xFF0000; 0x00FF00; 0x0000FF; 0xFFFFFF ] in 149 | let pal = Palette.of_list cols in 150 | for idx = -5 to -1 do 151 | let v = Palette.index_to_rgb pal idx in 152 | let c = List.nth cols (idx + 5) in 153 | assert_equal ~msg:"Colour match" (Int32.of_int c) v 154 | done; 155 | for idx = 5 to 9 do 156 | let v = Palette.index_to_rgb pal idx in 157 | let c = List.nth cols (idx - 5) in 158 | assert_equal ~msg:"Colour match" (Int32.of_int c) v 159 | done 160 | 161 | (* Tests for load_lospec_palette *) 162 | 163 | let test_valid_lospec_palette _ = 164 | let input = "#FF0000\n00FF00\n0000FF" in 165 | let palette = Palette.load_lospec_palette input in 166 | assert_equal 3 (Palette.size palette); 167 | assert_equal (Int32.of_int 0xFF0000) (Palette.index_to_rgb palette 0); 168 | assert_equal (Int32.of_int 0x00FF00) (Palette.index_to_rgb palette 1); 169 | assert_equal (Int32.of_int 0x0000FF) (Palette.index_to_rgb palette 2) 170 | 171 | let test_invalid_lospec_palette _ = 172 | let input = "#FF0000\nGGGGGG\n00FF00" in 173 | assert_raises (Invalid_argument "Failed to parse hex color: \"GGGGGG\"") 174 | (fun () -> ignore (Palette.load_lospec_palette input)) 175 | 176 | let test_empty_lospec_palette _ = 177 | assert_raises 178 | (Invalid_argument "Palette size must not be zero or invalid HEX values") 179 | (fun () -> ignore (Palette.load_lospec_palette "")) 180 | 181 | let test_circle_palette_valid _ = 182 | let original = Palette.of_list [ 0x000000; 0x111111; 0x222222; 0x333333 ] in 183 | let rotated_positively = Palette.circle_palette original 1 in 184 | assert_equal ~msg:"Rotated palette (positively offset) size" 185 | (Palette.size original) 186 | (Palette.size rotated_positively); 187 | assert_equal ~msg:"Positively offset, element 0" 188 | (Palette.index_to_rgb original 1) 189 | (Palette.index_to_rgb rotated_positively 0); 190 | assert_equal ~msg:"Positively offset, element 1" 191 | (Palette.index_to_rgb original 2) 192 | (Palette.index_to_rgb rotated_positively 1); 193 | assert_equal ~msg:"Positively offset, element 2" 194 | (Palette.index_to_rgb original 3) 195 | (Palette.index_to_rgb rotated_positively 2); 196 | assert_equal ~msg:"Positively offset, element 3" 197 | (Palette.index_to_rgb original 0) 198 | (Palette.index_to_rgb rotated_positively 3); 199 | let rotated_negatively = Palette.circle_palette original (-1) in 200 | assert_equal ~msg:"Rotated palette (negatively offset) size" 201 | (Palette.size original) 202 | (Palette.size rotated_negatively); 203 | assert_equal ~msg:"Negatively offset, element 0" 204 | (Palette.index_to_rgb original 3) 205 | (Palette.index_to_rgb rotated_negatively 0); 206 | assert_equal ~msg:"Negatively offset, element 1" 207 | (Palette.index_to_rgb original 0) 208 | (Palette.index_to_rgb rotated_negatively 1); 209 | assert_equal ~msg:"Negatively offset, element 2" 210 | (Palette.index_to_rgb original 1) 211 | (Palette.index_to_rgb rotated_negatively 2); 212 | assert_equal ~msg:"Negatively offset, element 3" 213 | (Palette.index_to_rgb original 2) 214 | (Palette.index_to_rgb rotated_negatively 3) 215 | 216 | let test_updated_entry_valid _ = 217 | let original = Palette.of_list [ 0xAAAAAA; 0xBBBBBB; 0xCCCCCC; 0xDDDDDD ] in 218 | let new_palette = Palette.updated_entry original 2 (0x12, 0x34, 0x56) in 219 | let expected_color = Int32.of_int (0x12 * 65536 lor (0x34 * 256) lor 0x56) in 220 | assert_equal ~msg:"Updated entry at index 2" expected_color 221 | (Palette.index_to_rgb new_palette 2); 222 | assert_equal ~msg:"Index 0 unchanged" 223 | (Palette.index_to_rgb original 0) 224 | (Palette.index_to_rgb new_palette 0); 225 | assert_equal ~msg:"Index 1 unchanged" 226 | (Palette.index_to_rgb original 1) 227 | (Palette.index_to_rgb new_palette 1); 228 | assert_equal ~msg:"Index 3 unchanged" 229 | (Palette.index_to_rgb original 3) 230 | (Palette.index_to_rgb new_palette 3) 231 | 232 | let test_updated_entry_invalid _ = 233 | let original = Palette.of_list [ 0xAAAAAA; 0xBBBBBB; 0xCCCCCC; 0xDDDDDD ] in 234 | assert_raises (Invalid_argument "Invalid palette index") (fun () -> 235 | Palette.updated_entry original (-1) (0x12, 0x34, 0x56)); 236 | assert_raises (Invalid_argument "Invalid palette index") (fun () -> 237 | Palette.updated_entry original 4 (0x12, 0x34, 0x56)) 238 | 239 | let suite = 240 | "PaletteTests" 241 | >::: [ 242 | "Test simple palette set up" >:: test_basic_palette_of_ints; 243 | "Test single entry palette set up" >:: test_single_entry_palette; 244 | "Test zero entry palette" >:: test_zero_entry_palette; 245 | "Test generate mac palette" >:: test_generate_mac_palette_creation; 246 | "Test generate sweetie16 palette" >:: test_generate_sweetie16_palette; 247 | "Test linear palette" >:: test_generate_linear_palette; 248 | "Test vapour wave creation" >:: test_generate_vapour_wave_creation; 249 | "Test classic vga palette creation" 250 | >:: test_generate_classic_vga_palette_creation; 251 | "Test microsoft vga palette creation" 252 | >:: test_generate_microsoft_vga_palette_creation; 253 | "Test plasma palette creation" >:: test_plasma_palette_creation; 254 | "Test mono creation" >:: test_mono_palette_creation; 255 | "Test fail to make empty palette" 256 | >:: test_create_empty_palette_from_list; 257 | "Test fail to make zero entry plasma palette" 258 | >:: test_create_empty_plasma; 259 | "Test fail to make zero entry mono palette" >:: test_create_empty_mono; 260 | "Test load tic80 palette string" >:: test_load_tic80_palette; 261 | "Test fail invalid tic80 palette" 262 | >:: test_fail_with_invalid_palette_byte_count; 263 | "Test fail empty tic80 palette" >:: test_fail_load_empty_tic80_palette; 264 | "Test palette wrap around" >:: test_palette_wrap_around; 265 | "Valid Lospec palette" >:: test_valid_lospec_palette; 266 | "Invalid Lospec palette" >:: test_invalid_lospec_palette; 267 | "Empty Lospec palette" >:: test_empty_lospec_palette; 268 | "Test circle_palette (valid)" >:: test_circle_palette_valid; 269 | "Test updated_entry (valid)" >:: test_updated_entry_valid; 270 | "Test updated_entry (invalid)" >:: test_updated_entry_invalid; 271 | ] 272 | 273 | let () = run_test_tt_main suite 274 | -------------------------------------------------------------------------------- /src/framebuffer.ml: -------------------------------------------------------------------------------- 1 | type t = { data : int array array; mutable dirty : bool } 2 | type shader_func = int -> int 3 | type shaderi_func = int -> int -> t -> int 4 | 5 | let to_array (buffer : t) : int array array = buffer.data 6 | 7 | let init (dimensions : int * int) (f : int -> int -> int) : t = 8 | let width, height = dimensions in 9 | if width <= 0 then raise (Invalid_argument "Invalid width"); 10 | if height <= 0 then raise (Invalid_argument "Invalid height"); 11 | { 12 | data = Array.init height (fun y -> Array.init width (fun x -> f x y)); 13 | dirty = true; 14 | } 15 | 16 | let pixel_write (x : int) (y : int) (col : int) (buffer : t) = 17 | if 18 | x >= 0 19 | && x < Array.length buffer.data.(0) 20 | && y >= 0 21 | && y < Array.length buffer.data 22 | then buffer.data.(y).(x) <- col; 23 | buffer.dirty <- true 24 | 25 | let pixel_read (x : int) (y : int) (buffer : t) : int option = 26 | if 27 | x >= 0 28 | && x < Array.length buffer.data.(0) 29 | && y >= 0 30 | && y < Array.length buffer.data 31 | then Some buffer.data.(y).(x) 32 | else None 33 | 34 | let draw_circle (x : int) (y : int) (r : float) (col : int) (buffer : t) = 35 | let fx = Float.of_int x and fy = Float.of_int y in 36 | 37 | for yo = 0 to Int.of_float (r *. sin (Float.pi *. 0.25)) do 38 | let yi = y + yo in 39 | let a = acos (Float.of_int (yi - y) /. r) in 40 | let xw = sin a *. r in 41 | 42 | pixel_write (Int.of_float (fx -. xw)) (y + yo) col buffer; 43 | pixel_write (Int.of_float (fx +. xw)) (y + yo) col buffer; 44 | pixel_write (Int.of_float (fx -. xw)) (y - yo) col buffer; 45 | pixel_write (Int.of_float (fx +. xw)) (y - yo) col buffer; 46 | 47 | pixel_write (x + yo) (Int.of_float (fy -. xw)) col buffer; 48 | pixel_write (x - yo) (Int.of_float (fy -. xw)) col buffer; 49 | pixel_write (x + yo) (Int.of_float (fy +. xw)) col buffer; 50 | pixel_write (x - yo) (Int.of_float (fy +. xw)) col buffer 51 | done 52 | 53 | let filled_circle (x : int) (y : int) (r : float) (col : int) (buffer : t) = 54 | let fx = Float.of_int x and fy = Float.of_int y in 55 | let my = Float.of_int (Array.length buffer.data - 1) 56 | and mx = Float.of_int (Array.length buffer.data.(0) - 1) in 57 | let pminy = fy -. r and pmaxy = fy +. r in 58 | let miny = if pminy < 0. then 0. else pminy 59 | and maxy = if pmaxy > my then my else pmaxy in 60 | for yi = Int.of_float miny to Int.of_float maxy do 61 | let a = acos (Float.of_int (yi - y) /. r) in 62 | let xw = sin a *. r in 63 | let pminx = fx -. xw and pmaxx = fx +. xw in 64 | let minx = if pminx < 0. then 0. else pminx 65 | and maxx = if pmaxx > mx then mx else pmaxx in 66 | if maxx > 0.0 && minx < mx then 67 | for xi = Int.of_float minx to Int.of_float maxx do 68 | pixel_write xi yi col buffer 69 | done 70 | done 71 | 72 | let draw_ellipse (x0 : int) (y0 : int) (a : float) (b : float) (col : int) 73 | (buffer : t) = 74 | let x = ref 0 in 75 | let y = ref (int_of_float b) in 76 | 77 | let d1 = ref ((b *. b) -. (a *. a *. b) +. (0.25 *. a *. a)) in 78 | let dx = ref (2. *. b *. b *. float_of_int !x) in 79 | let dy = ref (2. *. a *. a *. float_of_int !y) in 80 | 81 | while !dx < !dy do 82 | pixel_write (x0 + !x) (y0 + !y) col buffer; 83 | pixel_write (x0 - !x) (y0 + !y) col buffer; 84 | pixel_write (x0 + !x) (y0 - !y) col buffer; 85 | pixel_write (x0 - !x) (y0 - !y) col buffer; 86 | 87 | incr x; 88 | if !d1 < 0. then ( 89 | dx := !dx +. (2. *. b *. b); 90 | d1 := !d1 +. !dx +. (b *. b)) 91 | else ( 92 | decr y; 93 | dx := !dx +. (2. *. b *. b); 94 | dy := !dy -. (2. *. a *. a); 95 | d1 := !d1 +. !dx -. !dy +. (b *. b)) 96 | done; 97 | 98 | let d2 = 99 | ref 100 | ((b *. b *. (float_of_int (!x + 1) ** 2.)) 101 | +. (a *. a *. (float_of_int (!y - 1) ** 2.)) 102 | -. (a *. a *. b *. b)) 103 | in 104 | 105 | while !y >= 0 do 106 | pixel_write (x0 + !x) (y0 + !y) col buffer; 107 | pixel_write (x0 - !x) (y0 + !y) col buffer; 108 | pixel_write (x0 + !x) (y0 - !y) col buffer; 109 | pixel_write (x0 - !x) (y0 - !y) col buffer; 110 | 111 | if !d2 > 0. then ( 112 | decr y; 113 | dy := !dy -. (2. *. a *. a); 114 | d2 := !d2 +. (a *. a) -. !dy) 115 | else ( 116 | decr y; 117 | incr x; 118 | dx := !dx +. (2. *. b *. b); 119 | dy := !dy -. (2. *. a *. a); 120 | d2 := !d2 +. !dx -. !dy +. (a *. a)) 121 | done 122 | 123 | let filled_ellipse (x : int) (y : int) (rx : float) (ry : float) (col : int) 124 | (buffer : t) = 125 | let fx = Float.of_int x and fy = Float.of_int y in 126 | let my = Float.of_int (Array.length buffer.data - 1) 127 | and mx = Float.of_int (Array.length buffer.data.(0) - 1) in 128 | 129 | let pminy = fy -. ry and pmaxy = fy +. ry in 130 | let miny = if pminy < 0. then 0. else pminy 131 | and maxy = if pmaxy > my then my else pmaxy in 132 | 133 | for yi = Int.of_float miny to Int.of_float maxy do 134 | let dy = Float.of_int (yi - y) in 135 | let term = 1. -. (dy *. dy /. (ry *. ry)) in 136 | if term >= 0. then 137 | let xw = rx *. sqrt term in 138 | let pminx = fx -. xw and pmaxx = fx +. xw in 139 | let minx = if pminx < 0. then 0. else pminx 140 | and maxx = if pmaxx > mx then mx else pmaxx in 141 | 142 | if maxx > 0.0 && minx < mx then 143 | for xi = Int.of_float minx to Int.of_float maxx do 144 | pixel_write xi yi col buffer 145 | done 146 | done 147 | 148 | let draw_line (x0 : int) (y0 : int) (x1 : int) (y1 : int) (col : int) 149 | (buffer : t) = 150 | let dx = abs (x1 - x0) 151 | and sx = if x0 < x1 then 1 else -1 152 | and dy = abs (y1 - y0) * -1 153 | and sy = if y0 < y1 then 1 else -1 in 154 | let initial_error = dx + dy in 155 | 156 | let rec loop (x : int) (y : int) (error : int) = 157 | pixel_write x y col buffer; 158 | match x == x1 && y == y1 with 159 | | true -> () 160 | | false -> 161 | let e2 = 2 * error in 162 | let nx = match e2 >= dy with false -> x | true -> x + sx in 163 | let ny = match e2 <= dx with false -> y | true -> y + sy in 164 | let nex = match e2 >= dy with false -> 0 | true -> dy in 165 | let ney = match e2 <= dx with false -> 0 | true -> dx in 166 | loop nx ny (error + nex + ney) 167 | in 168 | loop x0 y0 initial_error 169 | 170 | let draw_polygon (points : (int * int) list) (col : int) (buffer : t) = 171 | match points with 172 | | [] -> () 173 | | hd :: tl -> 174 | let rec loop start prev rest = 175 | let x0, y0 = prev in 176 | match rest with 177 | | [] -> () 178 | | ihd :: [] -> 179 | let x1, y1 = ihd in 180 | draw_line x0 y0 x1 y1 col buffer; 181 | let xs, ys = start in 182 | draw_line x1 y1 xs ys col buffer 183 | | ihd :: itl -> 184 | let x1, y1 = ihd in 185 | draw_line x0 y0 x1 y1 col buffer; 186 | loop start ihd itl 187 | in 188 | loop hd hd tl 189 | 190 | let draw_rect (x : int) (y : int) (width : int) (height : int) (col : int) 191 | (buffer : t) = 192 | draw_polygon 193 | [ (x, y); (x + width, y); (x + width, y + height); (x, y + height) ] 194 | col buffer 195 | 196 | let filled_rect (x : int) (y : int) (width : int) (height : int) (col : int) 197 | (buffer : t) = 198 | for oy = 0 to height do 199 | draw_line x (y + oy) (x + width) (y + oy) col buffer 200 | done 201 | 202 | let draw_triangle (x0 : int) (y0 : int) (x1 : int) (y1 : int) (x2 : int) 203 | (y2 : int) (col : int) (buffer : t) = 204 | draw_line x0 y0 x1 y1 col buffer; 205 | draw_line x1 y1 x2 y2 col buffer; 206 | draw_line x2 y2 x0 y0 col buffer 207 | 208 | type span = Only of int | Pair of int * int 209 | 210 | let interpolate_line (x0 : int) (y0 : int) (x1 : int) (y1 : int) : span array = 211 | let dx = abs (x1 - x0) 212 | and sx = if x0 < x1 then 1 else -1 213 | and dy = abs (y1 - y0) * -1 214 | and sy = if y0 <= y1 then 1 else -1 in 215 | let initial_error = dx + dy in 216 | 217 | let result : span option array = 218 | Array.init (abs (y1 - y0) + 1) (fun _i -> None) 219 | in 220 | result.(0) <- Some (Only x0); 221 | 222 | let rec loop (x : int) (y : int) (error : int) = 223 | match x == x1 && y == y1 with 224 | | true -> () 225 | | false -> 226 | let e2 = 2 * error in 227 | let nx = match e2 >= dy with false -> x | true -> x + sx in 228 | let ny = match e2 <= dx with false -> y | true -> y + sy in 229 | let nex = match e2 >= dy with false -> 0 | true -> dy in 230 | let ney = match e2 <= dx with false -> 0 | true -> dx in 231 | let index = ny - (y0 * sy) in 232 | result.(index) <- 233 | (match result.(index) with 234 | | None -> Some (Only nx) 235 | | Some span -> 236 | Some 237 | (match span with 238 | | Only a -> 239 | if a == nx then Only a 240 | else if a > nx then Pair (nx, a) 241 | else Pair (a, nx) 242 | | Pair (a, b) -> if nx <= a then Pair (nx, b) else Pair (a, nx))); 243 | loop nx ny (error + nex + ney) 244 | in 245 | loop x0 y0 initial_error; 246 | Array.map 247 | (fun maybe_span -> 248 | match maybe_span with None -> assert false | Some span -> span) 249 | result 250 | 251 | let leftmost span = match span with Only x -> x | Pair (x0, _) -> x0 252 | let rightmost span = match span with Only x -> x | Pair (_, x1) -> x1 253 | 254 | let filled_triangle (x0 : int) (y0 : int) (x1 : int) (y1 : int) (x2 : int) 255 | (y2 : int) (col : int) (buffer : t) = 256 | let points = [ (x0, y0); (x1, y1); (x2, y2) ] in 257 | let sorted_points = 258 | List.sort 259 | (fun a b -> 260 | let _, ay = a and _, by = b in 261 | ay - by) 262 | points 263 | in 264 | let x0, y0 = List.nth sorted_points 0 265 | and x1, y1 = List.nth sorted_points 1 266 | and x2, y2 = List.nth sorted_points 2 in 267 | 268 | let long_edge = interpolate_line x0 y0 x2 y2 in 269 | 270 | let other_edge = 271 | if y1 == y0 then interpolate_line x1 y1 x2 y2 272 | else if y1 == y2 then interpolate_line x0 y0 x1 y1 273 | else 274 | let s1 = interpolate_line x0 y0 x1 y1 275 | and s2 = interpolate_line x1 y1 x2 y2 in 276 | Array.concat [ s1; Array.sub s2 1 (Array.length s2 - 1) ] 277 | in 278 | assert (Array.length long_edge == Array.length other_edge); 279 | 280 | let spans = Array.map2 (fun a b -> (a, b)) long_edge other_edge in 281 | Array.iteri 282 | (fun i s -> 283 | let index = y0 + i in 284 | if index >= 0 && index < Array.length buffer.data then 285 | let row = buffer.data.(index) in 286 | let stride = Array.length row in 287 | let p, q = s in 288 | let p0, p1 = if leftmost p <= leftmost q then (p, q) else (q, p) in 289 | let r0, r1 = (leftmost p0, rightmost p1) in 290 | if r1 > 0 && r0 < stride - 1 then 291 | let x0 = if r0 < 0 then 0 else if r0 >= stride then stride - 1 else r0 292 | and x1 = 293 | if r1 < 0 then 0 else if r1 >= stride then stride - 1 else r1 294 | in 295 | for x = x0 to x1 do 296 | pixel_write x index col buffer 297 | done) 298 | spans 299 | 300 | type strand = ((int * int) * (int * int)) list 301 | 302 | let strand_direction (s : strand) : int = 303 | List.fold_right 304 | (fun a acc -> 305 | match acc with 306 | | 0 -> 307 | let p0, p1 = a in 308 | let _, y0 = p0 and _, y1 = p1 in 309 | let diff = y1 - y0 in 310 | if diff = 0 then 0 else diff / abs diff 311 | | x -> x) 312 | s 0 313 | 314 | let poly_to_strands (points : (int * int) list) : strand list = 315 | match points with 316 | | [] | [ _ ] -> [] 317 | | points -> 318 | let lines = Utils.points_to_lines points in 319 | 320 | let rec loop (last_direction : int) (current_strand : strand) 321 | (result : strand list) (remaining : ((int * int) * (int * int)) list) 322 | : strand list = 323 | match remaining with 324 | | [] -> ( match current_strand with [] -> result | x -> x :: result) 325 | | hd :: tl -> 326 | let p0, p1 = hd in 327 | let _, y0 = p0 and _, y1 = p1 in 328 | let diff = y1 - y0 in 329 | let direction = if diff = 0 then 0 else diff / abs diff in 330 | if direction == 0 then 331 | loop last_direction (hd :: current_strand) result tl 332 | else if direction == last_direction then 333 | loop direction (hd :: current_strand) result tl 334 | else loop direction [ hd ] (current_strand :: result) tl 335 | in 336 | let raw = loop 0 [] [] lines in 337 | let unwrapped = List.filter (fun x -> List.length x > 0) raw in 338 | if List.length unwrapped < 2 then unwrapped 339 | else 340 | let head_dir = strand_direction (List.hd unwrapped) 341 | and end_dir = strand_direction (List.hd (List.rev unwrapped)) in 342 | if head_dir != end_dir then unwrapped 343 | else 344 | let fore = List.hd unwrapped and shortened = List.tl unwrapped in 345 | let rev_shorted = List.rev shortened in 346 | let hd = List.hd rev_shorted in 347 | let rest = List.tl rev_shorted in 348 | List.concat [ fore; hd ] :: rest 349 | 350 | let interpolate_strand (strand : ((int * int) * (int * int)) list) : 351 | int * span array = 352 | let spans = 353 | List.map 354 | (fun line -> 355 | let p0, p1 = line in 356 | let x0, y0 = p0 and x1, y1 = p1 in 357 | if y0 <= y1 then (y0, interpolate_line x0 y0 x1 y1) 358 | else (y1, interpolate_line x1 y1 x0 y0)) 359 | strand 360 | in 361 | let sorted_spans = 362 | List.sort 363 | (fun a b -> 364 | let y0, _ = a and y1, _ = b in 365 | y0 - y1) 366 | spans 367 | in 368 | match sorted_spans with 369 | | [] -> (0, [||]) 370 | | hd :: [] -> hd 371 | | hd :: tl -> 372 | let y0, first_span = hd in 373 | let rest = 374 | List.map 375 | (fun x -> 376 | let _, spans = x in 377 | Array.sub spans 1 (Array.length spans - 1)) 378 | tl 379 | in 380 | (y0, Array.concat (first_span :: rest)) 381 | 382 | let filled_polygon (points : (int * int) list) (col : int) (buffer : t) = 383 | match points with 384 | | [] | [ _ ] -> () 385 | | _ -> 386 | let sorted_points = 387 | List.sort 388 | (fun a b -> 389 | let _, ay = a and _, by = b in 390 | ay - by) 391 | points 392 | in 393 | let _, min_y = List.hd sorted_points 394 | and _, max_y = List.hd (List.rev sorted_points) in 395 | let strands = poly_to_strands points in 396 | let rendered_strands = List.map interpolate_strand strands in 397 | 398 | let map = Array.init (max_y - min_y + 1) (fun _i -> []) in 399 | List.iter 400 | (fun l -> 401 | let y, points = l in 402 | Array.iteri 403 | (fun i span -> 404 | let index = y + i - min_y in 405 | map.(index) <- span :: map.(index)) 406 | points) 407 | rendered_strands; 408 | 409 | let height = Array.length buffer.data in 410 | Array.iteri 411 | (fun i row -> 412 | let index = min_y + i in 413 | if index >= 0 && index < height then 414 | let brow = buffer.data.(index) in 415 | let stride = Array.length brow in 416 | let sorted_row = 417 | List.sort (fun a b -> leftmost a - leftmost b) row 418 | in 419 | 420 | let rec loop pairs = 421 | match pairs with 422 | | [] -> () 423 | | raw_x0 :: [] -> ( 424 | match raw_x0 with 425 | | Only x -> 426 | let x0 = 427 | if x < 0 then 0 428 | else if x >= stride then stride - 1 429 | else x 430 | in 431 | Array.fill brow x0 1 col 432 | | Pair (raw_x0, raw_x1) -> 433 | let x0 = 434 | if raw_x0 < 0 then 0 435 | else if raw_x0 >= stride then stride - 1 436 | else raw_x0 437 | and x1 = 438 | if raw_x1 < 0 then 0 439 | else if raw_x1 >= stride then stride - 1 440 | else raw_x1 441 | in 442 | let dist = x1 - x0 + 1 in 443 | if dist > 0 then Array.fill brow x0 dist col) 444 | | raw_x0 :: raw_x1 :: tl -> 445 | let rx0 = leftmost raw_x0 and rx1 = rightmost raw_x1 in 446 | (if rx1 > 0 && rx0 < stride - 1 then 447 | let x0 = 448 | if rx0 < 0 then 0 449 | else if rx0 >= stride then stride - 1 450 | else rx0 451 | and x1 = 452 | if rx1 < 0 then 0 453 | else if rx1 >= stride then stride - 1 454 | else rx1 455 | in 456 | let dist = x1 - x0 + 1 in 457 | Array.fill brow x0 dist col); 458 | loop tl 459 | in 460 | loop sorted_row) 461 | map; 462 | buffer.dirty <- true 463 | 464 | let draw_picture (pic : Picture.t) ?(scale = 1.0) (offset_x : int) 465 | (offset_y : int) (fb : t) : unit = 466 | let src_w, src_h = Picture.dimensions pic in 467 | let dst_w = int_of_float (float src_w *. scale) in 468 | let dst_h = int_of_float (float src_h *. scale) in 469 | let pixels = Picture.pixels pic in 470 | for y = 0 to dst_h - 1 do 471 | for x = 0 to dst_w - 1 do 472 | let src_x = min (src_w - 1) (int_of_float (float x /. scale)) in 473 | let src_y = min (src_h - 1) (int_of_float (float y /. scale)) in 474 | let idx = (src_y * src_w) + src_x in 475 | let color_index = pixels.(idx) in 476 | 477 | if color_index <> 0 then 478 | let fb_x = x + offset_x in 479 | let fb_y = y + offset_y in 480 | pixel_write fb_x fb_y color_index fb 481 | done 482 | done; 483 | fb.dirty <- true 484 | 485 | (* ----- *) 486 | 487 | let draw_char (x : int) (y : int) (f : Font.t) (c : char) (col : int) 488 | (buffer : t) : int = 489 | match Font.glyph_of_char f (Uchar.of_char c) with 490 | | None -> 0 491 | | Some glyph -> 492 | let gw, gh, _, _ = Font.Glyph.dimensions glyph in 493 | let bmp = Font.Glyph.bitmap glyph in 494 | let bytes_per_line = Bytes.length bmp / gh in 495 | for h = 0 to gh - 1 do 496 | for w = 0 to bytes_per_line - 1 do 497 | let bitcount = if (w + 1) * 8 < gw then 8 else (gw - (w * 8)) mod 8 in 498 | let b = int_of_char (Bytes.get bmp ((h * bytes_per_line) + w)) in 499 | for bit = 0 to bitcount - 1 do 500 | let isbit = (b lsl bit) land 0x80 in 501 | match isbit with 502 | | 0 -> () 503 | | _ -> pixel_write (x + (w * 8) + bit) (y + h) col buffer 504 | done 505 | done 506 | done; 507 | gw 508 | 509 | let draw_string (x : int) (y : int) (f : Font.t) (s : string) (col : int) 510 | (buffer : t) = 511 | let sl = List.init (String.length s) (String.get s) in 512 | let rec loop offset remaining = 513 | match remaining with 514 | | [] -> offset 515 | | c :: remaining -> 516 | let width = draw_char (x + offset) y f c col buffer in 517 | loop (offset + width) remaining 518 | in 519 | loop 0 sl 520 | 521 | (* ----- *) 522 | 523 | let map (f : shader_func) (buffer : t) : t = 524 | { data = Array.map (fun row -> Array.map f row) buffer.data; dirty = true } 525 | 526 | let mapi (f : shaderi_func) (buffer : t) : t = 527 | { 528 | data = 529 | Array.mapi 530 | (fun y row -> Array.mapi (fun x _p -> f x y buffer) row) 531 | buffer.data; 532 | dirty = true; 533 | } 534 | 535 | let map_inplace (f : shader_func) (buffer : t) = 536 | Array.iter 537 | (fun row -> Array.iteri (fun i v -> row.(i) <- f v) row) 538 | buffer.data; 539 | buffer.dirty <- true 540 | 541 | let mapi_inplace (f : shaderi_func) (buffer : t) = 542 | Array.iteri 543 | (fun y row -> Array.iteri (fun x _v -> row.(x) <- f x y buffer) row) 544 | buffer.data; 545 | buffer.dirty <- true 546 | 547 | (* ---- *) 548 | 549 | let render (buffer : t) (draw : Primitives.t list) = 550 | List.iter 551 | (fun prim -> 552 | match prim with 553 | | Primitives.Circle (point, r, col) -> 554 | draw_circle point.x point.y r col buffer 555 | | Primitives.FilledCircle (point, r, col) -> 556 | filled_circle point.x point.y r col buffer 557 | | Primitives.Ellipse (point, a, b, col) -> 558 | draw_ellipse point.x point.y a b col buffer 559 | | Primitives.FilledEllipse (point, a, b, col) -> 560 | filled_ellipse point.x point.y a b col buffer 561 | | Primitives.Line (p1, p2, col) -> 562 | draw_line p1.x p1.y p2.x p2.y col buffer 563 | | Primitives.Pixel (p, col) -> pixel_write p.x p.y col buffer 564 | | Primitives.Polygon (plist, col) -> 565 | draw_polygon 566 | (List.map (fun (p : Primitives.point) -> (p.x, p.y)) plist) 567 | col buffer 568 | | Primitives.FilledPolygon (plist, col) -> 569 | filled_polygon 570 | (List.map (fun (p : Primitives.point) -> (p.x, p.y)) plist) 571 | col buffer 572 | | Primitives.Rect (p1, p2, col) -> 573 | draw_rect p1.x p1.y (p2.x - p1.x) (p2.y - p1.y) col buffer 574 | | Primitives.FilledRect (p1, p2, col) -> 575 | filled_rect p1.x p1.y (p2.x - p1.x) (p2.y - p1.y) col buffer 576 | | Primitives.Triangle (p1, p2, p3, col) -> 577 | draw_triangle p1.x p1.y p2.x p2.y p3.x p3.y col buffer 578 | | Primitives.FilledTriangle (p1, p2, p3, col) -> 579 | filled_triangle p1.x p1.y p2.x p2.y p3.x p3.y col buffer 580 | | Primitives.Char (p, font, c, col) -> 581 | ignore (draw_char p.x p.y font c col buffer) 582 | | Primitives.String (p, font, s, col) -> 583 | ignore (draw_string p.x p.y font s col buffer) 584 | | Primitives.Picture (pos, pic) -> 585 | draw_picture pic ~scale:1.0 pos.x pos.y buffer) 586 | draw 587 | 588 | (* ----- *) 589 | 590 | let map2 (f : int -> int -> int) (origin : t) (delta : t) : t = 591 | try 592 | { 593 | data = 594 | Array.map2 595 | (fun o_row d_row -> 596 | Array.map2 (fun o_pixel d_pixel -> f o_pixel d_pixel) o_row d_row) 597 | origin.data delta.data; 598 | dirty = true; 599 | } 600 | with Invalid_argument _ -> 601 | raise 602 | (Invalid_argument 603 | "Merging framebuffers requires both to have same dimensions") 604 | 605 | let map2_inplace (f : int -> int -> int) (origin : t) (delta : t) = 606 | try 607 | Array.iter2 608 | (fun o_row d_row -> 609 | Array.iteri 610 | (fun index d_pixel -> o_row.(index) <- f o_row.(index) d_pixel) 611 | d_row) 612 | origin.data delta.data; 613 | origin.dirty <- true 614 | with Invalid_argument _ -> 615 | raise 616 | (Invalid_argument 617 | "Merging framebuffers requires both to have same dimensions") 618 | 619 | let is_dirty (buffer : t) : bool = buffer.dirty 620 | let set_dirty (buffer : t) : unit = buffer.dirty <- true 621 | let clear_dirty (buffer : t) : unit = buffer.dirty <- false 622 | -------------------------------------------------------------------------------- /test/test_primitives.ml: -------------------------------------------------------------------------------- 1 | open Claudius 2 | open OUnit2 3 | 4 | (* Helper: prepare a framebuffer by clearing its dirty bit and asserting it's clear *) 5 | let prepare_fb dims init_fun = 6 | let fb = Framebuffer.init dims init_fun in 7 | Framebuffer.clear_dirty fb; 8 | assert_equal ~msg:"dirty bit should be false after clear" false 9 | (Framebuffer.is_dirty fb); 10 | fb 11 | 12 | (* Line *) 13 | 14 | let test_draw_line_direct _ = 15 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 16 | assert_equal ~msg:"before (line direct)" (Some 0) 17 | (Framebuffer.pixel_read 5 5 fb); 18 | Framebuffer.draw_line 3 3 7 7 1 fb; 19 | assert_equal ~msg:"after (line direct)" (Some 1) 20 | (Framebuffer.pixel_read 5 5 fb); 21 | assert_equal ~msg:"dirty bit should be set after draw_line" true 22 | (Framebuffer.is_dirty fb) 23 | 24 | let test_draw_line_direct_off_framebuffer _ = 25 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 26 | assert_equal ~msg:"before (line off)" (Some 0) (Framebuffer.pixel_read 5 5 fb); 27 | Framebuffer.draw_line (-3) (-3) 7 7 1 fb; 28 | assert_equal ~msg:"after (line off)" (Some 1) (Framebuffer.pixel_read 5 5 fb); 29 | assert_equal ~msg:"dirty bit should be set after draw_line (off)" true 30 | (Framebuffer.is_dirty fb) 31 | 32 | let test_draw_line_with_primitive _ = 33 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 34 | assert_equal ~msg:"before (line prim)" (Some 0) 35 | (Framebuffer.pixel_read 5 5 fb); 36 | let line = Primitives.Line ({ x = 3; y = 3 }, { x = 7; y = 7 }, 1) in 37 | Framebuffer.render fb [ line ]; 38 | assert_equal ~msg:"after (line prim)" (Some 1) (Framebuffer.pixel_read 5 5 fb); 39 | assert_equal ~msg:"dirty bit should be set after render (line)" true 40 | (Framebuffer.is_dirty fb) 41 | 42 | (* Pixel *) 43 | let test_draw_pixel_with_primitive _ = 44 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 45 | assert_equal ~msg:"before (pixel prim)" (Some 0) 46 | (Framebuffer.pixel_read 5 5 fb); 47 | let prim = Primitives.Pixel ({ x = 5; y = 5 }, 1) in 48 | Framebuffer.render fb [ prim ]; 49 | assert_equal ~msg:"after (pixel prim)" (Some 1) 50 | (Framebuffer.pixel_read 5 5 fb); 51 | assert_equal ~msg:"dirty bit should be set after render (pixel)" true 52 | (Framebuffer.is_dirty fb) 53 | 54 | (* Circle *) 55 | let test_draw_circle_direct _ = 56 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 57 | assert_equal ~msg:"before (circle direct)" (Some 0) 58 | (Framebuffer.pixel_read 5 5 fb); 59 | Framebuffer.draw_circle 5 5 2.0 1 fb; 60 | assert_equal ~msg:"after center (circle direct)" (Some 0) 61 | (Framebuffer.pixel_read 5 5 fb); 62 | assert_equal ~msg:"after edge (circle direct)" (Some 1) 63 | (Framebuffer.pixel_read 5 7 fb); 64 | assert_equal ~msg:"dirty bit should be set after draw_circle" true 65 | (Framebuffer.is_dirty fb) 66 | 67 | let test_draw_circle_direct_off_framebuffer _ = 68 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 69 | assert_equal ~msg:"before (circle off)" (Some 0) 70 | (Framebuffer.pixel_read 5 5 fb); 71 | Framebuffer.draw_circle (-1) (-1) 3.0 1 fb; 72 | assert_equal ~msg:"after (circle off)" (Some 1) 73 | (Framebuffer.pixel_read 1 1 fb); 74 | assert_equal ~msg:"dirty bit should be set after draw_circle (off)" true 75 | (Framebuffer.is_dirty fb) 76 | 77 | let test_draw_circle_with_primitive _ = 78 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 79 | assert_equal ~msg:"before (circle prim)" (Some 0) 80 | (Framebuffer.pixel_read 5 5 fb); 81 | let prim = Primitives.Circle ({ x = 5; y = 5 }, 2.0, 1) in 82 | Framebuffer.render fb [ prim ]; 83 | assert_equal ~msg:"after center (circle prim)" (Some 0) 84 | (Framebuffer.pixel_read 5 5 fb); 85 | assert_equal ~msg:"after edge (circle prim)" (Some 1) 86 | (Framebuffer.pixel_read 5 7 fb); 87 | assert_equal ~msg:"dirty bit should be set after render (circle)" true 88 | (Framebuffer.is_dirty fb) 89 | 90 | (* Filled circle *) 91 | 92 | let test_draw_filled_circle_direct _ = 93 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 94 | assert_equal ~msg:"before (filled circle direct)" (Some 0) 95 | (Framebuffer.pixel_read 5 5 fb); 96 | Framebuffer.filled_circle 5 5 2.0 1 fb; 97 | assert_equal ~msg:"after center (filled circle direct)" (Some 1) 98 | (Framebuffer.pixel_read 5 5 fb); 99 | assert_equal ~msg:"after edge (filled circle direct)" (Some 1) 100 | (Framebuffer.pixel_read 5 7 fb); 101 | assert_equal ~msg:"dirty bit should be set after filled_circle" true 102 | (Framebuffer.is_dirty fb) 103 | 104 | let test_draw_filled_circle_direct_off_framebuffer _ = 105 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 106 | assert_equal ~msg:"before (filled circle off)" (Some 0) 107 | (Framebuffer.pixel_read 5 5 fb); 108 | Framebuffer.filled_circle (-1) (-1) 3.0 1 fb; 109 | assert_equal ~msg:"after (filled circle off)" (Some 1) 110 | (Framebuffer.pixel_read 1 1 fb); 111 | assert_equal ~msg:"dirty bit should be set after filled_circle (off)" true 112 | (Framebuffer.is_dirty fb) 113 | 114 | let test_draw_filled_circle_with_primitive _ = 115 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 116 | assert_equal ~msg:"before (filled circle prim)" (Some 0) 117 | (Framebuffer.pixel_read 5 5 fb); 118 | let prim = Primitives.FilledCircle ({ x = 5; y = 5 }, 2.0, 1) in 119 | Framebuffer.render fb [ prim ]; 120 | assert_equal ~msg:"after center (filled circle prim)" (Some 1) 121 | (Framebuffer.pixel_read 5 5 fb); 122 | assert_equal ~msg:"after edge (filled circle prim)" (Some 1) 123 | (Framebuffer.pixel_read 5 7 fb); 124 | assert_equal ~msg:"dirty bit should be set after render (filled circle)" true 125 | (Framebuffer.is_dirty fb) 126 | 127 | (* Ellipse *) 128 | 129 | let test_draw_ellipse_direct _ = 130 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 131 | assert_equal ~msg:"before (ellipse direct)" (Some 0) 132 | (Framebuffer.pixel_read 5 5 fb); 133 | Framebuffer.draw_ellipse 5 5 3.0 2.0 1 fb; 134 | assert_equal ~msg:"after center (ellipse direct)" (Some 0) 135 | (Framebuffer.pixel_read 5 5 fb); 136 | assert_equal ~msg:"after edge (ellipse direct)" (Some 1) 137 | (Framebuffer.pixel_read 5 7 fb); 138 | assert_equal ~msg:"dirty bit should be set after draw_ellipse" true 139 | (Framebuffer.is_dirty fb) 140 | 141 | let test_draw_ellipse_direct_off_framebuffer _ = 142 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 143 | assert_equal ~msg:"before (ellipse off)" (Some 0) 144 | (Framebuffer.pixel_read 5 5 fb); 145 | Framebuffer.draw_ellipse (-5) (-5) 4.0 3.0 1 fb; 146 | assert_equal ~msg:"after (ellipse off)" (Some 0) 147 | (Framebuffer.pixel_read 0 0 fb); 148 | assert_equal ~msg:"dirty bit should be set after draw_ellipse (off)" true 149 | (Framebuffer.is_dirty fb) 150 | 151 | let test_draw_ellipse_with_primitive _ = 152 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 153 | assert_equal ~msg:"before (ellipse prim)" (Some 0) 154 | (Framebuffer.pixel_read 5 5 fb); 155 | let prim = Primitives.Ellipse ({ x = 5; y = 5 }, 3.0, 2.0, 1) in 156 | Framebuffer.render fb [ prim ]; 157 | assert_equal ~msg:"after center (ellipse prim)" (Some 0) 158 | (Framebuffer.pixel_read 5 5 fb); 159 | assert_equal ~msg:"after edge (ellipse prim)" (Some 1) 160 | (Framebuffer.pixel_read 5 7 fb); 161 | assert_equal ~msg:"dirty bit should be set after render (ellipse)" true 162 | (Framebuffer.is_dirty fb) 163 | 164 | (* Filled ellipse *) 165 | 166 | let test_draw_filled_ellipse_direct _ = 167 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 168 | assert_equal ~msg:"before (filled ellipse direct)" (Some 0) 169 | (Framebuffer.pixel_read 5 5 fb); 170 | Framebuffer.filled_ellipse 5 5 3.0 2.0 1 fb; 171 | assert_equal ~msg:"after center (filled ellipse direct)" (Some 1) 172 | (Framebuffer.pixel_read 5 5 fb); 173 | assert_equal ~msg:"after edge (filled ellipse direct)" (Some 1) 174 | (Framebuffer.pixel_read 5 7 fb); 175 | assert_equal ~msg:"dirty bit should be set after filled_ellipse" true 176 | (Framebuffer.is_dirty fb) 177 | 178 | let test_draw_filled_ellipse_direct_off_framebuffer _ = 179 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 180 | assert_equal ~msg:"before (filled ellipse off)" (Some 0) 181 | (Framebuffer.pixel_read 5 5 fb); 182 | Framebuffer.filled_ellipse 0 0 4.0 3.0 1 fb; 183 | assert_equal ~msg:"after (filled ellipse off)" (Some 1) 184 | (Framebuffer.pixel_read 1 1 fb); 185 | assert_equal ~msg:"dirty bit should be set after filled_ellipse (off)" true 186 | (Framebuffer.is_dirty fb) 187 | 188 | let test_draw_filled_ellipse_with_primitive _ = 189 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 190 | assert_equal ~msg:"before (filled ellipse prim)" (Some 0) 191 | (Framebuffer.pixel_read 5 5 fb); 192 | let prim = Primitives.FilledEllipse ({ x = 5; y = 5 }, 3.0, 2.0, 1) in 193 | Framebuffer.render fb [ prim ]; 194 | assert_equal ~msg:"after center (filled ellipse prim)" (Some 1) 195 | (Framebuffer.pixel_read 5 5 fb); 196 | assert_equal ~msg:"after edge (filled ellipse prim)" (Some 1) 197 | (Framebuffer.pixel_read 5 7 fb); 198 | assert_equal ~msg:"dirty bit should be set after render (filled ellipse)" true 199 | (Framebuffer.is_dirty fb) 200 | 201 | (* Rect *) 202 | 203 | let test_draw_rect_direct _ = 204 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 205 | assert_equal ~msg:"before (rect direct)" (Some 0) 206 | (Framebuffer.pixel_read 5 5 fb); 207 | assert_equal ~msg:"before (rect direct)" (Some 0) 208 | (Framebuffer.pixel_read 7 7 fb); 209 | Framebuffer.draw_rect 3 3 3 3 1 fb; 210 | assert_equal ~msg:"after center (rect direct)" (Some 0) 211 | (Framebuffer.pixel_read 5 5 fb); 212 | assert_equal ~msg:"after edge (rect direct)" (Some 1) 213 | (Framebuffer.pixel_read 6 6 fb); 214 | assert_equal ~msg:"dirty bit should be set after draw_rect" true 215 | (Framebuffer.is_dirty fb) 216 | 217 | let test_draw_rect_direct_off_framebuffer _ = 218 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 219 | assert_equal ~msg:"before (rect off)" (Some 0) (Framebuffer.pixel_read 5 5 fb); 220 | Framebuffer.draw_rect (-1) (-1) 3 3 1 fb; 221 | assert_equal ~msg:"after (rect off)" (Some 1) (Framebuffer.pixel_read 2 2 fb); 222 | assert_equal ~msg:"dirty bit should be set after draw_rect (off)" true 223 | (Framebuffer.is_dirty fb) 224 | 225 | let test_draw_rect_with_primitive _ = 226 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 227 | assert_equal ~msg:"before (rect prim)" (Some 0) 228 | (Framebuffer.pixel_read 5 5 fb); 229 | assert_equal ~msg:"before (rect prim)" (Some 0) 230 | (Framebuffer.pixel_read 7 7 fb); 231 | let prim = Primitives.Rect ({ x = 3; y = 3 }, { x = 6; y = 6 }, 1) in 232 | Framebuffer.render fb [ prim ]; 233 | assert_equal ~msg:"after center (rect prim)" (Some 0) 234 | (Framebuffer.pixel_read 5 5 fb); 235 | assert_equal ~msg:"after edge (rect prim)" (Some 1) 236 | (Framebuffer.pixel_read 6 6 fb); 237 | assert_equal ~msg:"dirty bit should be set after render (rect)" true 238 | (Framebuffer.is_dirty fb) 239 | 240 | (* Filled rect *) 241 | 242 | let test_draw_filled_rect_direct _ = 243 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 244 | assert_equal ~msg:"before (filled rect direct)" (Some 0) 245 | (Framebuffer.pixel_read 5 5 fb); 246 | assert_equal ~msg:"before (filled rect direct)" (Some 0) 247 | (Framebuffer.pixel_read 7 7 fb); 248 | Framebuffer.filled_rect 3 3 3 3 1 fb; 249 | assert_equal ~msg:"after center (filled rect direct)" (Some 1) 250 | (Framebuffer.pixel_read 5 5 fb); 251 | assert_equal ~msg:"after edge (filled rect direct)" (Some 1) 252 | (Framebuffer.pixel_read 6 6 fb); 253 | assert_equal ~msg:"dirty bit should be set after filled_rect" true 254 | (Framebuffer.is_dirty fb) 255 | 256 | let test_draw_filled_rect_direct_off_framebuffer _ = 257 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 258 | assert_equal ~msg:"before (filled rect off)" (Some 0) 259 | (Framebuffer.pixel_read 5 5 fb); 260 | Framebuffer.filled_rect (-1) (-1) 3 3 1 fb; 261 | assert_equal ~msg:"after (filled rect off)" (Some 1) 262 | (Framebuffer.pixel_read 2 2 fb); 263 | assert_equal ~msg:"dirty bit should be set after filled_rect (off)" true 264 | (Framebuffer.is_dirty fb) 265 | 266 | let test_draw_filled_rect_with_primitive _ = 267 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 268 | assert_equal ~msg:"before (filled rect prim)" (Some 0) 269 | (Framebuffer.pixel_read 5 5 fb); 270 | assert_equal ~msg:"before (filled rect prim)" (Some 0) 271 | (Framebuffer.pixel_read 7 7 fb); 272 | let prim = Primitives.FilledRect ({ x = 3; y = 3 }, { x = 6; y = 6 }, 1) in 273 | Framebuffer.render fb [ prim ]; 274 | assert_equal ~msg:"after center (filled rect prim)" (Some 1) 275 | (Framebuffer.pixel_read 5 5 fb); 276 | assert_equal ~msg:"after edge (filled rect prim)" (Some 1) 277 | (Framebuffer.pixel_read 6 6 fb); 278 | assert_equal ~msg:"dirty bit should be set after render (filled rect)" true 279 | (Framebuffer.is_dirty fb) 280 | 281 | (* Triangle *) 282 | 283 | let test_draw_triangle_direct _ = 284 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 285 | assert_equal ~msg:"before (triangle direct)" (Some 0) 286 | (Framebuffer.pixel_read 5 5 fb); 287 | assert_equal ~msg:"before (triangle direct)" (Some 0) 288 | (Framebuffer.pixel_read 7 7 fb); 289 | Framebuffer.draw_triangle 3 3 5 8 8 3 1 fb; 290 | assert_equal ~msg:"after (triangle direct)" (Some 0) 291 | (Framebuffer.pixel_read 5 5 fb); 292 | assert_equal ~msg:"after (triangle direct)" (Some 1) 293 | (Framebuffer.pixel_read 5 3 fb); 294 | assert_equal ~msg:"dirty bit should be set after draw_triangle" true 295 | (Framebuffer.is_dirty fb) 296 | 297 | let test_draw_triangle_direct_off_framebuffer _ = 298 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 299 | assert_equal ~msg:"before (triangle off)" (Some 0) 300 | (Framebuffer.pixel_read 5 5 fb); 301 | Framebuffer.draw_triangle (-1) (-1) 3 3 (-5) 3 1 fb; 302 | assert_equal ~msg:"after (triangle off)" (Some 1) 303 | (Framebuffer.pixel_read 2 2 fb); 304 | assert_equal ~msg:"dirty bit should be set after draw_triangle (off)" true 305 | (Framebuffer.is_dirty fb) 306 | 307 | let test_draw_triangle_with_primitive _ = 308 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 309 | assert_equal ~msg:"before (triangle prim)" (Some 0) 310 | (Framebuffer.pixel_read 5 5 fb); 311 | assert_equal ~msg:"before (triangle prim)" (Some 0) 312 | (Framebuffer.pixel_read 7 7 fb); 313 | let prim = 314 | Primitives.Triangle ({ x = 3; y = 3 }, { x = 5; y = 8 }, { x = 8; y = 3 }, 1) 315 | in 316 | Framebuffer.render fb [ prim ]; 317 | assert_equal ~msg:"after (triangle prim)" (Some 0) 318 | (Framebuffer.pixel_read 5 5 fb); 319 | assert_equal ~msg:"after (triangle prim)" (Some 1) 320 | (Framebuffer.pixel_read 5 3 fb); 321 | assert_equal ~msg:"dirty bit should be set after render (triangle)" true 322 | (Framebuffer.is_dirty fb) 323 | 324 | (* Filled triangle *) 325 | 326 | let test_draw_filled_triangle_direct _ = 327 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 328 | assert_equal ~msg:"before (filled triangle direct)" (Some 0) 329 | (Framebuffer.pixel_read 5 5 fb); 330 | assert_equal ~msg:"before (filled triangle direct)" (Some 0) 331 | (Framebuffer.pixel_read 7 7 fb); 332 | Framebuffer.filled_triangle 3 3 5 8 8 3 1 fb; 333 | assert_equal ~msg:"after (filled triangle direct)" (Some 1) 334 | (Framebuffer.pixel_read 5 5 fb); 335 | assert_equal ~msg:"after (filled triangle direct)" (Some 1) 336 | (Framebuffer.pixel_read 5 3 fb); 337 | assert_equal ~msg:"dirty bit should be set after filled_triangle" true 338 | (Framebuffer.is_dirty fb) 339 | 340 | let test_draw_filled_triangle_direct_off_framebuffer _ = 341 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 342 | assert_equal ~msg:"before (filled triangle off)" (Some 0) 343 | (Framebuffer.pixel_read 5 5 fb); 344 | Framebuffer.filled_triangle (-1) (-1) 3 3 (-5) 3 1 fb; 345 | assert_equal ~msg:"after (filled triangle off)" (Some 1) 346 | (Framebuffer.pixel_read 2 2 fb); 347 | assert_equal ~msg:"dirty bit should be set after filled_triangle (off)" true 348 | (Framebuffer.is_dirty fb) 349 | 350 | let test_draw_filled_triangle_with_primitive _ = 351 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 352 | assert_equal ~msg:"before (filled triangle prim)" (Some 0) 353 | (Framebuffer.pixel_read 5 5 fb); 354 | assert_equal ~msg:"before (filled triangle prim)" (Some 0) 355 | (Framebuffer.pixel_read 7 7 fb); 356 | let prim = 357 | Primitives.FilledTriangle 358 | ({ x = 3; y = 3 }, { x = 5; y = 8 }, { x = 8; y = 3 }, 1) 359 | in 360 | Framebuffer.render fb [ prim ]; 361 | assert_equal ~msg:"after (filled triangle prim)" (Some 1) 362 | (Framebuffer.pixel_read 5 5 fb); 363 | assert_equal ~msg:"after (filled triangle prim)" (Some 1) 364 | (Framebuffer.pixel_read 5 3 fb); 365 | assert_equal ~msg:"dirty bit should be set after render (filled triangle)" 366 | true (Framebuffer.is_dirty fb) 367 | 368 | (* Polygon *) 369 | let test_draw_polygon_direct _ = 370 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 371 | assert_equal ~msg:"before (polygon direct)" (Some 0) 372 | (Framebuffer.pixel_read 5 5 fb); 373 | assert_equal ~msg:"before (polygon direct)" (Some 0) 374 | (Framebuffer.pixel_read 7 7 fb); 375 | Framebuffer.draw_polygon [ (3, 3); (5, 8); (8, 3) ] 1 fb; 376 | assert_equal ~msg:"after (polygon direct)" (Some 0) 377 | (Framebuffer.pixel_read 5 5 fb); 378 | assert_equal ~msg:"after (polygon direct)" (Some 1) 379 | (Framebuffer.pixel_read 5 3 fb); 380 | assert_equal ~msg:"dirty bit should be set after draw_polygon" true 381 | (Framebuffer.is_dirty fb) 382 | 383 | let test_draw_polygon_direct_off_framebuffer _ = 384 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 385 | assert_equal ~msg:"before (polygon off)" (Some 0) 386 | (Framebuffer.pixel_read 5 5 fb); 387 | Framebuffer.draw_polygon [ (-1, -1); (3, 3); (-5, 3) ] 1 fb; 388 | assert_equal ~msg:"after (polygon off)" (Some 1) 389 | (Framebuffer.pixel_read 2 2 fb); 390 | assert_equal ~msg:"dirty bit should be set after draw_polygon (off)" true 391 | (Framebuffer.is_dirty fb) 392 | 393 | let test_draw_polygon_with_primitive _ = 394 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 395 | assert_equal ~msg:"before (polygon prim)" (Some 0) 396 | (Framebuffer.pixel_read 5 5 fb); 397 | assert_equal ~msg:"before (polygon prim)" (Some 0) 398 | (Framebuffer.pixel_read 7 7 fb); 399 | let prim = 400 | Primitives.Polygon 401 | ([ { x = 3; y = 3 }; { x = 5; y = 8 }; { x = 8; y = 3 } ], 1) 402 | in 403 | Framebuffer.render fb [ prim ]; 404 | assert_equal ~msg:"after (polygon prim)" (Some 0) 405 | (Framebuffer.pixel_read 5 5 fb); 406 | assert_equal ~msg:"after (polygon prim)" (Some 1) 407 | (Framebuffer.pixel_read 5 3 fb); 408 | assert_equal ~msg:"dirty bit should be set after render (polygon)" true 409 | (Framebuffer.is_dirty fb) 410 | 411 | (* Filled polygon *) 412 | 413 | let test_draw_filled_polygon_direct _ = 414 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 415 | assert_equal ~msg:"before (filled polygon direct)" (Some 0) 416 | (Framebuffer.pixel_read 5 5 fb); 417 | assert_equal ~msg:"before (filled polygon direct)" (Some 0) 418 | (Framebuffer.pixel_read 7 7 fb); 419 | Framebuffer.filled_polygon [ (3, 3); (5, 8); (8, 3) ] 1 fb; 420 | assert_equal ~msg:"after (filled polygon direct)" (Some 1) 421 | (Framebuffer.pixel_read 5 5 fb); 422 | assert_equal ~msg:"after (filled polygon direct)" (Some 1) 423 | (Framebuffer.pixel_read 5 3 fb); 424 | assert_equal ~msg:"dirty bit should be set after filled_polygon" true 425 | (Framebuffer.is_dirty fb) 426 | 427 | let test_draw_filled_polygon_direct_off_framebuffer _ = 428 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 429 | assert_equal ~msg:"before (filled polygon off)" (Some 0) 430 | (Framebuffer.pixel_read 5 5 fb); 431 | Framebuffer.filled_polygon [ (-1, -1); (3, 3); (-5, 3) ] 1 fb; 432 | assert_equal ~msg:"after (filled polygon off)" (Some 1) 433 | (Framebuffer.pixel_read 2 2 fb); 434 | assert_equal ~msg:"dirty bit should be set after filled_polygon (off)" true 435 | (Framebuffer.is_dirty fb) 436 | 437 | let test_draw_filled_polygon_with_primitive _ = 438 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 439 | assert_equal ~msg:"before (filled polygon prim)" (Some 0) 440 | (Framebuffer.pixel_read 5 5 fb); 441 | assert_equal ~msg:"before (filled polygon prim)" (Some 0) 442 | (Framebuffer.pixel_read 7 7 fb); 443 | let prim = 444 | Primitives.FilledPolygon 445 | ([ { x = 3; y = 3 }; { x = 5; y = 8 }; { x = 8; y = 3 } ], 1) 446 | in 447 | Framebuffer.render fb [ prim ]; 448 | assert_equal ~msg:"after (filled polygon prim)" (Some 1) 449 | (Framebuffer.pixel_read 5 5 fb); 450 | assert_equal ~msg:"after (filled polygon prim)" (Some 1) 451 | (Framebuffer.pixel_read 5 3 fb); 452 | assert_equal ~msg:"dirty bit should be set after render (filled polygon)" true 453 | (Framebuffer.is_dirty fb) 454 | 455 | (* ----- Dirty Bit Test For All Primitives ----- *) 456 | let test_dirty_bit_render_primitive _ = 457 | let primitives = 458 | [ 459 | Primitives.Pixel ({ x = 5; y = 5 }, 1); 460 | Primitives.Line ({ x = 2; y = 2 }, { x = 5; y = 5 }, 1); 461 | Primitives.Circle ({ x = 5; y = 5 }, 4.0, 1); 462 | Primitives.FilledCircle ({ x = 5; y = 5 }, 4.0, 1); 463 | Primitives.Ellipse ({ x = 5; y = 5 }, 4.0, 3.0, 1); 464 | Primitives.FilledEllipse ({ x = 5; y = 5 }, 4.0, 3.0, 1); 465 | Primitives.Rect ({ x = 3; y = 3 }, { x = 6; y = 6 }, 1); 466 | Primitives.FilledRect ({ x = 3; y = 3 }, { x = 6; y = 6 }, 1); 467 | Primitives.Triangle 468 | ({ x = 3; y = 3 }, { x = 5; y = 8 }, { x = 8; y = 3 }, 1); 469 | Primitives.FilledTriangle 470 | ({ x = 3; y = 3 }, { x = 5; y = 8 }, { x = 8; y = 3 }, 1); 471 | Primitives.Polygon 472 | ([ { x = 3; y = 3 }; { x = 5; y = 8 }; { x = 8; y = 3 } ], 1); 473 | Primitives.FilledPolygon 474 | ([ { x = 3; y = 3 }; { x = 5; y = 8 }; { x = 8; y = 3 } ], 1); 475 | ] 476 | in 477 | List.iter 478 | (fun prim -> 479 | let fb = prepare_fb (10, 10) (fun _ _ -> 0) in 480 | Framebuffer.render fb [ prim ]; 481 | assert_equal ~msg:"dirty bit should be set after render (all prim)" true 482 | (Framebuffer.is_dirty fb)) 483 | primitives 484 | 485 | (* ----- Map Functions Tests ----- *) 486 | let test_map _ = 487 | let fb = prepare_fb (10, 10) (fun _ _ -> 1) in 488 | let fb2 = Framebuffer.map (fun x -> x + 1) fb in 489 | assert_equal ~msg:"map should increase pixel value" (Some 2) 490 | (Framebuffer.pixel_read 5 5 fb2); 491 | assert_equal ~msg:"dirty bit should be set in new framebuffer from map" true 492 | (Framebuffer.is_dirty fb2) 493 | 494 | let test_mapi _ = 495 | let fb = prepare_fb (10, 10) (fun x y -> x + y) in 496 | let fb2 = Framebuffer.mapi (fun x y _ -> x * y) fb in 497 | assert_equal ~msg:"mapi should compute product" (Some 12) 498 | (Framebuffer.pixel_read 3 4 fb2); 499 | assert_equal ~msg:"dirty bit should be set in new framebuffer from mapi" true 500 | (Framebuffer.is_dirty fb2) 501 | 502 | let test_map_inplace _ = 503 | let fb = prepare_fb (10, 10) (fun _ _ -> 1) in 504 | Framebuffer.map_inplace (fun x -> x * 2) fb; 505 | assert_equal ~msg:"map_inplace should double pixel" (Some 2) 506 | (Framebuffer.pixel_read 5 5 fb); 507 | assert_equal ~msg:"dirty bit should be set after map_inplace" true 508 | (Framebuffer.is_dirty fb) 509 | 510 | let test_mapi_inplace _ = 511 | let fb = prepare_fb (10, 10) (fun x y -> x + y) in 512 | Framebuffer.mapi_inplace (fun x y _ -> x * y) fb; 513 | assert_equal ~msg:"mapi_inplace should compute product" (Some 12) 514 | (Framebuffer.pixel_read 3 4 fb); 515 | assert_equal ~msg:"dirty bit should be set after mapi_inplace" true 516 | (Framebuffer.is_dirty fb) 517 | 518 | let suite = 519 | "Primitives tests" 520 | >::: [ 521 | "Test draw line direct" >:: test_draw_line_direct; 522 | "Test draw line direct off framebuffer" 523 | >:: test_draw_line_direct_off_framebuffer; 524 | "Test draw line with primative" >:: test_draw_line_with_primitive; 525 | "Test draw pixel with primative" >:: test_draw_pixel_with_primitive; 526 | "Test draw circle direct" >:: test_draw_circle_direct; 527 | "Test draw circle direct off framebuffer" 528 | >:: test_draw_circle_direct_off_framebuffer; 529 | "Test draw circle with primative" >:: test_draw_circle_with_primitive; 530 | "Test filled circle direct" >:: test_draw_filled_circle_direct; 531 | "Test filled circle direct off framebuffer" 532 | >:: test_draw_filled_circle_direct_off_framebuffer; 533 | "Test filled circle with primative" 534 | >:: test_draw_filled_circle_with_primitive; 535 | "Test draw ellipse direct" >:: test_draw_ellipse_direct; 536 | "Test draw ellipse direct off framebuffer" 537 | >:: test_draw_ellipse_direct_off_framebuffer; 538 | "Test draw ellipse with primitive" >:: test_draw_ellipse_with_primitive; 539 | "Test filled ellipse direct" >:: test_draw_filled_ellipse_direct; 540 | "Test filled ellipse direct off framebuffer" 541 | >:: test_draw_filled_ellipse_direct_off_framebuffer; 542 | "Test filled ellipse with primitive" 543 | >:: test_draw_filled_ellipse_with_primitive; 544 | "Test draw rect direct" >:: test_draw_rect_direct; 545 | "Test draw rect direct off framebuffer" 546 | >:: test_draw_rect_direct_off_framebuffer; 547 | "Test draw rect with primative" >:: test_draw_rect_with_primitive; 548 | "Test filled rect direct" >:: test_draw_filled_rect_direct; 549 | "Test filled rect direct off framebuffer" 550 | >:: test_draw_filled_rect_direct_off_framebuffer; 551 | "Test filled rect with primative" 552 | >:: test_draw_filled_rect_with_primitive; 553 | "Test draw triangle direct" >:: test_draw_triangle_direct; 554 | "Test draw triangle direct off framebuffer" 555 | >:: test_draw_triangle_direct_off_framebuffer; 556 | "Test draw triangle with primative" 557 | >:: test_draw_triangle_with_primitive; 558 | "Test filled triangle direct" >:: test_draw_filled_triangle_direct; 559 | "Test filled triangle direct off framebuffer" 560 | >:: test_draw_filled_triangle_direct_off_framebuffer; 561 | "Test filled triangle with primative" 562 | >:: test_draw_filled_triangle_with_primitive; 563 | "Test draw polygon direct" >:: test_draw_polygon_direct; 564 | "Test draw polygon direct off framebuffer" 565 | >:: test_draw_polygon_direct_off_framebuffer; 566 | "Test draw polygon with primative" >:: test_draw_polygon_with_primitive; 567 | "Test filled polygon direct" >:: test_draw_filled_polygon_direct; 568 | "Test filled polygon direct off framebuffer" 569 | >:: test_draw_filled_polygon_direct_off_framebuffer; 570 | "Test filled polygon with primative" 571 | >:: test_draw_filled_polygon_with_primitive; 572 | "Test dirty bit render primitive (all prim)" 573 | >:: test_dirty_bit_render_primitive; 574 | "Test map" >:: test_map; 575 | "Test mapi" >:: test_mapi; 576 | "Test map_inplace" >:: test_map_inplace; 577 | "Test mapi_inplace" >:: test_mapi_inplace; 578 | ] 579 | 580 | let () = run_test_tt_main suite 581 | --------------------------------------------------------------------------------