├── .gitignore ├── README.md ├── bench ├── bench_ecs.ml ├── bench_graphics.ml ├── bench_math.ml ├── bench_storage.ml ├── benchmark.ml └── dune ├── camlcade.opam ├── dune-project ├── examples ├── bounce.ml ├── disco.ml ├── dune ├── first_person.ml ├── game_of_life.ml ├── move.ml ├── plugin │ ├── dune │ ├── fp_camera.ml │ └── fp_camera.mli ├── shapes.ml └── spawn.ml ├── lib ├── app.ml ├── app.mli ├── camlcade.ml ├── dune ├── ecs │ ├── archetype.ml │ ├── archetype.mli │ ├── component.ml │ ├── component.mli │ ├── dune │ ├── event.ml │ ├── event.mli │ ├── id.ml │ ├── id.mli │ ├── query.ml │ ├── query.mli │ ├── scheduler.ml │ ├── scheduler.mli │ ├── system.ml │ ├── system.mli │ ├── world.ml │ └── world.mli ├── graphics │ ├── camera │ │ ├── camera.ml │ │ ├── camera.mli │ │ ├── projection.ml │ │ └── projection.mli │ ├── context.ml │ ├── context.mli │ ├── dune │ ├── graphics.ml │ ├── graphics.mli │ ├── light.ml │ ├── light.mli │ ├── material.ml │ ├── material.mli │ ├── mesh3d.ml │ ├── mesh3d.mli │ ├── primitive │ │ ├── cuboid.ml │ │ ├── cuboid.mli │ │ ├── primitive.ml │ │ ├── primitive.mli │ │ ├── sphere.ml │ │ └── sphere.mli │ ├── shader │ │ ├── normal.ml │ │ ├── normal.mli │ │ ├── phong.ml │ │ ├── phong.mli │ │ ├── shader.ml │ │ └── shader.mli │ ├── util.ml │ ├── util.mli │ ├── vertex_mesh.ml │ └── vertex_mesh.mli ├── input │ ├── button.ml │ ├── button.mli │ ├── button_state.ml │ ├── button_state.mli │ ├── dune │ ├── input.ml │ ├── input.mli │ ├── key.ml │ ├── key.mli │ ├── mouse_button.ml │ └── mouse_button.mli ├── math │ ├── dune │ ├── math.ml │ └── math.mli ├── storage │ ├── dune │ ├── sparse_array.ml │ ├── sparse_array.mli │ ├── sparse_set.ml │ └── sparse_set.mli └── transform │ ├── dune │ ├── transform.ml │ └── transform.mli └── test └── ecs ├── dune ├── test_archetype.ml ├── test_query.ml ├── test_world_components.ml ├── test_world_entities.ml ├── test_world_systems.ml └── util.ml /.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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 🐫🎮 camlcade 2 | 3 | > [!WARNING] 4 | > Still in development. Not ready for production. 5 | 6 | camlcade is an OCaml game engine. It features an archetype-based entity-component system (ECS) and an OpenGL-based renderer. 7 | 8 | ## Features 9 | 10 | - Archetype storage 11 | - Composable plugins 12 | - User-defined GLSL shaders 13 | - Custom meshes 14 | 15 | ## Examples 16 | 17 | To see how to use camlcade, see [examples/](examples/). 18 | 19 | Run an example with: 20 | ```sh 21 | # Runs the "shapes" example 22 | dune exec shapes 23 | ``` 24 | 25 | https://github.com/user-attachments/assets/8d5ea29c-ec0d-452f-b60a-a0c7129d0e10 26 | 27 | https://github.com/user-attachments/assets/95a5e881-ff3a-4c3d-b545-769d68b85b8e 28 | 29 | ## Development 30 | 31 | ### Project Structure 32 | 33 | ``` 34 | lib 35 | ├── ecs # Entity-component system 36 | ├── graphics # OpenGL-based renderer 37 | ├── input # Input and event handling 38 | ├── math # Math utilities 39 | ├── storage # Sparse storage 40 | └── transform # Transform component 41 | ``` 42 | 43 | ### Quick Start 44 | 45 | - Build: `dune build` 46 | - Test: `dune test` 47 | - Benchmark: `dune exec bench` 48 | - Documentation: `dune build @doc` (see `_build/default/_doc/_html/index.html`) 49 | -------------------------------------------------------------------------------- /bench/bench_ecs.ml: -------------------------------------------------------------------------------- 1 | open Core_bench 2 | open Ecs 3 | 4 | module Foo = struct 5 | type t = unit 6 | 7 | module C = Component.Make (struct 8 | type inner = t 9 | end) 10 | end 11 | 12 | module Bar = struct 13 | type t = unit 14 | 15 | module C = Component.Make (struct 16 | type inner = t 17 | end) 18 | end 19 | 20 | let t1 = 21 | Bench.Test.create ~name:"entity creation and removal" (fun () -> 22 | let world = World.create () in 23 | World.add_entity world |> World.remove_entity world) 24 | 25 | let t2 = 26 | Bench.Test.create_with_initialization 27 | ~name:"component repeated add and remove" (fun _ -> 28 | let world = World.create () in 29 | let entity = World.add_entity world in 30 | fun () -> 31 | for _ = 1 to 50 do 32 | World.with_component world (module Foo.C) () entity |> ignore; 33 | World.remove_component world Foo.C.id entity 34 | done) 35 | 36 | let t3 = 37 | Bench.Test.create_with_initialization ~name:"big query" (fun _ -> 38 | let param = 100_000 in 39 | let world = World.create () in 40 | for _ = 1 to param do 41 | World.add_entity world 42 | |> World.with_component world (module Foo.C) () 43 | |> World.with_component world (module Bar.C) () 44 | |> ignore 45 | done; 46 | fun () -> 47 | let results = 48 | World.query world Query.[ Req (module Foo.C); Req (module Bar.C) ] 49 | in 50 | assert (List.length results = param)) 51 | 52 | let t4 = 53 | Bench.Test.create ~name:"register and fetch systems" (fun () -> 54 | let registry = Scheduler.create () in 55 | for _ = 1 to 100 do 56 | let system results = ignore results in 57 | Scheduler.register registry Scheduler.Update system 58 | done; 59 | Scheduler.fetch registry Scheduler.Update |> ignore) 60 | 61 | let tests = [ t1; t2; t3; t4 ] 62 | let command = Bench.make_command tests 63 | -------------------------------------------------------------------------------- /bench/bench_graphics.ml: -------------------------------------------------------------------------------- 1 | open Core_bench 2 | open Graphics 3 | 4 | let t1 = 5 | Bench.Test.create ~name:"primitive sphere creation" (fun () -> 6 | Primitive.Sphere.create ~param1:50 ~param2:50 ()) 7 | 8 | let tests = [ t1 ] 9 | let command = Bench.make_command tests 10 | -------------------------------------------------------------------------------- /bench/bench_math.ml: -------------------------------------------------------------------------------- 1 | open Core_bench 2 | open Math 3 | 4 | let t1 = 5 | Bench.Test.create ~name:"mat4 operations" (fun () -> 6 | let m = 7 | Mat4.of_rows (Math.Vec4.v 1. 2. 3. 4.) (Math.Vec4.v 5. 6. 7. 8.) 8 | (Math.Vec4.v 9. 10. 11. 12.) 9 | (Math.Vec4.v 13. 14. 15. 16.) 10 | in 11 | ignore (Mat4.inv m); 12 | ignore (Mat4.transpose m); 13 | ignore (Mat4.mul m m)) 14 | 15 | let tests = [ t1 ] 16 | let command = Bench.make_command tests 17 | -------------------------------------------------------------------------------- /bench/bench_storage.ml: -------------------------------------------------------------------------------- 1 | (** Compare the performance of [Hashtbl] and [Sparse_set]. *) 2 | 3 | open Core_bench 4 | open Storage 5 | 6 | let param = 100_000 7 | 8 | let b1 = 9 | Bench.Test.create ~name:"baseline add" (fun () -> 10 | let table = Hashtbl.create 0 in 11 | for i = 0 to param do 12 | Hashtbl.add table i i 13 | done) 14 | 15 | let b2 = 16 | Bench.Test.create ~name:"baseline remove" (fun () -> 17 | let table = Hashtbl.create 0 in 18 | for i = 0 to param do 19 | Hashtbl.add table i i 20 | done; 21 | for i = 0 to param do 22 | Hashtbl.remove table i 23 | done) 24 | 25 | let b3 = 26 | Bench.Test.create_with_initialization ~name:"baseline find" (fun _ -> 27 | let table = Hashtbl.create 0 in 28 | for i = 0 to param do 29 | Hashtbl.add table i i 30 | done; 31 | fun () -> 32 | for i = 0 to param do 33 | Hashtbl.find_opt table i |> ignore 34 | done) 35 | 36 | let t1 = 37 | Bench.Test.create ~name:"sparse set add" (fun () -> 38 | let set = Sparse_set.create () in 39 | for i = 0 to param do 40 | Sparse_set.set set i i 41 | done) 42 | 43 | let t2 = 44 | Bench.Test.create ~name:"sparse set remove" (fun () -> 45 | let set = Sparse_set.create () in 46 | for i = 0 to param do 47 | Sparse_set.set set i i 48 | done; 49 | for i = 0 to param do 50 | Sparse_set.remove set i |> ignore 51 | done) 52 | 53 | let t3 = 54 | Bench.Test.create_with_initialization ~name:"sparse set find" (fun _ -> 55 | let set = Sparse_set.create () in 56 | for i = 0 to param do 57 | Sparse_set.set set i i 58 | done; 59 | fun () -> 60 | for i = 0 to param do 61 | Sparse_set.get set i |> ignore 62 | done) 63 | 64 | let tests = [ b1; b2; b3; t1; t2; t3 ] 65 | let command = Bench.make_command tests 66 | -------------------------------------------------------------------------------- /bench/benchmark.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let main () = 4 | Command_unix.run 5 | (Command.group ~summary:"Several benchmarks" 6 | [ 7 | ("ecs", Bench_ecs.command); 8 | ("graphics", Bench_graphics.command); 9 | ("math", Bench_math.command); 10 | ("storage", Bench_storage.command); 11 | ]) 12 | 13 | let () = main () 14 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name bench) 3 | (name benchmark) 4 | (libraries core_unix.command_unix core core_bench camlcade)) 5 | -------------------------------------------------------------------------------- /camlcade.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A short synopsis" 4 | description: "A longer description" 5 | maintainer: ["Maintainer Name"] 6 | authors: ["Author Name"] 7 | license: "LICENSE" 8 | tags: ["topics" "to describe" "your" "project"] 9 | homepage: "https://github.com/username/reponame" 10 | doc: "https://url/to/documentation" 11 | bug-reports: "https://github.com/username/reponame/issues" 12 | depends: [ 13 | "ocaml" 14 | "dune" {>= "3.16"} 15 | "tgls" 16 | "tsdl" 17 | "core_bench" 18 | "gg" 19 | "odoc" {with-doc} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/username/reponame.git" 36 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.16) 2 | 3 | (name camlcade) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github username/reponame)) 9 | 10 | (authors "Author Name") 11 | 12 | (maintainers "Maintainer Name") 13 | 14 | (license LICENSE) 15 | 16 | (documentation https://url/to/documentation) 17 | 18 | (package 19 | (name camlcade) 20 | (synopsis "A short synopsis") 21 | (description "A longer description") 22 | (depends ocaml dune tgls tsdl core_bench gg) 23 | (tags 24 | (topics "to describe" your project))) 25 | 26 | ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/reference/dune-project/index.html 27 | -------------------------------------------------------------------------------- /examples/bounce.ml: -------------------------------------------------------------------------------- 1 | (** Bounce a ball up and down. 2 | 3 | Press `F` to follow the ball with the camera. Press `R` to restart the ball 4 | at the top. *) 5 | 6 | open Camlcade 7 | open Ecs 8 | 9 | let maximum_height = 5. 10 | let bounciness = 0.8 11 | let ground = 0.5 12 | let gravity = Math.Vec3.v 0. (-9.81) 0. 13 | 14 | module Ball = struct 15 | type t = { mutable velocity : Math.Vec3.t; bounciness : float } 16 | 17 | let create bounciness () = { velocity = Math.Vec3.zero; bounciness } 18 | let velocity ball = ball.velocity 19 | let bounciness ball = ball.bounciness 20 | 21 | let fall ball dt = 22 | ball.velocity <- Math.Vec3.(add ball.velocity (smul dt gravity)) 23 | 24 | let set_velocity ball v = ball.velocity <- v 25 | 26 | module C = Component.Make (struct 27 | type inner = t 28 | end) 29 | end 30 | 31 | let simulate_ball = 32 | let query w = 33 | let _, (t, (b, ())) = 34 | World.query w Query.[ Req (module Transform.C); Req (module Ball.C) ] 35 | |> List.hd 36 | in 37 | (t, b) 38 | in 39 | let dt = 0.00000005 in 40 | let simulate (transform, ball) = 41 | Ball.fall ball dt; 42 | let velocity = Ball.velocity ball in 43 | let translation = Transform.translation transform in 44 | let translation = Math.Vec3.(translation + velocity) in 45 | Transform.set_translation transform translation; 46 | 47 | if Math.Vec3.y translation < ground then ( 48 | let x, _, z = Math.Vec3.to_tuple translation in 49 | let corrected_pos = Math.Vec3.v x ground z in 50 | Transform.set_translation transform corrected_pos; 51 | 52 | let bounce_y = -.Math.Vec3.y velocity *. Ball.bounciness ball in 53 | let vx, _, vz = Math.Vec3.to_tuple velocity in 54 | Ball.set_velocity ball (Math.Vec3.v vx bounce_y vz)) 55 | in 56 | System.make query (System.Query simulate) 57 | 58 | let restart_ball = 59 | let query w = 60 | let _, (k, ()) = 61 | World.query w Query.[ Req (module Input.Keyboard.C) ] |> List.hd 62 | in 63 | let _, (t, (b, ())) = 64 | World.query w Query.[ Req (module Transform.C); Req (module Ball.C) ] 65 | |> List.hd 66 | in 67 | (k, t, b) 68 | in 69 | let restart (keyboard, transform, ball) = 70 | let is_pressed = Input.Keyboard.is_pressed keyboard in 71 | if is_pressed `R then ( 72 | Transform.set_translation transform (Math.Vec3.v 0. maximum_height 0.); 73 | Ball.set_velocity ball (Math.Vec3.v 0. 0. 0.)) 74 | in 75 | System.make query (System.Query restart) 76 | 77 | let camera_follow_ball = 78 | let query w = 79 | let _, (k, ()) = 80 | World.query w Query.[ Req (module Input.Keyboard.C) ] |> List.hd 81 | in 82 | let _, (ball_t, ()) = 83 | World.query ~filter:(Query.Filter.With Ball.C.id) w 84 | Query.[ Req (module Transform.C) ] 85 | |> List.hd 86 | in 87 | let _, (camera_t, ()) = 88 | World.query ~filter:(Query.Filter.With Graphics.Camera3d.C.id) w 89 | Query.[ Req (module Transform.C) ] 90 | |> List.hd 91 | in 92 | (k, ball_t, camera_t) 93 | in 94 | let follow = ref false in 95 | let follow (k, ball_t, camera_t) = 96 | if Input.Keyboard.is_just_pressed k `F then follow := not !follow; 97 | if !follow then 98 | let ball_position = Transform.translation ball_t in 99 | Transform.set_look_at camera_t ball_position 100 | else Transform.set_look_at camera_t Math.Vec3.oy 101 | in 102 | System.make query (System.Query follow) 103 | 104 | let plugin w = 105 | let open Graphics in 106 | let _light = 107 | World.add_entity w 108 | |> World.with_component w 109 | (module Light.Point.C) 110 | (Light.Point.create ~color:(Math.Vec3.v 0.9 0.2 0.2) 111 | ~attenuation:(Math.Vec3.v 0.8 0.2 0.) ()) 112 | |> World.with_component w 113 | (module Transform.C) 114 | Transform.(identity () |> with_translation (Math.Vec3.v 0. 5. 5.)) 115 | in 116 | let _ground = 117 | World.add_entity w 118 | |> World.with_component w 119 | (module Mesh3d.C) 120 | (Primitive.to_mesh3d 121 | (Primitive.Cuboid.create ~x_length:100. ~y_length:0.1 ~z_length:100. 122 | ())) 123 | |> World.with_component w 124 | (module Material.C) 125 | (Material.create ~ambient:(Math.Vec3.v 0.2 0. 0.) ~shininess:1. ()) 126 | |> World.with_component w (module Shader.Phong.C) () 127 | in 128 | let _camera = 129 | World.add_entity w 130 | |> World.with_component w (module Camera3d.C) () 131 | |> World.with_component w 132 | (module Camera.Projection.C) 133 | (Camera.Projection.perspective ()) 134 | |> World.with_component w 135 | (module Transform.C) 136 | Transform.( 137 | identity () 138 | |> with_translation (Math.Vec3.v (-15.) 1. 0.) 139 | |> with_look_at (Math.Vec3.v 0. 1. 0.)) 140 | in 141 | let _ball = 142 | World.add_entity w 143 | |> World.with_component w 144 | (module Mesh3d.C) 145 | (Primitive.to_mesh3d 146 | (Primitive.Sphere.create ~param1:50 ~param2:50 ())) 147 | |> World.with_component w (module Shader.Phong.C) () 148 | |> World.with_component w 149 | (module Material.C) 150 | (Material.create ~ambient:(Math.Vec3.v 0.1 0.5 0.2) ~shininess:1. ()) 151 | |> World.with_component w 152 | (module Transform.C) 153 | Transform.( 154 | identity () |> with_translation (Math.Vec3.v 0. maximum_height 0.)) 155 | |> World.with_component w (module Ball.C) (Ball.create bounciness ()) 156 | in 157 | 158 | World.add_system w Scheduler.Update simulate_ball; 159 | World.add_system w Scheduler.Update restart_ball; 160 | World.add_system w Scheduler.Update camera_follow_ball 161 | 162 | let () = 163 | let app = 164 | App.create () 165 | |> App.add_plugin Input.plugin 166 | |> App.add_plugin Graphics.plugin 167 | |> App.add_plugin plugin 168 | in 169 | 170 | App.run app 171 | -------------------------------------------------------------------------------- /examples/disco.ml: -------------------------------------------------------------------------------- 1 | open Camlcade 2 | open Ecs 3 | 4 | module Spin = struct 5 | module C = Ecs.Component.Make (struct 6 | type inner = unit 7 | end) 8 | end 9 | 10 | module Disco_ball = struct 11 | type t = { 12 | mutable last_update : float; 13 | mutable color : Math.Vec3.t; 14 | mutable target_color : Math.Vec3.t; 15 | } 16 | 17 | let update_interval = 1.0 18 | 19 | let random_color () = 20 | Math.Vec3.v (Random.float 1.) (Random.float 1.) (Random.float 1.) 21 | 22 | let create ?(target_color = random_color ()) () = 23 | { last_update = 0.; color = random_color (); target_color } 24 | 25 | let update t now = 26 | if now -. t.last_update > update_interval then ( 27 | t.target_color <- random_color (); 28 | t.last_update <- now; 29 | t.target_color) 30 | else 31 | let lerp a b = a +. ((b -. a) *. 0.001) in 32 | let r, g, b = Math.Vec3.to_tuple t.color in 33 | let tr, tg, tb = Math.Vec3.to_tuple t.target_color in 34 | t.color <- Math.Vec3.v (lerp r tr) (lerp g tg) (lerp b tb); 35 | t.color 36 | 37 | module C = Ecs.Component.Make (struct 38 | type inner = t 39 | end) 40 | end 41 | 42 | let spawn_camera w = 43 | let open Graphics in 44 | World.add_entity w 45 | |> World.with_component w (module Camera3d.C) () 46 | |> World.with_component w 47 | (module Camera.Projection.C) 48 | (Camera.Projection.perspective ~far_plane:1000. ()) 49 | |> World.with_component w 50 | (module Transform.C) 51 | Transform.( 52 | identity () 53 | |> with_translation (Math.Vec3.v (-30.) 10. 0.) 54 | |> with_look_at (Math.Vec3.v 0. 1. 0.)) 55 | |> ignore 56 | 57 | let spawn_disco_ball w position = 58 | let open Graphics in 59 | World.add_entity w 60 | |> World.with_component w (module Disco_ball.C) (Disco_ball.create ()) 61 | |> World.with_component w 62 | (module Transform.C) 63 | Transform.(identity () |> with_translation position) 64 | |> World.with_component w (module Light.Point.C) (Light.Point.create ()) 65 | |> ignore 66 | 67 | let spawn_cube w position = 68 | let open Graphics in 69 | World.add_entity w 70 | |> World.with_component w (module Spin.C) () 71 | |> World.with_component w 72 | (module Mesh3d.C) 73 | (Primitive.to_mesh3d (Primitive.Cuboid.create ())) 74 | |> World.with_component w 75 | (module Transform.C) 76 | Transform.(identity () |> with_translation position) 77 | |> World.with_component w 78 | (module Material.C) 79 | (Material.create ~ambient:(Math.Vec3.v 0. 0. 0.) ~shininess:1. ()) 80 | |> World.with_component w (module Shader.Phong.C) () 81 | |> ignore 82 | 83 | let spawn_ground w = 84 | let open Graphics in 85 | World.add_entity w 86 | |> World.with_component w 87 | (module Mesh3d.C) 88 | (Primitive.to_mesh3d 89 | (Primitive.Cuboid.create ~x_length:25. ~y_length:0.1 ~z_length:25. ())) 90 | |> World.with_component w 91 | (module Material.C) 92 | (Material.create ~ambient:(Math.Vec3.v 0.1 0.1 0.1) ~shininess:1. ()) 93 | |> World.with_component w (module Shader.Phong.C) () 94 | |> ignore 95 | 96 | let spin = 97 | let query w = 98 | World.query ~filter:(Query.Filter.With Spin.C.id) w 99 | Query.[ Req (module Transform.C) ] 100 | |> List.map (fun (_, (t, ())) -> t) 101 | in 102 | let spin = 103 | List.iter (fun t -> 104 | Transform.set_rotation t 105 | (Math.Quat.rot3_zyx 106 | (Math.Vec3.v (Unix.gettimeofday ()) (Unix.gettimeofday ()) 107 | (Unix.gettimeofday ())))) 108 | in 109 | System.make query (System.Query spin) 110 | 111 | let update_disco_balls = 112 | let open Graphics in 113 | let query w = 114 | World.query w 115 | Query.[ Req (module Light.Point.C); Req (module Disco_ball.C) ] 116 | |> List.map (fun (_, (p, (db, ()))) -> (p, db)) 117 | in 118 | let dim_color color = 119 | let dim_factor = 0.2 in 120 | Math.Vec3.smul dim_factor color 121 | in 122 | let update = 123 | List.iter (fun (p, db) -> 124 | let color = Disco_ball.update db (Unix.gettimeofday ()) in 125 | Light.Point.set_color p (dim_color color)) 126 | in 127 | System.make query (System.Query update) 128 | 129 | let plugin w = 130 | spawn_camera w; 131 | spawn_cube w (Math.Vec3.v 0. 2. 0.); 132 | spawn_cube w (Math.Vec3.v 2. 3. 2.); 133 | spawn_cube w (Math.Vec3.v (-2.) 1. 2.); 134 | spawn_cube w (Math.Vec3.v 2. 3. (-2.)); 135 | spawn_cube w (Math.Vec3.v (-2.) 1. (-2.)); 136 | spawn_ground w; 137 | spawn_disco_ball w (Math.Vec3.v 0. 2. 5.); 138 | spawn_disco_ball w (Math.Vec3.v 0. 2. (-5.)); 139 | spawn_disco_ball w (Math.Vec3.v 5. 2. 0.); 140 | spawn_disco_ball w (Math.Vec3.v (-5.) 2. 0.); 141 | spawn_disco_ball w (Math.Vec3.v 0. 5. 0.); 142 | World.add_system w Scheduler.Update spin; 143 | World.add_system w Scheduler.Update update_disco_balls 144 | 145 | let () = 146 | Random.self_init (); 147 | let app = 148 | App.create () 149 | |> App.add_plugin Input.plugin 150 | |> App.add_plugin Graphics.plugin 151 | |> App.add_plugin plugin 152 | in 153 | 154 | App.run app 155 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (public_names bounce disco first_person game_of_life move shapes spawn) 3 | (libraries camlcade plugin)) 4 | -------------------------------------------------------------------------------- /examples/first_person.ml: -------------------------------------------------------------------------------- 1 | (** First person camera example. 2 | 3 | The first-person camera logic is implemented by the [Plugin.Fp_camera] 4 | plugin. *) 5 | 6 | open Plugin 7 | open Camlcade 8 | open Ecs 9 | 10 | let plugin w = 11 | let _cuboid = 12 | World.add_entity w 13 | |> World.with_component w 14 | (module Graphics.Mesh3d.C) 15 | (Graphics.Primitive.to_mesh3d (Graphics.Primitive.Cuboid.create ())) 16 | |> World.with_component w (module Graphics.Shader.Normal.C) () 17 | in 18 | 19 | let _camera = 20 | World.add_entity w 21 | |> World.with_component w (module Graphics.Camera3d.C) () 22 | |> World.with_component w 23 | (module Graphics.Camera.Projection.C) 24 | (Graphics.Camera.Projection.perspective ()) 25 | |> World.with_component w (module Transform.C) (Transform.identity ()) 26 | |> World.with_component w (module Fp_camera.C) () 27 | in 28 | () 29 | 30 | let () = 31 | let app = 32 | App.create () 33 | |> App.add_plugin Input.plugin 34 | |> App.add_plugin Graphics.plugin 35 | |> App.add_plugin (Fp_camera.plugin ~fullscreen:true) 36 | |> App.add_plugin plugin 37 | in 38 | 39 | App.run app 40 | -------------------------------------------------------------------------------- /examples/game_of_life.ml: -------------------------------------------------------------------------------- 1 | open Camlcade 2 | open Ecs 3 | 4 | module Grid = struct 5 | type t = { dimension : int; mutable cells : bool array } 6 | 7 | let get t x y z = 8 | t.cells.((z * t.dimension * t.dimension) + (y * t.dimension) + x) 9 | 10 | let is_alive_at t x y z = 11 | try 12 | let v = get t x y z in 13 | v 14 | with _ -> false 15 | 16 | let count_neighbors t x y z = 17 | let count = ref 0 in 18 | for dx = -1 to 1 do 19 | for dy = -1 to 1 do 20 | for dz = -1 to 1 do 21 | if dx = 0 && dy = 0 && dz = 0 then () 22 | else 23 | let nx = x + dx in 24 | let ny = y + dy in 25 | let nz = z + dz in 26 | if is_alive_at t nx ny nz then count := !count + 1 27 | done 28 | done 29 | done; 30 | !count 31 | 32 | let init ?(dimension = 16) () = 33 | { 34 | dimension; 35 | cells = 36 | Array.init (dimension * dimension * dimension) (fun _ -> Random.bool ()); 37 | } 38 | 39 | let randomize t = 40 | t.cells <- Array.init (Array.length t.cells) (fun _ -> Random.bool ()) 41 | 42 | let step t = 43 | let new_cells = Array.copy t.cells in 44 | let set_new x y z v = 45 | Array.set new_cells 46 | ((z * t.dimension * t.dimension) + (y * t.dimension) + x) 47 | v 48 | in 49 | for x = 0 to t.dimension - 1 do 50 | for y = 0 to t.dimension - 1 do 51 | for z = 0 to t.dimension - 1 do 52 | let neighbors = count_neighbors t x y z in 53 | let is_alive = is_alive_at t x y z in 54 | if is_alive then (if neighbors < 13 then set_new x y z false) 55 | else if neighbors >= 14 && neighbors <= 19 then set_new x y z true 56 | else set_new x y z is_alive 57 | done 58 | done 59 | done; 60 | t.cells <- new_cells 61 | 62 | let update_vm t vertex_mesh = 63 | (* TODO: only add visible faces/vertices. *) 64 | let open Graphics in 65 | let data = ref [] in 66 | for x = 0 to t.dimension - 1 do 67 | for y = 0 to t.dimension - 1 do 68 | for z = 0 to t.dimension - 1 do 69 | let is_alive = is_alive_at t x y z in 70 | if is_alive then 71 | let cube = Primitive.Cuboid.create () in 72 | let rec shift = function 73 | | [] -> [] 74 | | px :: py :: pz :: nx :: ny :: nz :: rest -> 75 | (px +. float_of_int x -. (float_of_int t.dimension /. 2.)) 76 | :: (py +. float_of_int y -. (float_of_int t.dimension /. 2.)) 77 | :: (pz +. float_of_int z -. (float_of_int t.dimension /. 2.)) 78 | :: nx :: ny :: nz :: shift rest 79 | | _ -> failwith "Invalid list" 80 | in 81 | data := shift cube @ !data 82 | done 83 | done 84 | done; 85 | Vertex_mesh.set_data vertex_mesh (Array.of_list !data) 86 | 87 | module C = Component.Make (struct 88 | type inner = t 89 | end) 90 | end 91 | 92 | let step = 93 | let query w = 94 | let _, (keyboard, ()) = 95 | World.query w Query.[ Req (module Input.Keyboard.C) ] |> List.hd 96 | in 97 | let _, (grid, (mesh, ())) = 98 | World.query w 99 | Query.[ Req (module Grid.C); Req (module Graphics.Mesh3d.C) ] 100 | |> List.hd 101 | in 102 | (keyboard, grid, mesh) 103 | in 104 | let step (keyboard, grid, mesh) = 105 | let pressed = Input.Keyboard.is_pressed keyboard in 106 | if pressed `T then ( 107 | Grid.step grid; 108 | Grid.update_vm grid (Graphics.Mesh3d.vertex_mesh mesh); 109 | Graphics.Mesh3d.install mesh) 110 | else if pressed `R then ( 111 | Grid.randomize grid; 112 | Grid.update_vm grid (Graphics.Mesh3d.vertex_mesh mesh); 113 | Graphics.Mesh3d.install mesh) 114 | in 115 | System.make query (System.Query step) 116 | 117 | let spawn_grid w = 118 | let open Graphics in 119 | let grid = Grid.init () in 120 | let vm = Vertex_mesh.create ~topology:TriangleList () in 121 | Vertex_mesh.set_attribute vm 0 3; 122 | Vertex_mesh.set_attribute vm 1 3; 123 | World.add_entity w 124 | |> World.with_component w (module Grid.C) grid 125 | |> World.with_component w (module Transform.C) (Transform.identity ()) 126 | |> World.with_component w (module Mesh3d.C) (Mesh3d.of_vertex_mesh vm) 127 | |> World.with_component w 128 | (module Material.C) 129 | (Material.create ~ambient:(Math.Vec3.v 0. 0. 0.) ~shininess:0.1 ()) 130 | |> World.with_component w (module Shader.Phong.C) () 131 | |> ignore 132 | 133 | let plugin w = 134 | spawn_grid w; 135 | 136 | let _sun = 137 | World.add_entity w 138 | |> World.with_component w 139 | (module Graphics.Light.Directional.C) 140 | (Graphics.Light.Directional.create ~color:(Math.Vec3.v 1. 1. 1.) ()) 141 | |> World.with_component w (module Transform.C) (Transform.identity ()) 142 | in 143 | 144 | let _camera = 145 | World.add_entity w 146 | |> World.with_component w (module Graphics.Camera3d.C) () 147 | |> World.with_component w 148 | (module Graphics.Camera.Projection.C) 149 | (Graphics.Camera.Projection.orthographic ~left:(-15.) ~right:15. 150 | ~bottom:(-15.) ~top:15. ()) 151 | |> World.with_component w 152 | (module Transform.C) 153 | Transform.( 154 | identity () 155 | |> with_translation (Math.Vec3.v 8. 20. 25.) 156 | |> with_look_at Math.Vec3.zero) 157 | in 158 | World.add_system w Scheduler.Update step 159 | 160 | let () = 161 | Random.self_init (); 162 | let app = 163 | App.create () 164 | |> App.add_plugin Input.plugin 165 | |> App.add_plugin Graphics.plugin 166 | |> App.add_plugin plugin 167 | in 168 | 169 | App.run app 170 | -------------------------------------------------------------------------------- /examples/move.ml: -------------------------------------------------------------------------------- 1 | (** Move a ball up and down with the W and S keys. *) 2 | 3 | open Camlcade 4 | open Ecs 5 | 6 | module Ball = struct 7 | type t = unit 8 | 9 | module C = Component.Make (struct 10 | type inner = t 11 | end) 12 | end 13 | 14 | let move_ball = 15 | let query w = 16 | let transforms = 17 | World.query ~filter:(Query.Filter.With Ball.C.id) w 18 | Query.[ Req (module Transform.C) ] 19 | |> List.map (fun (_, (t, ())) -> t) 20 | in 21 | let _, (k, ()) = 22 | World.query w Query.[ Req (module Input.Keyboard.C) ] |> List.hd 23 | in 24 | (transforms, k) 25 | in 26 | let move (transforms, keyboard) = 27 | let w_pressed = Input.Keyboard.is_pressed keyboard `W in 28 | let s_pressed = Input.Keyboard.is_pressed keyboard `S in 29 | List.iter 30 | (fun transform -> 31 | let tx, ty, tz = Math.Vec3.to_tuple (Transform.translation transform) in 32 | if w_pressed then 33 | Transform.set_translation transform (Math.Vec3.v tx ty (tz -. 0.001)); 34 | if s_pressed then 35 | Transform.set_translation transform (Math.Vec3.v tx ty (tz +. 0.001))) 36 | transforms 37 | in 38 | System.make query (System.Query move) 39 | 40 | let plugin w = 41 | let _camera = 42 | World.add_entity w 43 | |> World.with_component w (module Graphics.Camera3d.C) () 44 | |> World.with_component w 45 | (module Graphics.Camera.Projection.C) 46 | (Graphics.Camera.Projection.perspective ()) 47 | |> World.with_component w 48 | (module Transform.C) 49 | Transform.( 50 | identity () 51 | |> with_translation (Math.Vec3.v 3. 3. 3.) 52 | |> with_look_at (Math.Vec3.v 0. 0. 0.)) 53 | in 54 | let add_ball w = 55 | World.add_entity w 56 | |> World.with_component w 57 | (module Graphics.Mesh3d.C) 58 | (Graphics.Primitive.to_mesh3d 59 | (Graphics.Primitive.Sphere.create ~param1:10 ~param2:10 ())) 60 | |> World.with_component w (module Transform.C) (Transform.identity ()) 61 | |> World.with_component w (module Graphics.Shader.Normal.C) () 62 | |> World.with_component w (module Ball.C) () 63 | in 64 | add_ball w |> ignore; 65 | 66 | World.add_system w Scheduler.Update move_ball 67 | 68 | let () = 69 | let app = 70 | App.create () 71 | |> App.add_plugin Input.plugin 72 | |> App.add_plugin Graphics.plugin 73 | |> App.add_plugin plugin 74 | in 75 | 76 | App.run app 77 | -------------------------------------------------------------------------------- /examples/plugin/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name plugin) 3 | (libraries camlcade)) 4 | -------------------------------------------------------------------------------- /examples/plugin/fp_camera.ml: -------------------------------------------------------------------------------- 1 | open Ecs 2 | 3 | module C = Component.Make (struct 4 | type inner = unit 5 | end) 6 | 7 | let handle_keyboard factor = 8 | let query w = 9 | let transforms = 10 | World.query ~filter:(Query.Filter.With C.id) w 11 | Query.[ Req (module Transform.C) ] 12 | |> List.map (fun (_, (t, ())) -> t) 13 | in 14 | let k = 15 | World.query w Query.[ Req (module Input.Keyboard.C) ] 16 | |> List.map (fun (_, (k, ())) -> k) 17 | in 18 | (transforms, match k with k :: _ -> Some k | _ -> None) 19 | in 20 | let calculate_move transform w a s d = 21 | let move = ref (Math.Vec3.v 0. 0. 0.) in 22 | let forward = Transform.forward transform in 23 | let up = Transform.local_y transform in 24 | if w then move := Math.Vec3.add !move forward; 25 | (if a then move := Math.Vec3.(sub !move (normalize (cross forward up)))); 26 | if s then move := Math.Vec3.sub !move forward; 27 | (if d then move := Math.Vec3.(add !move (normalize (cross forward up)))); 28 | Math.Vec3.normalize !move 29 | in 30 | let move (transforms, keyboard) = 31 | match keyboard with 32 | | Some keyboard -> 33 | let is_pressed = Input.Keyboard.is_pressed keyboard in 34 | let w = is_pressed `W in 35 | let a = is_pressed `A in 36 | let s = is_pressed `S in 37 | let d = is_pressed `D in 38 | let space = is_pressed `Space in 39 | let shift = is_pressed `Lshift in 40 | 41 | transforms 42 | |> List.iter (fun transform -> 43 | (* Handle WASD movement *) 44 | let delta = calculate_move transform w a s d in 45 | if Math.Vec3.norm delta > 0. then 46 | Transform.set_translation transform 47 | Math.Vec3.( 48 | add (Transform.translation transform) (smul factor delta)); 49 | 50 | (* Handle space and shift movement *) 51 | let x, y, z = 52 | Math.Vec3.to_tuple (Transform.translation transform) 53 | in 54 | if space then 55 | Transform.set_translation transform 56 | (Math.Vec3.v x (y +. factor) z); 57 | if shift then 58 | Transform.set_translation transform 59 | (Math.Vec3.v x (y -. factor) z)) 60 | | None -> () 61 | in 62 | System.make query (System.Query move) 63 | 64 | let handle_mouse sensitivity = 65 | let query w = 66 | let transforms = 67 | World.query ~filter:(Query.Filter.With C.id) w 68 | Query.[ Req (module Transform.C) ] 69 | |> List.map (fun (_, (t, ())) -> t) 70 | in 71 | let mm = 72 | World.query w Query.[ Req (module Input.Mouse.Motion_event.C) ] 73 | |> List.map (fun (_, (mm, ())) -> mm) 74 | in 75 | (transforms, match mm with mm :: _ -> Some mm | _ -> None) 76 | in 77 | let update_rotation motion transform = 78 | let yaw_axis = Math.Vec3.oy in 79 | let pitch_axis = Math.Vec3.ox in 80 | let dx = float_of_int (Input.Mouse.dx motion) in 81 | let dy = float_of_int (Input.Mouse.dy motion) in 82 | let yaw = -.dx *. sensitivity in 83 | let pitch = -.dy *. sensitivity in 84 | let new_rotation = 85 | Math.Quat.( 86 | mul (rot3_axis yaw_axis yaw) 87 | (mul (Transform.rotation transform) (rot3_axis pitch_axis pitch))) 88 | in 89 | Transform.set_rotation transform new_rotation 90 | in 91 | let move (transforms, mouse_motion) = 92 | match mouse_motion with 93 | | Some mouse_motion -> 94 | Input.Mouse.Motion_event.read mouse_motion 95 | |> List.iter (fun motion -> 96 | transforms |> List.iter (update_rotation motion)) 97 | | None -> () 98 | in 99 | System.make query (System.Query move) 100 | 101 | let set_fullscreen = 102 | System.make 103 | (fun w -> 104 | World.query w Query.[ Req (module Graphics.Context.C) ] 105 | |> List.map (fun (_, (c, ())) -> c)) 106 | (System.Query 107 | (List.iter (fun context -> 108 | Graphics.Context.set_window_fullscreen context 109 | Graphics.Context.Window.fullscreen; 110 | Graphics.Context.set_relative_mouse_mode true))) 111 | 112 | let plugin ?(mouse_sensitivity = 0.001) ?(move_factor = 0.001) 113 | ?(fullscreen = false) w = 114 | if fullscreen then World.add_system w Scheduler.Startup set_fullscreen; 115 | World.add_system w Scheduler.Update (handle_keyboard move_factor); 116 | World.add_system w Scheduler.Update (handle_mouse mouse_sensitivity) 117 | -------------------------------------------------------------------------------- /examples/plugin/fp_camera.mli: -------------------------------------------------------------------------------- 1 | (** A first person camera plugin. 2 | 3 | This plugin allows the user to move the camera using the keyboard and the 4 | mouse. To use this plugin, add [Fp_camera.C] to the camera entity and add 5 | the [Fp_camera.plugin] to the app. *) 6 | 7 | module C : Ecs.Component.S with type t = unit 8 | 9 | val plugin : 10 | ?mouse_sensitivity:float -> 11 | ?move_factor:float -> 12 | ?fullscreen:bool -> 13 | Ecs.World.t -> 14 | unit 15 | -------------------------------------------------------------------------------- /examples/shapes.ml: -------------------------------------------------------------------------------- 1 | (** Demonstrate the various primitive shapes. *) 2 | 3 | open Camlcade 4 | open Ecs 5 | 6 | (** Marker component for shapes. *) 7 | module Shape = struct 8 | type t = unit 9 | 10 | module C = Component.Make (struct 11 | type inner = t 12 | end) 13 | end 14 | 15 | let rotate = 16 | let query w = 17 | let transforms = 18 | World.query ~filter:(Query.Filter.With Shape.C.id) w 19 | Query.[ Req (module Transform.C) ] 20 | |> List.map (fun (_, (t, ())) -> t) 21 | in 22 | transforms 23 | in 24 | let rotate = 25 | List.iter (fun t -> 26 | Transform.set_rotation t 27 | (Math.Quat.rot3_zyx (Math.Vec3.v 0.0 (Unix.gettimeofday ()) 0.0))) 28 | in 29 | System.make query (System.Query rotate) 30 | 31 | let add_shape w primitive x y z = 32 | World.add_entity w 33 | |> World.with_component w 34 | (module Graphics.Mesh3d.C) 35 | (Graphics.Primitive.to_mesh3d primitive) 36 | |> World.with_component w 37 | (module Transform.C) 38 | Transform.(of_xyz x y z |> with_scale (Math.Vec3.v 1.3 1.3 1.3)) 39 | |> World.with_component w (module Graphics.Shader.Normal.C) () 40 | |> World.with_component w (module Shape.C) () 41 | 42 | let add_camera w = 43 | World.add_entity w 44 | |> World.with_component w (module Graphics.Camera3d.C) () 45 | |> World.with_component w 46 | (module Graphics.Camera.Projection.C) 47 | (Graphics.Camera.Projection.perspective () ~height_angle:(Float.pi /. 4.)) 48 | |> World.with_component w 49 | (module Transform.C) 50 | Transform.( 51 | identity () 52 | |> with_translation (Math.Vec3.v 0. 7. 14.) 53 | |> with_look_at (Math.Vec3.v 0. 0. 0.)) 54 | 55 | let plugin w = 56 | add_camera w |> ignore; 57 | (* TODO: Use more interesting primitives *) 58 | let primitives = 59 | [ 60 | Graphics.Primitive.Sphere.create ~param1:2 ~param2:2 (); 61 | Graphics.Primitive.Sphere.create ~param1:4 ~param2:4 (); 62 | Graphics.Primitive.Sphere.create ~param1:8 ~param2:8 (); 63 | Graphics.Primitive.Sphere.create ~param1:16 ~param2:16 (); 64 | Graphics.Primitive.Cuboid.create ~param1:16 (); 65 | ] 66 | in 67 | let x_extent = 14.0 in 68 | let step = x_extent /. Float.of_int (List.length primitives) in 69 | List.iteri 70 | (fun i primitive -> 71 | add_shape w primitive ((Float.of_int i *. step) -. (x_extent /. 2.)) 0. 0. 72 | |> ignore) 73 | primitives; 74 | 75 | World.add_system w Scheduler.Update rotate 76 | 77 | let () = 78 | let app = 79 | App.create () 80 | |> App.add_plugin Input.plugin 81 | |> App.add_plugin Graphics.plugin 82 | |> App.add_plugin plugin 83 | in 84 | 85 | App.run app 86 | -------------------------------------------------------------------------------- /examples/spawn.ml: -------------------------------------------------------------------------------- 1 | (** Spawn random balls on left click. *) 2 | 3 | open Camlcade 4 | open Ecs 5 | 6 | let add_random_ball w = 7 | World.add_entity w 8 | |> World.with_component w 9 | (module Graphics.Mesh3d.C) 10 | (Graphics.Primitive.to_mesh3d 11 | (Graphics.Primitive.Sphere.create ~param1:20 ~param2:20 ())) 12 | |> World.with_component w 13 | (module Transform.C) 14 | Transform.( 15 | identity () 16 | |> with_translation 17 | (Math.Vec3.v 18 | (Random.float 10. -. 5.) 19 | (Random.float 10. -. 5.) 20 | (Random.float 10. -. 5.)) 21 | |> with_scale 22 | (Math.Vec3.v (Random.float 2.) (Random.float 2.) (Random.float 2.))) 23 | |> World.with_component w (module Graphics.Shader.Normal.C) () 24 | |> ignore 25 | 26 | let handle_spawn = 27 | let query w = 28 | let _, (mb, ()) = 29 | World.query w Query.[ Req (module Input.Mouse.Button.C) ] |> List.hd 30 | in 31 | mb 32 | in 33 | let spawn world mouse_button = 34 | if Input.Mouse.Button.is_just_pressed mouse_button `Left then ( 35 | print_endline 36 | (Printf.sprintf "%f: Spawned a random ball!" (Unix.gettimeofday ())); 37 | add_random_ball world) 38 | in 39 | System.make query (System.Immediate spawn) 40 | 41 | let add_camera w = 42 | World.add_entity w 43 | |> World.with_component w (module Graphics.Camera3d.C) () 44 | |> World.with_component w 45 | (module Graphics.Camera.Projection.C) 46 | (Graphics.Camera.Projection.perspective ()) 47 | |> World.with_component w 48 | (module Transform.C) 49 | Transform.( 50 | identity () 51 | |> with_translation (Math.Vec3.v 0. 7. 14.) 52 | |> with_look_at (Math.Vec3.v 0. 0. 0.)) 53 | 54 | let plugin w = 55 | add_camera w |> ignore; 56 | 57 | (* TODO: Use more interesting primitives *) 58 | World.add_system w Scheduler.Update handle_spawn 59 | 60 | let () = 61 | Random.self_init (); 62 | let app = 63 | App.create () 64 | |> App.add_plugin Input.plugin 65 | |> App.add_plugin Graphics.plugin 66 | |> App.add_plugin plugin 67 | in 68 | 69 | App.run app 70 | -------------------------------------------------------------------------------- /lib/app.ml: -------------------------------------------------------------------------------- 1 | open Ecs 2 | 3 | type t = { world : World.t; plugins : (World.t -> unit) list } 4 | 5 | let create () = { world = World.create (); plugins = [] } 6 | let add_plugin p a = { a with plugins = p :: a.plugins } 7 | 8 | let run a = 9 | let w = 10 | List.fold_right 11 | (fun p w -> 12 | p w; 13 | w) 14 | a.plugins a.world 15 | in 16 | World.run_systems w Scheduler.Startup; 17 | (* TODO: Run main loop *) 18 | while not (World.has_quit w) do 19 | World.run_systems w Scheduler.Update 20 | done; 21 | World.run_systems w Scheduler.Last 22 | -------------------------------------------------------------------------------- /lib/app.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val create : unit -> t 4 | val add_plugin : (Ecs.World.t -> unit) -> t -> t 5 | val run : t -> unit 6 | -------------------------------------------------------------------------------- /lib/camlcade.ml: -------------------------------------------------------------------------------- 1 | module App = App 2 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name camlcade) 3 | (public_name camlcade) 4 | (libraries ecs math graphics input storage)) 5 | -------------------------------------------------------------------------------- /lib/ecs/archetype.ml: -------------------------------------------------------------------------------- 1 | open Storage 2 | 3 | let calculate_hash l = 4 | (* Convert to a string first rather than operate on the list directly 5 | since Hashtbl.hash stops iterating through a list after 10 elements *) 6 | l |> List.sort compare 7 | |> List.map (fun v -> v |> Id.Component.to_int |> string_of_int) 8 | |> String.concat "" |> Hashtbl.hash 9 | 10 | type operation = Add of Id.Component.t | Remove of Id.Component.t 11 | 12 | type t = { 13 | components : Id.ComponentSet.t; 14 | hash : int; 15 | (* table[component.id][entity.id] = entity's component *) 16 | table : Component.packed Sparse_set.t Sparse_set.t; 17 | add_hashes : (Id.Component.t, int) Hashtbl.t; 18 | remove_hashes : (Id.Component.t, int) Hashtbl.t; 19 | mutable entities : Id.EntitySet.t; 20 | } 21 | 22 | let create components = 23 | let table = Sparse_set.create () in 24 | Id.ComponentSet.iter 25 | (fun cid -> 26 | Sparse_set.set table (Id.Component.to_int cid) (Sparse_set.create ())) 27 | components; 28 | { 29 | components; 30 | hash = calculate_hash (Id.ComponentSet.to_list components); 31 | table; 32 | add_hashes = Hashtbl.create 0; 33 | remove_hashes = Hashtbl.create 0; 34 | entities = Id.EntitySet.empty; 35 | } 36 | 37 | let empty () = create Id.ComponentSet.empty 38 | let hash a = a.hash 39 | let components a = a.components 40 | let entities a = a.entities 41 | 42 | let query a eid cid = 43 | let eid = Id.Entity.to_int eid in 44 | let cid = Id.Component.to_int cid in 45 | Option.bind (Sparse_set.get a.table cid) (fun c -> Sparse_set.get c eid) 46 | 47 | let remove a eid = 48 | let remove () = a.entities <- Id.EntitySet.remove eid a.entities in 49 | let eid = Id.Entity.to_int eid in 50 | a.components 51 | |> Id.ComponentSet.iter (fun cid -> 52 | let cid = Id.Component.to_int cid in 53 | match Sparse_set.get a.table cid with 54 | | None -> failwith "invariant violated, table missing component" 55 | | Some c -> Sparse_set.remove c eid |> ignore); 56 | remove () 57 | 58 | let add a eid components = 59 | let add () = a.entities <- Id.EntitySet.add eid a.entities in 60 | let eid = Id.Entity.to_int eid in 61 | let validate_components l = 62 | Id.ComponentSet.equal a.components 63 | (l |> List.map Component.id |> Id.ComponentSet.of_list) 64 | in 65 | if not (validate_components components) then 66 | invalid_arg "tried to add foreign component"; 67 | 68 | components 69 | |> List.iter (fun comp -> 70 | let cid = Id.Component.to_int (Component.id comp) in 71 | match Sparse_set.get a.table cid with 72 | | None -> failwith "invariant violated, table missing component" 73 | | Some c -> Sparse_set.set c eid comp); 74 | add () 75 | 76 | let replace a eid component = 77 | let eid = Id.Entity.to_int eid in 78 | let cid = Id.Component.to_int (Component.id component) in 79 | match Sparse_set.get a.table cid with 80 | | None -> invalid_arg "component not found" 81 | | Some c -> Sparse_set.set c eid component 82 | 83 | let next_hash a op = 84 | let find_or_compute tbl key compute = 85 | match Hashtbl.find_opt tbl key with 86 | | Some h -> h 87 | | None -> 88 | let h = compute () in 89 | Hashtbl.add tbl key h; 90 | h 91 | in 92 | match op with 93 | | Add cid -> 94 | if Id.ComponentSet.mem cid a.components then a.hash 95 | else 96 | find_or_compute a.add_hashes cid (fun () -> 97 | calculate_hash 98 | (Id.ComponentSet.to_list (Id.ComponentSet.add cid a.components))) 99 | | Remove cid -> 100 | if not (Id.ComponentSet.mem cid a.components) then a.hash 101 | else 102 | find_or_compute a.remove_hashes cid (fun () -> 103 | calculate_hash 104 | (Id.ComponentSet.to_list 105 | (Id.ComponentSet.remove cid a.components))) 106 | -------------------------------------------------------------------------------- /lib/ecs/archetype.mli: -------------------------------------------------------------------------------- 1 | (** Archetype storage and manipulation. *) 2 | 3 | (** Indicate an operation to add or remove a component. *) 4 | type operation = Add of Id.Component.t | Remove of Id.Component.t 5 | 6 | type t 7 | 8 | val create : Id.ComponentSet.t -> t 9 | (** Creates a new archetype with the given components. *) 10 | 11 | val empty : unit -> t 12 | (** Creates an archetype with no components. *) 13 | 14 | val hash : t -> int 15 | (** Returns the hash of the archetype. *) 16 | 17 | val components : t -> Id.ComponentSet.t 18 | (** Returns the components of the archetype. *) 19 | 20 | val entities : t -> Id.EntitySet.t 21 | (** Returns the entities in the archetype. *) 22 | 23 | val query : t -> Id.Entity.t -> Id.Component.t -> Component.packed option 24 | (** Queries the archetype for an entity's component. If the entity does not have 25 | the component, returns [None]. *) 26 | 27 | val remove : t -> Id.Entity.t -> unit 28 | (** Removes an entity from the archetype. No change if the entity is not in the 29 | archetype. *) 30 | 31 | val add : t -> Id.Entity.t -> Component.packed list -> unit 32 | (** Adds an entity to the archetype with the given components. The components 33 | must match the archetype's components exactly. *) 34 | 35 | val replace : t -> Id.Entity.t -> Component.packed -> unit 36 | (** Replaces an entity's component in the archetype. The entity must already be 37 | in the archetype and the component be one of the archetype's components. *) 38 | 39 | val next_hash : t -> operation -> int 40 | (** Returns the hash of the archetype after the given operation. Caches results 41 | for future calls. *) 42 | -------------------------------------------------------------------------------- /lib/ecs/component.ml: -------------------------------------------------------------------------------- 1 | type base = .. 2 | 3 | module type S = sig 4 | type t 5 | 6 | val id : Id.Component.t 7 | val of_base : base -> t 8 | val of_base_opt : base -> t option 9 | val to_base : t -> base 10 | end 11 | 12 | module Make (B : sig 13 | type inner 14 | end) : S with type t = B.inner = struct 15 | include B 16 | 17 | type t = inner 18 | type base += T of t 19 | 20 | let id = Id.Component.next () 21 | let of_base = function T t -> t | _ -> failwith "Invalid component" 22 | let of_base_opt = function T t -> Some t | _ -> None 23 | let to_base t = T t 24 | end 25 | 26 | (* A component that doesn't have any data. 27 | Mainly used for optional components in a query result *) 28 | module None = struct 29 | type t = unit 30 | 31 | module C = Make (struct 32 | type inner = t 33 | end) 34 | end 35 | 36 | type packed = Packed : (module S with type t = 'a) * 'a -> packed 37 | 38 | let pack : type a. (module S with type t = a) -> a -> packed = 39 | fun component value -> Packed (component, value) 40 | 41 | let unpack : type a. (module S with type t = a) -> packed -> a = 42 | fun (module C) (Packed ((module C'), value)) -> C.of_base (C'.to_base value) 43 | 44 | let unpack_opt : type a. (module S with type t = a) -> packed -> a option = 45 | fun (module C) (Packed ((module C'), value)) -> 46 | C.of_base_opt (C'.to_base value) 47 | 48 | let id : packed -> Id.Component.t = function Packed ((module C), _) -> C.id 49 | -------------------------------------------------------------------------------- /lib/ecs/component.mli: -------------------------------------------------------------------------------- 1 | (** Defines components. *) 2 | 3 | (** {1:components Components} *) 4 | 5 | type base 6 | (** Extensible variant type for components. 7 | 8 | This should only be used internally. *) 9 | 10 | (** Signature for a component. *) 11 | module type S = sig 12 | type t 13 | (** The internal data of the component. *) 14 | 15 | val id : Id.Component.t 16 | (** Unique identifier for the component. *) 17 | 18 | val of_base : base -> t 19 | (** Convert a {!Ecs.Component.base} to a component. *) 20 | 21 | val of_base_opt : base -> t option 22 | (** Convert a {!Ecs.Component.base} to a component, returning [None] if the 23 | base is not valid. *) 24 | 25 | val to_base : t -> base 26 | (** Convert a component to a {!Ecs.Component.base}. *) 27 | end 28 | 29 | (** Create a new component module. *) 30 | module Make (B : sig 31 | type inner 32 | end) : S with type t = B.inner 33 | 34 | (** A component that doesn't have any data. Mainly used for optional components 35 | in a query result. *) 36 | module None : sig 37 | type t = unit 38 | 39 | module C : S with type t = t 40 | end 41 | 42 | (** {1:packed Packed} *) 43 | 44 | type packed 45 | (** A type-erased component. 46 | 47 | This is used to store components, possibly of different types, in a 48 | container. *) 49 | 50 | val pack : 'a. (module S with type t = 'a) -> 'a -> packed 51 | (** [pack c v] packs the component value [v] of module [c]. *) 52 | 53 | val unpack : 'a. (module S with type t = 'a) -> packed -> 'a 54 | (** [unpack c p] unpacks the component [p] to the module [c]'s inner type. *) 55 | 56 | val unpack_opt : 'a. (module S with type t = 'a) -> packed -> 'a option 57 | (** [unpack_opt c p] unpacks the component [p] to the module [c], returning 58 | [None] if the component is not of the correct type. *) 59 | 60 | val id : packed -> Id.Component.t 61 | (** [id p] returns the unique identifier of the packed component [p]. *) 62 | -------------------------------------------------------------------------------- /lib/ecs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name camlcade.ecs) 3 | (name ecs) 4 | (libraries math storage)) 5 | -------------------------------------------------------------------------------- /lib/ecs/event.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type event 3 | type t 4 | 5 | val empty : unit -> t 6 | val clear : t -> unit -> unit 7 | val read : t -> event list 8 | val write : t -> event -> unit 9 | 10 | module C : Component.S with type t = t 11 | 12 | val querier : World.t -> t 13 | val clear_system : World.t System.t 14 | end 15 | 16 | module Make (B : sig 17 | type t 18 | end) : S with type event = B.t = struct 19 | type event = B.t 20 | type t = event list ref 21 | 22 | let empty () = ref [] 23 | let clear t () = t := [] 24 | let read t = List.rev !t 25 | let write t e = t := e :: !t 26 | 27 | module C = Component.Make (struct 28 | type inner = t 29 | end) 30 | 31 | let querier w = 32 | let _, (t, ()) = World.query w Query.[ Req (module C) ] |> List.hd in 33 | t 34 | 35 | let clear_system = 36 | let clear t = clear t () in 37 | System.make querier (System.Query clear) 38 | end 39 | -------------------------------------------------------------------------------- /lib/ecs/event.mli: -------------------------------------------------------------------------------- 1 | (** Make a component for managing events. *) 2 | 3 | module type S = sig 4 | type event 5 | type t 6 | 7 | val empty : unit -> t 8 | (** Create an empty event list. *) 9 | 10 | val clear : t -> unit -> unit 11 | (** Clear all events. *) 12 | 13 | val read : t -> event list 14 | (** Get a list of all events, from oldest to newest. *) 15 | 16 | val write : t -> event -> unit 17 | (** Write an event to the event list. *) 18 | 19 | module C : Component.S with type t = t 20 | 21 | val querier : World.t -> t 22 | (** Querier uses a querier to get a single event component. 23 | 24 | This will panic if there are multiple event components. *) 25 | 26 | val clear_system : World.t System.t 27 | (** System that clears all events. Should be called after events are read. *) 28 | end 29 | 30 | module Make (B : sig 31 | type t 32 | end) : S with type event = B.t 33 | -------------------------------------------------------------------------------- /lib/ecs/id.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | 4 | val next : unit -> t 5 | val compare : t -> t -> int 6 | val of_int : int -> t 7 | val to_int : t -> int 8 | end 9 | 10 | module Make () : S = struct 11 | type t = int 12 | 13 | let current = ref 0 14 | 15 | let next () : t = 16 | incr current; 17 | !current 18 | 19 | let compare = compare 20 | let of_int i = i 21 | let to_int i = i 22 | end 23 | 24 | module Component = Make () 25 | module Entity = Make () 26 | module ComponentSet = Set.Make (Component) 27 | module EntitySet = Set.Make (Entity) 28 | -------------------------------------------------------------------------------- /lib/ecs/id.mli: -------------------------------------------------------------------------------- 1 | (** Incremental identifiers. *) 2 | 3 | (** A module type for incremental identifiers. *) 4 | module type S = sig 5 | type t 6 | 7 | val next : unit -> t 8 | val compare : t -> t -> int 9 | val of_int : int -> t 10 | val to_int : t -> int 11 | end 12 | 13 | module Component : S 14 | (** Incremental identifier for components. *) 15 | 16 | module Entity : S 17 | (** Incremental identifier for entities. *) 18 | 19 | module ComponentSet : Set.S with type elt = Component.t 20 | (** Set of component identifiers. *) 21 | 22 | module EntitySet : Set.S with type elt = Entity.t 23 | (** Set of entity identifiers. *) 24 | -------------------------------------------------------------------------------- /lib/ecs/query.ml: -------------------------------------------------------------------------------- 1 | module Filter = struct 2 | type t = 3 | | With of Id.Component.t 4 | | Without of Id.Component.t 5 | | Not of t 6 | | And of t * t 7 | | Or of t * t 8 | | Wildcard 9 | 10 | let matches f components = 11 | let rec aux f components = 12 | match f with 13 | | With c -> Id.ComponentSet.mem c components 14 | | Without c -> not (Id.ComponentSet.mem c components) 15 | | Not f -> not (aux f components) 16 | | And (f1, f2) -> aux f1 components && aux f2 components 17 | | Or (f1, f2) -> aux f1 components || aux f2 components 18 | | Wildcard -> true 19 | in 20 | aux f components 21 | end 22 | 23 | type _ term = 24 | | Req : (module Component.S with type t = 'a) -> 'a term 25 | | Opt : (module Component.S with type t = 'a) -> 'a option term 26 | 27 | type _ t = [] : unit t | ( :: ) : 'a term * 'b t -> ('a * 'b) t 28 | 29 | let rec required_ids : type a. a t -> _ = function 30 | | [] -> Id.ComponentSet.empty 31 | | Req (module C) :: rest -> Id.ComponentSet.add C.id (required_ids rest) 32 | | Opt (module C) :: rest -> required_ids rest 33 | 34 | let evaluate : type a. 35 | ?filter:Filter.t -> a t -> Archetype.t list -> (Id.Entity.t * a) list = 36 | fun ?(filter = Filter.Wildcard) query archetypes -> 37 | let rec fetch : type a. a t -> Archetype.t -> Id.Entity.t -> a = 38 | fun q a e -> 39 | let get_component = Archetype.query a e in 40 | match q with 41 | | [] -> () 42 | | Req (module C) :: rest -> 43 | let c = 44 | get_component C.id |> Option.get |> Component.unpack (module C) 45 | in 46 | (c, fetch rest a e) 47 | | Opt (module C) :: rest -> 48 | (* TODO: Rethink this maybe *) 49 | let c = 50 | get_component C.id 51 | |> Option.value ~default:(Component.pack (module Component.None.C) ()) 52 | |> Component.unpack_opt (module C) 53 | in 54 | (c, fetch rest a e) 55 | in 56 | let required_ids = required_ids query in 57 | let is_candidate a = 58 | Id.ComponentSet.subset required_ids (Archetype.components a) 59 | && Filter.matches filter (Archetype.components a) 60 | in 61 | 62 | let build_result a = 63 | Archetype.entities a |> Id.EntitySet.to_list 64 | |> List.map (fun e -> (e, fetch query a e)) 65 | in 66 | 67 | archetypes |> List.filter is_candidate |> List.concat_map build_result 68 | -------------------------------------------------------------------------------- /lib/ecs/query.mli: -------------------------------------------------------------------------------- 1 | (** Construct and evaluate queries. *) 2 | 3 | (** A filter that can be used to filter entities based on their components. *) 4 | module Filter : sig 5 | type t = 6 | | With of Id.Component.t 7 | | Without of Id.Component.t 8 | | Not of t 9 | | And of t * t 10 | | Or of t * t 11 | | Wildcard 12 | 13 | val matches : t -> Id.ComponentSet.t -> bool 14 | (** Returns true if the given component set matches the filter. *) 15 | end 16 | 17 | (** A query term that can be used to construct queries. *) 18 | type 'a term = 19 | | Req : (module Component.S with type t = 'a) -> 'a term 20 | (** A required component must be present in an entity. *) 21 | | Opt : (module Component.S with type t = 'a) -> 'a option term 22 | (** An optional component will be None if an entity does not have it. *) 23 | 24 | (** The type of a query. *) 25 | type 'a t = [] : unit t | ( :: ) : 'a term * 'b t -> ('a * 'b) t 26 | 27 | val required_ids : 'a t -> Id.ComponentSet.t 28 | (** Returns the set of required component IDs for the given query. *) 29 | 30 | val evaluate : 31 | ?filter:Filter.t -> 'a t -> Archetype.t list -> (Id.Entity.t * 'a) list 32 | (** Evaluates the given query on the given archetypes. *) 33 | -------------------------------------------------------------------------------- /lib/ecs/scheduler.ml: -------------------------------------------------------------------------------- 1 | type schedule = Startup | Update | Last 2 | 3 | type 'a t = { 4 | mutable startup : 'a list; 5 | mutable update : 'a list; 6 | mutable last : 'a list; 7 | } 8 | 9 | let create () = { startup = []; update = []; last = [] } 10 | 11 | let register s schedule v = 12 | match schedule with 13 | | Startup -> s.startup <- v :: s.startup 14 | | Update -> s.update <- v :: s.update 15 | | Last -> s.last <- v :: s.last 16 | 17 | let fetch s schedule = 18 | (match schedule with 19 | | Startup -> s.startup 20 | | Update -> s.update 21 | | Last -> s.last) 22 | |> List.rev 23 | -------------------------------------------------------------------------------- /lib/ecs/scheduler.mli: -------------------------------------------------------------------------------- 1 | type schedule = Startup | Update | Last 2 | type 'a t 3 | 4 | val create : unit -> 'a t 5 | val register : 'a t -> schedule -> 'a -> unit 6 | val fetch : 'a t -> schedule -> 'a list 7 | -------------------------------------------------------------------------------- /lib/ecs/system.ml: -------------------------------------------------------------------------------- 1 | type ('world, 'a) operation = 2 | | Query of ('a -> unit) 3 | | Immediate of ('world -> 'a -> unit) 4 | 5 | type ('world, 'a) t' = { 6 | querier : 'world -> 'a; 7 | operation : ('world, 'a) operation; 8 | } 9 | 10 | type 'world t = System : ('world, 'a) t' -> 'world t 11 | 12 | let make querier operation = System { querier; operation } 13 | let task operation = System { querier = (fun _ -> ()); operation } 14 | 15 | let run world (System { querier = q; operation = op }) = 16 | match op with Query f -> f (q world) | Immediate f -> f world (q world) 17 | -------------------------------------------------------------------------------- /lib/ecs/system.mli: -------------------------------------------------------------------------------- 1 | (** Define systems that query and operate on the world. *) 2 | 3 | (** An operation that can be performed on the world. *) 4 | type ('world, 'a) operation = 5 | | Query of ('a -> unit) 6 | | Immediate of ('world -> 'a -> unit) 7 | 8 | type 'world t 9 | (** The type of a system. *) 10 | 11 | val make : ('world -> 'a) -> ('world, 'a) operation -> 'world t 12 | (** Make a system from a querier and an operation. *) 13 | 14 | val task : ('world, unit) operation -> 'world t 15 | (** Make a system that does not query the world. *) 16 | 17 | val run : 'world -> 'world t -> unit 18 | (** Run a system on the world. *) 19 | -------------------------------------------------------------------------------- /lib/ecs/world.ml: -------------------------------------------------------------------------------- 1 | module ArchetypeHashSet = Set.Make (Int) 2 | 3 | type t = { 4 | empty_archetype : Archetype.t; 5 | archetype_index : (int, Archetype.t) Hashtbl.t; 6 | entity_index : (Id.Entity.t, int) Hashtbl.t; 7 | component_index : (Id.Component.t, ArchetypeHashSet.t) Hashtbl.t; 8 | scheduler : t System.t Scheduler.t; 9 | mutable quit : bool; 10 | } 11 | 12 | let create () = 13 | let archetype_index = Hashtbl.create 0 in 14 | let empty_archetype = Archetype.empty () in 15 | Hashtbl.add archetype_index (Archetype.hash empty_archetype) empty_archetype; 16 | { 17 | empty_archetype; 18 | archetype_index; 19 | entity_index = Hashtbl.create 0; 20 | component_index = Hashtbl.create 0; 21 | scheduler = Scheduler.create (); 22 | quit = false; 23 | } 24 | 25 | let get_archetype w entity = 26 | Hashtbl.find w.archetype_index (Hashtbl.find w.entity_index entity) 27 | 28 | let add_entity w = 29 | let entity = Id.Entity.next () in 30 | Hashtbl.add w.entity_index entity (Archetype.hash w.empty_archetype); 31 | Archetype.add w.empty_archetype entity []; 32 | entity 33 | 34 | let remove_entity w entity = 35 | let arch = get_archetype w entity in 36 | Archetype.remove arch entity; 37 | Hashtbl.remove w.entity_index entity 38 | (* TODO: Should we remove the archetype if it's empty? i.e. should it be 39 | removed from the archetype index and/or its hash be removed from component index? *) 40 | 41 | let entities w = w.entity_index |> Hashtbl.to_seq_keys |> List.of_seq 42 | 43 | let get_new_archetype w old_arch operation = 44 | let next_hash = Archetype.next_hash old_arch operation in 45 | match Hashtbl.find_opt w.archetype_index next_hash with 46 | | Some a -> a 47 | | None -> 48 | let cid, operation = 49 | match operation with 50 | | Archetype.Add cid -> (cid, Id.ComponentSet.add) 51 | | Archetype.Remove cid -> (cid, Id.ComponentSet.remove) 52 | in 53 | let a = 54 | Archetype.create (operation cid (Archetype.components old_arch)) 55 | in 56 | Hashtbl.add w.archetype_index next_hash a; 57 | a 58 | 59 | let extract_from_archetype arch entity components = 60 | let l = 61 | components |> Id.ComponentSet.to_list 62 | |> List.map (fun cid -> Archetype.query arch entity cid |> Option.get) 63 | in 64 | Archetype.remove arch entity; 65 | l 66 | 67 | let update_component_index w arch = 68 | let operation = 69 | if Id.EntitySet.is_empty (Archetype.entities arch) then 70 | ArchetypeHashSet.remove 71 | else ArchetypeHashSet.add 72 | in 73 | Archetype.components arch 74 | |> Id.ComponentSet.iter (fun cid -> 75 | let arch_set = 76 | Option.value 77 | (Hashtbl.find_opt w.component_index cid) 78 | ~default:ArchetypeHashSet.empty 79 | in 80 | Hashtbl.replace w.component_index cid 81 | (operation (Archetype.hash arch) arch_set)) 82 | 83 | let add_component w component entity = 84 | let old_arch = get_archetype w entity in 85 | let new_arch = 86 | get_new_archetype w old_arch (Archetype.Add (Component.id component)) 87 | in 88 | if Archetype.hash old_arch = Archetype.hash new_arch then 89 | Archetype.replace old_arch entity component 90 | else ( 91 | Hashtbl.replace w.entity_index entity (Archetype.hash new_arch); 92 | Archetype.add new_arch entity 93 | (component 94 | :: extract_from_archetype old_arch entity (Archetype.components old_arch) 95 | ); 96 | update_component_index w old_arch; 97 | update_component_index w new_arch) 98 | 99 | let with_component : type a. 100 | t -> (module Component.S with type t = a) -> a -> Id.Entity.t -> Id.Entity.t 101 | = 102 | fun w (module C) component entity -> 103 | add_component w (Component.pack (module C) component) entity; 104 | entity 105 | 106 | let remove_component w component_id entity = 107 | let old_arch = get_archetype w entity in 108 | let new_arch = get_new_archetype w old_arch (Archetype.Remove component_id) in 109 | if Archetype.hash old_arch = Archetype.hash new_arch then () 110 | else 111 | let components = 112 | extract_from_archetype old_arch entity (Archetype.components new_arch) 113 | in 114 | Archetype.add new_arch entity components; 115 | Hashtbl.replace w.entity_index entity (Archetype.hash new_arch); 116 | update_component_index w old_arch; 117 | update_component_index w new_arch 118 | 119 | let get_component w entity component = 120 | try 121 | let archetype = get_archetype w entity in 122 | Archetype.query archetype entity component 123 | with Not_found -> None 124 | 125 | let add_system w schedule system = 126 | Scheduler.register w.scheduler schedule system 127 | 128 | let query ?(filter = Query.Filter.Wildcard) w (query : 'a Query.t) = 129 | let required_ids = Query.required_ids query in 130 | let intersection_opt acc c = 131 | let set = 132 | match Hashtbl.find_opt w.component_index c with 133 | | Some set -> set 134 | | None -> ArchetypeHashSet.empty 135 | in 136 | match acc with 137 | | Some acc -> Some (ArchetypeHashSet.inter acc set) 138 | | None -> Some set 139 | in 140 | let candidate_archetypes = 141 | if Id.ComponentSet.is_empty required_ids then 142 | (* There are no required components, so the candidate archetypes is the set of all archetypes *) 143 | Hashtbl.to_seq_values w.archetype_index |> List.of_seq 144 | else 145 | (* There are required components, so the candidate archetypes is the intersection of the sets 146 | of archetypes that contain each required component *) 147 | (* TODO: Check this *) 148 | required_ids |> Id.ComponentSet.to_list 149 | |> List.fold_left intersection_opt None 150 | |> Option.value ~default:ArchetypeHashSet.empty 151 | |> ArchetypeHashSet.to_list 152 | |> List.map (Hashtbl.find w.archetype_index) 153 | in 154 | Query.evaluate ~filter query candidate_archetypes 155 | 156 | exception Quit 157 | 158 | let run_systems w schedule = 159 | let run_system system = 160 | try System.run w system with Quit -> w.quit <- true 161 | in 162 | Scheduler.fetch w.scheduler schedule |> List.iter run_system 163 | 164 | let has_quit w = w.quit 165 | -------------------------------------------------------------------------------- /lib/ecs/world.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val create : unit -> t 4 | 5 | (* Entities *) 6 | val add_entity : t -> Id.Entity.t 7 | val remove_entity : t -> Id.Entity.t -> unit 8 | val entities : t -> Id.Entity.t list 9 | 10 | (* Components *) 11 | val add_component : t -> Component.packed -> Id.Entity.t -> unit 12 | 13 | val with_component : 14 | 'a. 15 | t -> (module Component.S with type t = 'a) -> 'a -> Id.Entity.t -> Id.Entity.t 16 | 17 | val remove_component : t -> Id.Component.t -> Id.Entity.t -> unit 18 | 19 | val get_component : 20 | t -> Id.Entity.t -> Id.Component.t -> Component.packed option 21 | 22 | (* Systems *) 23 | val query : ?filter:Query.Filter.t -> t -> 'a Query.t -> (Id.Entity.t * 'a) list 24 | val add_system : t -> Scheduler.schedule -> t System.t -> unit 25 | val run_systems : t -> Scheduler.schedule -> unit 26 | 27 | exception Quit 28 | 29 | val has_quit : t -> bool 30 | -------------------------------------------------------------------------------- /lib/graphics/camera/camera.ml: -------------------------------------------------------------------------------- 1 | module Projection = Projection 2 | 3 | module Camera3d = struct 4 | type t = unit 5 | 6 | module C = Ecs.Component.Make (struct 7 | type inner = t 8 | end) 9 | end 10 | -------------------------------------------------------------------------------- /lib/graphics/camera/camera.mli: -------------------------------------------------------------------------------- 1 | module Projection = Projection 2 | 3 | module Camera3d : sig 4 | type t = unit 5 | 6 | module C : Ecs.Component.S with type t = t 7 | end 8 | -------------------------------------------------------------------------------- /lib/graphics/camera/projection.ml: -------------------------------------------------------------------------------- 1 | type perspective = { 2 | height_angle : float; 3 | near_plane : float; 4 | far_plane : float; 5 | aspect_ratio : float; 6 | } 7 | 8 | let project_perspective p = 9 | let v = Math.Vec4.v in 10 | let scale = 11 | Math.Mat4.of_rows 12 | (v 13 | (1. /. (p.aspect_ratio *. p.far_plane *. tan (p.height_angle /. 2.))) 14 | 0. 0. 0.) 15 | (v 0. (1. /. (p.far_plane *. tan (p.height_angle /. 2.))) 0. 0.) 16 | (v 0. 0. (1. /. p.far_plane) 0.) 17 | (v 0. 0. 0. 1.) 18 | in 19 | let c = -.p.near_plane /. p.far_plane in 20 | let unhinge = 21 | Math.Mat4.of_rows (v 1. 0. 0. 0.) (v 0. 1. 0. 0.) 22 | (v 0. 0. (1. /. (1. +. c)) (-.c /. (1. +. c))) 23 | (v 0. 0. (-1.) 0.) 24 | in 25 | let adjust = 26 | Math.Mat4.of_rows (v 1. 0. 0. 0.) (v 0. 1. 0. 0.) (v 0. 0. (-2.) (-1.)) 27 | (v 0. 0. 0. 1.) 28 | in 29 | Math.Mat4.(mul (mul adjust unhinge) scale) 30 | 31 | type orthographic = { 32 | left : float; 33 | right : float; 34 | bottom : float; 35 | top : float; 36 | near_plane : float; 37 | far_plane : float; 38 | } 39 | 40 | let project_orthographic o = 41 | let inv_rl = 1.0 /. (o.right -. o.left) in 42 | let inv_tb = 1.0 /. (o.top -. o.bottom) in 43 | let inv_fn = 1.0 /. (o.far_plane -. o.near_plane) in 44 | 45 | let v = Math.Vec4.v in 46 | Math.Mat4.of_rows 47 | (v (2. *. inv_rl) 0. 0. (-.(o.right +. o.left) *. inv_rl)) 48 | (v 0. (2. *. inv_tb) 0. (-.(o.top +. o.bottom) *. inv_tb)) 49 | (v 0. 0. (-2. *. inv_fn) (-.(o.far_plane +. o.near_plane) *. inv_fn)) 50 | (v 0. 0. 0. 1.) 51 | 52 | type t = Perspective of perspective | Orthographic of orthographic 53 | 54 | let perspective ?(near_plane = 0.1) ?(far_plane = 100.) 55 | ?(aspect_ratio = 4. /. 3.) ?(height_angle = Float.pi /. 6.) () = 56 | Perspective { height_angle; near_plane; far_plane; aspect_ratio } 57 | 58 | let orthographic ?(left = -1.) ?(right = 1.) ?(bottom = -1.) ?(top = 1.) 59 | ?(near_plane = 0.1) ?(far_plane = 100.) () = 60 | Orthographic { left; right; bottom; top; near_plane; far_plane } 61 | 62 | let project t = 63 | match t with 64 | | Perspective p -> project_perspective p 65 | | Orthographic o -> project_orthographic o 66 | 67 | module C = Ecs.Component.Make (struct 68 | type inner = t 69 | end) 70 | -------------------------------------------------------------------------------- /lib/graphics/camera/projection.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val perspective : 4 | ?near_plane:float -> 5 | ?far_plane:float -> 6 | ?aspect_ratio:float -> 7 | ?height_angle:float -> 8 | unit -> 9 | t 10 | (** Construct a new perspective projection. *) 11 | 12 | val orthographic : 13 | ?left:float -> 14 | ?right:float -> 15 | ?bottom:float -> 16 | ?top:float -> 17 | ?near_plane:float -> 18 | ?far_plane:float -> 19 | unit -> 20 | t 21 | (** Construct a new orthographic projection. *) 22 | 23 | val project : t -> Math.Mat4.t 24 | (** Compute the projection matrix. *) 25 | 26 | module C : Ecs.Component.S with type t = t 27 | (** Projection component. *) 28 | -------------------------------------------------------------------------------- /lib/graphics/context.ml: -------------------------------------------------------------------------------- 1 | open Tsdl 2 | open Tgl4 3 | open Util 4 | 5 | type data = { win : Sdl.window; ctx : Sdl.gl_context } 6 | type t = data option ref 7 | 8 | let empty () = ref None 9 | 10 | let initialize ~gl t = 11 | match !t with 12 | | None -> 13 | let create_window ~gl:(maj, min) = 14 | let w_atts = Sdl.Window.(opengl + resizable) in 15 | let w_title = Printf.sprintf "OpenGL %d.%d" maj min in 16 | let set a v = Sdl.gl_set_attribute a v in 17 | set Sdl.Gl.context_profile_mask Sdl.Gl.context_profile_core 18 | >>= fun () -> 19 | set Sdl.Gl.context_major_version maj >>= fun () -> 20 | set Sdl.Gl.context_minor_version min >>= fun () -> 21 | set Sdl.Gl.doublebuffer 1 >>= fun () -> 22 | Sdl.create_window ~w:640 ~h:480 w_title w_atts >>= fun win -> 23 | Sdl.gl_create_context win >>= fun ctx -> 24 | Sdl.gl_make_current win ctx >>= fun () -> Ok (win, ctx) 25 | in 26 | 27 | let win, ctx = 28 | Sdl.init Sdl.Init.video >>= fun () -> 29 | create_window ~gl >>= fun (win, ctx) -> (win, ctx) 30 | in 31 | let _event = Sdl.Event.create () in 32 | 33 | Gl.enable Gl.depth_test; 34 | Gl.cull_face Gl.back; 35 | 36 | t := Some { win; ctx } 37 | | Some _ -> () 38 | 39 | let get_window_size t = 40 | match !t with 41 | | None -> invalid_arg "Context.get_window_size" 42 | | Some { win; _ } -> 43 | let w, h = Sdl.get_window_size win in 44 | (w, h) 45 | 46 | let render t = 47 | match !t with None -> () | Some { win; _ } -> Sdl.gl_swap_window win 48 | 49 | let destroy t = 50 | match !t with 51 | | None -> () 52 | | Some { win; ctx; _ } -> 53 | Sdl.destroy_window win; 54 | Sdl.gl_delete_context ctx 55 | 56 | module Window = Sdl.Window 57 | 58 | let set_relative_mouse_mode v = Sdl.set_relative_mouse_mode v >>= fun () -> () 59 | 60 | let set_window_fullscreen t flags = 61 | match !t with 62 | | None -> invalid_arg "Context.set_window_fullscreen" 63 | | Some { win; _ } -> Sdl.set_window_fullscreen win flags >>= fun () -> () 64 | 65 | module C = Ecs.Component.Make (struct 66 | type inner = t 67 | end) 68 | -------------------------------------------------------------------------------- /lib/graphics/context.mli: -------------------------------------------------------------------------------- 1 | open Tsdl 2 | 3 | type t 4 | 5 | val empty : unit -> t 6 | val initialize : gl:int * int -> t -> unit 7 | val get_window_size : t -> int * int 8 | val render : t -> unit 9 | val destroy : t -> unit 10 | 11 | module Window = Sdl.Window 12 | 13 | val set_window_fullscreen : t -> Window.flags -> unit 14 | (** Set the window fullscreen. *) 15 | 16 | val set_relative_mouse_mode : bool -> unit 17 | (** Set the relative mouse mode. *) 18 | 19 | module C : Ecs.Component.S with type t = t 20 | -------------------------------------------------------------------------------- /lib/graphics/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (public_name camlcade.graphics) 5 | (name graphics) 6 | (libraries ecs transform input tsdl tgls.tgl4)) 7 | -------------------------------------------------------------------------------- /lib/graphics/graphics.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Tgl4 3 | open Tsdl 4 | module Camera = Camera 5 | module Camera3d = Camera.Camera3d 6 | module Context = Context 7 | module Light = Light 8 | module Material = Material 9 | module Mesh3d = Mesh3d 10 | module Primitive = Primitive 11 | module Shader = Shader 12 | module Vertex_mesh = Vertex_mesh 13 | 14 | let initialize ~gl = 15 | Ecs.System.make 16 | (fun w -> 17 | let open Ecs in 18 | let _, (c, ()) = 19 | World.query w Query.[ Req (module Context.C) ] |> List.hd 20 | in 21 | c) 22 | (Ecs.System.Query 23 | (fun context -> 24 | Context.initialize ~gl context; 25 | (* Initialize shaders *) 26 | Shader.initialize Shader.normal; 27 | Shader.initialize Shader.phong)) 28 | 29 | let render = 30 | Ecs.System.make 31 | (fun w -> 32 | let open Ecs in 33 | let _, (c, ()) = 34 | World.query w Query.[ Req (module Context.C) ] |> List.hd 35 | in 36 | c) 37 | (Ecs.System.Query 38 | (fun context -> 39 | Context.render context; 40 | Gl.clear_color 0. 0. 0. 1.; 41 | Gl.clear (Gl.color_buffer_bit lor Gl.depth_buffer_bit); 42 | check_gl_error ())) 43 | 44 | let handle_events = 45 | Ecs.System.make 46 | (fun w -> 47 | let open Ecs in 48 | let c = World.query w Query.[ Req (module Context.C) ] in 49 | let we = World.query w Query.[ Req (module Input.Window_event.C) ] in 50 | ( List.nth_opt c 0 |> Option.map (fun (_, (c, ())) -> c), 51 | List.nth_opt we 0 |> Option.map (fun (_, (we, ())) -> we) )) 52 | (Ecs.System.Query 53 | (function 54 | | Some context, Some window_event -> 55 | List.iter 56 | (function 57 | | `Exposed | `Resized -> 58 | let w, h = Context.get_window_size context in 59 | Gl.viewport 0 0 w h 60 | | _ -> ()) 61 | (Input.Window_event.read window_event) 62 | | _ -> 63 | let _key_scancode e = 64 | Sdl.Scancode.enum Sdl.Event.(get e keyboard_scancode) 65 | in 66 | let _window_event e = 67 | Sdl.Event.(window_event_enum (get e window_event_id)) 68 | in 69 | let event = Sdl.Event.create () in 70 | while Sdl.poll_event (Some event) do 71 | match Sdl.Event.(enum (get event typ)) with 72 | | `Quit -> raise Ecs.World.Quit 73 | | _ -> () 74 | done)) 75 | 76 | let cleanup = 77 | Ecs.System.make 78 | (fun w -> 79 | let open Ecs in 80 | let c_entity, (c, ()) = 81 | World.query w Query.[ Req (module Context.C) ] |> List.hd 82 | in 83 | let m3d = World.query w Query.[ Req (module Mesh3d.C) ] in 84 | (c_entity, c, List.map (fun (_, (m3d, ())) -> m3d) m3d)) 85 | (Ecs.System.Immediate 86 | (fun w -> 87 | fun (context_entity, context, meshes3d) -> 88 | Context.destroy context; 89 | Ecs.World.remove_entity w context_entity; 90 | (* Destroy shaders *) 91 | Shader.destroy Shader.normal; 92 | (* Destroy meshes *) 93 | List.iter Mesh3d.destroy meshes3d)) 94 | 95 | let plugin w = 96 | let add_context w = 97 | Ecs.World.add_entity w 98 | |> Ecs.World.with_component w (module Context.C) (Context.empty ()) 99 | |> ignore 100 | in 101 | add_context w; 102 | 103 | Ecs.World.add_system w Ecs.Scheduler.Startup (initialize ~gl:(4, 0)); 104 | 105 | Ecs.World.add_system w Ecs.Scheduler.Update render; 106 | Ecs.World.add_system w Ecs.Scheduler.Update handle_events; 107 | Ecs.World.add_system w Ecs.Scheduler.Update Shader.shade_normal; 108 | Ecs.World.add_system w Ecs.Scheduler.Update Shader.shade_phong; 109 | 110 | Ecs.World.add_system w Ecs.Scheduler.Last cleanup 111 | -------------------------------------------------------------------------------- /lib/graphics/graphics.mli: -------------------------------------------------------------------------------- 1 | module Camera = Camera 2 | module Camera3d = Camera.Camera3d 3 | module Context = Context 4 | module Light = Light 5 | module Material = Material 6 | module Mesh3d = Mesh3d 7 | module Primitive = Primitive 8 | module Shader = Shader 9 | module Vertex_mesh = Vertex_mesh 10 | 11 | val plugin : Ecs.World.t -> unit 12 | (** Graphics plugin. *) 13 | -------------------------------------------------------------------------------- /lib/graphics/light.ml: -------------------------------------------------------------------------------- 1 | let default_color = Math.Vec3.v 1. 1. 1. 2 | let default_attenuation = Math.Vec3.v 1. 0. 0. 3 | 4 | module Point = struct 5 | type t = { mutable color : Math.Vec3.t; mutable attenuation : Math.Vec3.t } 6 | 7 | let create ?(color = default_color) ?(attenuation = default_attenuation) () = 8 | { color; attenuation } 9 | 10 | let color t = t.color 11 | let attenuation t = t.attenuation 12 | let set_color t color = t.color <- color 13 | let set_attenuation t attenuation = t.attenuation <- attenuation 14 | 15 | module C = Ecs.Component.Make (struct 16 | type inner = t 17 | end) 18 | end 19 | 20 | module Directional = struct 21 | type t = { mutable color : Math.Vec3.t; mutable attenuation : Math.Vec3.t } 22 | 23 | let create ?(color = default_color) ?(attenuation = default_attenuation) () = 24 | { color; attenuation } 25 | 26 | let color t = t.color 27 | let attenuation t = t.attenuation 28 | let set_color t color = t.color <- color 29 | let set_attenuation t attenuation = t.attenuation <- attenuation 30 | 31 | module C = Ecs.Component.Make (struct 32 | type inner = t 33 | end) 34 | end 35 | 36 | module Spot = struct 37 | type t = { 38 | mutable color : Math.Vec3.t; 39 | mutable attenuation : Math.Vec3.t; 40 | mutable penumbra : float; 41 | mutable angle : float; 42 | } 43 | 44 | let create ?(color = default_color) ?(attenuation = default_attenuation) 45 | ?(penumbra = 0.1) ?(angle = 0.5) () = 46 | { color; attenuation; penumbra; angle } 47 | 48 | let color t = t.color 49 | let attenuation t = t.attenuation 50 | let penumbra t = t.penumbra 51 | let angle t = t.angle 52 | let set_color t color = t.color <- color 53 | let set_attenuation t attenuation = t.attenuation <- attenuation 54 | let set_penumbra t penumbra = t.penumbra <- penumbra 55 | let set_angle t angle = t.angle <- angle 56 | 57 | module C = Ecs.Component.Make (struct 58 | type inner = t 59 | end) 60 | end 61 | -------------------------------------------------------------------------------- /lib/graphics/light.mli: -------------------------------------------------------------------------------- 1 | (** Light components. *) 2 | 3 | (** Point light. 4 | 5 | Use {!Transform.C} component to position the light. Direction has no effect. 6 | *) 7 | module Point : sig 8 | type t 9 | 10 | val create : ?color:Math.Vec3.t -> ?attenuation:Math.Vec3.t -> unit -> t 11 | val color : t -> Math.Vec3.t 12 | val attenuation : t -> Math.Vec3.t 13 | val set_color : t -> Math.Vec3.t -> unit 14 | val set_attenuation : t -> Math.Vec3.t -> unit 15 | 16 | module C : Ecs.Component.S with type t = t 17 | end 18 | 19 | (** Directional light. 20 | 21 | Use {!Transform.C} component to direct the light. Position has no effect. *) 22 | module Directional : sig 23 | type t 24 | 25 | val create : ?color:Math.Vec3.t -> ?attenuation:Math.Vec3.t -> unit -> t 26 | val color : t -> Math.Vec3.t 27 | val attenuation : t -> Math.Vec3.t 28 | val set_color : t -> Math.Vec3.t -> unit 29 | val set_attenuation : t -> Math.Vec3.t -> unit 30 | 31 | module C : Ecs.Component.S with type t = t 32 | end 33 | 34 | (** Spot light. 35 | 36 | Use {!Transform.C} component to position and direct the light. *) 37 | module Spot : sig 38 | type t 39 | 40 | val create : 41 | ?color:Math.Vec3.t -> 42 | ?attenuation:Math.Vec3.t -> 43 | ?penumbra:float -> 44 | ?angle:float -> 45 | unit -> 46 | t 47 | 48 | val color : t -> Math.Vec3.t 49 | val attenuation : t -> Math.Vec3.t 50 | val penumbra : t -> float 51 | val angle : t -> float 52 | val set_penumbra : t -> float -> unit 53 | val set_angle : t -> float -> unit 54 | val set_color : t -> Math.Vec3.t -> unit 55 | val set_attenuation : t -> Math.Vec3.t -> unit 56 | 57 | module C : Ecs.Component.S with type t = t 58 | end 59 | -------------------------------------------------------------------------------- /lib/graphics/material.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | mutable ambient : Math.Vec3.t; 3 | mutable diffuse : Math.Vec3.t; 4 | mutable specular : Math.Vec3.t; 5 | mutable shininess : float; 6 | } 7 | 8 | let create ?(ambient = Math.Vec3.v 1. 1. 1.) ?(diffuse = Math.Vec3.v 1. 1. 1.) 9 | ?(specular = Math.Vec3.v 1. 1. 1.) ?(shininess = 0.0) () = 10 | { ambient; diffuse; specular; shininess } 11 | 12 | let ambient t = t.ambient 13 | let diffuse t = t.diffuse 14 | let specular t = t.specular 15 | let shininess t = t.shininess 16 | let set_ambient t ambient = t.ambient <- ambient 17 | let set_diffuse t diffuse = t.diffuse <- diffuse 18 | let set_specular t specular = t.specular <- specular 19 | let set_shininess t shininess = t.shininess <- shininess 20 | 21 | module C = Ecs.Component.Make (struct 22 | type inner = t 23 | end) 24 | -------------------------------------------------------------------------------- /lib/graphics/material.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val create : 4 | ?ambient:Math.Vec3.t -> 5 | ?diffuse:Math.Vec3.t -> 6 | ?specular:Math.Vec3.t -> 7 | ?shininess:float -> 8 | unit -> 9 | t 10 | 11 | val ambient : t -> Math.Vec3.t 12 | val diffuse : t -> Math.Vec3.t 13 | val specular : t -> Math.Vec3.t 14 | val shininess : t -> float 15 | val set_ambient : t -> Math.Vec3.t -> unit 16 | val set_diffuse : t -> Math.Vec3.t -> unit 17 | val set_specular : t -> Math.Vec3.t -> unit 18 | val set_shininess : t -> float -> unit 19 | 20 | module C : Ecs.Component.S with type t = t 21 | -------------------------------------------------------------------------------- /lib/graphics/mesh3d.ml: -------------------------------------------------------------------------------- 1 | open Tgl4 2 | open Util 3 | 4 | type mesh3d = 5 | | Staged of { mesh : Vertex_mesh.t } 6 | | Initialized of { mesh : Vertex_mesh.t; vao : int; vbo : int } 7 | | Installed of { mesh : Vertex_mesh.t; vao : int; vbo : int } 8 | 9 | type t = mesh3d ref 10 | 11 | let of_vertex_mesh mesh = ref (Staged { mesh }) 12 | 13 | let vertex_mesh t = 14 | match !t with 15 | | Staged { mesh } | Initialized { mesh; _ } -> mesh 16 | | Installed { mesh; _ } -> mesh 17 | 18 | let initialize t = 19 | match !t with 20 | | Staged { mesh } -> 21 | let vao = get_int (Gl.gen_vertex_arrays 1) in 22 | let vbo = get_int (Gl.gen_buffers 1) in 23 | t := Initialized { mesh; vao; vbo } 24 | | Initialized _ -> () 25 | | Installed _ -> () 26 | 27 | let with_vao vao f = 28 | Gl.bind_vertex_array vao; 29 | f (); 30 | Gl.bind_vertex_array 0 31 | 32 | let with_vbo vbo f = 33 | Gl.bind_buffer Gl.array_buffer vbo; 34 | f (); 35 | Gl.bind_buffer Gl.array_buffer 0 36 | 37 | let rec install t = 38 | let aux mesh vao vbo = 39 | with_vao vao (fun () -> 40 | with_vbo vbo (fun () -> 41 | let vertex_data = Vertex_mesh.data mesh in 42 | let varray = 43 | bigarray_create Bigarray.float32 (Array.length vertex_data) 44 | in 45 | vertex_data |> Array.iteri (fun i v -> varray.{i} <- v); 46 | Gl.buffer_data Gl.array_buffer 47 | (Gl.bigarray_byte_size varray) 48 | (Some varray) Gl.static_draw; 49 | 50 | let size_of_float = 4 in 51 | let stride = Vertex_mesh.vertex_size mesh * size_of_float in 52 | let offset = ref 0 in 53 | Vertex_mesh.attributes mesh 54 | |> Hashtbl.to_seq |> List.of_seq |> List.sort compare 55 | |> List.iter (fun (index, size) -> 56 | Gl.enable_vertex_attrib_array index; 57 | Gl.vertex_attrib_pointer index size Gl.float false stride 58 | (`Offset (!offset * size_of_float)); 59 | offset := !offset + size))) 60 | in 61 | match !t with 62 | | Staged _ -> 63 | initialize t; 64 | install t 65 | | Initialized { mesh; vao; vbo } | Installed { mesh; vao; vbo } -> 66 | (* Here we still install even if already installed in case the mesh 67 | has changed *) 68 | aux mesh vao vbo; 69 | t := Installed { mesh; vao; vbo } 70 | 71 | let rec draw t = 72 | match !t with 73 | | Installed { mesh; vao; _ } -> 74 | with_vao vao (fun () -> 75 | let mode = 76 | match Vertex_mesh.topology mesh with 77 | | Vertex_mesh.TriangleList -> Gl.triangles 78 | in 79 | Gl.draw_arrays mode 0 (Vertex_mesh.count_vertices mesh)) 80 | | Initialized _ -> 81 | install t; 82 | draw t 83 | | Staged _ -> 84 | initialize t; 85 | draw t 86 | 87 | let destroy t = 88 | match !t with 89 | | Initialized { vbo; vao; _ } | Installed { vbo; vao; _ } -> 90 | set_int (Gl.delete_buffers 1) vbo; 91 | set_int (Gl.delete_vertex_arrays 1) vao 92 | | _ -> () 93 | 94 | module C = Ecs.Component.Make (struct 95 | type inner = t 96 | end) 97 | -------------------------------------------------------------------------------- /lib/graphics/mesh3d.mli: -------------------------------------------------------------------------------- 1 | (** 3D mesh component. *) 2 | 3 | type t 4 | 5 | val of_vertex_mesh : Vertex_mesh.t -> t 6 | (** Create a mesh component from a vertex mesh. *) 7 | 8 | val vertex_mesh : t -> Vertex_mesh.t 9 | (** Return the vertex mesh of the mesh component. *) 10 | 11 | val initialize : t -> unit 12 | (** Initialize the mesh component. If the mesh component is already initialized, 13 | this function does nothing. *) 14 | 15 | val install : t -> unit 16 | (** Install vertex data into the GPU. If the mesh component is not initialized, 17 | this function initializes it first. 18 | 19 | If the mesh component is already installed, this function re-installs it. 20 | This is useful when the underlying vertex data changes. *) 21 | 22 | val draw : t -> unit 23 | (** Draw the mesh component. This will initialize and install the mesh component 24 | as necessary. *) 25 | 26 | val destroy : t -> unit 27 | (** Destroy the mesh component. This will delete the vertex array and buffer 28 | objects. If the mesh component is not initialized, this function does 29 | nothing. *) 30 | 31 | module C : Ecs.Component.S with type t = t 32 | -------------------------------------------------------------------------------- /lib/graphics/primitive/cuboid.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type config = { param1 : int; half_size : Math.Vec3.t; data : float list ref } 4 | 5 | let add_tile c topl topr botl botr = 6 | let prepend v = prepend_vec3 c.data v in 7 | prepend Math.Vec3.(normalize (cross (botl - topl) (botr - topl))); 8 | prepend topl; 9 | prepend Math.Vec3.(normalize (cross (botr - botl) (topl - botl))); 10 | prepend botl; 11 | prepend Math.Vec3.(normalize (cross (topl - botr) (botl - botr))); 12 | prepend botr; 13 | 14 | prepend Math.Vec3.(normalize (cross (botr - topl) (topr - topl))); 15 | prepend topl; 16 | prepend Math.Vec3.(normalize (cross (topr - botr) (topl - botr))); 17 | prepend botr; 18 | prepend Math.Vec3.(normalize (cross (topl - topr) (botr - topr))); 19 | prepend topr 20 | 21 | let add_face c botl topl topr = 22 | let size = 1. /. float_of_int c.param1 in 23 | let col_delta = Math.Vec3.(smul size (topr - topl)) in 24 | let row_delta = Math.Vec3.(smul size (botl - topl)) in 25 | for col = 0 to c.param1 - 1 do 26 | for row = 0 to c.param1 - 1 do 27 | let col = float_of_int col in 28 | let row = float_of_int row in 29 | let tl = Math.Vec3.(topl + smul col col_delta + smul row row_delta) in 30 | let tr = Math.Vec3.(tl + col_delta) in 31 | let bl = Math.Vec3.(tl + row_delta) in 32 | let br = Math.Vec3.(bl + col_delta) in 33 | add_tile c tl tr bl br 34 | done 35 | done 36 | 37 | let construct c = 38 | let x, y, z = Math.Vec3.to_tuple c.half_size in 39 | let add = add_face c in 40 | let v = Math.Vec3.v in 41 | add (v (-.x) (-.y) z) (v (-.x) y z) (v x y z); 42 | add (v (-.x) (-.y) (-.z)) (v (-.x) y (-.z)) (v (-.x) y z); 43 | add (v x (-.y) z) (v x y z) (v x y (-.z)); 44 | add (v x (-.y) (-.z)) (v x y (-.z)) (v (-.x) y (-.z)); 45 | add (v x y (-.z)) (v x y z) (v (-.x) y z); 46 | add (v x (-.y) z) (v x (-.y) (-.z)) (v (-.x) (-.y) (-.z)); 47 | !(c.data) 48 | 49 | let create ?(x_length = 1.) ?(y_length = 1.) ?(z_length = 1.) ?(param1 = 2) () = 50 | let param1 = max param1 1 in 51 | let half_size = Math.Vec3.(smul 0.5 (v x_length y_length z_length)) in 52 | construct { half_size; param1; data = ref [] } 53 | -------------------------------------------------------------------------------- /lib/graphics/primitive/cuboid.mli: -------------------------------------------------------------------------------- 1 | val create : 2 | ?x_length:float -> 3 | ?y_length:float -> 4 | ?z_length:float -> 5 | ?param1:int -> 6 | unit -> 7 | float list 8 | -------------------------------------------------------------------------------- /lib/graphics/primitive/primitive.ml: -------------------------------------------------------------------------------- 1 | module Cuboid = Cuboid 2 | module Sphere = Sphere 3 | 4 | type t = float list 5 | 6 | let to_vertex_mesh t = 7 | let vm = Vertex_mesh.create ~topology:TriangleList () in 8 | Vertex_mesh.set_attribute vm 0 3; 9 | Vertex_mesh.set_attribute vm 1 3; 10 | Vertex_mesh.set_data vm (Array.of_list t); 11 | vm 12 | 13 | let to_mesh3d t = Mesh3d.of_vertex_mesh (to_vertex_mesh t) 14 | -------------------------------------------------------------------------------- /lib/graphics/primitive/primitive.mli: -------------------------------------------------------------------------------- 1 | module Cuboid = Cuboid 2 | module Sphere = Sphere 3 | 4 | type t = float list 5 | 6 | val to_vertex_mesh : t -> Vertex_mesh.t 7 | val to_mesh3d : t -> Mesh3d.t 8 | -------------------------------------------------------------------------------- /lib/graphics/primitive/sphere.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type config = { 4 | radius : float; 5 | param1 : int; 6 | param2 : int; 7 | data : float list ref; 8 | } 9 | 10 | let add_tile c tl tr bl br = 11 | let prepend v = 12 | prepend_vec3 c.data (Math.Vec3.normalize v); 13 | prepend_vec3 c.data v 14 | in 15 | prepend tl; 16 | prepend bl; 17 | prepend br; 18 | 19 | prepend tl; 20 | prepend br; 21 | prepend tr 22 | 23 | let add_wedge c theta theta' = 24 | let step = Float.pi /. float_of_int c.param1 in 25 | for i = 0 to c.param1 - 1 do 26 | let phi = float_of_int i *. step in 27 | let phi' = float_of_int (i + 1) *. step in 28 | let spherical = Math.Vec3.spherical c.radius in 29 | let tl = spherical theta phi' in 30 | let tr = spherical theta' phi' in 31 | let bl = spherical theta phi in 32 | let br = spherical theta' phi in 33 | add_tile c tl tr bl br 34 | done 35 | 36 | let construct c = 37 | let step = 2. *. Float.pi /. float_of_int c.param2 in 38 | for i = 0 to c.param2 - 1 do 39 | let theta = float_of_int i *. step in 40 | let theta' = float_of_int (i + 1) *. step in 41 | add_wedge c theta theta' 42 | done; 43 | !(c.data) 44 | 45 | let create ?(radius = 0.5) ?(param1 = 2) ?(param2 = 3) () = 46 | let param1 = max param1 2 in 47 | let param2 = max param2 3 in 48 | construct { radius; param1; param2; data = ref [] } 49 | -------------------------------------------------------------------------------- /lib/graphics/primitive/sphere.mli: -------------------------------------------------------------------------------- 1 | val create : ?radius:float -> ?param1:int -> ?param2:int -> unit -> float list 2 | -------------------------------------------------------------------------------- /lib/graphics/shader/normal.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let frag = " 4 | #version 400 core 5 | in vec3 worldSpaceNormal; 6 | in vec3 worldSpacePosition; 7 | out vec4 fragColor; 8 | void main() { 9 | fragColor = vec4(abs(worldSpaceNormal), 1.0); 10 | }" [@@ocamlformat "disable"] 11 | 12 | let vert = " 13 | #version 400 core 14 | layout(location = 0) in vec3 vertexPos; 15 | layout(location = 1) in vec3 vertexNormal; 16 | uniform mat4 modelMatrix; 17 | uniform mat4 viewMatrix; 18 | uniform mat4 projectionMatrix; 19 | uniform mat3 normalMatrix; 20 | out vec3 worldSpaceNormal; 21 | out vec3 worldSpacePosition; 22 | void main() { 23 | worldSpacePosition = (modelMatrix * vec4(vertexPos, 1.0)).xyz; 24 | worldSpaceNormal = normalMatrix * normalize(vertexNormal); 25 | gl_Position = projectionMatrix * viewMatrix * vec4(worldSpacePosition, 1.0); 26 | }" [@@ocamlformat "disable"] 27 | 28 | module C = Ecs.Component.Make (struct 29 | type inner = unit 30 | end) 31 | 32 | let query w = 33 | let open Ecs in 34 | let cameras = 35 | World.query ~filter:(Query.Filter.With Camera.Camera3d.C.id) w 36 | Query.[ Req (module Camera.Projection.C); Opt (module Transform.C) ] 37 | in 38 | let entities = 39 | World.query ~filter:(Query.Filter.With C.id) w 40 | Query.[ Req (module Mesh3d.C); Opt (module Transform.C) ] 41 | in 42 | ( List.map (fun (_, (c, (t, ()))) -> (c, t)) cameras, 43 | List.map (fun (_, (m, (t, ()))) -> (m, t)) entities ) 44 | 45 | let render ?(transform = Transform.identity ()) 46 | ?(camera_transform = Transform.identity ()) pid projection mesh3d = 47 | let view = Math.Mat4.inv (Transform.compute_matrix camera_transform) in 48 | load_matrix4fv view pid "viewMatrix"; 49 | 50 | let projection = Camera.Projection.project projection in 51 | load_matrix4fv projection pid "projectionMatrix"; 52 | 53 | let transform = Transform.compute_matrix transform in 54 | let normal_matrix = 55 | Math.Mat3.inv (Math.Mat3.transpose (Math.Mat3.of_m4 transform)) 56 | in 57 | 58 | load_matrix4fv transform pid "modelMatrix"; 59 | load_matrix3fv normal_matrix pid "normalMatrix"; 60 | 61 | Mesh3d.draw mesh3d 62 | -------------------------------------------------------------------------------- /lib/graphics/shader/normal.mli: -------------------------------------------------------------------------------- 1 | val frag : string 2 | val vert : string 3 | 4 | val query : 5 | Ecs.World.t -> 6 | (Camera.Projection.t * Transform.t option) list 7 | * (Mesh3d.t * Transform.t option) list 8 | (** [query q] returns the necessary components for the render function. *) 9 | 10 | val render : 11 | ?transform:Transform.t -> 12 | ?camera_transform:Transform.t -> 13 | int -> 14 | Camera.Projection.t -> 15 | Mesh3d.t -> 16 | unit 17 | (** Renders using the normal shader. *) 18 | 19 | module C : Ecs.Component.S with type t = unit 20 | (** Normal shader component. *) 21 | -------------------------------------------------------------------------------- /lib/graphics/shader/phong.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let frag = " 4 | #version 400 core 5 | 6 | in vec3 worldSpaceNormal; 7 | in vec3 worldSpacePosition; 8 | 9 | struct Light { 10 | // 0: Point, 1: Directional, 2: Spot 11 | int type; 12 | 13 | vec3 color; 14 | vec3 dir; 15 | vec3 pos; 16 | vec3 attenuation; 17 | 18 | float angle; 19 | float penumbra; 20 | }; 21 | 22 | struct Material { 23 | vec3 ambient; 24 | vec3 diffuse; 25 | vec3 specular; 26 | float shininess; 27 | }; 28 | 29 | uniform Material material; 30 | uniform Light lights[128]; 31 | uniform int lightCount; 32 | uniform vec3 worldSpaceCamera; 33 | 34 | out vec4 fragColor; 35 | 36 | vec3 calculateLightDirection(Light light, vec3 pos) { 37 | switch (light.type) { 38 | case 0: 39 | case 2: 40 | return normalize(light.pos - pos); 41 | case 1: 42 | default: 43 | return normalize(-light.dir); 44 | } 45 | } 46 | 47 | float calculateAttenuation(Light light, float distance) { 48 | float c1 = light.attenuation.x; 49 | float c2 = light.attenuation.y; 50 | float c3 = light.attenuation.z; 51 | return min(1.0f, 1.0f / (c1 + c2 * distance + c3 * distance * distance)); 52 | } 53 | 54 | float calculateSpotLightFactor(Light light, vec3 lightDirection) { 55 | float x = acos(dot(normalize(-light.dir), 56 | normalize(lightDirection))); 57 | float outer = light.angle; 58 | float inner = outer - light.penumbra; 59 | if (x <= inner) { 60 | return 1.0f; 61 | } else if (x > inner && x <= outer) { 62 | float factor = (x - inner) / (outer - inner); 63 | return 1.0f - (-2.0f * pow(factor, 3) + 3.0f * pow(factor, 2)); 64 | } else { 65 | return 0.0f; 66 | } 67 | } 68 | 69 | void main() { 70 | // TODO: Make this configurable ? 71 | float ka = 1.0; float kd = 1.0; float ks = 1.0; 72 | 73 | fragColor = vec4(0.0); 74 | 75 | // Ambient 76 | fragColor += vec4(ka * material.ambient, 0.0); 77 | 78 | vec3 viewDirection = normalize(worldSpaceCamera - worldSpacePosition); 79 | vec3 worldSpaceNormal = normalize(worldSpaceNormal); 80 | 81 | for (int i = 0; i < lightCount; i++) { 82 | Light light = lights[i]; 83 | 84 | float distance = length(light.pos - worldSpacePosition); 85 | 86 | float fAtt = 1.0; 87 | if (light.type == 0 || light.type == 2) { // Point or spot light 88 | fAtt = calculateAttenuation(light, distance); 89 | } 90 | 91 | vec3 lightDirection = calculateLightDirection(light, worldSpacePosition); 92 | 93 | float spotFactor = 1.0; 94 | if (light.type == 2) { // Spot light 95 | spotFactor = calculateSpotLightFactor(light, lightDirection); 96 | } 97 | 98 | // Diffuse 99 | float nl = max(dot(worldSpaceNormal, lightDirection), 0.0); 100 | fragColor += vec4(spotFactor * fAtt * kd * nl * material.diffuse * light.color, 0.0); 101 | 102 | // Specular (Blinn-Phong) 103 | vec3 halfDir = normalize(lightDirection + viewDirection); 104 | float specAngle = max(dot(halfDir, worldSpaceNormal), 0.0); 105 | if (specAngle == 0.0 && material.shininess <= 0.0) continue; 106 | float specular = pow(specAngle, material.shininess); 107 | fragColor += spotFactor * fAtt * vec4(ks * specular * material.specular * light.color, 0.0); 108 | } 109 | 110 | fragColor = clamp(fragColor, 0.0, 1.0); 111 | }" [@@ocamlformat "disable"] 112 | 113 | let vert = " 114 | #version 400 core 115 | 116 | layout(location = 0) in vec3 vertexPos; 117 | layout(location = 1) in vec3 vertexNormal; 118 | 119 | uniform mat4 modelMatrix; 120 | uniform mat4 viewMatrix; 121 | uniform mat4 projectionMatrix; 122 | uniform mat3 normalMatrix; 123 | 124 | out vec3 worldSpaceNormal; 125 | out vec3 worldSpacePosition; 126 | 127 | void main() { 128 | worldSpacePosition = (modelMatrix * vec4(vertexPos, 1.0)).xyz; 129 | worldSpaceNormal = normalMatrix * normalize(vertexNormal); 130 | 131 | gl_Position = projectionMatrix * viewMatrix * vec4(worldSpacePosition, 1.0); 132 | }" [@@ocamlformat "disable"] 133 | 134 | module C = Ecs.Component.Make (struct 135 | type inner = unit 136 | end) 137 | 138 | type context = { 139 | cameras : (Camera.Projection.t * Transform.t option) list; 140 | entities : (Mesh3d.t * Material.t * Transform.t option) list; 141 | point_lights : (Light.Point.t * Transform.t option) list; 142 | directional_lights : (Light.Directional.t * Transform.t option) list; 143 | spot_lights : (Light.Spot.t * Transform.t option) list; 144 | } 145 | 146 | let query w = 147 | let open Ecs in 148 | let cameras = 149 | World.query ~filter:(Query.Filter.With Camera.Camera3d.C.id) w 150 | Query.[ Req (module Camera.Projection.C); Opt (module Transform.C) ] 151 | |> List.map (fun (_, (p, (t, ()))) -> (p, t)) 152 | in 153 | 154 | let entities = 155 | World.query w ~filter:(Query.Filter.With C.id) 156 | Query. 157 | [ 158 | Req (module Mesh3d.C); 159 | Req (module Material.C); 160 | Opt (module Transform.C); 161 | ] 162 | |> List.map (fun (_, (m3d, (m, (t, ())))) -> (m3d, m, t)) 163 | in 164 | let parse_lights l = 165 | List.map (fun (_, (light, (transform, ()))) -> (light, transform)) l 166 | in 167 | 168 | let point_lights = 169 | World.query w Query.[ Req (module Light.Point.C); Opt (module Transform.C) ] 170 | |> parse_lights 171 | in 172 | let directional_lights = 173 | World.query w 174 | Query.[ Req (module Light.Directional.C); Opt (module Transform.C) ] 175 | |> parse_lights 176 | in 177 | let spot_lights = 178 | World.query w Query.[ Req (module Light.Spot.C); Opt (module Transform.C) ] 179 | |> parse_lights 180 | in 181 | { cameras; entities; point_lights; directional_lights; spot_lights } 182 | 183 | let load_lights pid point_lights directional_lights spot_lights = 184 | let light_index = ref 0 in 185 | let light_loc field = "lights[" ^ string_of_int !light_index ^ "]." ^ field in 186 | let load_light t color attenuation = 187 | load_uniform1i t pid (light_loc "type"); 188 | load_uniform3fv color pid (light_loc "color"); 189 | load_uniform3fv attenuation pid (light_loc "attenuation") 190 | in 191 | 192 | List.iter 193 | (fun (point, transform) -> 194 | load_light 0 (Light.Point.color point) (Light.Point.attenuation point); 195 | Option.iter 196 | (fun t -> 197 | let pos = Transform.translation t in 198 | load_uniform3fv pos pid (light_loc "pos")) 199 | transform; 200 | light_index := !light_index + 1) 201 | point_lights; 202 | 203 | List.iter 204 | (fun (directional, transform) -> 205 | load_light 1 206 | (Light.Directional.color directional) 207 | (Light.Directional.attenuation directional); 208 | Option.iter 209 | (fun t -> 210 | let rot = Transform.rotation t in 211 | let dir = Math.Quat.apply3 rot (Math.Vec3.v 0. 0. (-1.)) in 212 | load_uniform3fv dir pid (light_loc "dir")) 213 | transform; 214 | light_index := !light_index + 1) 215 | directional_lights; 216 | 217 | List.iter 218 | (fun (spot, transform) -> 219 | load_light 2 (Light.Spot.color spot) (Light.Spot.attenuation spot); 220 | load_uniform1f (Light.Spot.angle spot) pid (light_loc "angle"); 221 | load_uniform1f (Light.Spot.penumbra spot) pid (light_loc "penumbra"); 222 | Option.iter 223 | (fun t -> 224 | let pos = Transform.translation t in 225 | load_uniform3fv pos pid (light_loc "pos"); 226 | let rot = Transform.rotation t in 227 | let dir = Math.Quat.apply3 rot (Math.Vec3.v 0. 0. (-1.)) in 228 | load_uniform3fv dir pid (light_loc "dir")) 229 | transform; 230 | light_index := !light_index + 1) 231 | spot_lights; 232 | 233 | load_uniform1i !light_index pid "lightCount" 234 | 235 | let render pid 236 | { cameras; entities; point_lights; directional_lights; spot_lights } = 237 | let render_entity ?(transform = Transform.identity ()) m3d mat = 238 | let transform = Transform.compute_matrix transform in 239 | load_matrix4fv transform pid "modelMatrix"; 240 | 241 | let normal_matrix = 242 | Math.Mat3.inv (Math.Mat3.transpose (Math.Mat3.of_m4 transform)) 243 | in 244 | load_matrix3fv normal_matrix pid "normalMatrix"; 245 | 246 | load_uniform3fv (Material.ambient mat) pid "material.ambient"; 247 | load_uniform3fv (Material.diffuse mat) pid "material.diffuse"; 248 | load_uniform3fv (Material.specular mat) pid "material.specular"; 249 | load_uniform1f (Material.shininess mat) pid "material.shininess"; 250 | 251 | Mesh3d.draw m3d 252 | in 253 | 254 | let render_to_camera ?(ctransform = Transform.identity ()) proj = 255 | let view = Math.Mat4.inv (Transform.compute_matrix ctransform) in 256 | load_matrix4fv view pid "viewMatrix"; 257 | let projection = Camera.Projection.project proj in 258 | load_matrix4fv projection pid "projectionMatrix"; 259 | 260 | let world_space_camera = Transform.translation ctransform in 261 | load_uniform3fv world_space_camera pid "worldSpaceCamera"; 262 | 263 | load_lights pid point_lights directional_lights spot_lights; 264 | 265 | List.iter 266 | (fun (m3d, mat, transform) -> render_entity ?transform m3d mat) 267 | entities 268 | in 269 | List.iter (fun (p, ctransform) -> render_to_camera ?ctransform p) cameras 270 | -------------------------------------------------------------------------------- /lib/graphics/shader/phong.mli: -------------------------------------------------------------------------------- 1 | val frag : string 2 | val vert : string 3 | 4 | module C : Ecs.Component.S with type t = unit 5 | 6 | type context 7 | 8 | val query : Ecs.World.t -> context 9 | val render : int -> context -> unit 10 | -------------------------------------------------------------------------------- /lib/graphics/shader/shader.ml: -------------------------------------------------------------------------------- 1 | open Tgl4 2 | open Util 3 | module Normal = Normal 4 | module Phong = Phong 5 | 6 | type program = 7 | | Staged of { frag : string; vert : string } 8 | | Initialized of { pid : int } 9 | | Destroyed 10 | 11 | type t = program ref 12 | 13 | let create ~frag ~vert = ref (Staged { frag; vert }) 14 | 15 | let initialize s = 16 | let compile src typ = 17 | let get_shader sid e = get_int (Gl.get_shaderiv sid e) in 18 | let sid = Gl.create_shader typ in 19 | Gl.shader_source sid src; 20 | Gl.compile_shader sid; 21 | if get_shader sid Gl.compile_status = Gl.true_ then Ok sid 22 | else 23 | let len = get_shader sid Gl.info_log_length in 24 | let log = get_string len (Gl.get_shader_info_log sid len None) in 25 | Gl.delete_shader sid; 26 | Error (`Msg log) 27 | in 28 | match !s with 29 | | Staged { frag; vert } -> 30 | compile vert Gl.vertex_shader >>= fun vert -> 31 | compile frag Gl.fragment_shader >>= fun frag -> 32 | let pid = Gl.create_program () in 33 | Gl.attach_shader pid vert; 34 | Gl.attach_shader pid frag; 35 | Gl.link_program pid; 36 | let get_program_int pid e = get_int (Gl.get_programiv pid e) in 37 | let link_ok = get_program_int pid Gl.link_status = Gl.true_ in 38 | (if not link_ok then 39 | let len = get_program_int pid Gl.info_log_length in 40 | let log = get_string len (Gl.get_program_info_log pid len None) in 41 | failwith (Printf.sprintf "link error: %s" log)); 42 | Gl.delete_shader vert; 43 | Gl.delete_shader frag; 44 | Ok pid >>= fun pid -> s := Initialized { pid } 45 | | Initialized _ -> () 46 | | Destroyed -> failwith "attempt to initialize destroyed shader" 47 | 48 | let with_shader s f = 49 | match !s with 50 | | Initialized { pid } -> 51 | Gl.use_program pid; 52 | f pid; 53 | Gl.use_program 0 54 | | _ -> failwith "attempt to use uninitialized shader" 55 | 56 | let destroy s = 57 | match !s with 58 | | Initialized { pid } -> 59 | Gl.delete_program pid; 60 | s := Destroyed 61 | | _ -> () 62 | 63 | (* === Custom shaders === *) 64 | let normal = create ~frag:Normal.frag ~vert:Normal.vert 65 | 66 | let shade_normal = 67 | let shade pid entities projection camera_transform = 68 | List.iter 69 | (fun (m, t) -> 70 | Normal.render pid projection m ?transform:t ?camera_transform) 71 | entities 72 | in 73 | Ecs.System.make Normal.query 74 | (Ecs.System.Query 75 | (fun (cameras, entities) -> 76 | with_shader normal (fun pid -> 77 | List.iter (fun (p, t) -> shade pid entities p t) cameras))) 78 | 79 | let phong = create ~frag:Phong.frag ~vert:Phong.vert 80 | 81 | let shade_phong = 82 | Ecs.System.make Phong.query 83 | (Ecs.System.Query 84 | (fun context -> with_shader phong (fun pid -> Phong.render pid context))) 85 | -------------------------------------------------------------------------------- /lib/graphics/shader/shader.mli: -------------------------------------------------------------------------------- 1 | module Normal = Normal 2 | module Phong = Phong 3 | 4 | type t 5 | 6 | val create : frag:string -> vert:string -> t 7 | val initialize : t -> unit 8 | val with_shader : t -> (int -> unit) -> unit 9 | val destroy : t -> unit 10 | val normal : t 11 | val shade_normal : Ecs.World.t Ecs.System.t 12 | val phong : t 13 | val shade_phong : Ecs.World.t Ecs.System.t 14 | -------------------------------------------------------------------------------- /lib/graphics/util.ml: -------------------------------------------------------------------------------- 1 | open Tgl4 2 | 3 | let bigarray_create k len = Bigarray.(Array1.create k c_layout len) 4 | 5 | let get_int = 6 | let a = bigarray_create Bigarray.int32 1 in 7 | fun f -> 8 | f a; 9 | Int32.to_int a.{0} 10 | 11 | let set_int = 12 | let a = bigarray_create Bigarray.int32 1 in 13 | fun f i -> 14 | a.{0} <- Int32.of_int i; 15 | f a 16 | 17 | let get_string len f = 18 | let a = bigarray_create Bigarray.char len in 19 | f a; 20 | Gl.string_of_bigarray a 21 | 22 | let ( >>= ) x f = 23 | match x with Ok v -> f v | Error (`Msg msg) -> raise (Failure msg) 24 | 25 | let load_matrixnfv n mat f pid loc = 26 | let loc = Gl.get_uniform_location pid loc in 27 | let value = bigarray_create Bigarray.float32 (n * n) in 28 | mat |> List.iteri (fun i x -> value.{i} <- x); 29 | f loc 1 false value 30 | 31 | let load_matrix3fv mat = 32 | load_matrixnfv 3 (Math.Mat3.to_list mat) Gl.uniform_matrix3fv 33 | 34 | let load_matrix4fv mat = 35 | load_matrixnfv 4 (Math.Mat4.to_list mat) Gl.uniform_matrix4fv 36 | 37 | let load_uniform1i i pid loc = Gl.uniform1i (Gl.get_uniform_location pid loc) i 38 | let load_uniform1f i pid loc = Gl.uniform1f (Gl.get_uniform_location pid loc) i 39 | 40 | let load_uniform3fv v pid loc = 41 | let loc = Gl.get_uniform_location pid loc in 42 | let value = bigarray_create Bigarray.float32 3 in 43 | value.{0} <- Math.Vec3.x v; 44 | value.{1} <- Math.Vec3.y v; 45 | value.{2} <- Math.Vec3.z v; 46 | Gl.uniform3fv loc 1 value 47 | 48 | let check_gl_error () = 49 | let error = ref (Gl.get_error ()) in 50 | let errored = ref false in 51 | while !error != Gl.no_error do 52 | print_endline (Printf.sprintf "%d\n" !error); 53 | error := Gl.get_error (); 54 | errored := true 55 | done; 56 | if !errored then failwith "shortcircuit in print_gl_error" 57 | 58 | let prepend_vec3 l v = 59 | let x, y, z = Math.Vec3.to_tuple v in 60 | l := x :: y :: z :: !l 61 | -------------------------------------------------------------------------------- /lib/graphics/util.mli: -------------------------------------------------------------------------------- 1 | val bigarray_create : 2 | ('a, 'b) Bigarray.kind -> int -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 3 | 4 | val get_int : 5 | ((int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t -> unit) -> 6 | int 7 | 8 | val set_int : 9 | ((int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t -> unit) -> 10 | int -> 11 | unit 12 | 13 | val get_string : 14 | int -> 15 | ((char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t -> 16 | unit) -> 17 | string 18 | 19 | val ( >>= ) : ('a, [< `Msg of string ]) result -> ('a -> 'b) -> 'b 20 | val load_matrix4fv : Math.Mat4.t -> int -> string -> unit 21 | val load_matrix3fv : Math.Mat3.t -> int -> string -> unit 22 | val load_uniform1i : int -> int -> string -> unit 23 | val load_uniform1f : float -> int -> string -> unit 24 | val load_uniform3fv : Math.Vec3.t -> int -> string -> unit 25 | val check_gl_error : unit -> unit 26 | val prepend_vec3 : float list ref -> Math.Vec3.t -> unit 27 | -------------------------------------------------------------------------------- /lib/graphics/vertex_mesh.ml: -------------------------------------------------------------------------------- 1 | type topology = TriangleList 2 | 3 | type t = { 4 | mutable topology : topology; 5 | attributes : (int, int) Hashtbl.t; 6 | mutable data : float array; 7 | } 8 | 9 | let create ?(topology = TriangleList) () = 10 | { topology; attributes = Hashtbl.create 0; data = [||] } 11 | 12 | let topology t = t.topology 13 | let set_topology t topology = t.topology <- topology 14 | let attributes t = t.attributes 15 | let set_attribute t index size = Hashtbl.replace t.attributes index size 16 | let data t = t.data 17 | let set_data t data = t.data <- data 18 | let vertex_size t = Hashtbl.fold (fun _ size acc -> acc + size) t.attributes 0 19 | 20 | let count_vertices t = 21 | if Hashtbl.length t.attributes = 0 then 0 22 | else Array.length t.data / vertex_size t 23 | -------------------------------------------------------------------------------- /lib/graphics/vertex_mesh.mli: -------------------------------------------------------------------------------- 1 | (** Vertex mesh with attributes. *) 2 | 3 | type topology = TriangleList 4 | type t 5 | 6 | val create : ?topology:topology -> unit -> t 7 | (** Creates a new vertex mesh. *) 8 | 9 | val topology : t -> topology 10 | (** [topology t] returns the topology of the vertex mesh. *) 11 | 12 | val set_topology : t -> topology -> unit 13 | (** [set_topology t topology] sets the topology of the vertex mesh. *) 14 | 15 | val attributes : t -> (int, int) Hashtbl.t 16 | (** [attributes t] returns the attributes of the vertex mesh. *) 17 | 18 | val set_attribute : t -> int -> int -> unit 19 | (** [set_attribute t index size] sets the attribute of the vertex mesh. *) 20 | 21 | val data : t -> float array 22 | (** [data t] returns the data of the vertex mesh. *) 23 | 24 | val set_data : t -> float array -> unit 25 | (** [set_data t data] sets the data of the vertex mesh. *) 26 | 27 | val vertex_size : t -> int 28 | (** [vertex_size t] returns the size of the vertex in the vertex mesh. *) 29 | 30 | val count_vertices : t -> int 31 | (** [count_vertices t] returns the number of vertices in the vertex mesh. *) 32 | -------------------------------------------------------------------------------- /lib/input/button.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type button 3 | type t = Up of button | Down of button 4 | end 5 | 6 | module Make (T : sig 7 | type t 8 | end) : S with type button = T.t = struct 9 | type button = T.t 10 | type t = Up of button | Down of button 11 | end 12 | -------------------------------------------------------------------------------- /lib/input/button.mli: -------------------------------------------------------------------------------- 1 | (** A button is a type that can be in an up or down state. 2 | 3 | This is intentionally made as generic as possible to allow for different 4 | types of buttons. *) 5 | 6 | module type S = sig 7 | type button 8 | type t = Up of button | Down of button 9 | end 10 | 11 | module Make (T : sig 12 | type t 13 | end) : S with type button = T.t 14 | -------------------------------------------------------------------------------- /lib/input/button_state.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type button 3 | type t 4 | 5 | val create : unit -> t 6 | val is_pressed : t -> button -> bool 7 | val is_just_pressed : t -> button -> bool 8 | val is_just_released : t -> button -> bool 9 | 10 | module C : Ecs.Component.S with type t = t 11 | 12 | val update_system : Ecs.World.t Ecs.System.t 13 | end 14 | 15 | module Make (B : Button.S) (E : Ecs.Event.S with type event = B.t) : 16 | S with type button = B.button = struct 17 | type button = B.button 18 | 19 | module Set = Set.Make (struct 20 | type t = button 21 | 22 | let compare = compare 23 | end) 24 | 25 | type t = { 26 | mutable pressed : Set.t; 27 | mutable just_pressed : Set.t; 28 | mutable just_released : Set.t; 29 | } 30 | 31 | let create () = 32 | { pressed = Set.empty; just_pressed = Set.empty; just_released = Set.empty } 33 | 34 | let press t key = 35 | let already_pressed = Set.mem key t.pressed in 36 | t.pressed <- Set.add key t.pressed; 37 | t.just_pressed <- 38 | (if already_pressed then t.just_pressed else Set.add key t.just_pressed) 39 | 40 | let clear_just_pressed t = t.just_pressed <- Set.empty 41 | 42 | let release t key = 43 | let already_pressed = Set.mem key t.pressed in 44 | t.pressed <- Set.remove key t.pressed; 45 | t.just_pressed <- Set.remove key t.just_pressed; 46 | t.just_released <- 47 | (if already_pressed then Set.add key t.just_released else t.just_released) 48 | 49 | let is_pressed t key = Set.mem key t.pressed 50 | let is_just_pressed t key = Set.mem key t.just_pressed 51 | let is_just_released t key = Set.mem key t.just_released 52 | 53 | module C = Ecs.Component.Make (struct 54 | type inner = t 55 | end) 56 | 57 | let update_system = 58 | let query w = 59 | let open Ecs in 60 | let _, (event, ()) = 61 | World.query w Query.[ Req (module E.C) ] |> List.hd 62 | in 63 | let _, (state, ()) = World.query w Query.[ Req (module C) ] |> List.hd in 64 | (event, state) 65 | in 66 | let update event state = 67 | let keys = E.read event in 68 | List.iter 69 | (function B.Down e -> press state e | B.Up e -> release state e) 70 | keys 71 | in 72 | Ecs.System.make query 73 | (Ecs.System.Query 74 | (fun (event, state) -> 75 | clear_just_pressed state; 76 | update event state)) 77 | end 78 | -------------------------------------------------------------------------------- /lib/input/button_state.mli: -------------------------------------------------------------------------------- 1 | (** Create a component for managing the state of some buttons. *) 2 | 3 | module type S = sig 4 | type button 5 | type t 6 | 7 | val create : unit -> t 8 | (** Create a new keyboard input component. *) 9 | 10 | val is_pressed : t -> button -> bool 11 | (** Check if a button is currently pressed. *) 12 | 13 | val is_just_pressed : t -> button -> bool 14 | (** Check if a button was just pressed. *) 15 | 16 | val is_just_released : t -> button -> bool 17 | (** Check if a button was just released. *) 18 | 19 | module C : Ecs.Component.S with type t = t 20 | 21 | val update_system : Ecs.World.t Ecs.System.t 22 | end 23 | 24 | module Make (B : Button.S) (_ : Ecs.Event.S with type event = B.t) : 25 | S with type button = B.button 26 | -------------------------------------------------------------------------------- /lib/input/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name camlcade.input) 3 | (name input) 4 | (libraries ecs tsdl)) 5 | -------------------------------------------------------------------------------- /lib/input/input.ml: -------------------------------------------------------------------------------- 1 | open Tsdl 2 | 3 | module Key_event = Ecs.Event.Make (struct 4 | type t = Key.t 5 | end) 6 | 7 | module Keyboard = Button_state.Make (Key) (Key_event) 8 | 9 | module Window_event = Ecs.Event.Make (struct 10 | type t = Sdl.Event.window_event_enum 11 | end) 12 | 13 | module Mouse = struct 14 | module Button_event = Ecs.Event.Make (struct 15 | type t = Mouse_button.t 16 | end) 17 | 18 | module Button = Button_state.Make (Mouse_button) (Button_event) 19 | 20 | type motion = { x : int; y : int; dx : int; dy : int } 21 | 22 | let x m = m.x 23 | let y m = m.y 24 | let dx m = m.dx 25 | let dy m = m.dy 26 | 27 | module Motion_event = Ecs.Event.Make (struct 28 | type t = motion 29 | end) 30 | end 31 | 32 | let write_events = 33 | let query w = 34 | let open Ecs in 35 | let _, (ke, ()) = 36 | World.query w Query.[ Req (module Key_event.C) ] |> List.hd 37 | in 38 | let _, (we, ()) = 39 | World.query w Query.[ Req (module Window_event.C) ] |> List.hd 40 | in 41 | let _, (mb, ()) = 42 | World.query w Query.[ Req (module Mouse.Button_event.C) ] |> List.hd 43 | in 44 | let _, (mm, ()) = 45 | World.query w Query.[ Req (module Mouse.Motion_event.C) ] |> List.hd 46 | in 47 | (ke, we, mb, mm) 48 | in 49 | let write (key, window, mouse_button, mouse_motion) = 50 | let event = Sdl.Event.create () in 51 | 52 | (* Convenent functions for extracting data from SDL events. *) 53 | let scan_key e = Sdl.Scancode.enum Sdl.Event.(get e keyboard_scancode) in 54 | let scan_window e = Sdl.Event.(window_event_enum (get e window_event_id)) in 55 | let scan_mouse_button e = 56 | Mouse_button.of_int Sdl.Event.(get e mouse_button_button) 57 | in 58 | 59 | (* Handle SDL events. *) 60 | while Sdl.poll_event (Some event) do 61 | match Sdl.Event.(enum (get event typ)) with 62 | | `Quit -> raise Ecs.World.Quit 63 | | `Key_down -> Key_event.write key (Key.Down (scan_key event)) 64 | | `Key_up -> Key_event.write key (Key.Up (scan_key event)) 65 | | `Window_event -> Window_event.write window (scan_window event) 66 | | `Mouse_button_down -> 67 | Mouse.Button_event.write mouse_button 68 | (Mouse_button.Down (scan_mouse_button event)) 69 | | `Mouse_button_up -> 70 | Mouse.Button_event.write mouse_button 71 | (Mouse_button.Up (scan_mouse_button event)) 72 | | `Mouse_motion -> 73 | let x = Sdl.Event.(get event mouse_motion_x) in 74 | let y = Sdl.Event.(get event mouse_motion_y) in 75 | let dx = Sdl.Event.(get event mouse_motion_xrel) in 76 | let dy = Sdl.Event.(get event mouse_motion_yrel) in 77 | Mouse.Motion_event.write mouse_motion { x; y; dx; dy } 78 | | _ -> () 79 | done 80 | in 81 | Ecs.System.make query (Ecs.System.Query write) 82 | 83 | let plugin w = 84 | let _state = 85 | Ecs.World.add_entity w 86 | |> Ecs.World.with_component w 87 | (module Window_event.C) 88 | (Window_event.empty ()) 89 | |> Ecs.World.with_component w (module Key_event.C) (Key_event.empty ()) 90 | |> Ecs.World.with_component w (module Keyboard.C) (Keyboard.create ()) 91 | |> Ecs.World.with_component w 92 | (module Mouse.Button_event.C) 93 | (Mouse.Button_event.empty ()) 94 | |> Ecs.World.with_component w 95 | (module Mouse.Button.C) 96 | (Mouse.Button.create ()) 97 | |> Ecs.World.with_component w 98 | (module Mouse.Motion_event.C) 99 | (Mouse.Motion_event.empty ()) 100 | |> ignore 101 | in 102 | 103 | (* The ordering of systems is important. It should be clear -> write -> update. *) 104 | 105 | (* Clear events systems. *) 106 | Ecs.World.add_system w Ecs.Scheduler.Update Key_event.clear_system; 107 | Ecs.World.add_system w Ecs.Scheduler.Update Window_event.clear_system; 108 | Ecs.World.add_system w Ecs.Scheduler.Update Mouse.Button_event.clear_system; 109 | Ecs.World.add_system w Ecs.Scheduler.Update Mouse.Motion_event.clear_system; 110 | 111 | (* Write. *) 112 | Ecs.World.add_system w Ecs.Scheduler.Update write_events; 113 | 114 | (* Button state update systems. *) 115 | Ecs.World.add_system w Ecs.Scheduler.Update Keyboard.update_system; 116 | Ecs.World.add_system w Ecs.Scheduler.Update Mouse.Button.update_system 117 | -------------------------------------------------------------------------------- /lib/input/input.mli: -------------------------------------------------------------------------------- 1 | (** Input provides convenient components for handling input events. *) 2 | 3 | open Tsdl 4 | module Key_event : Ecs.Event.S with type event = Key.t 5 | module Keyboard : Button_state.S with type button = Key.key 6 | module Window_event : Ecs.Event.S with type event = Sdl.Event.window_event_enum 7 | 8 | module Mouse : sig 9 | module Button_event : Ecs.Event.S with type event = Mouse_button.t 10 | module Button : Button_state.S with type button = Mouse_button.mouse_button 11 | 12 | type motion 13 | 14 | val x : motion -> int 15 | val y : motion -> int 16 | val dx : motion -> int 17 | val dy : motion -> int 18 | 19 | module Motion_event : Ecs.Event.S with type event = motion 20 | end 21 | 22 | val plugin : Ecs.World.t -> unit 23 | -------------------------------------------------------------------------------- /lib/input/key.ml: -------------------------------------------------------------------------------- 1 | type key = 2 | [ `A 3 | | `Ac_back 4 | | `Ac_bookmarks 5 | | `Ac_forward 6 | | `Ac_home 7 | | `Ac_refresh 8 | | `Ac_search 9 | | `Ac_stop 10 | | `Again 11 | | `Alterase 12 | | `Apostrophe 13 | | `App1 14 | | `App2 15 | | `Application 16 | | `Audiomute 17 | | `Audionext 18 | | `Audioplay 19 | | `Audioprev 20 | | `Audiostop 21 | | `B 22 | | `Backslash 23 | | `Backspace 24 | | `Brightnessdown 25 | | `Brightnessup 26 | | `C 27 | | `Calculator 28 | | `Cancel 29 | | `Capslock 30 | | `Clear 31 | | `Clearagain 32 | | `Comma 33 | | `Computer 34 | | `Copy 35 | | `Crsel 36 | | `Currencysubunit 37 | | `Currencyunit 38 | | `Cut 39 | | `D 40 | | `Decimalseparator 41 | | `Delete 42 | | `Displayswitch 43 | | `Down 44 | | `E 45 | | `Eject 46 | | `End 47 | | `Equals 48 | | `Escape 49 | | `Execute 50 | | `Exsel 51 | | `F 52 | | `F1 53 | | `F10 54 | | `F11 55 | | `F12 56 | | `F13 57 | | `F14 58 | | `F15 59 | | `F16 60 | | `F17 61 | | `F18 62 | | `F19 63 | | `F2 64 | | `F20 65 | | `F21 66 | | `F22 67 | | `F23 68 | | `F24 69 | | `F3 70 | | `F4 71 | | `F5 72 | | `F6 73 | | `F7 74 | | `F8 75 | | `F9 76 | | `Find 77 | | `G 78 | | `Grave 79 | | `H 80 | | `Help 81 | | `Home 82 | | `I 83 | | `Insert 84 | | `International1 85 | | `International2 86 | | `International3 87 | | `International4 88 | | `International5 89 | | `International6 90 | | `International7 91 | | `International8 92 | | `International9 93 | | `J 94 | | `K 95 | | `K0 96 | | `K1 97 | | `K2 98 | | `K3 99 | | `K4 100 | | `K5 101 | | `K6 102 | | `K7 103 | | `K8 104 | | `K9 105 | | `Kbdillumdown 106 | | `Kbdillumtoggle 107 | | `Kbdillumup 108 | | `Kp_0 109 | | `Kp_00 110 | | `Kp_000 111 | | `Kp_1 112 | | `Kp_2 113 | | `Kp_3 114 | | `Kp_4 115 | | `Kp_5 116 | | `Kp_6 117 | | `Kp_7 118 | | `Kp_8 119 | | `Kp_9 120 | | `Kp_a 121 | | `Kp_ampersand 122 | | `Kp_at 123 | | `Kp_b 124 | | `Kp_backspace 125 | | `Kp_binary 126 | | `Kp_c 127 | | `Kp_clear 128 | | `Kp_clearentry 129 | | `Kp_colon 130 | | `Kp_comma 131 | | `Kp_d 132 | | `Kp_dblampersand 133 | | `Kp_dblverticalbar 134 | | `Kp_decimal 135 | | `Kp_divide 136 | | `Kp_e 137 | | `Kp_enter 138 | | `Kp_equals 139 | | `Kp_equalsas400 140 | | `Kp_exclam 141 | | `Kp_f 142 | | `Kp_greater 143 | | `Kp_hash 144 | | `Kp_hexadecimal 145 | | `Kp_leftbrace 146 | | `Kp_leftparen 147 | | `Kp_less 148 | | `Kp_memadd 149 | | `Kp_memclear 150 | | `Kp_memdivide 151 | | `Kp_memmultiply 152 | | `Kp_memrecall 153 | | `Kp_memstore 154 | | `Kp_memsubtract 155 | | `Kp_minus 156 | | `Kp_multiply 157 | | `Kp_octal 158 | | `Kp_percent 159 | | `Kp_period 160 | | `Kp_plus 161 | | `Kp_plusminus 162 | | `Kp_power 163 | | `Kp_rightbrace 164 | | `Kp_rightparen 165 | | `Kp_space 166 | | `Kp_tab 167 | | `Kp_verticalbar 168 | | `Kp_xor 169 | | `L 170 | | `Lalt 171 | | `Lang1 172 | | `Lang2 173 | | `Lang3 174 | | `Lang4 175 | | `Lang5 176 | | `Lang6 177 | | `Lang7 178 | | `Lang8 179 | | `Lang9 180 | | `Lctrl 181 | | `Left 182 | | `Leftbracket 183 | | `Lgui 184 | | `Lshift 185 | | `M 186 | | `Mail 187 | | `Mediaselect 188 | | `Menu 189 | | `Minus 190 | | `Mode 191 | | `Mute 192 | | `N 193 | | `Nonusbackslash 194 | | `Nonushash 195 | | `Numlockclear 196 | | `O 197 | | `Oper 198 | | `Out 199 | | `P 200 | | `Pagedown 201 | | `Pageup 202 | | `Paste 203 | | `Pause 204 | | `Period 205 | | `Power 206 | | `Printscreen 207 | | `Prior 208 | | `Q 209 | | `R 210 | | `Ralt 211 | | `Rctrl 212 | | `Return 213 | | `Return2 214 | | `Rgui 215 | | `Right 216 | | `Rightbracket 217 | | `Rshift 218 | | `S 219 | | `Scrolllock 220 | | `Select 221 | | `Semicolon 222 | | `Separator 223 | | `Slash 224 | | `Sleep 225 | | `Space 226 | | `Stop 227 | | `Sysreq 228 | | `T 229 | | `Tab 230 | | `Thousandsseparator 231 | | `U 232 | | `Undo 233 | | `Unknown 234 | | `Up 235 | | `V 236 | | `Volumedown 237 | | `Volumeup 238 | | `W 239 | | `Www 240 | | `X 241 | | `Y 242 | | `Z ] 243 | 244 | include Button.Make (struct 245 | type t = key 246 | end) 247 | -------------------------------------------------------------------------------- /lib/input/key.mli: -------------------------------------------------------------------------------- 1 | (** Key events. *) 2 | 3 | type key = 4 | [ `A 5 | | `Ac_back 6 | | `Ac_bookmarks 7 | | `Ac_forward 8 | | `Ac_home 9 | | `Ac_refresh 10 | | `Ac_search 11 | | `Ac_stop 12 | | `Again 13 | | `Alterase 14 | | `Apostrophe 15 | | `App1 16 | | `App2 17 | | `Application 18 | | `Audiomute 19 | | `Audionext 20 | | `Audioplay 21 | | `Audioprev 22 | | `Audiostop 23 | | `B 24 | | `Backslash 25 | | `Backspace 26 | | `Brightnessdown 27 | | `Brightnessup 28 | | `C 29 | | `Calculator 30 | | `Cancel 31 | | `Capslock 32 | | `Clear 33 | | `Clearagain 34 | | `Comma 35 | | `Computer 36 | | `Copy 37 | | `Crsel 38 | | `Currencysubunit 39 | | `Currencyunit 40 | | `Cut 41 | | `D 42 | | `Decimalseparator 43 | | `Delete 44 | | `Displayswitch 45 | | `Down 46 | | `E 47 | | `Eject 48 | | `End 49 | | `Equals 50 | | `Escape 51 | | `Execute 52 | | `Exsel 53 | | `F 54 | | `F1 55 | | `F10 56 | | `F11 57 | | `F12 58 | | `F13 59 | | `F14 60 | | `F15 61 | | `F16 62 | | `F17 63 | | `F18 64 | | `F19 65 | | `F2 66 | | `F20 67 | | `F21 68 | | `F22 69 | | `F23 70 | | `F24 71 | | `F3 72 | | `F4 73 | | `F5 74 | | `F6 75 | | `F7 76 | | `F8 77 | | `F9 78 | | `Find 79 | | `G 80 | | `Grave 81 | | `H 82 | | `Help 83 | | `Home 84 | | `I 85 | | `Insert 86 | | `International1 87 | | `International2 88 | | `International3 89 | | `International4 90 | | `International5 91 | | `International6 92 | | `International7 93 | | `International8 94 | | `International9 95 | | `J 96 | | `K 97 | | `K0 98 | | `K1 99 | | `K2 100 | | `K3 101 | | `K4 102 | | `K5 103 | | `K6 104 | | `K7 105 | | `K8 106 | | `K9 107 | | `Kbdillumdown 108 | | `Kbdillumtoggle 109 | | `Kbdillumup 110 | | `Kp_0 111 | | `Kp_00 112 | | `Kp_000 113 | | `Kp_1 114 | | `Kp_2 115 | | `Kp_3 116 | | `Kp_4 117 | | `Kp_5 118 | | `Kp_6 119 | | `Kp_7 120 | | `Kp_8 121 | | `Kp_9 122 | | `Kp_a 123 | | `Kp_ampersand 124 | | `Kp_at 125 | | `Kp_b 126 | | `Kp_backspace 127 | | `Kp_binary 128 | | `Kp_c 129 | | `Kp_clear 130 | | `Kp_clearentry 131 | | `Kp_colon 132 | | `Kp_comma 133 | | `Kp_d 134 | | `Kp_dblampersand 135 | | `Kp_dblverticalbar 136 | | `Kp_decimal 137 | | `Kp_divide 138 | | `Kp_e 139 | | `Kp_enter 140 | | `Kp_equals 141 | | `Kp_equalsas400 142 | | `Kp_exclam 143 | | `Kp_f 144 | | `Kp_greater 145 | | `Kp_hash 146 | | `Kp_hexadecimal 147 | | `Kp_leftbrace 148 | | `Kp_leftparen 149 | | `Kp_less 150 | | `Kp_memadd 151 | | `Kp_memclear 152 | | `Kp_memdivide 153 | | `Kp_memmultiply 154 | | `Kp_memrecall 155 | | `Kp_memstore 156 | | `Kp_memsubtract 157 | | `Kp_minus 158 | | `Kp_multiply 159 | | `Kp_octal 160 | | `Kp_percent 161 | | `Kp_period 162 | | `Kp_plus 163 | | `Kp_plusminus 164 | | `Kp_power 165 | | `Kp_rightbrace 166 | | `Kp_rightparen 167 | | `Kp_space 168 | | `Kp_tab 169 | | `Kp_verticalbar 170 | | `Kp_xor 171 | | `L 172 | | `Lalt 173 | | `Lang1 174 | | `Lang2 175 | | `Lang3 176 | | `Lang4 177 | | `Lang5 178 | | `Lang6 179 | | `Lang7 180 | | `Lang8 181 | | `Lang9 182 | | `Lctrl 183 | | `Left 184 | | `Leftbracket 185 | | `Lgui 186 | | `Lshift 187 | | `M 188 | | `Mail 189 | | `Mediaselect 190 | | `Menu 191 | | `Minus 192 | | `Mode 193 | | `Mute 194 | | `N 195 | | `Nonusbackslash 196 | | `Nonushash 197 | | `Numlockclear 198 | | `O 199 | | `Oper 200 | | `Out 201 | | `P 202 | | `Pagedown 203 | | `Pageup 204 | | `Paste 205 | | `Pause 206 | | `Period 207 | | `Power 208 | | `Printscreen 209 | | `Prior 210 | | `Q 211 | | `R 212 | | `Ralt 213 | | `Rctrl 214 | | `Return 215 | | `Return2 216 | | `Rgui 217 | | `Right 218 | | `Rightbracket 219 | | `Rshift 220 | | `S 221 | | `Scrolllock 222 | | `Select 223 | | `Semicolon 224 | | `Separator 225 | | `Slash 226 | | `Sleep 227 | | `Space 228 | | `Stop 229 | | `Sysreq 230 | | `T 231 | | `Tab 232 | | `Thousandsseparator 233 | | `U 234 | | `Undo 235 | | `Unknown 236 | | `Up 237 | | `V 238 | | `Volumedown 239 | | `Volumeup 240 | | `W 241 | | `Www 242 | | `X 243 | | `Y 244 | | `Z ] 245 | 246 | include Button.S with type button = key 247 | -------------------------------------------------------------------------------- /lib/input/mouse_button.ml: -------------------------------------------------------------------------------- 1 | type mouse_button = [ `Left | `Middle | `Right | `X1 | `X2 | `Unknown of int ] 2 | 3 | let of_int = function 4 | | 1 -> `Left 5 | | 2 -> `Right 6 | | 3 -> `Middle 7 | | 4 -> `X1 8 | | 5 -> `X2 9 | | i -> `Unknown i 10 | 11 | include Button.Make (struct 12 | type t = mouse_button 13 | end) 14 | -------------------------------------------------------------------------------- /lib/input/mouse_button.mli: -------------------------------------------------------------------------------- 1 | (** Mouse button events. *) 2 | 3 | type mouse_button = [ `Left | `Middle | `Right | `X1 | `X2 | `Unknown of int ] 4 | 5 | val of_int : int -> mouse_button 6 | 7 | include Button.S with type button = mouse_button 8 | -------------------------------------------------------------------------------- /lib/math/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name camlcade.math) 3 | (name math) 4 | (libraries gg)) 5 | -------------------------------------------------------------------------------- /lib/math/math.ml: -------------------------------------------------------------------------------- 1 | module Vec3 = struct 2 | include Gg.V3 3 | 4 | let normalize t = Gg.V3.smul (1. /. Gg.V3.norm t) t 5 | end 6 | 7 | module Vec4 = struct 8 | include Gg.V4 9 | 10 | let normalize t = Gg.V4.smul (1. /. Gg.V4.norm t) t 11 | end 12 | 13 | module Mat3 = struct 14 | include Gg.M3 15 | 16 | let to_list t = 17 | [ 18 | Gg.M3.e00 t; 19 | Gg.M3.e10 t; 20 | Gg.M3.e20 t; 21 | Gg.M3.e01 t; 22 | Gg.M3.e11 t; 23 | Gg.M3.e21 t; 24 | Gg.M3.e02 t; 25 | Gg.M3.e12 t; 26 | Gg.M3.e22 t; 27 | ] 28 | end 29 | 30 | module Mat4 = struct 31 | include Gg.M4 32 | 33 | let to_list t = 34 | [ 35 | Gg.M4.e00 t; 36 | Gg.M4.e10 t; 37 | Gg.M4.e20 t; 38 | Gg.M4.e30 t; 39 | Gg.M4.e01 t; 40 | Gg.M4.e11 t; 41 | Gg.M4.e21 t; 42 | Gg.M4.e31 t; 43 | Gg.M4.e02 t; 44 | Gg.M4.e12 t; 45 | Gg.M4.e22 t; 46 | Gg.M4.e32 t; 47 | Gg.M4.e03 t; 48 | Gg.M4.e13 t; 49 | Gg.M4.e23 t; 50 | Gg.M4.e33 t; 51 | ] 52 | end 53 | 54 | module Quat = struct 55 | include Gg.Quat 56 | 57 | let to_axes t = 58 | let x, y, z, w = Vec4.to_tuple t in 59 | let x2 = x +. x in 60 | let y2 = y +. y in 61 | let z2 = z +. z in 62 | let xx = x *. x2 in 63 | let xy = x *. y2 in 64 | let xz = x *. z2 in 65 | let yy = y *. y2 in 66 | let yz = y *. z2 in 67 | let zz = z *. z2 in 68 | let wx = w *. x2 in 69 | let wy = w *. y2 in 70 | let wz = w *. z2 in 71 | 72 | let x_axis = Vec4.v (1. -. (yy +. zz)) (xy +. wz) (xz -. wy) 0. in 73 | let y_axis = Vec4.v (xy -. wz) (1. -. (xx +. zz)) (yz +. wx) 0. in 74 | let z_axis = Vec4.v (xz +. wy) (yz -. wx) (1. -. (xx +. yy)) 0. in 75 | (x_axis, y_axis, z_axis) 76 | end 77 | -------------------------------------------------------------------------------- /lib/math/math.mli: -------------------------------------------------------------------------------- 1 | module Vec3 : sig 2 | include module type of Gg.V3 3 | 4 | val normalize : t -> t 5 | end 6 | 7 | module Vec4 : sig 8 | include module type of Gg.V4 9 | 10 | val normalize : t -> t 11 | end 12 | 13 | module Mat3 : sig 14 | include module type of Gg.M3 15 | 16 | val to_list : t -> float list 17 | end 18 | 19 | module Mat4 : sig 20 | include module type of Gg.M4 21 | 22 | val to_list : t -> float list 23 | end 24 | 25 | module Quat : sig 26 | include module type of Gg.Quat 27 | 28 | val to_axes : t -> Vec4.t * Vec4.t * Vec4.t 29 | end 30 | -------------------------------------------------------------------------------- /lib/storage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name camlcade.storage) 3 | (name storage) 4 | (libraries containers)) 5 | -------------------------------------------------------------------------------- /lib/storage/sparse_array.ml: -------------------------------------------------------------------------------- 1 | open Containers 2 | 3 | type 'a t = { values : 'a option Vector.vector } 4 | 5 | let unsafe_get t i = (Vector.unsafe_get_array t.values).(i) 6 | let unsafe_set t i v = (Vector.unsafe_get_array t.values).(i) <- v 7 | let create () = { values = Vector.create () } 8 | 9 | let get t i = 10 | if i >= 0 && i < Vector.length t.values then unsafe_get t i else None 11 | 12 | let contains t i = get t i |> Option.is_some 13 | 14 | let set t i v = 15 | if i >= Vector.length t.values then 16 | Vector.resize_with_init t.values ~init:None (i + 1); 17 | unsafe_set t i (Some v) 18 | 19 | let remove t i = 20 | get t i 21 | |> Option.map (fun v -> 22 | unsafe_set t i None; 23 | v) 24 | 25 | let clear t = Vector.clear t.values 26 | -------------------------------------------------------------------------------- /lib/storage/sparse_array.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val create : unit -> 'a t 4 | val get : 'a t -> int -> 'a option 5 | val contains : 'a t -> int -> bool 6 | val set : 'a t -> int -> 'a -> unit 7 | val remove : 'a t -> int -> 'a option 8 | val clear : 'a t -> unit 9 | -------------------------------------------------------------------------------- /lib/storage/sparse_set.ml: -------------------------------------------------------------------------------- 1 | open Containers 2 | 3 | type 'a t = { 4 | dense : 'a Vector.vector; 5 | sparse : int Sparse_array.t; 6 | indices : int Vector.vector; 7 | } 8 | 9 | let create () = 10 | { 11 | dense = Vector.create (); 12 | sparse = Sparse_array.create (); 13 | indices = Vector.create (); 14 | } 15 | 16 | let length t = Vector.length t.dense 17 | let contains t i = Sparse_array.contains t.sparse i 18 | 19 | let get t i = 20 | Sparse_array.get t.sparse i 21 | |> Option.map (Array.get (Vector.unsafe_get_array t.dense)) 22 | 23 | let set t i v = 24 | match Sparse_array.get t.sparse i with 25 | | Some j -> Vector.set t.dense j v 26 | | None -> 27 | Sparse_array.set t.sparse i (Vector.length t.dense); 28 | Vector.push t.indices i; 29 | Vector.push t.dense v 30 | 31 | let remove t i = 32 | Sparse_array.remove t.sparse i 33 | |> Option.map (fun j -> 34 | let last = Vector.length t.dense - 1 in 35 | let value = Vector.get t.dense j in 36 | Vector.remove_unordered t.dense j; 37 | Vector.remove_unordered t.indices j; 38 | (if j < last then 39 | let swapped = Vector.get t.indices j in 40 | Sparse_array.set t.sparse swapped j); 41 | value) 42 | -------------------------------------------------------------------------------- /lib/storage/sparse_set.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val create : unit -> 'a t 4 | val length : 'a t -> int 5 | val contains : 'a t -> int -> bool 6 | val get : 'a t -> int -> 'a option 7 | val set : 'a t -> int -> 'a -> unit 8 | val remove : 'a t -> int -> 'a option 9 | -------------------------------------------------------------------------------- /lib/transform/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name camlcade.transform) 3 | (name transform) 4 | (libraries ecs math)) 5 | -------------------------------------------------------------------------------- /lib/transform/transform.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | mutable translation : Math.Vec3.t; 3 | mutable rotation : Math.Quat.t; 4 | mutable scale : Math.Vec3.t; 5 | } 6 | 7 | let identity () = 8 | { 9 | translation = Math.Vec3.zero; 10 | rotation = Math.Quat.id; 11 | scale = Math.Vec3.v 1. 1. 1.; 12 | } 13 | 14 | let of_xyz x y z = { (identity ()) with translation = Math.Vec3.v x y z } 15 | let with_translation v t = { t with translation = v } 16 | let with_rotation q t = { t with rotation = q } 17 | let with_scale v t = { t with scale = v } 18 | 19 | let with_look_to ?(up = Math.Vec3.oy) dir t = 20 | let dir = Math.Vec3.normalize dir in 21 | let up = Math.Vec3.normalize up in 22 | let back = Math.Vec3.neg dir in 23 | let right = Math.Vec3.cross up back in 24 | let up = Math.Vec3.cross back right in 25 | { t with rotation = Math.Quat.of_m3 (Math.Mat3.of_cols right up back) } 26 | 27 | let with_look_at ?(up = Math.Vec3.oy) target t = 28 | with_look_to ~up Math.Vec3.(target - t.translation) t 29 | 30 | let translation t = t.translation 31 | let rotation t = t.rotation 32 | let scale t = t.scale 33 | let set_translation t v = t.translation <- v 34 | let set_rotation t q = t.rotation <- q 35 | let set_scale t v = t.scale <- v 36 | 37 | let set_look_to t ?(up = Math.Vec3.oy) dir = 38 | t.rotation <- rotation (with_look_to ~up dir t) 39 | 40 | let set_look_at t ?(up = Math.Vec3.oy) target = 41 | t.rotation <- rotation (with_look_at ~up target t) 42 | 43 | let compute_matrix t = 44 | let x_axis, y_axis, z_axis = Math.Quat.to_axes t.rotation in 45 | let sx, sy, sz = Math.Vec3.to_tuple t.scale in 46 | let tx, ty, tz = Math.Vec3.to_tuple t.translation in 47 | Math.Mat4.of_cols (Math.Vec4.smul sx x_axis) (Math.Vec4.smul sy y_axis) 48 | (Math.Vec4.smul sz z_axis) (Math.Vec4.v tx ty tz 1.) 49 | 50 | let local axis t = Math.Vec3.normalize (Math.Quat.apply3 t.rotation axis) 51 | let local_x = local Math.Vec3.ox 52 | let local_y = local Math.Vec3.oy 53 | let local_z = local Math.Vec3.oz 54 | let forward t = Math.Vec3.neg (local_z t) 55 | 56 | module C = Ecs.Component.Make (struct 57 | type inner = t 58 | end) 59 | -------------------------------------------------------------------------------- /lib/transform/transform.mli: -------------------------------------------------------------------------------- 1 | (** Represents translation, rotation, and scale. *) 2 | 3 | type t 4 | (** The type of a transform. *) 5 | 6 | (** {1:transforms Transforms} *) 7 | 8 | val identity : unit -> t 9 | (** Identity transform. *) 10 | 11 | val of_xyz : float -> float -> float -> t 12 | (** Create a transform with the given translation. *) 13 | 14 | (** {1:builders Builders} *) 15 | 16 | val with_translation : Math.Vec3.t -> t -> t 17 | (** Build a transform with the given translation. *) 18 | 19 | val with_rotation : Math.Quat.t -> t -> t 20 | (** Build a transform with the given rotation. *) 21 | 22 | val with_scale : Math.Vec3.t -> t -> t 23 | (** Build a transform with the given scale. *) 24 | 25 | val with_look_to : ?up:Math.Vec3.t -> Math.Vec3.t -> t -> t 26 | (** [with_look_to ~up dir t] returns a new transform that looks in the direction 27 | [dir] with the up vector [up]. *) 28 | 29 | val with_look_at : ?up:Math.Vec3.t -> Math.Vec3.t -> t -> t 30 | (** [with_look_at ~up target t] returns a new transform that looks at the target 31 | [target] with the up vector [up]. *) 32 | 33 | (** {1:operations Operations} *) 34 | 35 | (** {1:getters Getters} *) 36 | 37 | val translation : t -> Math.Vec3.t 38 | (** Return the translation of the transform. *) 39 | 40 | val rotation : t -> Math.Quat.t 41 | (** Return the rotation of the transform. *) 42 | 43 | val scale : t -> Math.Vec3.t 44 | (** Return the scale of the transform. *) 45 | 46 | (** {1:setters Setters} *) 47 | 48 | val set_translation : t -> Math.Vec3.t -> unit 49 | (** Set the translation of the transform. *) 50 | 51 | val set_rotation : t -> Math.Quat.t -> unit 52 | (** Set the rotation of the transform. *) 53 | 54 | val set_scale : t -> Math.Vec3.t -> unit 55 | (** Set the scale of the transform. *) 56 | 57 | val set_look_to : t -> ?up:Math.Vec3.t -> Math.Vec3.t -> unit 58 | (** Set the rotation of the transform to look in the direction [dir] with the up 59 | vector [up]. *) 60 | 61 | val set_look_at : t -> ?up:Math.Vec3.t -> Math.Vec3.t -> unit 62 | (** Set the rotation of the transform to look at the target [target] with the up 63 | vector [up]. *) 64 | 65 | (** {1:compute Compute} *) 66 | 67 | val compute_matrix : t -> Math.Mat4.t 68 | (** Calculate the transformation matrix from the translation, rotation, and 69 | scale. *) 70 | 71 | val local_x : t -> Math.Vec3.t 72 | (** Return the local x-axis of the transform. *) 73 | 74 | val local_y : t -> Math.Vec3.t 75 | (** Return the local y-axis of the transform. *) 76 | 77 | val local_z : t -> Math.Vec3.t 78 | (** Return the local z-axis of the transform. *) 79 | 80 | val forward : t -> Math.Vec3.t 81 | (** Return the forward vector of the transform. 82 | 83 | This is equivalent to the negative z-axis. *) 84 | 85 | (** {1:component Component} *) 86 | 87 | module C : Ecs.Component.S with type t = t 88 | (** Transform component *) 89 | -------------------------------------------------------------------------------- /test/ecs/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names 3 | test_archetype 4 | test_query 5 | test_world_entities 6 | test_world_components 7 | test_world_systems) 8 | (libraries camlcade)) 9 | -------------------------------------------------------------------------------- /test/ecs/test_archetype.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Ecs 3 | 4 | let test_components () = 5 | let components = Id.ComponentSet.of_list [ Foo.C.id; Bar.C.id; Baz.C.id ] in 6 | let a = Archetype.create components in 7 | assert (Id.ComponentSet.equal (Archetype.components a) components); 8 | 9 | let a = Archetype.empty () in 10 | assert (Id.ComponentSet.is_empty (Archetype.components a)) 11 | 12 | let test_add_entity () = 13 | let a = Archetype.create (Id.ComponentSet.of_list [ Foo.C.id; Bar.C.id ]) in 14 | let e = Id.Entity.of_int 1 in 15 | 16 | let foo_value e = 17 | !(Archetype.query a e Foo.C.id 18 | |> Option.get 19 | |> Component.unpack (module Foo.C)) 20 | in 21 | let bar_value e = 22 | !(Archetype.query a e Bar.C.id 23 | |> Option.get 24 | |> Component.unpack (module Bar.C)) 25 | in 26 | 27 | Archetype.add a e 28 | [ 29 | Component.pack (module Foo.C) (ref 0); 30 | Component.pack (module Bar.C) (ref 1); 31 | ]; 32 | assert (foo_value e = 0); 33 | assert (bar_value e = 1); 34 | 35 | Archetype.add a e 36 | [ 37 | Component.pack (module Bar.C) (ref 24); 38 | Component.pack (module Foo.C) (ref 42); 39 | ]; 40 | assert (foo_value e = 42); 41 | assert (bar_value e = 24) 42 | 43 | let test_add_entity_exception () = 44 | let a = Archetype.create (Id.ComponentSet.of_list [ Foo.C.id; Bar.C.id ]) in 45 | let e = Id.Entity.of_int 1 in 46 | 47 | let is_invalid_arg f = 48 | try 49 | f (); 50 | false 51 | with Invalid_argument _ -> true 52 | in 53 | 54 | assert (is_invalid_arg (fun _ -> Archetype.add a e [])); 55 | assert ( 56 | is_invalid_arg (fun _ -> 57 | Archetype.add a e [ Component.pack (module Baz.C) (ref 0) ])); 58 | assert ( 59 | is_invalid_arg (fun _ -> 60 | Archetype.add a e 61 | [ 62 | Component.pack (module Foo.C) (ref 0); 63 | Component.pack (module Baz.C) (ref 0); 64 | ])); 65 | assert ( 66 | is_invalid_arg (fun _ -> 67 | Archetype.add a e 68 | [ 69 | Component.pack (module Foo.C) (ref 0); 70 | Component.pack (module Bar.C) (ref 0); 71 | Component.pack (module Baz.C) (ref 0); 72 | ])) 73 | 74 | let () = 75 | test_components (); 76 | test_add_entity (); 77 | test_add_entity_exception () 78 | -------------------------------------------------------------------------------- /test/ecs/test_query.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Ecs 3 | 4 | let test_filter_matches () = 5 | let open Query.Filter in 6 | let a, b, c, d = (Foo.C.id, Bar.C.id, Baz.C.id, Name.C.id) in 7 | assert (matches (With a) (Id.ComponentSet.of_list [ b; a; c ])); 8 | assert (not (matches (With a) (Id.ComponentSet.of_list [ b ]))); 9 | assert (not (matches (With a) (Id.ComponentSet.of_list [ c ]))); 10 | 11 | assert (matches (Without b) (Id.ComponentSet.of_list [])); 12 | assert (not (matches (Without c) (Id.ComponentSet.of_list [ c; b; a ]))); 13 | assert (matches (Without a) (Id.ComponentSet.of_list [ b; c; d ])); 14 | 15 | assert (matches (Not (With a)) (Id.ComponentSet.of_list [ b ])); 16 | assert (not (matches (Not (With a)) (Id.ComponentSet.of_list [ a ]))); 17 | 18 | assert (matches (And (With a, With b)) (Id.ComponentSet.of_list [ b; a ])); 19 | assert (matches (And (With a, With b)) (Id.ComponentSet.of_list [ a; d; b ])); 20 | assert ( 21 | not (matches (And (With b, With a)) (Id.ComponentSet.of_list [ b; d ]))); 22 | assert (not (matches (And (With b, With d)) (Id.ComponentSet.of_list [ a ]))); 23 | 24 | assert (matches (Or (With a, With b)) (Id.ComponentSet.of_list [ a; b ])); 25 | assert (matches (Or (With a, With b)) (Id.ComponentSet.of_list [ b; c; a ])); 26 | assert (matches (Or (With a, With b)) (Id.ComponentSet.of_list [ a; c ])); 27 | assert (not (matches (Or (With a, With b)) (Id.ComponentSet.of_list [ c ]))); 28 | assert (not (matches (Or (With a, With b)) (Id.ComponentSet.of_list []))); 29 | 30 | assert (matches Wildcard (Id.ComponentSet.of_list [ a; b; c; d ])); 31 | assert (matches Wildcard (Id.ComponentSet.of_list [])) 32 | 33 | let test_required_components () = 34 | let open Query in 35 | let required_eq q l = 36 | Id.ComponentSet.equal (required_ids q) (Id.ComponentSet.of_list l) 37 | in 38 | let q = [] in 39 | assert (required_eq q []); 40 | let q = Req (module Foo.C) :: [] in 41 | assert (required_eq q [ Foo.C.id ]); 42 | 43 | let q = [ Req (module Foo.C); Opt (module Bar.C) ] in 44 | assert (required_eq q [ Foo.C.id ]); 45 | 46 | let q = [ Opt (module Bar.C); Opt (module Baz.C) ] in 47 | assert (required_eq q []); 48 | 49 | let q = [ Req (module Foo.C); Opt (module Baz.C); Req (module Bar.C) ] in 50 | assert (required_eq q [ Foo.C.id; Bar.C.id ]) 51 | 52 | let test_evaluate () = 53 | (* TODO: Implement test_evaluate *) 54 | assert true 55 | 56 | let () = 57 | test_filter_matches (); 58 | test_required_components (); 59 | test_evaluate () 60 | -------------------------------------------------------------------------------- /test/ecs/test_world_components.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Ecs 3 | 4 | let test_with_component () = 5 | let w = World.create () in 6 | let e = 7 | World.add_entity w 8 | |> World.with_component w (module Foo.C) (ref 2) 9 | |> World.with_component w (module Bar.C) (ref 1) 10 | |> World.with_component w (module Foo.C) (ref 0) 11 | in 12 | let e_components = World.get_component w e in 13 | (match (e_components Foo.C.id, e_components Bar.C.id) with 14 | | Some foo, Some bar -> 15 | let foo = foo |> Component.unpack (module Foo.C) in 16 | assert (!foo = 0); 17 | let bar = bar |> Component.unpack (module Bar.C) in 18 | assert (!bar = 1) 19 | | _ -> assert false); 20 | 21 | assert (e_components Baz.C.id |> Option.is_none) 22 | 23 | let test_diabolical_graph () = 24 | let w = World.create () in 25 | (* e1 creates archetype graph [] -> [Foo] -> [Foo, Bar] -> [Foo, Bar, Baz] *) 26 | let e1 = 27 | World.add_entity w 28 | |> World.with_component w (module Foo.C) (ref 0) 29 | |> World.with_component w (module Bar.C) (ref 0) 30 | |> World.with_component w (module Baz.C) (ref 0) 31 | in 32 | (* e2 creates archetype graph [] -> [Bar] -> [Bar, Baz] *) 33 | let e2 = 34 | World.add_entity w 35 | |> World.with_component w (module Bar.C) (ref 0) 36 | |> World.with_component w (module Baz.C) (ref 0) 37 | in 38 | 39 | (* When Foo is removed, the world will attempt to traverse the archetype graph 40 | from [Foo, Bar, Baz] to [Bar, Baz], but this remove edge does not exist yet. 41 | However, the [Bar, Baz] archetype already exists after e2 was added. 42 | So, this test ensures that the same archetype is reused. *) 43 | World.remove_component w Foo.C.id e1; 44 | 45 | let e1_get = World.get_component w e1 in 46 | assert (e1_get Foo.C.id = None); 47 | assert (e1_get Bar.C.id |> Option.is_some); 48 | assert (e1_get Baz.C.id |> Option.is_some); 49 | 50 | (* e2 should still have components [Bar, Baz], if not, it probably means that 51 | the previous remove_component call inadvertently replaced the [Bar, Baz] archetype *) 52 | let e2_get = World.get_component w e2 in 53 | assert (e2_get Bar.C.id |> Option.is_some); 54 | assert (e2_get Baz.C.id |> Option.is_some); 55 | 56 | (* Now, add back the Foo component to e1 *) 57 | World.add_component w (Component.pack (module Foo.C) (ref 1)) e1; 58 | assert (e1_get Foo.C.id |> Option.is_some) 59 | 60 | let () = 61 | test_with_component (); 62 | test_diabolical_graph () 63 | -------------------------------------------------------------------------------- /test/ecs/test_world_entities.ml: -------------------------------------------------------------------------------- 1 | open Ecs 2 | 3 | let test_start_empty () = 4 | let w = World.create () in 5 | assert (World.entities w = []) 6 | 7 | let test_uniqueness () = 8 | let w = World.create () in 9 | assert (World.add_entity w <> World.add_entity w) 10 | 11 | let test_add_entity () = 12 | let w = World.create () in 13 | let e = World.add_entity w in 14 | assert (World.entities w = [ e ]); 15 | for _ = 1 to 99 do 16 | World.add_entity w |> ignore 17 | done; 18 | assert (List.length (World.entities w) = 100) 19 | 20 | let test_remove_entity () = 21 | let w = World.create () in 22 | let e = World.add_entity w in 23 | World.remove_entity w e; 24 | assert (List.is_empty (World.entities w)); 25 | 26 | assert ( 27 | try 28 | World.remove_entity w e; 29 | false 30 | with Not_found -> true) 31 | 32 | let () = 33 | test_start_empty (); 34 | test_uniqueness (); 35 | test_add_entity (); 36 | test_remove_entity () 37 | -------------------------------------------------------------------------------- /test/ecs/test_world_systems.ml: -------------------------------------------------------------------------------- 1 | (* 2 | open Util 3 | open Ecs 4 | 5 | let test_simple () = 6 | let w = World.create () in 7 | let e = 8 | World.add_entity w |> World.with_component w (module Foo.C) (ref 42) 9 | in 10 | 11 | let value = ref None in 12 | let simple = function 13 | | [| [ (e', [ foo ]) ] |] -> 14 | assert (e' == e); 15 | let foo = foo |> Component.unpack (module Foo.C) in 16 | value := Some !foo 17 | | _ -> assert false 18 | in 19 | 20 | World.add_system w Scheduler.Update 21 | [| Query.create [ Query.Required Foo.C.id ] |] 22 | (System.Query simple); 23 | 24 | World.run_systems w Scheduler.Update; 25 | 26 | assert (!value = Some 42) 27 | 28 | let test_order () = 29 | let w = World.create () in 30 | let e = World.add_entity w |> World.with_component w (module Foo.C) (ref 0) in 31 | 32 | let set_system n = function 33 | | [| [ (_, [ foo ]) ] |] -> 34 | let foo = foo |> Component.unpack (module Foo.C) in 35 | foo := n 36 | | _ -> assert false 37 | in 38 | 39 | let set_one = set_system 1 in 40 | let set_two = set_system 2 in 41 | 42 | World.add_system w Scheduler.Update 43 | [| Query.create [ Query.Required Foo.C.id ] |] 44 | (System.Query set_two); 45 | 46 | World.add_system w Scheduler.Update 47 | [| Query.create [ Query.Required Foo.C.id ] |] 48 | (System.Query set_one); 49 | 50 | World.run_systems w Scheduler.Update; 51 | 52 | let foo = 53 | World.get_component w e Foo.C.id 54 | |> Option.get 55 | |> Component.unpack (module Foo.C) 56 | in 57 | assert (!foo = 1) 58 | 59 | let test_complex () = 60 | let w = World.create () in 61 | let entities = 62 | List.init 10 (fun v -> 63 | World.add_entity w 64 | |> World.with_component w (module Foo.C) (ref v) 65 | |> World.with_component w (module Name.C) (ref "placeholder")) 66 | in 67 | 68 | let update_entities : Query.Result.t array -> unit = function 69 | | [| r1; r2 |] -> 70 | r1 71 | |> List.iter (function 72 | | e, [ foo; name; baz ] -> 73 | let foo = foo |> Component.unpack (module Foo.C) in 74 | let name = name |> Component.unpack (module Name.C) in 75 | foo := Id.Entity.to_int e; 76 | name := string_of_int (Id.Entity.to_int e); 77 | assert ( 78 | baz |> Component.unpack_opt (module Baz.C) |> Option.is_none) 79 | | _ -> assert false); 80 | let baz_is_none = function 81 | | _, [ baz ] -> 82 | assert ( 83 | baz |> Component.unpack_opt (module Baz.C) |> Option.is_none) 84 | | _ -> assert false 85 | in 86 | r2 |> List.iter baz_is_none 87 | | _ -> assert false 88 | in 89 | 90 | World.add_system w Scheduler.Update 91 | [| 92 | Query.create 93 | [ 94 | Query.Required Foo.C.id; 95 | Query.Required Name.C.id; 96 | Query.Optional Baz.C.id; 97 | ]; 98 | Query.create [ Query.Optional Baz.C.id ]; 99 | |] 100 | (System.Query update_entities); 101 | 102 | World.run_systems w Scheduler.Update; 103 | 104 | entities 105 | |> List.iter (fun e -> 106 | let foo = 107 | World.get_component w e Foo.C.id 108 | |> Option.get 109 | |> Component.unpack (module Foo.C) 110 | in 111 | assert (!foo = Id.Entity.to_int e); 112 | let name = 113 | World.get_component w e Name.C.id 114 | |> Option.get 115 | |> Component.unpack (module Name.C) 116 | in 117 | assert (int_of_string !name = Id.Entity.to_int e)) 118 | 119 | let test_immediate () = 120 | let w = World.create () in 121 | let original_entity = 122 | World.add_entity w 123 | |> World.with_component w (module Name.C) (ref "whatever") 124 | in 125 | 126 | assert (List.length (World.entities w) = 1); 127 | 128 | let spawn_more_entities world : Query.Result.t array -> unit = function 129 | | _ -> ( 130 | for _ = 1 to 10 do 131 | World.add_entity world 132 | |> World.add_component world (Component.pack (module Foo.C) (ref 0)) 133 | done; 134 | try World.remove_entity world original_entity with _ -> ()) 135 | in 136 | 137 | World.add_system w Scheduler.Update 138 | [| Query.create [] |] 139 | (System.Immediate spawn_more_entities); 140 | 141 | World.run_systems w Scheduler.Update; 142 | 143 | assert (List.length (World.entities w) = 10); 144 | 145 | World.run_systems w Scheduler.Update; 146 | 147 | assert (List.length (World.entities w) = 20) 148 | 149 | let test_quit () = 150 | let w = World.create () in 151 | 152 | assert (not (World.has_quit w)); 153 | 154 | let quit_system = function _ -> raise World.Quit in 155 | World.add_system w Scheduler.Update [||] (System.Query quit_system); 156 | 157 | World.run_systems w Scheduler.Update; 158 | 159 | assert (World.has_quit w) 160 | 161 | let () = 162 | test_simple (); 163 | test_order (); 164 | test_complex (); 165 | test_immediate (); 166 | test_quit () 167 | *) 168 | -------------------------------------------------------------------------------- /test/ecs/util.ml: -------------------------------------------------------------------------------- 1 | open Ecs 2 | 3 | module Foo = struct 4 | type t = int ref 5 | 6 | module C = Component.Make (struct 7 | type inner = t 8 | end) 9 | end 10 | 11 | module Bar = struct 12 | type t = int ref 13 | 14 | module C = Component.Make (struct 15 | type inner = t 16 | end) 17 | end 18 | 19 | module Baz = struct 20 | type t = int ref 21 | 22 | module C = Component.Make (struct 23 | type inner = t 24 | end) 25 | end 26 | 27 | module Name = struct 28 | type t = string ref 29 | 30 | module C = Component.Make (struct 31 | type inner = t 32 | end) 33 | end 34 | --------------------------------------------------------------------------------