├── .gitignore ├── .snitch.yaml ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── default.nix ├── kkona.png ├── samples ├── arkanoid.ml ├── empty.ml ├── rotation.ml ├── sort.ml └── swirl.ml └── src ├── animation.ml ├── cairo.ml ├── cairo.mli ├── cairo_impl.c ├── cairo_matrix.ml ├── cairo_matrix_impl.c ├── color.ml ├── console.ml ├── console_impl.c ├── extra.ml ├── flow.ml ├── font.ml ├── hot.ml ├── main.ml ├── picture.ml ├── rect.ml ├── sdlTexture.ml ├── vec2.ml ├── watcher.ml └── watcher_impl.c /.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 | multik.opt 26 | multik.prof 27 | multik 28 | out/ 29 | *.mp4 30 | 31 | gmon.out -------------------------------------------------------------------------------- /.snitch.yaml: -------------------------------------------------------------------------------- 1 | title: 2 | transforms: 3 | - match: (.*) \*/ 4 | replace: $1 5 | - match: (.*) \*\) 6 | replace: $1 7 | - match: (.*) \-\-\> 8 | replace: $1 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | addons: 4 | apt: 5 | packages: 6 | - libsdl2-dev 7 | install: 8 | - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-ocaml.sh 9 | - bash -ex .travis-ocaml.sh 10 | - opam install -y ocamlfind camlp4 11 | script: 12 | - eval `opam config env` 13 | - make 14 | - make multik.prof 15 | env: 16 | - OCAML_VERSION=4.04 17 | os: 18 | - linux 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Tsoding 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS=-Wall -Werror -ggdb $(shell pkg-config --cflags sdl2 cairo) 2 | LIBS=$(shell pkg-config --libs sdl2 cairo) 3 | CORE_MLS=src/extra.ml \ 4 | src/flow.ml \ 5 | src/color.ml \ 6 | src/font.ml \ 7 | src/vec2.ml \ 8 | src/rect.ml \ 9 | src/picture.ml \ 10 | src/sdlTexture.ml \ 11 | src/cairo_matrix.ml \ 12 | src/cairo.mli \ 13 | src/cairo.ml \ 14 | src/console.ml \ 15 | src/watcher.ml \ 16 | src/animation.ml \ 17 | src/hot.ml 18 | OBJS=src/cairo_matrix_impl.o \ 19 | src/cairo_impl.o \ 20 | src/console_impl.o \ 21 | src/watcher_impl.o 22 | SAMPLES=samples/arkanoid.cmo \ 23 | samples/empty.cmo \ 24 | samples/rotation.cmo \ 25 | samples/swirl.cmo \ 26 | samples/sort.cmo 27 | 28 | all: multik $(SAMPLES) 29 | 30 | multik: $(OBJS) $(CORE_MLS) src/main.ml Makefile 31 | ocamlfind ocamlc -pp "camlp4o pa_macro.cmo" -linkpkg -package threads,dynlink -thread \ 32 | -custom -I ./src/ \ 33 | -o multik \ 34 | $(OBJS) \ 35 | $(CORE_MLS) src/main.ml \ 36 | -ccopt "$(CFLAGS)" \ 37 | -cclib "$(LIBS)" \ 38 | 39 | multik.prof: $(OBJS) $(CORE_MLS) src/main.ml 40 | ocamlfind ocamlopt -pp "camlp4o pa_macro.cmo -DPROFILE" -linkpkg -package threads,dynlink -thread \ 41 | -I ./src/ \ 42 | -o multik.prof \ 43 | $(OBJS) \ 44 | $(CORE_MLS) src/main.ml \ 45 | -ccopt "-pg -ggdb $(CFLAGS)" \ 46 | -cclib "$(LIBS)" \ 47 | 48 | src/%.o: src/%.c 49 | ocamlc -c -ccopt "$(CFLAGS)" $< -cclib "$(LIBS)" 50 | mv $(notdir $@) src/ 51 | 52 | samples/%.cmo: samples/%.ml $(CORE_MLS) 53 | ocamlc -pp "camlp4o pa_macro.cmo" -I ./src/ -c $(CORE_MLS) $< 54 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Tsoding](https://img.shields.io/badge/twitch.tv-tsoding-purple?logo=twitch&style=for-the-badge)](https://www.twitch.tv/tsoding) 2 | # multik 3 | 4 | Animation Framework 5 | 6 | [![MULTIK DEMO](https://img.youtube.com/vi/6QAeNTOdhsk/0.jpg)](https://www.youtube.com/watch?v=6QAeNTOdhsk) 7 | 8 | ## Dependencies 9 | 10 | - [OCaml] 11 | - [gcc] 12 | - [SDL2] 13 | - [cairo] 14 | - [ffmpeg] 15 | 16 | Note that the only supported OS at the moment is Linux. Track [#49] for Windows support. 17 | 18 | ### NixOS 19 | 20 | For [NixOS] we have a development environment defined in [default.nix] 21 | with all of the required dependencies. You can enter the environment 22 | with nix-shell command: 23 | 24 | ```console 25 | $ nix-shell 26 | ``` 27 | 28 | ### Ubuntu 29 | 30 | ```console 31 | $ sudo apt-get install gcc ocaml libsdl2-dev libcairo2-dev 32 | ``` 33 | 34 | ## Quick Start 35 | 36 | ```console 37 | $ nix-shell # For NixOS 38 | $ make 39 | $ ./multik preview samples/arkanoid.cmo 40 | $ ./multik render samples/arkanoid.cmo arkanoid.mp4 41 | ``` 42 | 43 | ## Profiling 44 | 45 | ```console 46 | $ make multik.prof 47 | $ ./multik.prof preview # you can provide any file, it will be ignored 48 | # because the animation is baked into the executable 49 | $ gprof ./multik.prof 50 | ``` 51 | 52 | ## Support 53 | 54 | You can support my work via 55 | 56 | - Twitch channel: https://www.twitch.tv/subs/tsoding 57 | - Patreon: https://www.patreon.com/tsoding 58 | 59 | [OCaml]: http://www.ocaml.org/ 60 | [gcc]: https://gcc.gnu.org/ 61 | [SDL2]: https://www.libsdl.org/ 62 | [cairo]: https://www.cairographics.org/ 63 | [ffmpeg]: https://ffmpeg.org/ 64 | [#49]: https://github.com/tsoding/multik/issues/49 65 | [NixOS]: https://nixos.org/ 66 | [default.nix]: ./default.nix 67 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | with import {}; { 2 | cairoprobeEnv = stdenv.mkDerivation { 3 | name = "cairoprobe-env"; 4 | buildInputs = [ stdenv 5 | gcc 6 | gdb 7 | ocaml 8 | ocamlPackages.findlib 9 | ocamlPackages.camlp4 10 | pkgconfig 11 | cairo 12 | SDL2 13 | ffmpeg-full 14 | ncurses 15 | pkg-config 16 | ]; 17 | }; 18 | } 19 | -------------------------------------------------------------------------------- /kkona.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tsoding/multik/15384bd44c607f1b76c625ef97c01ad50a155cdc/kkona.png -------------------------------------------------------------------------------- /samples/arkanoid.ml: -------------------------------------------------------------------------------- 1 | module Arkanoid : Animation.T = 2 | struct 3 | type t = 4 | { 5 | position: Vec2.t; 6 | direction: Vec2.t; 7 | angle: float; 8 | } 9 | 10 | let radius = 50.0 11 | 12 | let init = 13 | { 14 | position = (100.0, 100.0); 15 | direction = (1000.0, 1000.0); 16 | angle = 0.0; 17 | } 18 | 19 | let resolution = (1920, 1080) 20 | 21 | let obj (x, y: Vec2.t) (angle: float): Picture.t = 22 | Picture.rect (radius, radius) 23 | |> (Color.rgb 0.8 0.1 0.8 |> Picture.color) 24 | |> Picture.scale (2.0, 2.0) 25 | |> Picture.rotate angle 26 | |> Picture.translate (x, y) 27 | 28 | let render state = 29 | let (w, h) = resolution in 30 | [ Picture.rect (float_of_int w, float_of_int h) 31 | |> (Color.rgb 0.1 0.1 0.1 |> Picture.color) 32 | ; obj state.position state.angle 33 | ] |> Picture.compose 34 | 35 | let wall_collision (state: t): t = 36 | let (x, y) = state.position in 37 | let (dx, dy) = state.direction in 38 | let (w, h) = resolution in 39 | { state with 40 | direction = ((if radius <= x && x <= ((float_of_int w) -. radius) then dx else (dx *. -1.)), 41 | (if radius <= y && y <= ((float_of_int h) -. radius) then dy else (dy *. -1.))) 42 | } 43 | 44 | let move (delta_time: float) (state: t): t = 45 | let (x, y) = state.position in 46 | let (dx, dy) = state.direction in 47 | { state with 48 | position = (x +. dx *. delta_time, y +. dy *. delta_time) 49 | } 50 | 51 | let rotate (delta_time: float) (state: t): t= 52 | { state with 53 | angle = state.angle +. delta_time 54 | } 55 | 56 | let update delta_time state = 57 | state |> wall_collision |> move delta_time |> rotate delta_time 58 | 59 | let fps = 60 60 | 61 | let frames = 62 | init 63 | |> Flow.iterate (update (1.0 /. float_of_int fps)) 64 | |> Flow.map render 65 | |> Flow.take 200 66 | end 67 | 68 | let () = Hot.load (module Arkanoid : Animation.T) 69 | -------------------------------------------------------------------------------- /samples/empty.ml: -------------------------------------------------------------------------------- 1 | module Empty : Animation.T = 2 | struct 3 | let frames = Flow.nil 4 | let fps = 30 5 | let resolution = (800, 600) 6 | end 7 | 8 | let () = Hot.load (module Empty : Animation.T) 9 | -------------------------------------------------------------------------------- /samples/rotation.ml: -------------------------------------------------------------------------------- 1 | module Rotation : Animation.T = 2 | struct 3 | type t = 4 | { 5 | angle: float; 6 | } 7 | 8 | let width = 1920 9 | let height = 1080 10 | let resolution = (width, height) 11 | let fps = 30 12 | let background_color = Color.rgb 0.1 0.1 0.1 13 | let dot_color = Color.rgb 1.0 0.5 0.5 14 | 15 | let background = 16 | Picture.Rect (float_of_int width, float_of_int height) 17 | |> Picture.color background_color 18 | 19 | let circle (n: int) (l: float): Vec2.t list = 20 | let pi = 3.14159265359 in 21 | let delta_angle = 2.0 *. pi /. float_of_int n in 22 | Flow.from 0 23 | |> Flow.take n 24 | |> Flow.map (fun i -> 25 | let angle = float_of_int i *. delta_angle in 26 | (l *. cos angle, l *. sin angle)) 27 | |> Flow.as_list 28 | 29 | let dot = 30 | Picture.Circle 15.0 31 | |> Picture.color dot_color 32 | 33 | let dots ps = 34 | ps 35 | |> List.map (fun (x, y) -> dot |> Picture.translate (x, y)) 36 | |> Picture.compose 37 | 38 | 39 | let init_state = 40 | { 41 | angle = 0.0 42 | } 43 | 44 | let ring (state: t) (r: float) = 45 | circle 100 r 46 | |> dots 47 | |> Picture.rotate state.angle 48 | |> Picture.translate 49 | (float_of_int width *. 0.5, 50 | float_of_int height *. 0.5) 51 | 52 | let render_state state = 53 | Picture.Compose [ background; 54 | ring state 500.0; 55 | ring state 300.0] 56 | 57 | let update_state state = {angle = state.angle +. 0.1} 58 | 59 | let frames = 60 | Flow.iterate update_state init_state 61 | |> Flow.map render_state 62 | |> Flow.take 100 63 | end 64 | 65 | let () = Hot.load (module Rotation : Animation.T) 66 | -------------------------------------------------------------------------------- /samples/sort.ml: -------------------------------------------------------------------------------- 1 | open Extra 2 | 3 | type action_t = Swap of int * int 4 | | Assign of int * int 5 | 6 | module Bubble = 7 | struct 8 | let trace (xs: int list): action_t list = 9 | let input = Array.of_list xs in 10 | let output = ref [] in 11 | let n = Array.length input in 12 | for i = n downto 2 do 13 | for j = 0 to i - 2 do 14 | let a = Array.get input j in 15 | let b = Array.get input (j + 1) in 16 | if a > b then 17 | begin 18 | Array.set input j b; 19 | Array.set input (j + 1) a; 20 | output := Swap (j, j + 1) :: !output 21 | (* output := Assign (j, b) :: Assign (j + 1, a) :: !output *) 22 | end 23 | done 24 | done; 25 | List.rev !output 26 | end 27 | 28 | module Merge = 29 | struct 30 | let merge_array (xs: int array) (l: int) (m: int) (h: int): action_t list = 31 | let n = h - l in 32 | let ys = Array.make n 0 in 33 | let rec merge_array_impl (i: int) (j: int) (k: int): unit = 34 | match () with 35 | | _ when (i >= m) && (j >= h) -> () 36 | | _ when i >= m -> (* ran out of left, pick right *) 37 | Array.set ys k (Array.get xs j); 38 | merge_array_impl i (j + 1) (k + 1) 39 | | _ when j >= h -> (* ran out of right, pick left *) 40 | Array.set ys k (Array.get xs i); 41 | merge_array_impl (i + 1) j (k + 1) 42 | | _ when Array.get xs i < Array.get xs j -> (* pick left *) 43 | Array.set ys k (Array.get xs i); 44 | merge_array_impl (i + 1) j (k + 1) 45 | | _ when Array.get xs i >= Array.get xs j -> (* pick right *) 46 | Array.set ys k (Array.get xs j); 47 | merge_array_impl i (j + 1) (k + 1) 48 | | _ -> failwith "Should never happen" 49 | in 50 | merge_array_impl l m 0; 51 | Array.blit ys 0 xs l (h - l); 52 | ys 53 | |> Array.to_list 54 | |> List.mapi (fun i y -> Assign (l + i, y)) 55 | 56 | let trace (xs: int list): action_t list = 57 | let rec merge_trace_impl (xs: int array) (l: int) (h: int): action_t list = 58 | if h - l <= 1 59 | then [] 60 | else let m = l + (h - l) / 2 in 61 | let t1 = merge_trace_impl xs l m in 62 | let t2 = merge_trace_impl xs m h in 63 | let t3 = merge_array xs l m h in 64 | t1 @ t2 @ t3 65 | in 66 | let arr = Array.of_list xs in 67 | let t = merge_trace_impl arr 0 (List.length xs) in 68 | arr |> Array.iter (Printf.printf "%d "); 69 | print_endline ""; 70 | t 71 | end 72 | 73 | module Quick = 74 | struct 75 | let trace (xs: int list): action_t list = 76 | let n = List.length xs in 77 | let ys = Array.of_list xs in 78 | let trace = ref [] in 79 | 80 | let pivot_nth (p0: int) (l: int) (h: int): int = 81 | let rec pivot_left (p: int) (i: int): int = 82 | if i < p then 83 | (if (Array.get ys p) <= (Array.get ys i) 84 | then 85 | begin 86 | Array.swap i (p - 1) ys; 87 | trace := (i, (p - 1)) :: !trace; 88 | 89 | Array.swap (p - 1) p ys; 90 | trace := ((p - 1), p) :: !trace; 91 | 92 | pivot_left (p - 1) i 93 | end 94 | else pivot_left p (i + 1)) 95 | else p 96 | in 97 | let rec pivot_right (p: int) (i: int): int = 98 | if i < h then 99 | (if (Array.get ys p) > (Array.get ys i) then 100 | begin 101 | Array.swap (p + 1) i ys; 102 | trace := ((p + 1), i) :: !trace; 103 | 104 | Array.swap p (p + 1) ys; 105 | trace := (p, (p + 1)) :: !trace; 106 | 107 | pivot_right (p + 1) (i + 1) 108 | end 109 | else 110 | pivot_right p (i + 1)) 111 | else p 112 | in 113 | let p1 = pivot_left p0 l in 114 | pivot_right p1 (p1 + 1) 115 | in 116 | 117 | let pivot_first (l: int) (h: int): int = 118 | pivot_nth l l h 119 | in 120 | 121 | let pivot_middle (l: int) (h: int): int = 122 | pivot_nth (l + (h - l) / 2) l h 123 | in 124 | 125 | let pivot_random (l: int) (h: int): int = 126 | pivot_nth (l + Random.int (h - l)) l h 127 | in 128 | 129 | let rec quick_trace_impl (l: int) (h: int) (pivot: int -> int -> int): unit = 130 | if h - l >= 2 then 131 | let p = pivot l h in 132 | quick_trace_impl l p pivot; 133 | quick_trace_impl (p + 1) h pivot 134 | in 135 | quick_trace_impl 0 n pivot_random; 136 | print_endline ""; 137 | !trace 138 | |> List.rev 139 | |> List.filter (fun (a, b) -> a != b) 140 | |> List.map (fun (a, b) -> Swap (a, b)) 141 | end 142 | 143 | module Sort : Animation.T = 144 | struct 145 | let row_padding = 50.0 146 | let resolution = (1920, 1080) 147 | let (width, height) = resolution |> Vec2.of_ints 148 | let fps = 60 149 | let delta_time = 1.0 /. float_of_int fps 150 | 151 | let background_color = (0.1, 0.1, 0.1, 1.0) 152 | let foreground_color = (1.0, 0.2, 0.2, 1.0) 153 | let highlight_color = (0.2, 1.0, 0.2, 1.0) 154 | 155 | let background: Picture.t = 156 | Picture.rect (width, height) 157 | |> Picture.color background_color 158 | 159 | let shadow (p: Picture.t): Picture.t = 160 | let offset = 3.0 in 161 | Picture.compose [ p 162 | |> Picture.color Color.black 163 | |> Picture.translate (offset, offset) 164 | ; p ] 165 | 166 | let dot (circle_color: Color.t) (titleText: string): Picture.t = 167 | let radius = 25.0 in 168 | let text_color = (0.8, 0.8, 0.8, 1.0) in 169 | Picture.compose 170 | [ Picture.circle radius 171 | |> Picture.color circle_color 172 | ; let title = 173 | Picture.text (Font.make "Ubuntu Mono" (radius *. 1.2)) titleText 174 | |> shadow 175 | |> Picture.color text_color 176 | in Picture.sizeOf 177 | title 178 | (fun (_, _, w, h) -> 179 | title 180 | |> Picture.translate (w *. (-0.5), h *. 0.5))] 181 | 182 | let row_layout (padding: float) (xs: 'a list): Vec2.t list = 183 | xs |> List.mapi (fun i _ -> (padding *. float_of_int i, 0.0)) 184 | 185 | (* TODO(#122): row layouting should be available to all animations *) 186 | let row (padding: float) (ps: Picture.t list): Picture.t list = 187 | List.map2 Picture.translate (row_layout padding ps) ps 188 | 189 | let screenCenter (p: Picture.t): Picture.t = 190 | Picture.sizeOf p 191 | (fun (_, _, w, h) -> 192 | p |> Picture.translate (width *. 0.5 -. w *. 0.5, 193 | height *. 0.5)) 194 | 195 | let kkona_snek (angle: float) = 196 | List.range 1 30 197 | |> List.map string_of_int 198 | |> List.map (fun _ -> 199 | Picture.image "./kkona.png" 200 | |> Picture.scale (2.5, 2.5)) 201 | |> List.mapi (fun i p -> 202 | p 203 | |> Picture.translate 204 | (0.0, sin (angle +. float_of_int i *. 0.6) *. 50.0)) 205 | |> row 50.0 206 | 207 | let render_array (xs: int list): Picture.t = 208 | xs 209 | |> List.map string_of_int 210 | |> List.map (dot foreground_color) 211 | |> row row_padding 212 | |> Picture.compose 213 | 214 | type t = float 215 | 216 | (* TODO(#123): animate_move is not available to all of the animations *) 217 | let animate_move (duration: float) (p: Picture.t) (start: Vec2.t) (finish: Vec2.t): Picture.t Flow.t = 218 | let n = floor (duration /. delta_time) in 219 | let r = delta_time /. duration in 220 | let dir = let open Vec2 in finish |-| start in 221 | Flow.range 0 (int_of_float n - 1) 222 | |> Flow.map (fun i -> 223 | let open Vec2 in 224 | p 225 | |> Picture.translate (start |+| (dir |**| (r *. float_of_int i)))) 226 | 227 | let animate_hop (duration: float) (height: float) (p: Picture.t): Picture.t Flow.t = 228 | let up = animate_move 229 | (duration *. 0.5) p (0.0, 0.0) (0.0, -. height) 230 | in 231 | let down = animate_move 232 | (duration *. 0.5) p (0.0, -. height) (0.0, 0.0) 233 | in 234 | Flow.concat up down 235 | 236 | let animate_swap (a, b: int * int) (xs: int list): Picture.t Flow.t = 237 | let (i, j) = if a > b then (b, a) else (a, b) in 238 | let dots = xs 239 | |> List.map string_of_int 240 | |> List.map (dot foreground_color) 241 | in 242 | let ps = row_layout row_padding dots in 243 | let dot1 = List.nth dots i in 244 | let dot2 = List.nth dots j in 245 | let p1 = List.nth ps i in 246 | let p2 = List.nth ps j in 247 | let rest_dots = dots 248 | |> List.excludeNth j 249 | |> List.excludeNth i 250 | in 251 | let rest_ps = ps 252 | |> List.excludeNth j 253 | |> List.excludeNth i 254 | in 255 | let duration = 0.1 in 256 | [List.map2 Picture.translate rest_ps rest_dots 257 | |> Picture.compose] 258 | |> Flow.of_list 259 | |> Flow.cycle 260 | |> Flow.zipWith 261 | Picture.compose2 262 | (Flow.zipWith 263 | Picture.compose2 264 | (animate_move duration dot1 p1 p2) 265 | (animate_move duration dot2 p2 p1)) 266 | 267 | (* TODO(#124): animate_wait is not available to all of the animations *) 268 | let animate_wait (seconds: float) (fps: int) (p: Picture.t): Picture.t Flow.t = 269 | Flow.replicate (floor (seconds *. float_of_int fps) |> int_of_float) p 270 | 271 | let animate_assign (i, x: int * int) (xs: int list): Picture.t Flow.t = 272 | let dots = xs 273 | |> List.map string_of_int 274 | |> List.map (dot foreground_color) in 275 | let ps = row_layout row_padding dots in 276 | let plox = string_of_int x 277 | |> dot highlight_color 278 | |> Picture.translate (List.nth ps i) 279 | in 280 | let background = List.map2 281 | Picture.translate 282 | (ps |> List.excludeNth i) 283 | (dots |> List.excludeNth i) 284 | |> Picture.compose 285 | in 286 | let duration = 0.1 in 287 | Flow.zipWith 288 | Picture.compose2 289 | (Flow.iterate (fun a -> a) background) 290 | (animate_hop duration 15.0 plox) 291 | 292 | let animate_trace (xs: int list) (trace: action_t list): Picture.t Flow.t = 293 | let n = List.length trace in 294 | let states = 295 | let arr = Array.of_list xs in 296 | xs :: (trace 297 | |> List.map (function 298 | Swap (i, j) -> 299 | arr |> Array.swap i j; 300 | arr |> Array.to_list 301 | | Assign (i, x) -> 302 | Array.set arr i x; 303 | arr |> Array.to_list)) 304 | in 305 | let last_state = List.nth states n 306 | |> render_array 307 | |> animate_wait 2.0 fps 308 | in (List.map2 (fun action state -> 309 | match action with 310 | Swap (i, j) -> 311 | animate_swap (i, j) state 312 | | Assign (i, x) -> 313 | animate_assign (i, x) state) 314 | trace 315 | (states |> List.take n) 316 | @ [last_state]) 317 | |> List.fold_left Flow.concat Flow.nil 318 | 319 | let frames = 320 | let xs = Random.int_list 50 35 in 321 | let trace = Merge.trace xs in 322 | trace |> List.length |> Printf.printf "Number of swaps: %d\n"; 323 | Flow.zipWith 324 | Picture.compose2 325 | (Flow.of_list [background] |> Flow.cycle) 326 | (animate_trace xs trace 327 | |> Flow.map screenCenter) 328 | 329 | end 330 | 331 | let () = Hot.load (module Sort : Animation.T) 332 | -------------------------------------------------------------------------------- /samples/swirl.ml: -------------------------------------------------------------------------------- 1 | module Swirl : Animation.T = 2 | struct 3 | let fps = 60 4 | let resolution = (1920, 1080) 5 | 6 | let center (p: Picture.t): Picture.t = 7 | let w, h = resolution in 8 | let half_w, half_h = (float_of_int w *. 0.5, float_of_int h *. 0.5) in 9 | p |> Picture.translate (half_w, half_h) 10 | 11 | let background : Picture.t = 12 | let brightness = 1.0 /. 10.0 in 13 | Picture.rect (resolution |> Vec2.of_ints) 14 | |> Picture.color (Color.rgba brightness brightness brightness 1.0) 15 | 16 | let dot = 17 | Picture.image "./kkona.png" 18 | (* Picture.Circle 10.0 *) 19 | (* |> Picture.color (Color.rgba 0.8 0.9 0.9 1.0) *) 20 | 21 | let swirl (p: Picture.t): Picture.t Flow.t = 22 | Flow.iterate (fun angle -> angle +. 0.025) 0.1 23 | |> Flow.map (fun angle -> 24 | p 25 | |> Picture.scale (0.2 *. angle, 0.2 *. angle) 26 | |> Picture.translate (angle *. 50.0, 0.0) 27 | |> Picture.rotate angle 28 | |> Picture.color (Color.rgba (angle *. 0.1) (1.0 /. (angle *. 0.1)) (angle *. 0.05) 1.0) 29 | |> center) 30 | |> Flow.take 1000 31 | |> Flow.cycle 32 | 33 | let rec shift (n: int) (s: int) (frames: Picture.t Flow.t): Picture.t Flow.t = 34 | if n <= 1 35 | then frames 36 | else Flow.zip frames (shift (n - 1) s (frames |> Flow.drop s)) 37 | |> Flow.map (fun (a, b) -> Picture.Compose [a; b]) 38 | 39 | let frames = 40 | Flow.zip ([background] |> Flow.of_list |> Flow.cycle) (swirl dot |> shift 100 10) 41 | |> Flow.map (fun (a, b) -> Picture.Compose [a; b]) 42 | |> Flow.take 800 43 | 44 | end 45 | 46 | let () = Hot.load (module Swirl : Animation.T) 47 | -------------------------------------------------------------------------------- /src/animation.ml: -------------------------------------------------------------------------------- 1 | module type T = 2 | sig 3 | val frames : Picture.t Flow.t 4 | val fps : int 5 | val resolution : int * int 6 | end 7 | -------------------------------------------------------------------------------- /src/cairo.ml: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | external make : int -> int -> t = "multik_cairo_make" 4 | external make_from_texture: SdlTexture.t -> t = "multik_cairo_make_from_texture" 5 | external free : t -> unit = "multik_cairo_free" 6 | external set_fill_color : t -> Color.t -> unit = "multik_cairo_set_fill_color" 7 | external fill_rect : t -> Rect.t -> unit = "multik_cairo_fill_rect" 8 | external fill_circle : t -> Vec2.t -> float -> unit = "multik_cairo_fill_circle" 9 | external draw_text : t -> Vec2.t -> Font.t -> string -> unit = "multik_cairo_draw_text" 10 | external draw_image : t -> string -> unit = "multik_cairo_draw_image" 11 | external boundary_text: t -> Vec2.t -> Font.t -> string -> Vec2.t = 12 | "multik_cairo_boundary_text" 13 | external boundary_image: string -> Vec2.t = 14 | "multik_cairo_boundary_image" 15 | external transform : t -> Cairo_matrix.t -> unit = "multik_cairo_transform" 16 | 17 | let with_context (width, height: int * int) (block: t -> 'a): 'a = 18 | let context = make width height in 19 | try 20 | let value = block context in 21 | free context; 22 | value 23 | with e -> free context; 24 | raise e 25 | 26 | let with_texture (texture: SdlTexture.t) (block: t -> 'a): 'a = 27 | let context = make_from_texture texture in 28 | try 29 | let value = block context in 30 | free context; 31 | value 32 | with e -> free context; 33 | raise e 34 | 35 | (* TODO(#92): Boundary calculcation is probably broken *) 36 | let rec boundary (context: t) (p: Picture.t): Rect.t = 37 | match p with 38 | | Rect (w, h) -> (0.0, 0.0, w, h) 39 | | Compose ps -> 40 | let f (x11, y11, x21, y21) (x12, y12, x22, y22) = 41 | (min x11 x12, min y11 y12, max x21 x22, max y21 y22) 42 | in 43 | let init = (1e120, 1e120, -1e120, -1e120) in 44 | ps 45 | |> List.map (boundary context) 46 | |> List.map Rect.xywh_to_pp 47 | |> List.fold_left f init 48 | |> Rect.pp_to_xywh 49 | | Circle (radius) -> 50 | (0.0, 0.0, radius *. 2.0, radius *. 2.0) 51 | | Text (font, text) -> 52 | (* TODO(#113): boundary_text should probably have hardcoded position *) 53 | let (w, h) = boundary_text context (0.0, 0.0) font text 54 | in (0.0, 0.0, w, h) 55 | | Color (_, p) -> 56 | boundary context p 57 | | Nothing -> (0.0, 0.0, 0.0, 0.0) 58 | | SizeOf (p, template) -> 59 | p 60 | |> boundary context 61 | |> template 62 | |> boundary context 63 | | Translate ((x, y), p) -> 64 | let (x1, y1, w, h) = boundary context p 65 | in (x +. x1, y +. y1, w, h) 66 | | Scale ((fx, fy), p) -> 67 | let (x, y, w, h) = boundary context p 68 | in (fx *. x, fy *. fy, fx *. w, fy *. h) 69 | | Rotate (_, p) -> boundary context p 70 | | Image filepath -> 71 | let (w, h) = boundary_image filepath 72 | in (0.0, 0.0, w, h) 73 | 74 | (* TODO(#110): can we rewrite render_with_context completely in C *) 75 | let rec render_with_context (current_color: Color.t) (context: t) (p: Picture.t): unit = 76 | match p with 77 | | Nothing -> () 78 | | Rect (w0, h0) -> 79 | Rect.from_points (0.0, 0.0) (w0, h0) 80 | |> fill_rect context 81 | | Compose ps -> 82 | List.iter (render_with_context current_color context) ps 83 | | Color (next_color, p) -> 84 | set_fill_color context next_color; 85 | render_with_context next_color context p; 86 | set_fill_color context current_color 87 | | Circle (radius) -> 88 | fill_circle context (0.0, 0.0) radius 89 | | Text (font, text) -> 90 | draw_text context (0.0, 0.0) font text 91 | | SizeOf (p, template) -> 92 | p 93 | |> boundary context 94 | |> template 95 | |> render_with_context current_color context 96 | | Translate (position, p) -> 97 | Cairo_matrix.translate position |> transform context; 98 | render_with_context current_color context p; 99 | Cairo_matrix.translate position |> Cairo_matrix.invert |> transform context 100 | | Scale (scaling, p) -> 101 | Cairo_matrix.scale scaling |> transform context; 102 | render_with_context current_color context p; 103 | Cairo_matrix.scale scaling |> Cairo_matrix.invert |> transform context 104 | | Rotate (angle, p) -> 105 | Cairo_matrix.rotate angle |> transform context; 106 | render_with_context current_color context p; 107 | Cairo_matrix.rotate angle |> Cairo_matrix.invert |> transform context 108 | | Image filepath -> 109 | draw_image context filepath 110 | 111 | let render (context: t) (p: Picture.t) = 112 | render_with_context Color.black context p 113 | 114 | external save_to_png : t -> string -> unit = "multik_cairo_save_to_png" 115 | -------------------------------------------------------------------------------- /src/cairo.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val with_context : int * int -> (t -> 'a) -> 'a 4 | val with_texture : SdlTexture.t -> (t -> 'a) -> 'a 5 | 6 | external save_to_png : t -> string -> unit = "multik_cairo_save_to_png" 7 | val render : t -> Picture.t -> unit 8 | -------------------------------------------------------------------------------- /src/cairo_impl.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include 12 | 13 | #include 14 | 15 | struct Context 16 | { 17 | cairo_surface_t *surface; 18 | cairo_t *context; 19 | SDL_Texture *texture; 20 | }; 21 | 22 | /* TODO(#114): Image cache is linear */ 23 | #define CACHE_CAPACITY 1024 24 | cairo_surface_t *cache_surface[CACHE_CAPACITY]; 25 | const char *cache_filename[CACHE_CAPACITY]; 26 | size_t cache_count = 0; 27 | 28 | static cairo_surface_t *multik_image_cache_get(const char *filename) 29 | { 30 | int index = -1; 31 | for (size_t i = 0; i < cache_count; ++i) { 32 | if (strcmp(filename, cache_filename[i]) == 0) { 33 | index = i; 34 | break; 35 | } 36 | } 37 | 38 | if (index < 0) { 39 | assert(cache_count < CACHE_CAPACITY); 40 | cache_filename[cache_count] = strdup(filename); 41 | cache_surface[cache_count] = cairo_image_surface_create_from_png(filename); 42 | return cache_surface[cache_count++]; 43 | } 44 | 45 | return cache_surface[index]; 46 | } 47 | 48 | CAMLprim value 49 | multik_cairo_make(value width, value height) 50 | { 51 | const char *error_message = ""; 52 | 53 | struct Context *context = malloc(sizeof(struct Context)); 54 | if (context == NULL) { 55 | error_message = "Could not allocate memory. Download more RAM."; 56 | goto fail; 57 | } 58 | 59 | context->surface = cairo_image_surface_create( 60 | CAIRO_FORMAT_ARGB32, 61 | Int_val(width), Int_val(height)); 62 | if (context->surface == NULL) { 63 | error_message = "Could not allocate Cairo surface"; 64 | goto fail; 65 | } 66 | 67 | context->context = cairo_create(context->surface); 68 | if (context->context == NULL) { 69 | error_message = "Could not allocate Cairo context"; 70 | goto fail; 71 | } 72 | 73 | context->texture = NULL; 74 | 75 | return (value) context; 76 | 77 | fail: 78 | if (context != NULL) { 79 | if (context->context) { 80 | cairo_destroy(context->context); 81 | } 82 | 83 | if (context->surface) { 84 | cairo_surface_destroy(context->surface); 85 | } 86 | 87 | free(context); 88 | } 89 | 90 | caml_failwith(error_message); 91 | 92 | return (value) NULL; 93 | } 94 | 95 | CAMLprim value 96 | multik_cairo_make_from_texture(value texture_value) 97 | { 98 | const char *error_message = NULL; 99 | 100 | struct Context *context = malloc(sizeof(struct Context)); 101 | if (context == NULL) { 102 | error_message = "Could not allocate memory. Download more RAM."; 103 | goto fail; 104 | } 105 | 106 | SDL_Texture *texture = (SDL_Texture*) texture_value; 107 | 108 | if (texture == NULL) { 109 | error_message = "Texture is NULL!"; 110 | goto fail; 111 | } 112 | 113 | int w, h; 114 | 115 | if (SDL_QueryTexture(texture, NULL, NULL, &w, &h) < 0) { 116 | error_message = SDL_GetError(); 117 | goto fail; 118 | } 119 | 120 | void *pixels; 121 | int pitch; 122 | 123 | if (SDL_LockTexture(texture, NULL, &pixels, &pitch) < 0) { 124 | error_message = SDL_GetError(); 125 | goto fail; 126 | } 127 | 128 | context->surface = cairo_image_surface_create_for_data( 129 | pixels, 130 | CAIRO_FORMAT_ARGB32, 131 | w, h, pitch); 132 | if (context->surface == NULL) { 133 | error_message = "Could not allocate Cairo surface"; 134 | goto fail; 135 | } 136 | 137 | context->context = cairo_create(context->surface); 138 | if (context->context == NULL) { 139 | error_message = "Could not allocate Cairo context"; 140 | goto fail; 141 | } 142 | 143 | context->texture = texture; 144 | 145 | return (value) context; 146 | 147 | fail: 148 | 149 | if (context != NULL) { 150 | if (context->context) { 151 | cairo_destroy(context->context); 152 | } 153 | 154 | if (context->surface) { 155 | cairo_surface_destroy(context->surface); 156 | 157 | if (texture) { 158 | SDL_UnlockTexture(texture); 159 | } 160 | } 161 | 162 | free(context); 163 | } 164 | 165 | caml_failwith(error_message); 166 | 167 | return (value) NULL; 168 | } 169 | 170 | CAMLprim value 171 | multik_cairo_free(value context_value) 172 | { 173 | struct Context *context = (struct Context *) context_value; 174 | 175 | if (context == NULL) { 176 | caml_failwith("Context is NULL"); 177 | } 178 | 179 | if (context->context) { 180 | cairo_destroy(context->context); 181 | } 182 | 183 | if (context->surface) { 184 | cairo_surface_destroy(context->surface); 185 | } 186 | 187 | if (context->texture) { 188 | SDL_UnlockTexture(context->texture); 189 | } 190 | 191 | free(context); 192 | 193 | return Val_unit; 194 | } 195 | 196 | CAMLprim value 197 | multik_cairo_set_fill_color(value context_value, value color) 198 | { 199 | CAMLparam2(context_value, color); 200 | CAMLlocal4(r, g, b, a); 201 | 202 | r = Field(color, 0); 203 | g = Field(color, 1); 204 | b = Field(color, 2); 205 | a = Field(color, 3); 206 | 207 | struct Context *context = (struct Context *) context_value; 208 | 209 | if (context == NULL) { 210 | caml_failwith("Context is NULL"); 211 | } 212 | 213 | cairo_set_source_rgba(context->context, 214 | Double_val(r), Double_val(g), Double_val(b), 215 | Double_val(a)); 216 | 217 | CAMLreturn(Val_unit); 218 | } 219 | 220 | CAMLprim value 221 | multik_cairo_fill_rect(value context_value, value rect) 222 | { 223 | CAMLparam2(context_value, rect); 224 | CAMLlocal4(x, y, w, h); 225 | 226 | x = Field(rect, 0); 227 | y = Field(rect, 1); 228 | w = Field(rect, 2); 229 | h = Field(rect, 3); 230 | 231 | struct Context *context = (struct Context *) context_value; 232 | 233 | if (context == NULL) { 234 | caml_failwith("Context is NULL"); 235 | } 236 | 237 | cairo_rectangle(context->context, Double_val(x), Double_val(y), Double_val(w), Double_val(h)); 238 | cairo_fill(context->context); 239 | 240 | CAMLreturn(Val_unit); 241 | } 242 | 243 | CAMLprim value 244 | multik_cairo_fill_circle(value context_value, value center, value r) 245 | { 246 | CAMLparam3(context_value, center, r); 247 | CAMLlocal2(x, y); 248 | 249 | x = Field(center, 0); 250 | y = Field(center, 1); 251 | 252 | struct Context *context = (struct Context *) context_value; 253 | 254 | if (context == NULL) { 255 | caml_failwith("Context is NULL"); 256 | } 257 | 258 | cairo_arc(context->context, 259 | Double_val(x), Double_val(y), Double_val(r), 260 | 0.0, 2 * M_PI); 261 | cairo_fill(context->context); 262 | 263 | CAMLreturn(Val_unit); 264 | } 265 | 266 | CAMLprim value 267 | multik_cairo_draw_text(value context_value, 268 | value position, 269 | value font, 270 | value text) 271 | { 272 | CAMLparam4(context_value, position, font, text); 273 | CAMLlocal4(x, y, font_name, font_size); 274 | 275 | x = Field(position, 0); 276 | y = Field(position, 1); 277 | font_name = Field(font, 0); 278 | font_size = Field(font, 1); 279 | 280 | const struct Context *context = (struct Context *) context_value; 281 | 282 | cairo_select_font_face( 283 | context->context, String_val(font_name), 284 | CAIRO_FONT_SLANT_NORMAL, 285 | CAIRO_FONT_WEIGHT_BOLD); 286 | cairo_set_font_size(context->context, Double_val(font_size)); 287 | cairo_move_to(context->context, Double_val(x), Double_val(y)); 288 | cairo_text_path(context->context, String_val(text)); 289 | cairo_fill(context->context); 290 | 291 | CAMLreturn(Val_unit); 292 | } 293 | 294 | CAMLprim value 295 | multik_cairo_draw_image(value context_value, 296 | value filepath) 297 | { 298 | CAMLparam2(context_value, filepath); 299 | struct Context *context = (struct Context *) context_value; 300 | 301 | if (context == NULL) { 302 | caml_failwith("Context is NULL"); 303 | } 304 | 305 | cairo_surface_t *image = 306 | multik_image_cache_get(String_val(filepath)); 307 | assert(image); 308 | const int width = cairo_image_surface_get_width(image); 309 | const int height = cairo_image_surface_get_height(image); 310 | 311 | cairo_set_source_surface( 312 | context->context, 313 | image, 314 | 0.0, 0.0); 315 | cairo_rectangle(context->context, 0.0, 0.0, 316 | width, height); 317 | cairo_fill(context->context); 318 | 319 | CAMLreturn(Val_unit); 320 | } 321 | 322 | CAMLprim value 323 | multik_cairo_boundary_image(value filepath) 324 | { 325 | CAMLparam1(filepath); 326 | CAMLlocal1(boundary); 327 | 328 | cairo_surface_t *image = 329 | multik_image_cache_get(String_val(filepath)); 330 | assert(image); 331 | const int width = cairo_image_surface_get_width(image); 332 | const int height = cairo_image_surface_get_height(image); 333 | boundary = caml_alloc(2, 0); 334 | Store_field(boundary, 0, caml_copy_double((double) width)); 335 | Store_field(boundary, 1, caml_copy_double((double) height)); 336 | CAMLreturn(boundary); 337 | } 338 | 339 | CAMLprim value 340 | multik_cairo_boundary_text(value context_value, 341 | value position, 342 | value font, 343 | value text) 344 | { 345 | CAMLparam4(context_value, position, font, text); 346 | CAMLlocal5(x, y, font_name, font_size, boundary); 347 | 348 | x = Field(position, 0); 349 | y = Field(position, 1); 350 | font_name = Field(font, 0); 351 | font_size = Field(font, 1); 352 | boundary = caml_alloc(2, 0); 353 | 354 | const struct Context *context = (struct Context *) context_value; 355 | 356 | cairo_select_font_face( 357 | context->context, String_val(font_name), 358 | CAIRO_FONT_SLANT_NORMAL, 359 | CAIRO_FONT_WEIGHT_BOLD); 360 | cairo_set_font_size(context->context, Double_val(font_size)); 361 | cairo_move_to(context->context, Double_val(x), Double_val(y)); 362 | 363 | cairo_text_extents_t extents; 364 | cairo_text_extents(context->context, String_val(text), &extents); 365 | 366 | Store_field(boundary, 0, caml_copy_double(extents.width)); 367 | Store_field(boundary, 1, caml_copy_double(extents.height)); 368 | 369 | CAMLreturn(boundary); 370 | } 371 | 372 | CAMLprim value 373 | multik_cairo_save_to_png(value context_value, value filename) 374 | { 375 | const struct Context *context = (struct Context *)context_value; 376 | 377 | if (context == NULL) { 378 | caml_failwith("Context is NULL!"); 379 | } 380 | 381 | cairo_status_t res = cairo_surface_write_to_png(context->surface, String_val(filename)); 382 | if (res != CAIRO_STATUS_SUCCESS) { 383 | caml_failwith(cairo_status_to_string(res)); 384 | } 385 | 386 | return Val_unit; 387 | } 388 | 389 | void mat_ocaml_to_cairo(value input, cairo_matrix_t *output); 390 | 391 | CAMLprim value 392 | multik_cairo_transform(value context_value, value matrix_tuple) 393 | { 394 | CAMLparam2(context_value, matrix_tuple); 395 | const struct Context *context = (struct Context *)context_value; 396 | 397 | if (context == NULL) { 398 | caml_failwith("Context is NULL!"); 399 | } 400 | 401 | cairo_matrix_t matrix; 402 | mat_ocaml_to_cairo(matrix_tuple, &matrix); 403 | cairo_transform(context->context, &matrix); 404 | 405 | CAMLreturn(Val_unit); 406 | } 407 | -------------------------------------------------------------------------------- /src/cairo_matrix.ml: -------------------------------------------------------------------------------- 1 | type t = float * float * float * float * float * float 2 | 3 | let as_string (xx, xy, x0, yx, yy, y0: t): string = 4 | Printf.sprintf "%f %f\n%f %f\n%f %f\n" xx yx xy yy x0 y0 5 | 6 | external (|*|): t -> t -> t = "multik_cairo_matrix_product" 7 | external id: unit -> t = "multik_cairo_matrix_id" 8 | external translate: Vec2.t -> t = "multik_cairo_matrix_translate" 9 | external scale: Vec2.t -> t = "multik_cairo_matrix_scale" 10 | external rotate: float -> t = "multik_cairo_matrix_rotate" 11 | external invert: t -> t = "multik_cairo_matrix_invert" 12 | -------------------------------------------------------------------------------- /src/cairo_matrix_impl.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #include 8 | 9 | void mat_ocaml_to_cairo(value input, cairo_matrix_t *output) 10 | { 11 | output->xx = Double_val(Field(input, 0)); 12 | output->xy = Double_val(Field(input, 1)); 13 | output->x0 = Double_val(Field(input, 2)); 14 | output->yx = Double_val(Field(input, 3)); 15 | output->yy = Double_val(Field(input, 4)); 16 | output->y0 = Double_val(Field(input, 5)); 17 | } 18 | 19 | static void mat_cairo_to_ocaml(cairo_matrix_t *input, value output) 20 | { 21 | Store_field(output, 0, caml_copy_double(input->xx)); 22 | Store_field(output, 1, caml_copy_double(input->xy)); 23 | Store_field(output, 2, caml_copy_double(input->x0)); 24 | Store_field(output, 3, caml_copy_double(input->yx)); 25 | Store_field(output, 4, caml_copy_double(input->yy)); 26 | Store_field(output, 5, caml_copy_double(input->y0)); 27 | } 28 | 29 | CAMLprim value 30 | multik_cairo_matrix_product(value m1, value m2) 31 | { 32 | CAMLparam2(m1, m2); 33 | value result = caml_alloc(9, 0); 34 | 35 | cairo_matrix_t a, b, c; 36 | mat_ocaml_to_cairo(m1, &a); 37 | mat_ocaml_to_cairo(m2, &b); 38 | cairo_matrix_multiply(&c, &a, &b); 39 | 40 | mat_cairo_to_ocaml(&c, result); 41 | 42 | CAMLreturn(result); 43 | } 44 | 45 | CAMLprim value 46 | multik_cairo_matrix_id(value unit) 47 | { 48 | CAMLparam1(unit); 49 | value result = caml_alloc(9, 0); 50 | 51 | cairo_matrix_t a; 52 | cairo_matrix_init_identity(&a); 53 | mat_cairo_to_ocaml(&a, result); 54 | 55 | CAMLreturn(result); 56 | } 57 | 58 | CAMLprim value 59 | multik_cairo_matrix_translate(value vec) 60 | { 61 | CAMLparam1(vec); 62 | value result = caml_alloc(9, 0); 63 | 64 | cairo_matrix_t a; 65 | cairo_matrix_init_translate( 66 | &a, Double_val(Field(vec, 0)), 67 | Double_val(Field(vec, 1))); 68 | mat_cairo_to_ocaml(&a, result); 69 | 70 | CAMLreturn(result); 71 | } 72 | 73 | CAMLprim value 74 | multik_cairo_matrix_scale(value vec) 75 | { 76 | CAMLparam1(vec); 77 | value result = caml_alloc(9, 0); 78 | 79 | cairo_matrix_t a; 80 | cairo_matrix_init_scale( 81 | &a, Double_val(Field(vec, 0)), 82 | Double_val(Field(vec, 1))); 83 | mat_cairo_to_ocaml(&a, result); 84 | 85 | CAMLreturn(result); 86 | } 87 | 88 | CAMLprim value 89 | multik_cairo_matrix_rotate(value angle) 90 | { 91 | CAMLparam1(angle); 92 | value result = caml_alloc(9, 0); 93 | 94 | cairo_matrix_t a; 95 | cairo_matrix_init_rotate(&a, Double_val(angle)); 96 | mat_cairo_to_ocaml(&a, result); 97 | 98 | CAMLreturn(result); 99 | } 100 | 101 | CAMLprim value 102 | multik_cairo_matrix_invert(value m) 103 | { 104 | CAMLparam1(m); 105 | value result = caml_alloc(9, 0); 106 | 107 | cairo_matrix_t a; 108 | mat_ocaml_to_cairo(m, &a); 109 | cairo_status_t res = cairo_matrix_invert(&a); 110 | if (res != CAIRO_STATUS_SUCCESS) { 111 | caml_failwith(cairo_status_to_string(res)); 112 | } 113 | mat_cairo_to_ocaml(&a, result); 114 | 115 | CAMLreturn(result); 116 | } 117 | -------------------------------------------------------------------------------- /src/color.ml: -------------------------------------------------------------------------------- 1 | type t = float * float * float * float 2 | 3 | let rgba (r: float) (g: float) (b: float) (a: float): t = (r, g, b, a) 4 | let rgb (r: float) (g: float) (b: float): t = rgba r g b 1.0 5 | let black: t = (0.0, 0.0, 0.0, 1.0) 6 | let red: t = (1.0, 0.0, 0.0, 1.0) 7 | let green: t = (0.0, 1.0, 0.0, 1.0) 8 | let blue: t = (0.0, 0.0, 1.0, 1.0) 9 | let white: t = (1.0, 1.0, 1.0, 1.0) 10 | let yellow: t = (1.0, 1.0, 0.0, 1.0) 11 | -------------------------------------------------------------------------------- /src/console.ml: -------------------------------------------------------------------------------- 1 | external init: int -> int -> unit = "console_init" 2 | external free: unit -> unit = "console_free" 3 | external should_quit: unit -> bool = "console_should_quit" 4 | external present: unit -> unit = "console_present" 5 | external texture: unit -> SdlTexture.t = "console_texture" 6 | external viewport: unit -> Rect.t = "console_viewport" 7 | -------------------------------------------------------------------------------- /src/console_impl.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | #include 10 | #include 11 | 12 | static SDL_Window *window = NULL; 13 | static SDL_Renderer *renderer = NULL; 14 | static SDL_Texture *texture = NULL; 15 | 16 | CAMLprim value 17 | console_init(value width, value height) 18 | { 19 | if (SDL_Init(SDL_INIT_EVERYTHING) < 0) { 20 | goto fail; 21 | } 22 | 23 | if (window == NULL) { 24 | window = SDL_CreateWindow( 25 | "Multik", 26 | 100, 100, 27 | Int_val(width), Int_val(height), 28 | SDL_WINDOW_SHOWN | SDL_WINDOW_RESIZABLE); 29 | if (window == NULL) { 30 | goto fail; 31 | } 32 | } 33 | 34 | if (renderer == NULL) { 35 | renderer = SDL_CreateRenderer( 36 | window, -1, 37 | SDL_RENDERER_ACCELERATED | SDL_RENDERER_PRESENTVSYNC); 38 | if (renderer == NULL) { 39 | goto fail; 40 | } 41 | } 42 | 43 | if (SDL_SetRenderDrawBlendMode(renderer, SDL_BLENDMODE_BLEND) < 0) { 44 | goto fail; 45 | } 46 | 47 | if (texture == NULL) { 48 | texture = SDL_CreateTexture( 49 | renderer, 50 | SDL_PIXELFORMAT_ARGB8888, 51 | SDL_TEXTUREACCESS_STREAMING, 52 | Int_val(width), Int_val(height)); 53 | if (texture == NULL) { 54 | goto fail; 55 | } 56 | } 57 | 58 | return Val_unit; 59 | 60 | fail: 61 | if (texture != NULL) { 62 | SDL_DestroyTexture(texture); 63 | texture = NULL; 64 | } 65 | 66 | if (renderer != NULL) { 67 | SDL_DestroyRenderer(renderer); 68 | renderer = NULL; 69 | } 70 | 71 | if (window != NULL) { 72 | SDL_DestroyWindow(window); 73 | window = NULL; 74 | } 75 | 76 | failwith(SDL_GetError()); 77 | 78 | return Val_unit; 79 | } 80 | 81 | CAMLprim value 82 | console_should_quit(value unit) 83 | { 84 | SDL_Event event; 85 | while (SDL_PollEvent(&event)) { 86 | switch (event.type) { 87 | case SDL_QUIT: 88 | return Val_true; 89 | 90 | case SDL_WINDOWEVENT: 91 | switch(event.window.event) { 92 | case SDL_WINDOWEVENT_RESIZED: 93 | if (renderer == NULL) { 94 | caml_failwith("Renderer is not initialized"); 95 | } 96 | 97 | if (texture == NULL) { 98 | caml_failwith("Texture was not initialized"); 99 | } 100 | 101 | SDL_DestroyTexture(texture); 102 | texture = SDL_CreateTexture( 103 | renderer, 104 | SDL_PIXELFORMAT_ARGB8888, 105 | SDL_TEXTUREACCESS_STREAMING, 106 | event.window.data1, 107 | event.window.data2); 108 | break; 109 | } 110 | break; 111 | } 112 | } 113 | 114 | return Val_false; 115 | } 116 | 117 | CAMLprim value 118 | console_present(value unit) 119 | { 120 | if (renderer == NULL) { 121 | caml_failwith("Renderer is not initialized"); 122 | } 123 | 124 | SDL_Rect view_port; 125 | SDL_RenderGetViewport(renderer, &view_port); 126 | SDL_RenderCopy(renderer, texture, 127 | &view_port, 128 | &view_port); 129 | 130 | SDL_RenderPresent(renderer); 131 | 132 | return Val_unit; 133 | } 134 | 135 | CAMLprim value 136 | console_free(value unit) 137 | { 138 | if (texture != NULL) { 139 | SDL_DestroyTexture(texture); 140 | texture = NULL; 141 | } 142 | 143 | if (renderer != NULL) { 144 | SDL_DestroyRenderer(renderer); 145 | renderer = NULL; 146 | } 147 | 148 | if (window != NULL) { 149 | SDL_DestroyWindow(window); 150 | window = NULL; 151 | } 152 | 153 | SDL_Quit(); 154 | 155 | return Val_unit; 156 | } 157 | 158 | CAMLprim value 159 | console_texture(value unit) 160 | { 161 | return (value) texture; 162 | } 163 | 164 | CAMLprim value 165 | console_viewport(value unit) 166 | { 167 | CAMLparam1(unit); 168 | CAMLlocal1(result); 169 | 170 | result = caml_alloc(4, 0); 171 | 172 | if (renderer == NULL) { 173 | caml_failwith("Renderer is not initialized"); 174 | } 175 | 176 | SDL_Rect view_port; 177 | SDL_RenderGetViewport(renderer, &view_port); 178 | 179 | Store_field(result, 0, caml_copy_double(view_port.x)); 180 | Store_field(result, 1, caml_copy_double(view_port.y)); 181 | Store_field(result, 2, caml_copy_double(view_port.w)); 182 | Store_field(result, 3, caml_copy_double(view_port.h)); 183 | 184 | CAMLreturn(result); 185 | } 186 | -------------------------------------------------------------------------------- /src/extra.ml: -------------------------------------------------------------------------------- 1 | module List = 2 | struct 3 | let rec range (low: int) (high: int): int list = 4 | if low > high 5 | then [] 6 | else low :: range (low + 1) high 7 | 8 | let excludeNth (n: int) (xs: 'a list): 'a list = 9 | xs 10 | |> List.mapi (fun i x -> (i, x)) 11 | |> List.filter (fun (i, _) -> i != n) 12 | |> List.map snd 13 | 14 | let replaceNth (n: int) (x: 'a) (xs: 'a list): 'a list = 15 | List.mapi (fun i y -> if i == n then x else y) xs 16 | 17 | let rec take (n: int) (xs: 'a list): 'a list = 18 | if n <= 0 19 | then [] 20 | else (match xs with 21 | | [] -> [] 22 | | x :: ys -> x :: take (n - 1) ys) 23 | 24 | include List 25 | end 26 | 27 | module Array = 28 | struct 29 | let swap (i: int) (j: int) (xs: 'a array): unit = 30 | let a = Array.get xs i in 31 | let b = Array.get xs j in 32 | Array.set xs i b; 33 | Array.set xs j a 34 | 35 | include Array 36 | end 37 | 38 | module Random = 39 | struct 40 | let int_list (bound: int) (n: int): int list = 41 | let rec int_list_impl (i: int) (acc: int list) = 42 | if i < n 43 | then int_list_impl (i + 1) (Random.int bound :: acc) 44 | else acc 45 | in 46 | int_list_impl 0 [] 47 | 48 | include Random 49 | end 50 | 51 | module Fun = 52 | struct 53 | let uncurry (f: 'a -> 'b -> 'c): 'a * 'b -> 'c = 54 | fun (a, b) -> f a b 55 | end 56 | -------------------------------------------------------------------------------- /src/flow.ml: -------------------------------------------------------------------------------- 1 | open Extra 2 | 3 | type 'a cons = Nil | Cons of 'a Lazy.t * 'a t 4 | and 'a t = 5 | { 6 | flow : 'a cons Lazy.t 7 | } 8 | 9 | let nil: 'a t = { flow = lazy Nil } 10 | 11 | let cons (x: 'a Lazy.t) (xs: 'a t): 'a t = 12 | { 13 | flow = lazy (Cons (x, xs)) 14 | } 15 | 16 | let uncons (xs: 'a t): ('a Lazy.t * 'a t) option = 17 | match Lazy.force xs.flow with 18 | | Nil -> None 19 | | Cons (x, xs) -> Some (x, xs) 20 | 21 | let is_nil (xs : 'a t): bool = 22 | match Lazy.force xs.flow with 23 | | Nil -> true 24 | | _ -> false 25 | 26 | let rec of_list (xs: 'a list): 'a t = 27 | { 28 | flow = lazy 29 | (match xs with 30 | | [] -> Nil 31 | | x :: xs -> Cons (lazy x, of_list xs)) 32 | } 33 | 34 | let rec as_list (xs: 'a t): 'a list = 35 | match Lazy.force xs.flow with 36 | | Nil -> [] 37 | | Cons (x, xs) -> Lazy.force x :: as_list xs 38 | 39 | let rec map (f: 'a -> 'b) (xs: 'a t): 'b t = 40 | { 41 | flow = lazy 42 | (match Lazy.force xs.flow with 43 | | Nil -> Nil 44 | | Cons (x, xs) -> 45 | Cons (lazy (Lazy.force x |> f), 46 | map f xs)) 47 | } 48 | 49 | let rec concat (xs1: 'a t) (xs2: 'a t): 'a t = 50 | { 51 | flow = lazy 52 | (match Lazy.force xs1.flow with 53 | | Nil -> Lazy.force xs2.flow 54 | | Cons (x, xs) -> Cons (x, concat xs xs2)) 55 | } 56 | 57 | let rec cycle (xs: 'a t): 'a t = 58 | if is_nil xs 59 | then failwith "Empty flow" 60 | else concat xs { flow = lazy (Lazy.force (cycle xs).flow) } 61 | 62 | let rec iterate (f: 'a -> 'a) (init: 'a): 'a t = 63 | { 64 | flow = lazy (Cons (lazy init, iterate f (f init))) 65 | } 66 | 67 | let rec take (n : int) (xs : 'a t): 'a t = 68 | { 69 | flow = lazy (if n <= 0 70 | then Nil 71 | else match Lazy.force xs.flow with 72 | | Nil -> Nil 73 | | Cons (x, xs) -> 74 | Cons (x, take (n - 1) xs)) 75 | } 76 | 77 | let rec drop (n : int) (xs : 'a t): 'a t = 78 | { 79 | flow = lazy (if n <= 0 80 | then Lazy.force xs.flow 81 | else match Lazy.force xs.flow with 82 | | Nil -> Nil 83 | | Cons (x, xs) -> Lazy.force (drop (n - 1) xs).flow) 84 | } 85 | 86 | let rec zip (xs : 'a t) (ys : 'b t): ('a * 'b) t = 87 | match (Lazy.force xs.flow, Lazy.force ys.flow) with 88 | | (Nil, _) -> nil 89 | | (_, Nil) -> nil 90 | | (Cons (x, xs), Cons (y, ys)) -> { 91 | flow = lazy (Cons 92 | (lazy (Lazy.force x, Lazy.force y), 93 | zip xs ys)) 94 | } 95 | 96 | let rec zipWith (f: 'a -> 'b -> 'c) (xs: 'a t) (ys: 'b t): 'c t = 97 | zip xs ys |> map (Fun.uncurry f) 98 | 99 | let rec from (n: int): int t = 100 | { 101 | flow = lazy (Cons (lazy n, from (n + 1))) 102 | } 103 | 104 | let rec for_ (f: 'a -> unit) (xs: 'a t): unit = 105 | match Lazy.force xs.flow with 106 | | Nil -> () 107 | | Cons (x, xs) -> Lazy.force x |> f; 108 | for_ f xs 109 | 110 | let rec length (xs: 'a t): int = 111 | match Lazy.force xs.flow with 112 | | Nil -> 0 113 | | Cons (_, xs) -> 1 + length xs 114 | 115 | let rec replicate (n: int) (x: 'a): 'a t = 116 | [x] |> of_list |> cycle |> take n 117 | 118 | let rec range (low: int) (high: int): int t = 119 | { 120 | flow = lazy (if low > high 121 | then Nil 122 | else Cons (lazy low, range (low + 1) high)) 123 | } 124 | -------------------------------------------------------------------------------- /src/font.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { 3 | name: string; 4 | size: float 5 | } 6 | 7 | let make (name: string) (size: float): t = 8 | { 9 | name = name; 10 | size = size 11 | } 12 | -------------------------------------------------------------------------------- /src/hot.ml: -------------------------------------------------------------------------------- 1 | IFDEF PROFILE THEN 2 | module Hot = 3 | struct 4 | let load (module A: Animation.T): unit = () 5 | end 6 | 7 | INCLUDE "./samples/swirl.ml" 8 | 9 | let get_current () = (module Swirl: Animation.T) 10 | let loadfile(filepath: string): unit = () 11 | ELSE 12 | (* TODO(#55): there is no default "No Animation Loaded" animation *) 13 | let current : (module Animation.T) option ref = ref None 14 | 15 | let get_current () = 16 | match !current with 17 | | Some animation -> animation 18 | | None -> failwith "No animation loaded" 19 | 20 | let load (module A: Animation.T): unit = 21 | current := Some (module A: Animation.T) 22 | 23 | let loadfile(filepath: string): unit = 24 | Dynlink.loadfile(filepath) 25 | 26 | ENDIF 27 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | let empty_animation_frame (screen_width, screen_height) = 2 | let label_text = "" in 3 | let label_at position = 4 | Picture.Text (Font.make "Sans" 50.0, label_text) 5 | in 6 | Picture.sizeOf 7 | (label_at (0.0, 0.0)) 8 | (fun (_, _, label_width, label_height) -> 9 | Picture.Color 10 | ( Color.red 11 | , Picture.Text (Font.make "Sans" 50.0, label_text) 12 | |> Picture.translate 13 | (float_of_int screen_width *. 0.5 -. label_width *. 0.5, float_of_int screen_height *. 0.5 -. label_height *. 0.5))) 14 | 15 | let compose_video_file (dirpath: string) (fps: int) (output_filename: string) (flags: string list): Unix.process_status = 16 | let cli = 17 | Printf.sprintf "ffmpeg -y -framerate %d -i %s/%%d.png %s %s" fps dirpath output_filename (flags |> String.concat " ") 18 | in 19 | print_endline cli; 20 | cli 21 | |> Unix.open_process_in 22 | |> Unix.close_process_in 23 | 24 | let temp_dir (prefix: string) (suffix: string): string = 25 | let filename = Filename.temp_file prefix suffix in 26 | Sys.remove filename; 27 | Unix.mkdir filename 0o755; 28 | filename 29 | 30 | let rec rmdir_rec (path: string): unit = 31 | Printf.printf "Remove %s\n" path; 32 | if Sys.is_directory path 33 | then 34 | (let children = path 35 | |> Sys.readdir 36 | |> Array.to_list 37 | in if List.length children > 0 38 | then children 39 | |> List.map (Filename.concat path) 40 | |> List.iter rmdir_rec; 41 | Unix.rmdir path) 42 | else Sys.remove path 43 | 44 | type render_config_t = 45 | { 46 | scaling : float; 47 | fps_scaling: float; 48 | ffmpeg_flags: string list; 49 | } 50 | 51 | let string_of_render_config (config: render_config_t): string = 52 | Printf.sprintf "CONFIG:\n SCALING: %f\n FPS_SCALING: %f\n FFMPEG_FLAGS: %s\n" 53 | config.scaling 54 | config.fps_scaling 55 | (config.ffmpeg_flags |> String.concat " ") 56 | 57 | let scale_fps (src_fps: int) (dest_fps: int) (frames: 'a Flow.t): 'a Flow.t = 58 | let src_dt = 1.0 /. float_of_int src_fps in 59 | let dest_dt = 1.0 /. float_of_int dest_fps in 60 | let rec interpolate_frames (t: float) (frames: 'a Flow.t): 'a Flow.t = 61 | match Flow.uncons frames with 62 | | Some (x, xs) -> 63 | if t < src_dt 64 | then Flow.cons x (interpolate_frames (t +. dest_dt) frames) 65 | else interpolate_frames (t -. src_dt) xs 66 | | None -> Flow.nil 67 | in if src_fps != dest_fps 68 | then interpolate_frames 0.0 frames 69 | else frames 70 | 71 | let explain_status (status: Unix.process_status): string = 72 | match status with 73 | | Unix.WEXITED code -> Printf.sprintf "exited with %d" code 74 | | Unix.WSIGNALED signal -> Printf.sprintf "was killed by a signal %d" signal 75 | | Unix.WSTOPPED signal -> Printf.sprintf "was stopped by a signal %d" signal 76 | 77 | (* TODO(#40): if the animation is infinite the rendering will be infinite *) 78 | let render (animation_path: string) (output_filename: string) (config: render_config_t): unit = 79 | string_of_render_config config |> print_endline; 80 | Hot.loadfile(animation_path); 81 | let module A = (val Hot.get_current () : Animation.T) in 82 | let scaled_fps = A.fps |> float_of_int |> ( *. ) config.fps_scaling |> int_of_float in 83 | let scaled_frames = A.frames 84 | |> scale_fps A.fps scaled_fps 85 | |> Flow.map (Picture.scale (Vec2.of_float config.scaling)) in 86 | let n = scaled_frames |> Flow.length in 87 | let dirpath = temp_dir "multik" "frames" in 88 | Printf.printf "Rendering frames to %s\n" dirpath; 89 | let (width, height) = A.resolution in 90 | let scaled_resolution = ((float_of_int width *. config.scaling) |> floor |> int_of_float, 91 | (float_of_int height *. config.scaling) |> floor |> int_of_float) in 92 | Cairo.with_context scaled_resolution 93 | (fun c -> 94 | scaled_frames 95 | |> Flow.zip (Flow.from 0) 96 | |> Flow.for_ (fun (index, picture) -> 97 | let filename = dirpath 98 | ^ Filename.dir_sep 99 | ^ string_of_int index 100 | ^ ".png" 101 | in Printf.sprintf "Rendering frame %d/%d" (index + 1) n |> print_string; 102 | Cairo.render c picture; 103 | Cairo.save_to_png c filename; 104 | print_string "\r"; 105 | flush stdout)); 106 | print_endline ""; 107 | compose_video_file dirpath scaled_fps output_filename config.ffmpeg_flags 108 | |> explain_status 109 | |> Printf.printf "ffmpeg %s"; 110 | rmdir_rec dirpath 111 | 112 | (* TODO(#125): Shadow function is not available to the animations *) 113 | let shadow (p: Picture.t): Picture.t = 114 | Picture.compose [ p 115 | |> Picture.color Color.black 116 | |> Picture.translate (3.0, 3.0) 117 | ; p ] 118 | 119 | let preview (animation_path: string) = 120 | let render_picture (p: Picture.t): unit = 121 | Cairo.with_texture (Console.texture ()) 122 | (fun c -> Cairo.render c p) 123 | in 124 | let rec loop (current_fps: int) (frames: Picture.t Flow.t): unit = 125 | if not (Console.should_quit ()) 126 | then (if (Watcher.is_file_modified ()) 127 | then (print_endline "reloading"; 128 | Hot.loadfile(animation_path); 129 | let module Reload = (val Hot.get_current () : Animation.T) in 130 | if Flow.is_nil Reload.frames 131 | then loop current_fps Flow.nil 132 | else Reload.frames |> Flow.cycle |> loop current_fps) 133 | else (let module A = (val Hot.get_current () : Animation.T) in 134 | let frame_begin = Sys.time () in 135 | match Flow.uncons frames with 136 | | Some (frame, rest_frames) -> 137 | let (_, _, vx, _) = Console.viewport () in 138 | let rx, _ = A.resolution in 139 | let s = vx /. float_of_int rx in 140 | Picture.compose [ Lazy.force frame 141 | ; Printf.sprintf "FPS: %d" current_fps 142 | |> Picture.text (Font.make "Sans" 100.0) 143 | |> shadow 144 | |> Picture.translate (0.0, 100.0) 145 | |> Picture.color Color.white ] 146 | |> Picture.scale (s, s) 147 | |> render_picture; 148 | Console.present (); 149 | let frame_work = Sys.time () -. frame_begin in 150 | let delta_time = 1.0 /. (float_of_int A.fps) in 151 | (delta_time -. frame_work) |> max 0.0 |> Thread.delay; 152 | let next_fps = 1.0 /. (max frame_work delta_time) in 153 | loop (int_of_float ((next_fps +. float_of_int current_fps) /. 2.0)) rest_frames 154 | | None -> [empty_animation_frame A.resolution] 155 | |> Flow.of_list 156 | |> Flow.cycle 157 | |> loop current_fps)) 158 | else () 159 | in 160 | Hot.loadfile(animation_path); 161 | let module A = (val Hot.get_current () : Animation.T) in 162 | let (width, height) = A.resolution in 163 | Console.init width height; 164 | Watcher.init animation_path; 165 | if Flow.is_nil A.frames 166 | then loop 0 Flow.nil 167 | else A.frames |> Flow.cycle |> loop 0; 168 | Watcher.free (); 169 | Console.free () 170 | 171 | (* TODO(#93): flags override each other in a reversed order *) 172 | let rec render_config_of_args (args: string list): render_config_t = 173 | match args with 174 | | [] -> { scaling = 1.0; fps_scaling = 1.0; ffmpeg_flags = [] } 175 | | "--scale" :: factor :: rest_args -> 176 | { (render_config_of_args rest_args) with 177 | scaling = float_of_string factor } 178 | | "--fps-scale" :: fps_factor :: rest_args -> 179 | { (render_config_of_args rest_args) with 180 | fps_scaling = float_of_string fps_factor } 181 | | "--ffmpeg" :: rest_args -> 182 | { 183 | scaling = 1.0; 184 | fps_scaling = 1.0; 185 | ffmpeg_flags = rest_args 186 | } 187 | | unknown_flag :: _ -> 188 | Printf.sprintf "Unknown flag: %s" unknown_flag |> failwith 189 | 190 | let () = 191 | match Sys.argv |> Array.to_list with 192 | | _ :: "preview" :: animation_path :: _ -> 193 | preview animation_path 194 | | name :: "preview" :: _ -> 195 | Printf.fprintf stderr "Using %s preview " name 196 | | _ :: "render" :: animation_path :: output_filename :: args -> 197 | render_config_of_args args 198 | |> render animation_path output_filename 199 | | name :: "render" :: _ -> 200 | (* 201 | * TODO(#96): multik does not scale to an absolute resolution 202 | * It should support both relative and absolute ones. 203 | *) 204 | Printf.fprintf stderr "Using: %s render [--scale ] [--fps-scale ] [--ffmpeg ]" name 205 | | name :: _ -> Printf.fprintf stderr "Using: %s " name 206 | | _ -> Printf.fprintf stderr "Using: " 207 | -------------------------------------------------------------------------------- /src/picture.ml: -------------------------------------------------------------------------------- 1 | type t = Nothing 2 | | Color of Color.t * t 3 | | Translate of (float * float) * t 4 | | Scale of (float * float) * t 5 | | Rotate of float * t 6 | | Rect of float * float 7 | | Circle of float 8 | | Text of Font.t * string 9 | | Image of string 10 | | Compose of t list 11 | | SizeOf of t * (Rect.t -> t) 12 | 13 | let nothing = Nothing 14 | 15 | let color (c: Color.t) (p: t): t = 16 | Color (c, p) 17 | 18 | let rect (w, h: float * float): t = 19 | Rect (w, h) 20 | 21 | let circle (r: float): t = 22 | Circle r 23 | 24 | let compose (ps: t list): t = 25 | Compose ps 26 | 27 | let compose2 (p1: t) (p2: t): t = 28 | Compose [p1; p2] 29 | 30 | let text (font: Font.t) (text: string): t = 31 | Text (font, text) 32 | 33 | let sizeOf (p: t) (template: Rect.t -> t): t = 34 | SizeOf (p, template) 35 | 36 | let translate (x, y: float * float) (p: t): t = 37 | Translate ((x, y), p) 38 | 39 | let scale (sx, sy: float * float) (p: t): t = 40 | Scale ((sx, sy), p) 41 | 42 | let rotate (angle: float) (p: t): t = 43 | Rotate (angle, p) 44 | 45 | let image (filepath: string): t = 46 | Image filepath 47 | -------------------------------------------------------------------------------- /src/rect.ml: -------------------------------------------------------------------------------- 1 | type t = float * float * float * float 2 | 3 | let xywh_to_pp ((x, y, w, h): t): t = 4 | (x, y, x +. w, y +. h) 5 | 6 | let pp_to_xywh ((x1, y1, x2, y2): t): t = 7 | (x1, y1, x2 -. x1, y2 -. y1) 8 | 9 | let from_points (x1, y1: Vec2.t) (x2, y2: Vec2.t): t = 10 | (min x1 x2, min y1 y2, abs_float (x2 -. x1), abs_float (y2 -. y1)) 11 | -------------------------------------------------------------------------------- /src/sdlTexture.ml: -------------------------------------------------------------------------------- 1 | type t 2 | -------------------------------------------------------------------------------- /src/vec2.ml: -------------------------------------------------------------------------------- 1 | type t = float * float 2 | type homo_t = float * float * float 3 | 4 | let as_string (x, y: t): string = 5 | Printf.sprintf "%f %f\n" x y 6 | 7 | let of_ints (x, y : int * int) : t = 8 | (float_of_int x, float_of_int y) 9 | 10 | let of_float (x: float) : t = x, x 11 | 12 | let homo (x, y: float * float): homo_t = 13 | (x, y, 1.0) 14 | 15 | let cart (x, y, z: homo_t): t = 16 | (x /. z, y /. z) 17 | 18 | let len ((x, y): t): float = 19 | sqrt (x *. x +. y *. y) 20 | 21 | let norm ((x, y): t): t = 22 | let n = len (x, y) in 23 | (x /. n, y /. n) 24 | 25 | let (|+|) ((x1, y1): t) ((x2, y2): t) = (x1 +. x2, y1 +. y2) 26 | let (|-|) ((x1, y1): t) ((x2, y2): t) = (x1 -. x2, y1 -. y2) 27 | let (|*|) ((x1, y1): t) ((x2, y2): t) = (x1 *. x2, y1 *. y2) 28 | let (|**|) ((x, y): t) (s: float) = (x *. s, y *. s) 29 | -------------------------------------------------------------------------------- /src/watcher.ml: -------------------------------------------------------------------------------- 1 | external init: string -> unit = "watcher_init" 2 | external is_file_modified: unit -> bool = "watcher_is_file_modified" 3 | external free: unit -> unit = "watcher_free" 4 | -------------------------------------------------------------------------------- /src/watcher_impl.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #include 8 | #include 9 | 10 | #include 11 | #include 12 | 13 | #define BUF_LEN (10 * (sizeof(struct inotify_event) + NAME_MAX + 1)) 14 | 15 | static int inotifyFd = 0; 16 | static int wd = 0; 17 | static char buf[BUF_LEN] __attribute__ ((aligned(8))); 18 | 19 | CAMLprim value 20 | watcher_init(value filename) 21 | { 22 | char exception[256]; 23 | 24 | inotifyFd = inotify_init1(IN_NONBLOCK); 25 | if (inotifyFd == -1) { 26 | caml_failwith("Could not initialize inotify system"); 27 | } 28 | 29 | wd = inotify_add_watch(inotifyFd, String_val(filename), IN_CLOSE_WRITE); 30 | if (wd == -1) { 31 | snprintf(exception, 256, "Could not add watcher for a file %s", String_val(filename)); 32 | caml_failwith(exception); 33 | } 34 | 35 | return Val_unit; 36 | } 37 | 38 | CAMLprim value 39 | watcher_is_file_modified(value unit) 40 | { 41 | ssize_t numRead = read(inotifyFd, buf, BUF_LEN); 42 | 43 | if (errno != EAGAIN) { 44 | caml_failwith(strerror(errno)); 45 | } 46 | 47 | return Val_bool(numRead > 0); 48 | } 49 | 50 | CAMLprim value 51 | watcher_free(value unit) 52 | { 53 | // TODO(#52): watcher_free is not implemented 54 | // It is not even clear what we can do here, because OS will 55 | // probably close everything for us when the application exits. 56 | return Val_unit; 57 | } 58 | --------------------------------------------------------------------------------