├── .gitignore ├── CHANGES ├── LICENSE ├── Makefile ├── README.md ├── TODO ├── dune-ignore ├── dune-project ├── example ├── Makefile ├── NotoEmoji-Regular.ttf ├── Roboto-Bold.ttf ├── Roboto-Light.ttf ├── Roboto-Regular.ttf ├── blemish.ml ├── colorweb.ml ├── dune ├── entypo.ttf ├── example.ml ├── images │ ├── image1.jpg │ ├── image10.jpg │ ├── image11.jpg │ ├── image12.jpg │ ├── image2.jpg │ ├── image3.jpg │ ├── image4.jpg │ ├── image5.jpg │ ├── image6.jpg │ ├── image7.jpg │ ├── image8.jpg │ └── image9.jpg └── minimal.ml ├── lib ├── config │ ├── discover.ml │ └── dune ├── dune ├── wall.ml ├── wall.mli ├── wall__backend.ml ├── wall__backend.mli ├── wall__backend_stubs.c ├── wall__geom.ml ├── wall__geom.mli ├── wall_text.ml ├── wall_text.mli └── wall_types.ml ├── package.json ├── slideshow ├── Makefile ├── Roboto-Regular.ttf ├── RobotoMono-Regular.ttf ├── dune ├── nyan_cat.png ├── old │ ├── driver.ml │ └── mod_use.ml ├── pres_state.ml ├── presentation.ml ├── slide.top ├── slideshow.ml └── tree_slides.ml └── wall.opam /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | .merlin 11 | 12 | # ocamlbuild working directory 13 | _build/ 14 | 15 | # ocamlbuild targets 16 | *.byte 17 | *.native 18 | 19 | # oasis generated files 20 | setup.data 21 | setup.log 22 | 23 | # Jbuiler generated 24 | *.install 25 | 26 | *.yarn-error.log 27 | node_modules 28 | 29 | *.lock 30 | yarn-error.log 31 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | v0.4.1, Wed Oct 28 17:31:19 CET 2020 2 | ------------------------------------ 3 | 4 | Small fixes to help testing with unreleased compiler. 5 | Thanks to @kit-ty-kate. 6 | 7 | v0.4, Fri Apr 10 21:12:37 CEST 2020 8 | ----------------------------------- 9 | 10 | Port to OCaml 4.10 11 | 12 | v0.3, Sun Oct 14 08:16:07 CEST 2018 13 | ----------------------------------- 14 | 15 | Fix rendering bugs. 16 | Add OCaml 2018 presentation. 17 | 18 | v0.2, Sun Jul 8 18:07:09 CEST 2018 19 | ----------------------------------- 20 | 21 | Measure performance in microseconds. 22 | Support older versions of macOS without clock\_gettime 23 | 24 | v0.1, Mon May 21 18:51:10 CEST 2018 25 | ----------------------------------- 26 | 27 | Initial release 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Frédéric Bour 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of wall nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | 4 | clean: 5 | dune clean 6 | 7 | minimal.exe example.exe blemish.exe colorweb.exe example.bc: 8 | dune build example/$@ 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Wall is a vector graphics renderer using OpenGL written in OCaml. 2 | 3 | Code is licensed under BSD3. 4 | 5 | # Installation 6 | 7 | The project is distributed through [opam](https://opam.ocaml.org/): 8 | 9 | ```shell 10 | $ opam install wall 11 | ``` 12 | 13 | # Credits 14 | 15 | The main inspiration for this project is 16 | [NanoVG](https://github.com/memononen/nanovg). 17 | 18 | Shader and renderer design are taken from it. 19 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | # Expose performance counters 2 | 3 | # depth-based shading pipeline 4 | 5 | Use depth rather than stencil to occlude objects (as in fast ui draw): 6 | - simpler for stroke and convex fill, similar for complex fill 7 | - opaque draw can benefit of Z rejection 8 | - might be possible to implement a `frame` combinator to clip in/out. should be 9 | combined with a stroke to hide the lack of antialiasing :P 10 | 11 | # Abstract the GL backend. 12 | 13 | The two promising approaches are: 14 | - [Lit](http://erratique.ch/software/lit), however it is not actively developed 15 | - [Bgfx](https://github.com/bkaradzic/bgfx), a bit overkill and in C++ (which paradoxically, worsen the portability, especially if considering Web GL) 16 | 17 | ## OSX target 18 | 19 | Proper support for OSX platform is a must. 20 | 21 | # Better Font management 22 | 23 | The strategy for allocating and collecting font buffers is quite naive... It 24 | deserves more work. 25 | 26 | # Spatial and temporal sharing 27 | 28 | Something very naive would deliver most of the benefits... 29 | 30 | # Integration with VG and abstraction for reusing buffers. 31 | 32 | ... 33 | 34 | # Document 35 | 36 | Wall API could benefit from some doc comments (especially fonts and tasks) 37 | -------------------------------------------------------------------------------- /dune-ignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | .git 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (generate_opam_files true) 3 | 4 | (name wall) 5 | (source (github let-def/wall)) 6 | (license BSD3) 7 | (authors "Frédéric Bour") 8 | (maintainers "frederic.bour@lakaban.net") 9 | (documentation "https://let-def.github.io/wall/doc") 10 | 11 | (package 12 | (name wall) 13 | (synopsis "Realtime Vector Graphics with OpenGL") 14 | (description "Lightweight, fast and declarative vector graphics rasterization using OpenGL") 15 | (depends ocaml gg result grenier conf-gles2 16 | stb_image (stb_truetype (>= "0.5")))) 17 | -------------------------------------------------------------------------------- /example/Makefile: -------------------------------------------------------------------------------- 1 | TARGETS=blemish.exe example.exe example.bc minimal.exe colorweb.exe 2 | 3 | F?=1 4 | 5 | $(TARGETS): 6 | $(MAKE) -C ../ $@ 7 | ../_build/default/example/$@ $(F) 8 | 9 | .PHONY: $(TARGETS) 10 | -------------------------------------------------------------------------------- /example/NotoEmoji-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/NotoEmoji-Regular.ttf -------------------------------------------------------------------------------- /example/Roboto-Bold.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/Roboto-Bold.ttf -------------------------------------------------------------------------------- /example/Roboto-Light.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/Roboto-Light.ttf -------------------------------------------------------------------------------- /example/Roboto-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/Roboto-Regular.ttf -------------------------------------------------------------------------------- /example/colorweb.ml: -------------------------------------------------------------------------------- 1 | let perlin_noise3 = 2 | let t = [|0x15; 0x38; 0x32; 0x2c; 0x0d; 0x13; 0x07; 0x21|] in 3 | let b2 n b = (n lsr b) land 1 in 4 | let b i j k b = 5 | let idx = (b2 i b lsl 2) lor (b2 j b lsl 1) lor (b2 k b) in 6 | t.(idx) 7 | in 8 | let shuffle i j k = 9 | b i j k 0 + b j k i 1 + b k i j 2 + b i j k 3 + 10 | b j k i 4 + b k i j 5 + b i j k 6 + b j k i 7 11 | in 12 | let select c l r = if c then l else r in 13 | fun x y z -> 14 | let a = Array.make 3 0 in 15 | let s = (x +. y +. z) *. (1.0 /. 3.0) in 16 | let i = floor (x +. s) in 17 | let j = floor (y +. s) in 18 | let kk = floor (z +. s) in 19 | let s = (i +. j +. kk) *. (1.0 /. 6.0) in 20 | let u = x -. i +. s in 21 | let v = y -. j +. s in 22 | let w = z -. kk +. s in 23 | let i = int_of_float i in 24 | let j = int_of_float j in 25 | let kk = int_of_float kk in 26 | let k aa = 27 | let s = float (a.(0) + a.(1) + a.(2)) /. 6.0 in 28 | let x = u -. float a.(0) +. s in 29 | let y = v -. float a.(1) +. s in 30 | let z = w -. float a.(2) +. s in 31 | let t = 0.6 -. x *. x -. y *. y -. z *. z in 32 | let h = shuffle (i + a.(0)) (j + a.(1)) (kk + a.(2)) in 33 | a.(aa) <- a.(aa) + 1; 34 | if t < 0.0 then 0.0 else 35 | let b5 = (h lsr 5) land 1 in 36 | let b4 = (h lsr 4) land 1 in 37 | let b3 = (h lsr 3) land 1 in 38 | let b2 = (h lsr 2) land 1 in 39 | let bb = h land 3 in 40 | let p = ref x in 41 | let q = ref y in 42 | let r = ref z in 43 | if bb = 2 then ( 44 | p := y; 45 | q := z; 46 | r := x; 47 | ) else if bb = 3 then ( 48 | p := z; 49 | q := x; 50 | r := y; 51 | ); 52 | if b5 = b3 then 53 | p := -. !p; 54 | if b5 = b4 then 55 | q := -. !q; 56 | if b5 <> (b4 lxor b3) then 57 | r := -. !r; 58 | let t = t *. t in 59 | let tmp1 = 60 | if bb = 0 then !q +. !r 61 | else if b2 = 0 then !q 62 | else !r 63 | in 64 | 8.0 *. t *. t *. (!p +. tmp1) 65 | in 66 | let hi = select (w < u) (select (v < u) 0 1) (select (w < v) 1 2) in 67 | let lo = select (u < w) (select (u < v) 0 1) (select (v < w) 1 2) in 68 | k hi +. k (3 - hi - lo) +. k lo +. k 0 69 | 70 | let perlin_noise2 x y = perlin_noise3 x y 0.0 71 | 72 | let grid_width = 33 73 | let grid_height = 19 74 | 75 | let grid = Array.create_float (grid_width * grid_height * 2) 76 | 77 | let fill_noise t = 78 | for x = 0 to grid_width - 2 do 79 | for y = 0 to grid_height - 2 do 80 | let a = perlin_noise2 (float x *. 0.1 +. t) (float y *. 0.1 -. t) in 81 | let b = perlin_noise2 (float y *. 0.1 +. t) (float x *. 0.1 -. t) in 82 | grid.((x * grid_height + y) * 2 + 0) <- a; 83 | grid.((x * grid_height + y) * 2 + 1) <- b; 84 | done 85 | done 86 | 87 | let g_a x y = 88 | grid.((x * grid_height + y) * 2 + 0) 89 | 90 | let g_b x y = 91 | grid.((x * grid_height + y) * 2 + 1) 92 | 93 | let g_dx x y = if x > 0 && x < grid_width - 1 then g_a x y *. 3.0 else 0.0 94 | let g_dy x y = if y > 0 && y < grid_height - 1 then g_b x y *. 3.0 else 0.0 95 | let g_cr x y = 0.5 +. g_a x y *. 2.0 96 | let g_cg x y = 0.5 +. g_b x y *. 2.0 97 | let g_cb x y = 0.5 -. g_a x y -. g_b x y 98 | 99 | let g_color x y = 100 | let a = g_a x y and b = g_b x y in 101 | let r = 0.5 +. a *. 2.0 in 102 | let g = 0.5 +. b *. 2.0 in 103 | let b = (0.5 -. a -. b) *. 2.0 in 104 | Wall.Color.v r g b 1.0 105 | 106 | let g_x x y = float x +. g_dx x y 107 | let g_y x y = float y +. g_dy x y 108 | 109 | open Wall 110 | 111 | let cell x y = 112 | let path = 113 | Path.make @@ fun ctx -> 114 | Path.move_to ctx (g_x x y) (g_y x y); 115 | Path.line_to ctx (g_x (x+1) y) (g_y (x+1) y); 116 | Path.line_to ctx (g_x (x+1) (y+1)) (g_y (x+1) (y+1)); 117 | Path.line_to ctx (g_x x (y+1)) (g_y x (y+1)) 118 | in 119 | let bg = 120 | Image.stack 121 | (Image.paint (Paint.color (g_color x y)) (Image.fill path)) 122 | (Image.paint Paint.black (Image.stroke (Outline.make ~width:0.01 ()) path)) 123 | in 124 | if x > 0 && y > 0 then 125 | Image.stack bg 126 | (Image.paint Paint.white 127 | (Image.fill_path 128 | (Path.circle ~cx:(g_x x y) ~cy:(g_y x y) 129 | ~r:((abs_float (g_dx x y) +. abs_float (g_dy x y)) *. 0.25)))) 130 | else 131 | bg 132 | 133 | let frame t = 134 | fill_noise t; 135 | let image = ref Image.empty in 136 | for x = 0 to grid_width - 2 do 137 | for y = 0 to grid_height - 2 do 138 | image := Image.stack !image (cell x y) 139 | done 140 | done; 141 | Image.transform (Transform.scale 20.0 20.0) !image 142 | 143 | open Tsdl 144 | open Tgles2 145 | 146 | let main () = 147 | Printexc.record_backtrace true; 148 | match Sdl.init Sdl.Init.video with 149 | | Error (`Msg e) -> Sdl.log "Init error: %s" e; exit 1 150 | | Ok () -> 151 | ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); 152 | match 153 | Sdl.create_window ~w:640 ~h:480 "SDL OpenGL" 154 | Sdl.Window.(opengl + allow_highdpi) 155 | with 156 | | Error (`Msg e) -> Sdl.log "Create window error: %s" e; exit 1 157 | | Ok w -> 158 | (*Sdl.gl_set_attribute Sdl.Gl.context_profile_mask Sdl.Gl.context_profile_core;*) 159 | (*Sdl.gl_set_attribute Sdl.Gl.context_major_version 2;*) 160 | (*Sdl.gl_set_attribute Sdl.Gl.context_minor_version 1;*) 161 | ignore (Sdl.gl_set_swap_interval (-1)); 162 | let ow, oh = Sdl.gl_get_drawable_size w in 163 | match Sdl.gl_create_context w with 164 | | Error (`Msg e) -> Sdl.log "Create context error: %s" e; exit 1 165 | | Ok ctx -> 166 | let context = Renderer.create ~antialias:true () in 167 | let quit = ref false in 168 | let event = Sdl.Event.create () in 169 | while not !quit do 170 | while Sdl.poll_event (Some event) do 171 | match Sdl.Event.enum (Sdl.Event.get event Sdl.Event.typ) with 172 | | `Quit -> quit := true 173 | | _ -> () 174 | done; 175 | Gl.viewport 0 0 ow oh; 176 | Gl.clear_color 0.3 0.3 0.32 1.0; 177 | Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); 178 | Gl.enable Gl.blend; 179 | Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha; 180 | Gl.enable Gl.cull_face_enum; 181 | Gl.disable Gl.depth_test; 182 | Renderer.render context ~width:640.0 ~height:480.0 (frame (Sys.time ())); 183 | Sdl.gl_swap_window w; 184 | done; 185 | Sdl.gl_delete_context ctx; 186 | Sdl.destroy_window w; 187 | Sdl.quit (); 188 | exit 0 189 | 190 | let () = main () 191 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names example minimal blemish colorweb) 3 | (flags :standard -w -3-6-27) 4 | (libraries tsdl tgls.tgles2 wall)) 5 | -------------------------------------------------------------------------------- /example/entypo.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/entypo.ttf -------------------------------------------------------------------------------- /example/example.ml: -------------------------------------------------------------------------------- 1 | open Tsdl 2 | 3 | open Wall 4 | module I = Image 5 | module P = Path 6 | module Text = Wall_text 7 | 8 | let b2 x y w h = Gg.Box2.v (Gg.P2.v x y) (Gg.Size2.v w h) 9 | 10 | let normalize (dx, dy) = 11 | let d = sqrt (dx *. dx +. dy *. dy) in 12 | if d > 1.0 then 13 | (dx /. d, dy /. d) 14 | else 15 | (dx, dy) 16 | 17 | let gray ?(a=1.0) v = 18 | Color.v v v v a 19 | 20 | let load_font name = 21 | let ic = open_in_bin name in 22 | let dim = in_channel_length ic in 23 | let fd = Unix.descr_of_in_channel ic in 24 | let buffer = 25 | Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [|dim|] 26 | |> Bigarray.array1_of_genarray 27 | in 28 | let offset = List.hd (Stb_truetype.enum buffer) in 29 | match Stb_truetype.init buffer offset with 30 | | None -> assert false 31 | | Some font -> font 32 | 33 | let font_icons = lazy (load_font "entypo.ttf") 34 | let font_sans = lazy (load_font "Roboto-Regular.ttf") 35 | let font_sans_bold = lazy (load_font "Roboto-Bold.ttf") 36 | let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf") 37 | 38 | let draw_eyes x y w h mx my t = 39 | let ex = w *. 0.23 in 40 | let ey = h *. 0.5 in 41 | let lx = x +. ex in 42 | let ly = y +. ey in 43 | let rx = x +. w -. ex in 44 | let ry = y +. ey in 45 | let br = min ex ey *. 0.5 in 46 | let blink = 1.0 -. (sin (t *. 0.5) ** 200.0) *. 0.8 in 47 | 48 | let dx, dy = normalize 49 | ((mx -. rx) /. (ex *. 10.0), (my -. ry) /. (ey *. 10.0)) in 50 | let dx = dx *. ex *. 0.4 in 51 | let dy = dy *. ey *. 0.5 in 52 | I.seq [ 53 | I.paint 54 | (Paint.linear_gradient 55 | ~sx:x ~sy:(y +. h *. 0.5) ~ex:(x +. w *. 0.1) ~ey:(y +. h) 56 | ~inner:(Color.v 0.0 0.0 0.0 0.125) 57 | ~outer:(Color.v 0.0 0.0 0.0 0.0625)) 58 | (I.fill_path @@ fun t -> 59 | P.ellipse t ~cx:(lx +. 3.0) ~cy:(ly +. 16.0) ~rx:ex ~ry:ey; 60 | P.ellipse t ~cx:(rx +. 3.0) ~cy:(ry +. 16.0) ~rx:ex ~ry:ey); 61 | I.paint 62 | (Paint.linear_gradient 63 | ~sx:x ~sy:(y +. h *. 0.25) ~ex:(x +. w *. 0.1) ~ey:(y +. h) 64 | ~inner:(Color.v 0.86 0.86 0.86 1.0) 65 | ~outer:(Color.v 0.5 0.5 0.5 1.0)) 66 | (I.fill_path @@ fun t-> 67 | P.ellipse t ~cx:lx ~cy:ly ~rx:ex ~ry:ey; 68 | P.ellipse t ~cx:rx ~cy:ry ~rx:ex ~ry:ey); 69 | I.paint (Paint.color (Color.v 0.125 0.125 0.125 1.0)) 70 | (I.fill_path @@ fun t -> 71 | P.ellipse t 72 | ~cx:(lx +. dx) ~cy:(ly +. dy +. ey *. 0.25 *. (1.0 -. blink)) 73 | ~rx:br ~ry:(br *. blink)); 74 | I.paint (Paint.color (Color.v 0.125 0.125 0.125 1.0)) 75 | (I.fill_path @@ fun t -> 76 | P.ellipse t 77 | ~cx:(rx +. dx) ~cy:(ry +. dy +. ey *. 0.25 *. (1.0 -. blink)) 78 | ~rx:br ~ry:(br *. blink); 79 | ); 80 | (* Gloss *) 81 | I.paint 82 | (Paint.radial_gradient 83 | ~cx:(lx -. ex *. 0.25) ~cy:(ry -. ey *. 0.5) 84 | ~inr:(ex *. 0.1) ~outr:(ex *. 0.75) 85 | ~inner:(Color.v 1.0 1.0 1.0 0.5) 86 | ~outer:(Color.v 1.0 1.0 1.0 0.0)) 87 | (I.fill_path @@ fun t -> 88 | P.ellipse t ~cx:lx ~cy:ly ~rx:ex ~ry:ey); 89 | I.paint 90 | (Paint.radial_gradient 91 | ~cx:(rx -. ex *. 0.25) ~cy:(ry -. ey *. 0.5) 92 | ~inr:(ex *. 0.1) ~outr:(ex *. 0.75) 93 | ~inner:(Color.v 1.0 1.0 1.0 0.5) 94 | ~outer:(Color.v 1.0 1.0 1.0 0.0)) 95 | (I.fill_path @@ fun t -> 96 | P.ellipse t ~cx:rx ~cy:ry ~rx:ex ~ry:ey) 97 | ] 98 | 99 | let draw_graph x y w h t = 100 | let samples = [| 101 | (1.0 +. sin (t *. 1.2345 +. cos (t *. 0.33457) *. 0.44 )) *. 0.5; 102 | (1.0 +. sin (t *. 0.68363 +. cos (t *. 1.3 ) *. 1.55 )) *. 0.5; 103 | (1.0 +. sin (t *. 1.1642 +. cos (t *. 0.33457) *. 1.24 )) *. 0.5; 104 | (1.0 +. sin (t *. 0.56345 +. cos (t *. 1.63 ) *. 0.14 )) *. 0.5; 105 | (1.0 +. sin (t *. 1.6245 +. cos (t *. 0.254 ) *. 0.3 )) *. 0.5; 106 | (1.0 +. sin (t *. 0.345 +. cos (t *. 0.03 ) *. 0.6 )) *. 0.5; 107 | |] in 108 | let dx = w /. 5.0 in 109 | let sx i = x +. float i *. dx in 110 | let sy i = y +. h *. samples.(i) *. 0.8 in 111 | I.seq [ 112 | (* Graph background *) 113 | I.paint 114 | (Paint.linear_gradient ~sx:x ~sy:y ~ex:x ~ey:(y +. h) 115 | ~inner:(Color.v 0.00 0.60 0.75 0.00) 116 | ~outer:(Color.v 0.00 0.60 0.75 0.25)) 117 | (I.fill_path @@ fun t -> 118 | P.move_to t ~x:(sx 0) ~y:(sy 0); 119 | for i = 1 to 5 do 120 | P.bezier_to t 121 | ~c1x:(sx (i - 1) +. dx *. 0.5) ~c1y:(sy (i - 1)) 122 | ~c2x:(sx i -. dx *. 0.5) ~c2y:(sy i) 123 | ~x:(sx i) ~y:(sy i) 124 | done; 125 | P.line_to t ~x:(x +. w) ~y:(y +. h); 126 | P.line_to t ~x ~y:(y +. h)); 127 | (* Graph line *) 128 | I.paint (Paint.color (Color.v 0.0 0.0 0.0 0.125)) 129 | (I.stroke_path Outline.{default with stroke_width = 3.0} @@ fun t -> 130 | P.move_to t ~x:(sx 0) ~y:(sy 0 +. 2.0); 131 | for i = 1 to 5 do 132 | P.bezier_to t 133 | ~c1x:(sx (i - 1) +. dx *. 0.5) ~c1y:(sy (i - 1) +. 2.0) 134 | ~c2x:(sx i -. dx *. 0.5) ~c2y:(sy i +. 2.0) 135 | ~x:(sx i) ~y:(sy i +. 2.0) 136 | done); 137 | I.paint (Paint.color (Color.v 0.0 0.60 0.75 1.0)) 138 | (I.stroke_path Outline.{default with stroke_width = 3.0} @@ fun t -> 139 | P.move_to t ~x:(sx 0) ~y:(sy 0); 140 | for i = 1 to 5 do 141 | P.bezier_to t 142 | ~c1x:(sx (i - 1) +. dx *. 0.5) ~c1y:(sy (i - 1)) 143 | ~c2x:(sx i -. dx *. 0.5) ~c2y:(sy i) 144 | ~x:(sx i) ~y:(sy i) 145 | done); 146 | (* Graph sample pos *) 147 | (let node = ref I.empty in 148 | for i = 0 to 5 do 149 | node := I.stack !node ( 150 | I.paint 151 | (Paint.radial_gradient ~cx:(sx i) ~cy:(sy i +. 2.0) ~inr:3.0 ~outr:8.0 152 | ~inner:(Color.v 0.0 0.0 0.0 0.125) ~outer:(Color.v 0.0 0.0 0.0 0.0)) 153 | (I.fill_path @@ fun t -> 154 | P.rect t ~x:(sx i -. 10.0) ~y:(sy i -. 10.0 +. 2.0) ~w:20.0 ~h:20.0)) 155 | done; 156 | !node); 157 | I.paint (Paint.color (Color.v 0.0 0.6 0.75 1.0)) 158 | (I.fill_path @@ fun t -> 159 | for i = 0 to 5 do 160 | P.circle t ~cx:(sx i) ~cy:(sy i) ~r:4.0; 161 | done); 162 | I.paint (Paint.color (Color.v 0.8 0.8 0.8 1.0)) 163 | (I.fill_path @@ fun t -> 164 | for i = 0 to 5 do 165 | P.circle t ~cx:(sx i) ~cy:(sy i) ~r:2.0 166 | done) 167 | ] 168 | 169 | let draw_spinner cx cy r t = 170 | let a0 = 0.0 +. t *. 6.0 in 171 | let a1 = pi +. t *. 6.0 in 172 | let r0 = r in 173 | let r1 = r *. 0.75 in 174 | let sx = cx +. cos a0 *. (r0 +. r1) *. 0.5 in 175 | let sy = cy +. sin a0 *. (r0 +. r1) *. 0.5 in 176 | let ex = cx +. cos a1 *. (r0 +. r1) *. 0.5 in 177 | let ey = cy +. sin a1 *. (r0 +. r1) *. 0.5 in 178 | I.paint 179 | (Paint.linear_gradient ~sx ~sy ~ex ~ey 180 | ~inner:(Color.v 0.0 0.0 0.0 0.0) 181 | ~outer:(Color.v 0.0 0.0 0.0 0.5)) 182 | (I.fill_path @@ fun t -> 183 | P.arc t ~cx ~cy ~r:r0 ~a0:a0 ~a1:a1 `CW; 184 | P.arc t ~cx ~cy ~r:r1 ~a0:a1 ~a1:a0 `CCW; 185 | P.close t) 186 | 187 | let draw_colorwheel x y w h t = 188 | let cx = x +. w *. 0.5 in 189 | let cy = y +. h *. 0.5 in 190 | let hue = sin (t *. 0.12) in 191 | let r1 = min w h *. 0.5 -. 5.0 in 192 | let r0 = r1 -. 20.0 in 193 | let aeps = 0.5 /. r1 in 194 | let node = ref I.empty in 195 | for i = 0 to 5 do 196 | let a0 = float i /. 6.0 *. pi *. 2.0 -. aeps in 197 | let a1 = (float i +. 1.0) /. 6.0 *. pi *. 2.0 +. aeps in 198 | let sx = cx +. cos a0 *. (r0 +. r1) *. 0.5 in 199 | let sy = cy +. sin a0 *. (r0 +. r1) *. 0.5 in 200 | let ex = cx +. cos a1 *. (r0 +. r1) *. 0.5 in 201 | let ey = cy +. sin a1 *. (r0 +. r1) *. 0.5 in 202 | (*Printf.printf "sx=%f, sy=%f, ex=%f, ey=%f\n%!" sx sy ex ey;*) 203 | node := I.stack !node ( 204 | I.paint 205 | (Paint.linear_gradient 206 | ~sx ~sy ~ex ~ey 207 | ~inner:(Color.hsl ~h:(a0 /. (2.0 *. pi)) ~s:1.0 ~l:0.55) 208 | ~outer:(Color.hsl ~h:(a1 /. (2.0 *. pi)) ~s:1.0 ~l:0.55)) 209 | (I.fill_path @@ fun t -> 210 | P.arc t ~cx ~cy ~r:r0 ~a0:a0 ~a1:a1 `CW; 211 | P.arc t ~cx ~cy ~r:r1 ~a0:a1 ~a1:a0 `CCW; 212 | P.close t) 213 | ) 214 | done; 215 | I.seq [ 216 | !node; 217 | I.paint 218 | (Paint.color (Color.v 0.0 0.0 0.0 0.25)) 219 | (I.stroke_path Outline.{default with stroke_width = 1.0} @@ fun t -> 220 | P.circle t ~cx ~cy ~r:(r0 -. 0.5); 221 | P.circle t ~cx ~cy ~r:(r1 +. 0.5)); 222 | (* Selector *) 223 | I.transform 224 | (Transform.(rotate (hue *. 2.0 *. pi) (translation ~x:cx ~y:cy))) 225 | (I.seq [ 226 | I.paint (Paint.color (gray ~a:0.75 1.0)) 227 | (I.stroke_path Outline.{default with stroke_width = 2.0} @@ fun t -> 228 | P.rect t ~x:(r0 -. 1.0) ~y:(-3.0) ~w:(r1-.r0+.2.) ~h:6.0); 229 | I.paint 230 | (Paint.box_gradient ~x:(r0-.3.0) ~y:(-5.0) 231 | ~w:(r1-.r0+.6.0) ~h:10.0 ~r:2.0 ~f:4.0 232 | ~inner:(gray ~a:0.5 0.0) ~outer:(gray ~a:0.0 0.0)) 233 | (I.fill_path @@ fun t -> 234 | P.rect t ~x:(r0-.2.0-.10.0) ~y:(-.4.0-.10.0) 235 | ~w:(r1-.r0+.4.0+.20.0) ~h:(8.0+.20.0); 236 | P.rect t ~x:(r0-.2.0) ~y:(-4.0) ~w:(r1-.r0+.4.0) ~h:8.0; 237 | P.set_winding t `HOLE); 238 | (* Center triangle *) 239 | let r = r0 -. 6.0 in 240 | let ax = cos (120.0/.180.0 *. pi) *. r in 241 | let ay = sin (120.0/.180.0 *. pi) *. r in 242 | let bx = cos (-.120.0/.180.0 *. pi) *. r in 243 | let by = sin (-.120.0/.180.0 *. pi) *. r in 244 | let path = Path.make @@ fun t -> 245 | P.move_to t ~x:r ~y:0.0; 246 | P.line_to t ~x:ax ~y:ay; 247 | P.line_to t ~x:bx ~y:by; 248 | P.close t 249 | in 250 | (*Printf.printf "sx=%f, sy=%f, ex=%f, ey=%f\n%!" r 0.0 ax ay;*) 251 | let fill = I.fill path in 252 | I.seq [ 253 | I.paint 254 | (Paint.linear_gradient ~sx:r ~sy:0.0 ~ex:ax ~ey:ay 255 | ~inner:(Color.hsl ~h:hue ~s:1.0 ~l:0.5) ~outer:Color.white) 256 | fill; 257 | I.paint 258 | (Paint.linear_gradient ~sx:((r+.ax)*.0.5) ~sy:((0.0+.ay)*.0.5) 259 | ~ex:bx ~ey:by 260 | ~inner:(gray ~a:0.0 0.0) ~outer:(gray ~a:1.0 0.0)) 261 | fill; 262 | I.paint (Paint.color (gray ~a:0.25 0.0)) 263 | (I.stroke Outline.default path); 264 | 265 | (* Select circle on triangle *) 266 | let ax = cos (120.0 /. 180.0 *. pi) *. r *. 0.3 in 267 | let ay = sin (120.0 /. 180.0 *. pi) *. r *. 0.4 in 268 | I.stack 269 | (I.paint (Paint.color (gray ~a:0.75 1.0)) 270 | (I.stroke_path Outline.{default with stroke_width = 2.0} @@ fun t -> 271 | P.circle t ~cx:ax ~cy:ay ~r:5.0)) 272 | (I.paint 273 | (Paint.radial_gradient ~cx:ax ~cy:ay ~inr:7.0 ~outr:9.0 274 | ~inner:(gray ~a:0.25 0.0) ~outer:(gray ~a:0.0 0.0)) 275 | (I.fill_path @@ fun t -> 276 | P.rect t ~x:(ax -. 20.0) ~y:(ay -. 20.0) ~w:40.0 ~h:40.0; 277 | P.circle t ~cx:ax ~cy:ay ~r:7.0; 278 | P.set_winding t `HOLE)) 279 | ] 280 | ]) 281 | ] 282 | 283 | let draw_lines x y w _h t = 284 | let pad = 5.0 in 285 | let s = w /. 9.0 -. pad *. 2.0 in 286 | let joins = [|`MITER; `ROUND; `BEVEL|] in 287 | let caps = [|`BUTT; `ROUND; `SQUARE|] in 288 | let px = function 289 | | 0 -> -.s*.0.25 +. cos (t*.0.3) *. s*.0.5 290 | | 1 -> -.s*.0.25 291 | | 2 -> s*.0.25 292 | | 3 -> s*.0.25 +. cos (-.t*.0.3) *. s*.0.5 293 | | _ -> assert false 294 | in 295 | let py = function 296 | | 0 -> sin (t*.0.3) *. s*.0.5 297 | | 1 -> 0.0 298 | | 2 -> 0.0 299 | | 3 -> sin (-.t*.0.3) *. s*.0.5 300 | | _ -> assert false 301 | in 302 | let node = ref I.empty in 303 | for i = 0 to 2 do 304 | for j = 0 to 2 do 305 | let fx = x +. s *. 0.5 +. float (i * 3 + j) /. 9.0 *. w +. pad in 306 | let fy = y -. s *. 0.5 +. pad in 307 | let px i = fx +. px i in 308 | let py i = fy +. py i in 309 | node := I.seq [ 310 | !node; 311 | I.paint (Paint.color (gray ~a:0.625 0.0)) 312 | (I.stroke_path 313 | Outline.{default with stroke_width = s *. 0.3; 314 | line_cap = caps.(i); line_join = joins.(j) } 315 | @@ fun t -> 316 | P.move_to t ~x:(px 0) ~y:(py 0); 317 | P.line_to t ~x:(px 1) ~y:(py 1); 318 | P.line_to t ~x:(px 2) ~y:(py 2); 319 | P.line_to t ~x:(px 3) ~y:(py 3)); 320 | I.paint (Paint.color (Color.v 0.0 0.75 1.0 1.0)) 321 | (I.stroke_path 322 | Outline.{default with stroke_width = 1.0; 323 | line_cap = `BUTT; line_join = joins.(j)} 324 | @@ fun t -> 325 | P.move_to t ~x:(px 0) ~y:(py 0); 326 | P.line_to t ~x:(px 1) ~y:(py 1); 327 | P.line_to t ~x:(px 2) ~y:(py 2); 328 | P.line_to t ~x:(px 3) ~y:(py 3)) 329 | ] 330 | done 331 | done; 332 | !node 333 | 334 | let draw_widths x y w = 335 | let paint = Paint.color Color.black in 336 | let y = ref y in 337 | let node = ref I.empty in 338 | for i = 0 to 19 do 339 | let y' = !y in 340 | node := I.stack !node 341 | (I.paint paint 342 | (I.stroke_path 343 | Outline.{default with stroke_width = (float i +. 0.5) /. 10.0} 344 | @@ fun t -> 345 | P.move_to t ~x ~y:y'; 346 | P.line_to t ~x:(x+.w) ~y:(y'+.w*.0.3))); 347 | y := !y +. 10.0; 348 | done; 349 | !node 350 | 351 | let draw_caps x y w = 352 | let width = 8.0 in 353 | let f cap i = 354 | I.paint Paint.black 355 | (I.stroke_path (Outline.make ~width ~cap ()) @@ fun t -> 356 | P.move_to t ~x ~y:(y +. float (i * 10 + 5)); 357 | P.line_to t ~x:(x +. w) ~y:(y +. float (i * 10 + 5))) 358 | in 359 | I.seq [ 360 | I.paint (Paint.color (gray ~a:0.125 1.0)) 361 | (I.fill_path @@ fun t -> P.rect t ~x ~y ~w ~h:40.0); 362 | I.paint (Paint.color (gray ~a:0.125 1.0)) 363 | (I.fill_path @@ fun t -> P.rect t ~x:(x-.width/.2.0) ~y ~w:(w+.width) ~h:40.0); 364 | f `BUTT 0; 365 | f `ROUND 1; 366 | f `SQUARE 2 367 | ] 368 | 369 | let draw_scissor x y t = 370 | let xf = Transform.(rotate (5.0 /. 180.0 *. pi) (translation ~x ~y)) in 371 | let shape = I.fill_path @@ fun t -> P.rect t ~x:(-20.0) ~y:(-10.0) ~w:60.0 ~h:30.0 in 372 | I.transform xf ( 373 | I.stack 374 | (* Draw first rect and set scissor to it's area. *) 375 | (I.paint 376 | (Paint.color (Color.v 1.0 0.0 0.0 1.0)) 377 | (I.fill_path @@ fun t -> P.rect t ~x:(-20.0) ~y:(-20.0) ~w:(60.0) ~h:(40.0))) 378 | (* Draw second rectangle with offset and rotation. *) 379 | ((*let frame = Frame.set_scissor (-20.0) (-20.0) 60.0 40.0 Transform.identity frame in*) 380 | let xf = Transform.(rotate t (translation ~x:40.0 ~y:0.0)) in 381 | I.stack 382 | (* Draw the intended second rectangle without any scissoring. *) 383 | (I.transform xf (I.paint (Paint.color (Color.v 1.0 0.5 0.0 0.25)) shape)) 384 | (* Draw second rectangle with combined scissoring. *) 385 | (I.scissor (b2 (-20.0) (-20.0) 60.0 40.0) 386 | (I.transform xf 387 | (I.intersect_scissor (b2 (-20.0) (-10.0) 60.0 30.0) 388 | (I.paint (Paint.color (Color.v 1.0 0.5 0.0 1.0)) shape)))) 389 | ) 390 | ) 391 | 392 | let draw_window title x y w h = 393 | let cornerRadius = 3.0 in 394 | let font = Lazy.force font_sans_bold in 395 | I.seq [ 396 | (* Window *) 397 | I.paint 398 | (Paint.color (Color.v 0.110 0.118 0.133 0.75)) 399 | (I.fill_path @@ fun t -> P.round_rect t ~x ~y ~w ~h ~r:cornerRadius); 400 | 401 | (* Drop shadow *) 402 | I.paint 403 | (Paint.box_gradient ~x ~y:(y+.2.0) ~w ~h ~r:(cornerRadius*.2.0) ~f:10.0 404 | ~inner:(gray ~a:0.5 0.0) ~outer:(gray ~a:0.0 0.0)) 405 | (I.fill_path @@ fun t -> 406 | P.rect t ~x:(x -. 10.0) ~y:(y -. 10.0) ~w:(w +. 20.0) ~h:(h +. 30.0); 407 | P.round_rect t ~x ~y ~w ~h ~r:cornerRadius; 408 | P.set_winding t `HOLE); 409 | 410 | (* Header *) 411 | I.paint 412 | (Paint.linear_gradient ~sx:x ~sy:y ~ex:x ~ey:(y+.15.0) 413 | ~inner:(gray ~a:(8.0/.255.0) 1.0) ~outer:(gray ~a:(16.0/.255.0) 0.0)) 414 | (I.fill_path @@ fun t -> 415 | P.round_rect t ~x:(x+.1.0) ~y:(y+.1.0) ~w:(w-.2.0) ~h:30.0 ~r:(cornerRadius -. 1.0)); 416 | I.paint 417 | (Paint.color (gray ~a:0.125 0.0)) 418 | (I.stroke_path Outline.default @@ fun t -> 419 | P.move_to t ~x:(x+.0.5) ~y:(y+.0.5+.30.0); 420 | P.line_to t ~x:(x+.0.5+.w-.1.0) ~y:(y+.0.5+.30.0)); 421 | 422 | I.paint (Paint.color (gray ~a:0.5 0.0)) 423 | Text.(simple_text 424 | (Font.make ~blur:2.0 ~size:18.0 font) 425 | ~valign:`MIDDLE ~halign:`CENTER 426 | ~x:(x+.w/.2.) ~y:(y+.16.+.1.0) title); 427 | 428 | I.paint (Paint.color (gray ~a:0.6 0.9)) 429 | Text.(simple_text 430 | (Font.make ~size:18.0 font) 431 | ~valign:`MIDDLE ~halign:`CENTER 432 | ~x:(x+.w/.2.) ~y:(y+.16.) title) 433 | ] 434 | 435 | let draw_searchbox text x y w h = 436 | let cornerRadius = h /. 2.0 -. 1.0 in 437 | (* Edit *) 438 | I.seq [ 439 | I.paint 440 | (Paint.box_gradient ~x ~y:(y +. 1.5) ~w ~h ~r:(h /. 2.0) ~f:5.0 441 | ~inner:(gray ~a:0.08 0.0) ~outer:(gray ~a:0.375 0.0)) 442 | (I.fill_path @@ fun t -> P.round_rect t ~x ~y ~w ~h ~r:cornerRadius); 443 | 444 | I.paint 445 | (Paint.color (gray ~a:0.2 0.0)) 446 | (I.stroke_path Outline.default @@ fun t -> 447 | P.round_rect t ~x:(x+.0.5) ~y:(y+.0.5) ~w:(w-.1.0) ~h:(h-.1.0) ~r:(cornerRadius-.0.5)); 448 | 449 | I.paint (Paint.color (gray ~a:0.25 1.0)) 450 | Text.(simple_text 451 | (Font.make ~size:(h*.1.3) (Lazy.force font_icons)) 452 | ~valign:`MIDDLE ~halign:`CENTER 453 | ~x:(x+.h*.0.55) ~y:(y+.h*.0.55) "🔍"); 454 | 455 | I.paint (Paint.color (gray ~a:0.125 1.0)) 456 | Text.(simple_text 457 | (Font.make ~size:20.0 (Lazy.force font_sans)) 458 | ~valign:`MIDDLE ~halign:`LEFT 459 | ~x:(x+.h*.1.05) ~y:(y+.h*.0.5) text); 460 | 461 | I.paint (Paint.color (gray ~a:0.125 1.0)) 462 | Text.(simple_text 463 | (Font.make ~size:(h*.1.3) (Lazy.force font_icons)) 464 | ~valign:`MIDDLE ~halign:`CENTER 465 | ~x:(x+.w-.h*.0.55) ~y:(y+.h*.0.55) "✖") 466 | ] 467 | 468 | let draw_dropdown text x y w h = 469 | let cornerRadius = 4.0 in 470 | I.seq [ 471 | I.paint 472 | (Paint.linear_gradient ~sx:x ~sy:y ~ex:x ~ey:(y+.h) 473 | ~inner:(gray ~a:0.08 1.0) ~outer:(gray ~a:0.08 0.0)) 474 | (I.fill_path @@ fun t -> 475 | P.round_rect t ~x:(x+.1.0) ~y:(y+.1.0) ~w:(w-.2.0) ~h:(h-.2.0) ~r:(cornerRadius-.1.0)); 476 | 477 | I.paint 478 | (Paint.color (gray ~a:0.1875 0.0)) 479 | (I.stroke_path Outline.default @@ fun t -> 480 | P.round_rect t ~x:(x+.0.5) ~y:(y+.0.5) ~w:(w-.1.0) ~h:(h-.1.0) ~r:(cornerRadius-.0.5)); 481 | 482 | I.paint (Paint.color (gray ~a:0.8 1.0)) 483 | Text.(simple_text 484 | (Font.make ~size:20.0 (Lazy.force font_sans)) 485 | ~valign:`MIDDLE ~halign:`LEFT 486 | ~x:(x+.h*.0.3) ~y:(y+.h*.0.5) text); 487 | 488 | I.paint (Paint.color (gray ~a:0.8 1.0)) 489 | Text.(simple_text 490 | (Font.make ~size:(h*.1.3) (Lazy.force font_icons)) 491 | ~valign:`MIDDLE ~halign:`CENTER 492 | ~x:(x+.w-.h*.0.5) ~y:(y+.h*.0.5) " ") 493 | ] 494 | 495 | let draw_label text ~x ~y ~w:_ ~h = 496 | I.paint (Paint.color (gray ~a:0.5 1.0)) 497 | Text.(simple_text 498 | (Font.make ~size:18.0 (Lazy.force font_sans)) 499 | ~valign:`MIDDLE ~halign:`LEFT 500 | ~x ~y:(y+.h*.0.5) text) 501 | 502 | let draw_editboxbase ~x ~y ~w ~h = 503 | I.stack 504 | (I.paint 505 | (Paint.box_gradient ~x:(x+.1.0) ~y:(y+.1.0+.1.5) ~w:(w-.2.0) ~h:(h-.2.0) ~r:3.0 ~f:4.0 506 | ~inner:(gray ~a:0.125 1.0) ~outer:(gray ~a:0.125 0.125)) 507 | (I.fill_path @@ fun t -> 508 | P.round_rect t ~x:(x+.1.0) ~y:(y+.1.0) ~w:(w-.2.0) ~h:(h-.2.0) ~r:(4.0-.1.0))) 509 | (I.paint 510 | (Paint.color (gray ~a:0.1875 0.0)) 511 | (I.stroke_path Outline.default @@ fun t -> 512 | P.round_rect t ~x:(x+.0.5) ~y:(y+.0.5) ~w:(w-.1.0) ~h:(h-.1.0) ~r:(4.0-.0.5))) 513 | 514 | let draw_editbox text ~x ~y ~w ~h = 515 | I.stack (draw_editboxbase ~x ~y ~w ~h) 516 | (I.paint (Paint.color (gray ~a:0.25 1.0)) 517 | Text.(simple_text 518 | (Font.make ~size:20.0 (Lazy.force font_sans)) 519 | ~valign:`MIDDLE ~halign:`LEFT 520 | ~x:(x+.h*.0.3) ~y:(y+.h*.0.5) text)) 521 | 522 | let draw_editboxnum text units ~x ~y ~w ~h = 523 | let ufont = Text.Font.make ~size:18.0 (Lazy.force font_sans) in 524 | let uw = Text.Font.text_width ufont units in 525 | I.seq [ 526 | draw_editboxbase ~x ~y ~w ~h; 527 | I.paint (Paint.color (gray ~a:0.25 1.0)) 528 | Text.(simple_text 529 | ~valign:`MIDDLE ufont ~halign:`RIGHT 530 | ~x:(x+.w-.h*.0.3) ~y:(y+.h*.0.5) units); 531 | I.paint (Paint.color (gray ~a:0.5 1.0)) 532 | Text.(simple_text 533 | (Font.make ~size:20.0 (Lazy.force font_sans)) 534 | ~valign:`MIDDLE ~halign:`RIGHT 535 | ~x:(x+.w-.uw-.h*.0.5) ~y:(y+.h*.0.5) text) 536 | ] 537 | 538 | let draw_checkbox text ~x ~y ~w:_ ~h = 539 | I.seq [ 540 | I.paint (Paint.color (gray ~a:0.66 1.0)) 541 | Text.(simple_text 542 | (Font.make ~size:18.0 (Lazy.force font_sans)) 543 | ~valign:`MIDDLE 544 | ~x:(x+.28.) ~y:(y+.h*.0.5) text); 545 | I.paint 546 | (Paint.box_gradient ~x:(x+.1.0) ~y:(y+.floor(h/.2.0)-.9.0+.1.0) 547 | ~w:18.0 ~h:18.0 ~r:3.0 ~f:3.0 548 | ~inner:(gray ~a:0.125 0.0) ~outer:(gray ~a:0.375 0.0)) 549 | (I.fill_path @@ fun t -> 550 | P.round_rect t ~x:(x+.1.0) ~y:(y+.floor(h/.2.0)-.9.0) ~w:18.0 ~h:18.0 ~r:3.0); 551 | I.paint (Paint.color (gray ~a:0.5 1.0)) 552 | Text.(simple_text 553 | (Font.make ~size:40.0 (Lazy.force font_icons)) 554 | ~valign:`MIDDLE ~halign:`CENTER 555 | ~x:(x+.11.) ~y:(y+.h*.0.5) "✓") 556 | ] 557 | 558 | let cp_to_utf8 cp = 559 | let n = 560 | if cp < 0x80 then 1 561 | else if (cp < 0x800) then 2 562 | else if (cp < 0x10000) then 3 563 | else if (cp < 0x200000) then 4 564 | else if (cp < 0x4000000) then 5 565 | else if (cp <= 0x7fffffff) then 6 566 | else assert false 567 | in 568 | let str= Bytes.create n in 569 | let cp = ref cp in 570 | begin try 571 | if n > 5 then (Bytes.set str 5 (Char.chr (0x80 lor (!cp land 0x3f))); 572 | cp := (!cp lsr 6) lor 0x4000000); 573 | if n > 4 then (Bytes.set str 4 (Char.chr (0x80 lor (!cp land 0x3f))); 574 | cp := (!cp lsr 6) lor 0x200000); 575 | if n > 3 then (Bytes.set str 3 (Char.chr (0x80 lor (!cp land 0x3f))); 576 | cp := (!cp lsr 6) lor 0x10000); 577 | if n > 2 then (Bytes.set str 2 (Char.chr (0x80 lor (!cp land 0x3f))); 578 | cp := (!cp lsr 6) lor 0x800); 579 | if n > 1 then (Bytes.set str 1 (Char.chr (0x80 lor (!cp land 0x3f))); 580 | cp := (!cp lsr 6) lor 0xc0); 581 | (Bytes.set str 0 (Char.chr !cp)); 582 | with exn -> 583 | prerr_endline ("cp: " ^ string_of_int !cp); 584 | raise exn 585 | end; 586 | Bytes.to_string str 587 | 588 | 589 | let draw_button preicon text ~x ~y ~w ~h ~color:col = 590 | let is_black = Color.a col > 0.0 in 591 | let cornerRadius = 4.0 in 592 | let shape = I.fill_path @@ fun t -> 593 | P.round_rect t ~x:(x+.1.0) ~y:(y+.1.0) ~w:(w-.2.0) ~h:(h-.2.0) ~r:(cornerRadius-.1.0) 594 | in 595 | I.seq [ 596 | if is_black then I.paint (Paint.color col) shape else I.empty; 597 | I.paint 598 | (Paint.linear_gradient ~sx:x ~sy:y ~ex:x ~ey:(y+.h) 599 | ~inner:(gray 1.0 ~a:(if is_black then 0.125 else 0.25)) 600 | ~outer:(gray 0.0 ~a:(if is_black then 0.125 else 0.25))) 601 | shape; 602 | I.paint 603 | (Paint.color (gray ~a:0.375 0.0)) 604 | (I.stroke_path Outline.default @@ fun t -> 605 | P.round_rect t ~x:(x+.0.5) ~y:(y+.0.5) ~w:(w-.1.0) ~h:(h-.1.0) ~r:(cornerRadius-.0.5)); 606 | let font = Text.Font.make ~size:20.0 (Lazy.force font_sans_bold) in 607 | let tw = Text.Font.text_width font text in 608 | let base, iw = if preicon = 0 then I.empty, 0.0 else 609 | let font = Text.Font.make ~size:(h*.1.3) (Lazy.force font_icons) in 610 | let icon = cp_to_utf8 preicon in 611 | let iw = Text.Font.text_width font icon in 612 | (I.paint (Paint.color (gray ~a:0.40 1.0)) 613 | Text.(simple_text font icon 614 | ~halign:`LEFT ~valign:`MIDDLE 615 | ~x:(x+.w*.0.5-.tw*.0.5-.iw*.0.75) ~y:(y+.h*.0.5)), 616 | iw) 617 | in 618 | I.seq [ 619 | base; 620 | I.paint (Paint.color (gray ~a:0.66 0.0)) 621 | Text.(simple_text font text 622 | ~valign:`MIDDLE ~halign:`LEFT 623 | ~x:(x+.w*.0.5-.tw*.0.5+.iw*.0.25) ~y:(y+.h*.0.5-.0.5)); 624 | I.paint (Paint.color (gray ~a:0.66 1.0)) 625 | Text.(simple_text font text 626 | ~valign:`MIDDLE ~halign:`LEFT 627 | ~x:(x+.w*.0.5-.tw*.0.5+.iw*.0.25) ~y:(y+.h*.0.5)) 628 | ] 629 | ] 630 | 631 | let draw_slider pos ~x ~y ~w ~h = 632 | let cy = y +. floor (h*.0.5) in 633 | let kr = floor (h*.0.25) in 634 | I.seq [ 635 | (* Slot *) 636 | I.paint 637 | (Paint.box_gradient ~x ~y:(cy-.2.0+.1.0) ~w ~h:4.0 ~r:2.0 ~f:2.0 638 | ~inner:(gray ~a:0.125 0.0) ~outer:(gray ~a:0.5 0.0)) 639 | (I.fill_path @@ fun t -> 640 | P.round_rect t ~x ~y:(cy-.2.) ~w ~h:4.0 ~r:2.0); 641 | 642 | (* Knob Shadow *) 643 | I.paint 644 | (Paint.radial_gradient ~cx:(x+.floor(pos*.w)) ~cy:(cy+.1.0) ~inr:(kr-.3.0) ~outr:(kr+.3.0) 645 | ~inner:(gray ~a:0.25 0.0) ~outer:(gray ~a:0.0 0.0)) 646 | (I.fill_path @@ fun t -> 647 | P.rect t ~x:(x+.floor(pos*.w)-.kr-.5.0) ~y:(cy-.kr-.5.0) 648 | ~w:(kr*.2.0+.5.0+.5.0) ~h:(kr*.2.0+.5.0+.5.0+.3.0); 649 | P.circle t ~cx:(x+.floor(pos*.w)) ~cy ~r:kr; 650 | P.set_winding t `HOLE); 651 | 652 | (* Knob *) 653 | let shape = I.fill_path @@ fun t -> 654 | P.circle t ~cx:(x+.floor(pos*.w)) ~cy ~r:(kr-.1.0) 655 | in 656 | I.seq [ 657 | I.paint (Paint.color (Color.v (40.0/.255.0) (43.0/.255.0) (48.0/.255.0) 1.0)) shape; 658 | I.paint (Paint.linear_gradient ~sx:x ~sy:(cy-.kr) ~ex:x ~ey:(cy+.kr) 659 | ~inner:(gray ~a:0.0625 1.0) ~outer:(gray ~a:0.0625 0.0)) 660 | shape; 661 | I.paint 662 | (Paint.color (gray ~a:0.375 0.0)) 663 | (I.stroke_path Outline.default @@ fun t -> 664 | P.circle t ~cx:(x+.floor(pos*.w)) ~cy ~r:(kr-.0.5)) 665 | ] 666 | ] 667 | 668 | let image_size image = Texture.width image, Texture.height image 669 | let image_texture image = image 670 | 671 | let load_demo_data t = 672 | Array.init 12 (fun i -> 673 | let name = Printf.sprintf "images/image%d.jpg" (i+1) in 674 | match Texture.load_image t ~alpha:false ~name name with 675 | | Result.Ok image -> image 676 | | Result.Error (`Msg msg) -> 677 | Printf.eprintf "error loading %s: %s\n%!" name msg; 678 | exit 1 679 | ) 680 | 681 | let draw_thumbnails ~x ~y ~w ~h images t = 682 | let cornerRadius = 3.0 and thumb = 60.0 and arry = 30.5 in 683 | let stackh = float (Array.length images / 2) *. (thumb +. 10.0) +. 10.0 in 684 | let u = (1.0 +. cos (t*.0.5)) *. 0.5 in 685 | let u2 = (1.0 -. cos (t*.0.2)) *. 0.5 in 686 | 687 | I.seq [ 688 | (* Drop shadow *) 689 | I.paint 690 | (Paint.box_gradient ~x ~y:(y+.4.0) ~w ~h ~r:(cornerRadius*.2.0) ~f:20.0 691 | ~inner:(gray ~a:0.5 0.0) ~outer:(gray ~a:0.0 0.0)) 692 | (I.fill_path @@ fun t -> 693 | P.rect t ~x:(x-.10.0) ~y:(y-.10.0) ~w:(w+.20.0) ~h:(h+.30.0); 694 | P.round_rect t ~x ~y ~w ~h ~r:cornerRadius; 695 | P.set_winding t `HOLE); 696 | 697 | (* Window *) 698 | I.paint 699 | (Paint.color (gray (200.0/.255.0))) 700 | (I.fill_path @@ fun t -> 701 | P.round_rect t ~x ~y ~w ~h ~r:cornerRadius; 702 | P.move_to t ~x:(x -. 10.0) ~y:(y +. arry); 703 | P.line_to t ~x:(x +. 1.0) ~y:(y +. arry -. 11.0); 704 | P.line_to t ~x:(x +. 1.0) ~y:(y +. arry +. 11.0)); 705 | 706 | begin 707 | let xf' = Transform.translation ~x:0.0 ~y:(-. (stackh -. h) *. u) in 708 | let dv = 1.0 /. float (Array.length images - 1) in 709 | let acc = ref I.empty in 710 | Array.iteri (fun i image -> 711 | let tx = x +. 10.0 +. float (i mod 2) *. (thumb +. 10.0) in 712 | let ty = y +. 10.0 +. float (i / 2) *. (thumb +. 10.0) in 713 | 714 | let imgw, imgh = image_size image in 715 | let imgw, imgh = float imgw, float imgh in 716 | let iw, ih, ix, iy = 717 | if imgw < imgh then 718 | let iw = thumb in 719 | let ih = iw *. imgh /. imgw in 720 | (iw, ih, 0.0, -.(ih -. thumb) *. 0.5) 721 | else 722 | let ih = thumb in 723 | let iw = ih *. imgw /. imgh in 724 | (iw, ih, -.(iw -. thumb) *. 0.5, 0.0) 725 | in 726 | let v = float i *. dv in 727 | let a = max 0.0 (min 1.0 ((u2 -. v) /. dv)) in 728 | 729 | if a < 1.0 then 730 | acc := I.stack !acc 731 | (draw_spinner (tx +. thumb /. 2.0) (ty +. thumb /. 2.0) (thumb*.0.25) t); 732 | acc := I.seq [ 733 | !acc; 734 | I.paint 735 | (Paint.image_pattern 736 | (Gg.P2.v (tx+.ix) (ty+.iy)) (Gg.Size2.v iw ih) 737 | ~angle:0.0 ~alpha:a (image_texture image)) 738 | (I.fill_path @@ fun t -> 739 | P.round_rect t ~x:tx ~y:ty ~w:thumb ~h:thumb ~r:5.0); 740 | I.paint 741 | (Paint.box_gradient ~x:(tx-.1.0) ~y:ty ~w:(thumb+.2.0) ~h:(thumb+.2.0) ~r:5.0 ~f:3.0 742 | ~inner:(gray ~a:0.5 0.0) ~outer:(gray ~a:0.0 0.0)) 743 | (I.fill_path @@ fun t -> 744 | P.rect t ~x:(tx-.5.0) ~y:(ty-.5.0) ~w:(thumb+.10.0) ~h:(thumb+.10.0); 745 | P.round_rect t ~x:tx ~y:ty ~w:thumb ~h:thumb ~r:6.0; 746 | P.set_winding t `HOLE); 747 | I.paint 748 | (Paint.color (gray ~a:0.75 1.0)) 749 | (I.stroke_path Outline.{default with stroke_width = 1.0} @@ fun t -> 750 | P.round_rect t ~x:(tx+.0.5) ~y:(ty+.0.5) ~w:(thumb-.1.0) ~h:(thumb-.1.0) ~r:(4.0-.0.5)) 751 | ] 752 | ) images; 753 | I.scissor (b2 x y w h) (I.transform xf' !acc) 754 | end; 755 | 756 | (* Hide fades *) 757 | I.paint 758 | (Paint.linear_gradient ~sx:x ~sy:y ~ex:x ~ey:(y+.6.0) 759 | ~inner:(gray ~a:1.0 0.8) ~outer:(gray ~a:0.0 0.8)) 760 | (I.fill_path @@ fun t -> 761 | P.rect t ~x:(x+.4.0) ~y ~w:(w-.8.0) ~h:6.0); 762 | I.paint 763 | (Paint.linear_gradient ~sx:x ~sy:(y+.h) ~ex:x ~ey:(y+.h-.6.0) 764 | ~inner:(gray ~a:1.0 0.8) ~outer:(gray ~a:0.0 0.8)) 765 | (I.fill_path @@ fun t -> 766 | P.rect t ~x:(x+.4.0) ~y:(y+.h-.6.0) ~w:(w-.8.0) ~h:6.0); 767 | 768 | (* Scroll bar *) 769 | I.paint 770 | (Paint.box_gradient ~x:(x+.w-.12.0+.1.0) ~y:(y+.4.0+.1.0) ~w:8.0 ~h:(h-.8.0) 771 | ~r:3.0 ~f:4.0 ~inner:(gray ~a:0.125 0.0) ~outer:(gray ~a:0.375 0.0)) 772 | (I.fill_path @@ fun t -> 773 | P.round_rect t ~x:(x+.w-.12.0) ~y:(y+.4.0) ~w:8.0 ~h:(h-.8.0) ~r:3.0); 774 | 775 | let scrollh = (h/.stackh) *. (h-.8.0) in 776 | I.paint 777 | (Paint.box_gradient ~x:(x+.w-.12.-.1.) ~y:(y+.4.+.(h-.8.-.scrollh)*.u-.1.) 778 | ~w:8. ~h:scrollh ~r:3. ~f:4. 779 | ~inner:(gray ~a:0.9 1.0) ~outer:(gray ~a:0.5 1.0)) 780 | (I.fill_path @@ fun t -> 781 | P.round_rect t ~x:(x+.w-.12.+.1.) ~y:(y+.4.+.1. +. (h-.8.-.scrollh)*.u) 782 | ~w:(8.-.2.) ~h:(scrollh-.2.) ~r:2.) 783 | ] 784 | 785 | let draw_demo mx my w h t images = ( 786 | let node = ref I.empty in 787 | let push n = node := I.stack !node n in 788 | push @@ draw_eyes (w -. 250.0) 50.0 150.0 100.0 mx my t; 789 | push @@ draw_graph 0.0 (h /. 2.0) w (h /. 2.0) t; 790 | push @@ draw_colorwheel (w -. 300.0) (h -. 300.0) 250.0 250.0 t; 791 | push @@ draw_lines 120.0 (h -. 50.0) 600.0 50.0 t; 792 | push @@ draw_widths 10.0 50.0 30.0; 793 | push @@ draw_caps 10.0 300.0 30.0; 794 | push @@ draw_scissor 50.0 (h-.80.0) t; 795 | 796 | (* Widgets *) 797 | push @@ draw_window "Widgets `n Stuff" 50.0 50.0 300.0 400.0; 798 | let x = 60.0 and y = 95.0 in 799 | push @@ draw_searchbox "Search" x y 280.0 25.0; 800 | let y = y +. 40.0 in 801 | push @@ draw_dropdown "Effects" x y 280.0 28.0; 802 | let popy = y +. 14.0 in 803 | let y = y +. 45.0 in 804 | 805 | (* Form *) 806 | push @@ draw_label "Login" ~x ~y ~w:280.0 ~h:20.0; 807 | let y = y +. 25.0 in 808 | push @@ draw_editbox "Email" ~x ~y ~w:280.0 ~h:28.0; 809 | let y = y +. 35.0 in 810 | push @@ draw_editbox "Password" ~x ~y ~w:280.0 ~h:28.0; 811 | let y = y +. 38.0 in 812 | push @@ draw_checkbox "Remember me" ~x ~y ~w:140.0 ~h:28.0; 813 | push @@ draw_button (*ICON_LOGIN*)0xE740 "Sign in" ~x:(x+.138.0) ~y ~w:140.0 ~h:28.0 814 | ~color:(Color.v 0.0 0.375 0.5 1.0); 815 | let y = y +. 45.0 in 816 | 817 | (* Slider *) 818 | push @@ draw_label "Diameter" ~x ~y ~w:280.0 ~h:20.0; 819 | let y = y +. 25.0 in 820 | push @@ draw_editboxnum "123.00" "px" ~x:(x+.180.0) ~y ~w:100.0 ~h:28.0; 821 | push @@ draw_slider 0.4 ~x ~y ~w:170.0 ~h:28.0; 822 | let y = y +. 55.0 in 823 | 824 | push @@ draw_button (*ICON_TRASH*)0xE729 "Delete" ~x ~y ~w:160.0 ~h:28.0 ~color:(Color.v 0.5 0.0625 0.03125 1.0); 825 | push @@ draw_button 0 "Cancel" ~x:(x+.170.0) ~y ~w:110.0 ~h:28.0 ~color:(gray ~a:0.0 0.0); 826 | 827 | push @@ draw_thumbnails ~x:365.0 ~y:(popy-.30.0) ~w:160.0 ~h:300.0 images t; 828 | !node 829 | ) 830 | 831 | let w = 1000 832 | let h = 600 833 | let f = (try float_of_string Sys.argv.(1) with _ -> 1.0) 834 | let fw = int_of_float (f *. float w) 835 | let fh = int_of_float (f *. float h) 836 | 837 | let counter = Performance_counter.make () 838 | 839 | let dump_perf = 840 | let t0 = ref 0 in 841 | fun t -> 842 | let t = int_of_float t in 843 | if t <> !t0 then ( 844 | t0 := t; 845 | prerr_endline (Performance_counter.report counter); 846 | Performance_counter.reset counter 847 | ) 848 | 849 | let render context sw sh t images = 850 | let lw = float w in 851 | let lh = float h in 852 | let width = lw *. f *. sw in 853 | let height = lh *. f *. sh in 854 | let _, (x, y) = Sdl.get_mouse_state () in 855 | let x = float x /. f and y = float y /. f in 856 | let demo = draw_demo x y lw lh t images in 857 | Renderer.render context ~width ~height ~performance_counter:counter 858 | (I.seq [ 859 | (*I.transform (Transform.scale (sw *. f /. 2.0) (sh *. f)) demo; 860 | I.transform (Transform.scale (sw *. f /. 1.8) (sh *. f)) demo; 861 | I.transform (Transform.scale (sw *. f /. 1.6) (sh *. f)) demo; 862 | I.transform (Transform.scale (sw *. f /. 1.4) (sh *. f)) demo; 863 | I.transform (Transform.scale (sw *. f /. 1.2) (sh *. f)) demo;*) 864 | I.transform (Transform.scale ~sx:(sw *. f) ~sy:(sh *. f)) demo; 865 | ]); 866 | dump_perf t 867 | 868 | open Tgles2 869 | 870 | let main () = 871 | Printexc.record_backtrace true; 872 | match Sdl.init Sdl.Init.video with 873 | | Error (`Msg e) -> Sdl.log "Init error: %s" e; exit 1 874 | | Ok () -> 875 | ignore (Sdl.gl_set_attribute Sdl.Gl.depth_size 24 : _ result); 876 | ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 8 : _ result); 877 | match 878 | Sdl.create_window ~w:fw ~h:fh "SDL OpenGL" 879 | Sdl.Window.(opengl + allow_highdpi) 880 | with 881 | | Error (`Msg e) -> Sdl.log "Create window error: %s" e; exit 1 882 | | Ok w -> 883 | (*Sdl.gl_set_attribute Sdl.Gl.context_profile_mask Sdl.Gl.context_profile_core; 884 | Sdl.gl_set_attribute Sdl.Gl.context_major_version 2; 885 | Sdl.gl_set_attribute Sdl.Gl.context_minor_version 1;*) 886 | ignore (Sdl.gl_set_swap_interval (-1)); 887 | let ow, oh = Sdl.gl_get_drawable_size w in 888 | Sdl.log "window size: %d,%d\topengl drawable size: %d,%d" fw fh ow oh; 889 | let sw = float ow /. float fw and sh = float oh /. float fh in 890 | ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); 891 | match Sdl.gl_create_context w with 892 | | Error (`Msg e) -> Sdl.log "Create context error: %s" e; exit 1 893 | | Ok ctx -> 894 | let context = Renderer.create ~antialias:true () in 895 | let images = load_demo_data context in 896 | let quit = ref false in 897 | let event = Sdl.Event.create () in 898 | while not !quit do 899 | while Sdl.poll_event (Some event) do 900 | match Sdl.Event.enum (Sdl.Event.get event Sdl.Event.typ) with 901 | | `Quit -> quit := true 902 | | _ -> () 903 | done; 904 | Gl.viewport 0 0 ow oh; 905 | Gl.clear_color 0.3 0.3 0.32 1.0; 906 | Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); 907 | Gl.enable Gl.blend; 908 | Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha; 909 | Gl.enable Gl.cull_face_enum; 910 | Gl.disable Gl.depth_test; 911 | render context sw sh (Int32.to_float (Sdl.get_ticks ()) /. 1000.0) images; 912 | Sdl.gl_swap_window w; 913 | done; 914 | Sdl.gl_delete_context ctx; 915 | Sdl.destroy_window w; 916 | Sdl.quit (); 917 | exit 0 918 | 919 | let () = main () 920 | -------------------------------------------------------------------------------- /example/images/image1.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image1.jpg -------------------------------------------------------------------------------- /example/images/image10.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image10.jpg -------------------------------------------------------------------------------- /example/images/image11.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image11.jpg -------------------------------------------------------------------------------- /example/images/image12.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image12.jpg -------------------------------------------------------------------------------- /example/images/image2.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image2.jpg -------------------------------------------------------------------------------- /example/images/image3.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image3.jpg -------------------------------------------------------------------------------- /example/images/image4.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image4.jpg -------------------------------------------------------------------------------- /example/images/image5.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image5.jpg -------------------------------------------------------------------------------- /example/images/image6.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image6.jpg -------------------------------------------------------------------------------- /example/images/image7.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image7.jpg -------------------------------------------------------------------------------- /example/images/image8.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image8.jpg -------------------------------------------------------------------------------- /example/images/image9.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/example/images/image9.jpg -------------------------------------------------------------------------------- /example/minimal.ml: -------------------------------------------------------------------------------- 1 | open Tsdl 2 | 3 | open Wall 4 | 5 | let load_font name = 6 | let ic = open_in_bin name in 7 | let dim = in_channel_length ic in 8 | let fd = Unix.descr_of_in_channel ic in 9 | let buffer = 10 | Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [|dim|] 11 | |> Bigarray.array1_of_genarray 12 | in 13 | let offset = List.hd (Stb_truetype.enum buffer) in 14 | match Stb_truetype.init buffer offset with 15 | | None -> assert false 16 | | Some font -> font 17 | 18 | let font_sans = lazy (load_font "Roboto-Regular.ttf") 19 | 20 | let normalize (dx, dy) = 21 | let d = sqrt (dx *. dx +. dy *. dy) in 22 | if d > 1.0 then 23 | (dx /. d, dy /. d) 24 | else 25 | (dx, dy) 26 | 27 | let w = 1000 28 | let h = 600 29 | let f = try float_of_string Sys.argv.(1) with _ -> 1.0 30 | let fw = int_of_float (f *. float w) 31 | let fh = int_of_float (f *. float h) 32 | 33 | let b2 x y w h = Gg.Box2.v (Gg.P2.v x y) (Gg.Size2.v w h) 34 | 35 | let draw_arrow ~x ~y ~size color = 36 | Image.paint (Paint.color color) 37 | (Image.fill_path @@ fun t -> 38 | Path.move_to t x y; 39 | Path.line_to t (x-.size) (y+.size); 40 | Path.line_to t (x-.size) (y-.size); 41 | Path.close t; 42 | ) 43 | 44 | let draw_arrow' ~x ~y ~size color = 45 | Image.paint (Paint.color color) 46 | (Image.fill_path @@ fun t -> 47 | Path.move_to t x y; 48 | Path.line_to t (x-.size) (y-.size); 49 | Path.line_to t (x-.size/.2.0) y; 50 | Path.line_to t (x-.size) (y+.size); 51 | Path.close t; 52 | ) 53 | 54 | let text_arrow ?(size=16.0) ~x ~y () = 55 | Image.alpha 0.5 (draw_arrow ~x ~y ~size Color.blue) 56 | 57 | let text_arrow' ?(size=16.0) ~x ~y () = 58 | Image.alpha 0.5 (draw_arrow' ~x ~y ~size Color.blue) 59 | 60 | let render context sw sh t = 61 | let lw = float w in 62 | let lh = float h in 63 | let pw = lw *. f *. sw in 64 | let ph = lh *. f *. sh in 65 | Renderer.render context ~width:pw ~height:ph 66 | (Image.paint Paint.black @@ 67 | Image.seq [ 68 | (*text_arrow ~x:400.0 ~y:300.0 ~size:200.0 ();*) 69 | text_arrow' ~x:300.0 ~y:300.0 ~size:200.0 (); 70 | (*Image.transform (Transform.translate 10.0 10.0 (Transform.scale 5.0 5.0)) ( 71 | Image.seq [ 72 | (*text_arrow ~x:50.0 ~y:50.0 (); 73 | text_arrow' ~x:50.0 ~y:60.0 ();*) 74 | Image.stroke_path (Outline.make ~join:`MITER ~cap:`BUTT (*~cap:`ROUND*) ~width:(15.0) ()) @@ fun p -> 75 | Path.move_to p 300.0 (18.0 +. 100.0 *. sin t); 76 | Path.line_to p 0.0 0.0; 77 | Path.line_to p 300.0 0.0; 78 | Path.line_to p 300.0 (18.0 +. 100.0 *. sin t); 79 | Path.close p; 80 | ] 81 | )*) 82 | ]) 83 | 84 | open Tgles2 85 | 86 | let main () = 87 | Printexc.record_backtrace true; 88 | match Sdl.init Sdl.Init.video with 89 | | Error (`Msg e) -> Sdl.log "Init error: %s" e; exit 1 90 | | Ok () -> 91 | match 92 | Sdl.create_window ~w:fw ~h:fh "SDL OpenGL" 93 | Sdl.Window.(opengl + allow_highdpi) 94 | with 95 | | Error (`Msg e) -> Sdl.log "Create window error: %s" e; exit 1 96 | | Ok w -> 97 | (*Sdl.gl_set_attribute Sdl.Gl.context_profile_mask Sdl.Gl.context_profile_core;*) 98 | (*Sdl.gl_set_attribute Sdl.Gl.context_major_version 2;*) 99 | (*Sdl.gl_set_attribute Sdl.Gl.context_minor_version 1;*) 100 | ignore (Sdl.gl_set_swap_interval (-1)); 101 | let ow, oh = Sdl.gl_get_drawable_size w in 102 | Sdl.log "window size: %d,%d\topengl drawable size: %d,%d" fw fh ow oh; 103 | let sw = float ow /. float fw and sh = float oh /. float fh in 104 | (* GL3 initialization: *) 105 | ignore (Sdl.gl_set_attribute Sdl.Gl.context_profile_mask Sdl.Gl.context_profile_core); 106 | ignore (Sdl.gl_set_attribute Sdl.Gl.context_major_version 3); 107 | ignore (Sdl.gl_set_attribute Sdl.Gl.context_minor_version 2); 108 | ignore (Sdl.gl_set_attribute Sdl.Gl.depth_size 24); 109 | ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 8); 110 | match Sdl.gl_create_context w with 111 | | Error (`Msg e) -> Sdl.log "Create context error: %s" e; exit 1 112 | | Ok ctx -> 113 | let context = Renderer.create ~antialias:true ~stencil_strokes:true () in 114 | let quit = ref false in 115 | let event = Sdl.Event.create () in 116 | Gl.viewport 0 0 fw fh; 117 | Gl.clear_color 0.0 0.0 0.0 1.0; 118 | Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); 119 | Gl.enable Gl.blend; 120 | Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha; 121 | Gl.enable Gl.cull_face_enum; 122 | Gl.disable Gl.depth_test; 123 | Renderer.render context ~width:sw ~height:sh 124 | (Image.stroke_path Outline.default (fun ctx -> Path.rect ctx 0. 0. 50. 50.)); 125 | Sdl.gl_swap_window w; 126 | while not !quit do 127 | while Sdl.poll_event (Some event) do 128 | match Sdl.Event.enum (Sdl.Event.get event Sdl.Event.typ) with 129 | | `Quit -> quit := true 130 | | _ -> () 131 | done; 132 | Gl.viewport 0 0 fw fh; 133 | Gl.clear_color 1.0 1.0 1.0 1.0; 134 | Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); 135 | Gl.enable Gl.blend; 136 | Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha; 137 | Gl.enable Gl.cull_face_enum; 138 | Gl.disable Gl.depth_test; 139 | render context sw sh (Int32.to_float (Sdl.get_ticks ()) /. 1000.0); 140 | Sdl.gl_swap_window w; 141 | done; 142 | Sdl.gl_delete_context ctx; 143 | Sdl.destroy_window w; 144 | Sdl.quit (); 145 | exit 0 146 | 147 | let () = main () 148 | -------------------------------------------------------------------------------- /lib/config/discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let () = 4 | C.main ~name:"wall" (fun c -> 5 | let default : C.Pkg_config.package_conf = 6 | { libs = ["-lSDL2"] 7 | ; cflags = [] 8 | } 9 | in 10 | let conf = 11 | match C.Pkg_config.get c with 12 | | None -> default 13 | | Some pc -> 14 | match (C.Pkg_config.query pc ~package:"sdl2") with 15 | | None -> default 16 | | Some deps -> deps 17 | in 18 | let is_macos = match C.ocaml_config_var c "system" with 19 | | Some "macosx" -> true 20 | | _ -> false 21 | in 22 | let libs = conf.libs in 23 | let libs = if is_macos then "-framework" :: "OpenGL" :: libs else libs in 24 | C.Flags.write_sexp "c_flags.sexp" conf.cflags; 25 | C.Flags.write_sexp "c_library_flags.sexp" libs) 26 | -------------------------------------------------------------------------------- /lib/config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (libraries dune-configurator)) 4 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name wall) 3 | (flags -w -40 -w +26) 4 | (public_name wall) 5 | (wrapped false) 6 | (foreign_stubs 7 | (language c) 8 | (names wall__backend_stubs) 9 | (flags -g -O2 (:include c_flags.sexp))) 10 | (c_library_flags (:include c_library_flags.sexp)) 11 | (libraries gg result stb_image stb_truetype grenier.binpacking)) 12 | 13 | (rule 14 | (targets c_flags.sexp c_library_flags.sexp) 15 | (action (run ./config/discover.exe))) 16 | -------------------------------------------------------------------------------- /lib/wall.mli: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2015 Frédéric Bour 3 | 4 | This software is provided 'as-is', without any express or implied 5 | warranty. In no event will the authors be held liable for any damages 6 | arising from the use of this software. 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 1. The origin of this software must not be misrepresented; you must not 11 | claim that you wrote the original software. If you use this software 12 | in a product, an acknowledgment in the product documentation would be 13 | appreciated but is not required. 14 | 2. Altered source versions must be plainly marked as such, and must not be 15 | misrepresented as being the original software. 16 | 3. This notice may not be removed or altered from any source distribution. 17 | *) 18 | 19 | open Gg 20 | open Wall_types 21 | 22 | (**/**) 23 | 24 | (** @canonical Wall.Renderer.t *) 25 | type renderer 26 | 27 | (**/**) 28 | 29 | (** Definition of colors, taken from Gg *) 30 | module Color : sig 31 | include module type of struct include Color end 32 | 33 | (* Beware: 34 | Lots of operators (e.g. [gray]) take SRGB values, not linear RGB. 35 | *) 36 | 37 | val hsl : h:float -> s:float -> l:float -> t 38 | val hsla : h:float -> s:float -> l:float -> a:float -> t 39 | 40 | (* Linear interpolation between to (linear) RGBA values. *) 41 | val lerp_rgba : float -> t -> t -> t 42 | end 43 | 44 | (** Definition of affine transformation matrices. *) 45 | module Transform : sig 46 | 47 | type t = transform = { 48 | x00 : float; 49 | x01 : float; 50 | x10 : float; 51 | x11 : float; 52 | x20 : float; 53 | x21 : float; 54 | } 55 | 56 | val identity : t 57 | val average_scale : t -> float 58 | val scale_x : t -> float 59 | val scale_y : t -> float 60 | 61 | val translation : x:float -> y:float -> t 62 | val rotation : a:float -> t 63 | val scale : sx:float -> sy:float -> t 64 | val skew : sx:float -> sy:float -> t 65 | 66 | val compose : t -> t -> t 67 | val inverse : t -> t 68 | val translate : x:float -> y:float -> t -> t 69 | val rotate : float -> t -> t 70 | val rescale : sx:float -> sy:float -> t -> t 71 | 72 | (** [px t x y] is the x coordinate of the point (x,y) after applying the 73 | affine transformation [t]. *) 74 | val px : t -> float -> float -> float 75 | 76 | (** [py t x y] is the y coordinate of the point (x,y) after applying the 77 | affine transformation [t]. *) 78 | val py : t -> float -> float -> float 79 | 80 | (** [linear_px t x y] is the x coordinate of the point (x,y) after applying 81 | the linear transformation described by [t]. Translation is ignored! *) 82 | val linear_px : t -> float -> float -> float 83 | 84 | (** [linear_py t x y] is the y coordinate of the point (x,y) after applying 85 | the linear transformation described by [t]. Translation is ignored! *) 86 | val linear_py : t -> float -> float -> float 87 | 88 | (** [point t p] is the point [p] after transformation by [t] *) 89 | val point : t -> p2 -> p2 90 | end 91 | 92 | 93 | (** {1 Wall drawing model} 94 | 95 | Drawing in wall is achieved by intersecting a simple, infinite image with a 96 | shape. 97 | 98 | This image is described by a ['a Paint.t] value and is simple by nature: 99 | - a single color, 100 | - a few different kinds of gradients, 101 | - some user-defined pattern or textures, as determined by ['a]. 102 | 103 | The ['a] depends on the renderer and in practice it will be a 104 | [Wall_texture.t], an abstraction over OpenGL texture. 105 | 106 | The shapes are made from a [Path.t] that is filled or stroked. 107 | The path is list of points that are connected by straight or curved (bezier) 108 | lines. 109 | When filled, the path is interpreted as the contour of a surface and the 110 | resulting image is this surface. 111 | When stroked, the path is interpreted as one or more lines: an [Outline.t] 112 | that describe the style of line rendering (thickness, square or round ends, 113 | etc) is used transform the abstract lines into a surface. 114 | *) 115 | 116 | module Paint : sig 117 | type 'texture t = 'texture paint = { 118 | xform : Transform.t; 119 | extent : size2; 120 | radius : float; 121 | feather : float; 122 | inner : color; 123 | outer : color; 124 | texture : 'texture option; 125 | } 126 | val linear_gradient : 127 | sx:float -> sy:float -> 128 | ex:float -> ey:float -> 129 | inner:color -> outer:color -> _ t 130 | val radial_gradient : 131 | cx:float -> cy:float -> 132 | inr:float -> outr:float -> 133 | inner:color -> outer:color -> _ t 134 | val box_gradient : 135 | x:float -> y:float -> 136 | w:float -> h:float -> 137 | r:float -> f:float -> 138 | inner:color -> outer:color -> _ t 139 | val image_pattern : 140 | p2 -> size2 -> angle:float -> alpha:float -> 141 | 'image -> 'image t 142 | 143 | val color : color -> _ t 144 | val rgba : float -> float -> float -> float -> _ t 145 | val rgbai : int -> int -> int -> int -> _ t 146 | 147 | val white : _ t 148 | val black : _ t 149 | 150 | val transform : 'a t -> Transform.t -> 'a t 151 | end 152 | 153 | module Outline : sig 154 | type line_cap = [ `BUTT | `ROUND | `SQUARE ] 155 | type line_join = [ `BEVEL | `MITER | `ROUND ] 156 | 157 | type t = outline = { 158 | stroke_width : float; 159 | miter_limit : float; 160 | line_join : line_join; 161 | line_cap : line_cap; 162 | } 163 | 164 | val default : t 165 | 166 | val make : ?miter_limit:float -> ?join:line_join -> ?cap:line_cap -> ?width:float -> unit -> t 167 | end 168 | 169 | module Path : sig 170 | type ctx 171 | 172 | val level_of_detail : ctx -> float 173 | 174 | val set_winding : ctx -> [< `HOLE | `SOLID | `CW | `CCW ] -> unit 175 | 176 | val move_to : ctx -> x:float -> y:float -> unit 177 | 178 | val line_to : ctx -> x:float -> y:float -> unit 179 | 180 | val bezier_to : ctx -> c1x:float -> c1y:float -> 181 | c2x:float -> c2y:float -> 182 | x:float -> y:float -> unit 183 | 184 | val quad_to : ctx -> cx:float -> cy:float -> 185 | x:float -> y:float -> unit 186 | 187 | val rect : ctx -> x:float -> y:float -> 188 | w:float -> h:float -> unit 189 | 190 | val round_rect : ctx -> 191 | x:float -> y:float -> w:float -> h:float -> r:float -> unit 192 | 193 | val round_rect' : ctx -> 194 | x:float -> y:float -> w:float -> h:float -> 195 | rtl:float -> rtr:float -> rbl:float -> rbr:float -> unit 196 | 197 | val circle : ctx -> cx:float -> cy:float -> r:float -> unit 198 | 199 | val ellipse : ctx -> cx:float -> cy:float -> 200 | rx:float -> ry:float -> unit 201 | 202 | val arc : ctx -> cx:float -> cy:float -> r:float -> 203 | a0:float -> a1:float -> [< `CW | `CCW ] -> unit 204 | 205 | val arc_to : ctx -> x1:float -> y1:float -> 206 | x2:float -> y2:float -> r:float -> unit 207 | 208 | val close : ctx -> unit 209 | 210 | type t 211 | val make : (ctx -> unit) -> t 212 | end 213 | 214 | module Texture : sig 215 | type t 216 | val release : t -> unit 217 | 218 | val flip_image : 'a Stb_image.t -> unit 219 | val from_image : renderer -> name:string -> 'a Stb_image.t -> t 220 | val load_image : 221 | renderer -> 222 | ?float:bool -> ?alpha:bool -> ?flip:bool -> ?name:string -> string -> 223 | (t, [`Msg of string]) Result.result 224 | 225 | val channels : t -> int 226 | val width : t -> int 227 | val height : t -> int 228 | 229 | val update : t -> 'a Stb_image.t -> unit 230 | end 231 | 232 | module Typesetter : sig 233 | type quadbuf = { 234 | mutable x0: float; 235 | mutable y0: float; 236 | mutable x1: float; 237 | mutable y1: float; 238 | mutable u0: float; 239 | mutable v0: float; 240 | mutable u1: float; 241 | mutable v1: float; 242 | } 243 | 244 | type 'input t = { 245 | allocate : renderer -> sx:float -> sy:float -> 'input -> (unit -> unit) option; 246 | render : renderer -> Transform.t -> 'input -> quadbuf -> push:(unit -> unit) -> Texture.t; 247 | } 248 | 249 | val make 250 | : allocate:(renderer -> sx:float -> sy:float -> 'input -> (unit -> unit) option) 251 | -> render:(renderer -> Transform.t -> 'input -> quadbuf -> push:(unit -> unit) -> Texture.t) 252 | -> 'input t 253 | end 254 | 255 | module Image : sig 256 | type t 257 | 258 | (** {1 Primitive images} *) 259 | 260 | val empty : t 261 | val stroke : Outline.t -> Path.t -> t 262 | val fill : Path.t -> t 263 | val typeset : 'input Typesetter.t -> 'input -> t 264 | 265 | (** {1 Composite images} *) 266 | 267 | val paint : Texture.t Paint.t -> t -> t 268 | val transform : Transform.t -> t -> t 269 | val scissor : ?transform:Transform.t -> Gg.box2 -> t -> t 270 | val reset_scissor : t -> t 271 | val intersect_scissor : ?transform:Transform.t -> Gg.box2 -> t -> t 272 | val alpha : float -> t -> t 273 | val stack : t -> t -> t 274 | val seq : t list -> t 275 | 276 | (** {1 Convenience functions} *) 277 | 278 | val stroke_path : Outline.t -> (Path.ctx -> unit) -> t 279 | val fill_path : (Path.ctx -> unit) -> t 280 | end 281 | 282 | module Performance_counter : sig 283 | type t 284 | 285 | val make : unit -> t 286 | 287 | (** Microseconds spent rendering *) 288 | val time_spent : t -> int 289 | 290 | (** Memory words allocated *) 291 | val mem_spent : t -> int 292 | 293 | val reset : t -> unit 294 | 295 | val report : t -> string 296 | end 297 | 298 | module Renderer : sig 299 | (** A renderer allocates the OpenGL resources that are necessary to 300 | render contents. *) 301 | 302 | type t = renderer 303 | 304 | (** [create ~antialias] creates a new drawing context. 305 | [antialias] determines whether antialiasing is on or off, though it is 306 | strongly recommended to turn it on. *) 307 | val create : ?antialias:bool -> ?stencil_strokes:bool -> unit -> t 308 | 309 | (** Calling [delete t] releases all the resources associated to the drawing 310 | context [t]. It is incorrect to use this context after the call. 311 | 312 | A context can retain a lot of memory, so it is good practice to release 313 | it if you are no longer going to use it. *) 314 | val delete : t -> unit 315 | 316 | val render : t -> ?performance_counter:Performance_counter.t 317 | -> width:float -> height:float -> Image.t -> unit 318 | end 319 | 320 | type color = Color.t 321 | type transform = Transform.t 322 | type outline = Outline.t 323 | type path = Path.t 324 | type texture = Texture.t 325 | type image = Image.t 326 | type 'texture paint = 'texture Paint.t 327 | type 'input typesetter = 'input Typesetter.t 328 | 329 | val pi : float 330 | -------------------------------------------------------------------------------- /lib/wall__backend.ml: -------------------------------------------------------------------------------- 1 | open Wall_types 2 | open Gg 3 | open Bigarray 4 | 5 | type state 6 | 7 | external wall_gl_create 8 | : antialias:bool -> state 9 | = "wall_gl_create" 10 | 11 | external wall_gl_delete 12 | : state -> unit 13 | = "wall_gl_delete" 14 | 15 | external wall_gl_is_valid 16 | : state -> bool 17 | = "wall_gl_is_valid" [@@noalloc] 18 | 19 | external wall_gl_bind_xform 20 | : state -> Wall__geom.B.bigarray -> unit 21 | = "wall_gl_bind_xform" [@@noalloc] 22 | 23 | external wall_gl_bind_paint 24 | : state -> Wall__geom.B.bigarray -> unit 25 | = "wall_gl_bind_paint" [@@noalloc] 26 | 27 | external wall_gl_bind_texture 28 | : state -> int -> unit 29 | = "wall_gl_bind_texture" [@@noalloc] 30 | 31 | external wall_gl_draw_triangle_fan 32 | : state -> first:int -> count:int -> unit 33 | = "wall_gl_draw_triangle_fan" [@@noalloc] 34 | 35 | external wall_gl_draw_triangle_strip 36 | : state -> first:int -> count:int -> unit 37 | = "wall_gl_draw_triangle_strip" [@@noalloc] 38 | 39 | external wall_gl_draw_triangles 40 | : state -> first:int -> count:int -> unit 41 | = "wall_gl_draw_triangles" [@@noalloc] 42 | 43 | external wall_gl_fill_prepare_stencil 44 | : state -> unit 45 | = "wall_gl_fill_prepare_stencil" [@@noalloc] 46 | 47 | external wall_gl_fill_prepare_cover 48 | : state -> unit 49 | = "wall_gl_fill_prepare_cover" [@@noalloc] 50 | 51 | external wall_gl_prepare_aa 52 | : state -> unit 53 | = "wall_gl_prepare_aa" [@@noalloc] 54 | 55 | external wall_gl_fill_finish_and_cover 56 | : state -> first:int -> count:int -> unit 57 | = "wall_gl_fill_finish_and_cover" [@@noalloc] 58 | 59 | external wall_gl_stencil_stroke_prepare_stencil 60 | : state -> unit 61 | = "wall_gl_stencil_stroke_prepare_stencil" [@@noalloc] 62 | 63 | external wall_gl_stencil_stroke_prepare_clear 64 | : state -> unit 65 | = "wall_gl_stencil_stroke_prepare_clear" [@@noalloc] 66 | 67 | external wall_gl_stencil_stroke_finish 68 | : state -> unit 69 | = "wall_gl_stencil_stroke_finish" [@@noalloc] 70 | 71 | external wall_gl_set_reversed 72 | : state -> bool -> unit 73 | = "wall_gl_set_reversed" [@@noalloc] 74 | 75 | external wall_gl_frame_prepare 76 | : state -> width:float -> height:float -> Wall__geom.B.bigarray -> unit 77 | = "wall_gl_frame_prepare" 78 | 79 | external wall_gl_frame_finish 80 | : state -> unit 81 | = "wall_gl_frame_finish" 82 | 83 | external wall_gl_texture_create 84 | : state -> int 85 | = "wall_gl_texture_create" 86 | 87 | external wall_gl_texture_delete 88 | : state -> int -> unit 89 | = "wall_gl_texture_delete" 90 | 91 | external wall_gl_texture_upload 92 | : state -> int -> level:int -> is_float:bool -> 93 | width:int -> height:int -> channels:int -> 94 | ('a, 'b, c_layout) Array1.t -> offset:int -> stride:int -> unit 95 | = "wall_gl_texture_upload_bc" "wall_gl_texture_upload" 96 | 97 | external wall_gl_texture_update 98 | : state -> int -> level:int -> is_float:bool -> 99 | x:int -> y:int -> width:int -> height:int -> channels:int -> 100 | ('a, 'b, c_layout) Array1.t -> offset:int -> stride:int -> unit 101 | = "wall_gl_texture_update_bc" "wall_gl_texture_update" 102 | 103 | external wall_gl_texture_generate_mipmap 104 | : state -> int -> unit 105 | = "wall_gl_texture_generate_mipmap" 106 | 107 | let create = wall_gl_create 108 | 109 | let delete = wall_gl_delete 110 | 111 | let fringe = 1.0 112 | 113 | module Texture = struct 114 | type t = int 115 | 116 | type specification = { 117 | gl_tex : int; 118 | premultiplied : bool; 119 | channels : int; 120 | } 121 | 122 | let create = wall_gl_texture_create 123 | let delete = wall_gl_texture_delete 124 | 125 | let is_float (type a) (type b) (image : (a, b) Bigarray.kind Stb_image.t) = 126 | match Bigarray.Array1.kind image.Stb_image.data with 127 | | Bigarray.Int8_unsigned -> false 128 | | Bigarray.Float32 -> true 129 | | _ -> invalid_arg "wall: unsupported image format" 130 | 131 | let channels img = 132 | match Stb_image.channels img with 133 | | 1 | 3 | 4 as c -> c 134 | | c -> 135 | failwith ("wall: " ^ string_of_int c ^ " channels texture format not supported") 136 | 137 | let upload ?(level=0) st img t = 138 | wall_gl_texture_upload st t ~level ~is_float:(is_float img) 139 | ~width:(Stb_image.width img) ~height:(Stb_image.height img) 140 | ~channels:(channels img) 141 | (Stb_image.data img) 142 | ~offset:img.Stb_image.offset ~stride:img.Stb_image.stride 143 | 144 | let update ?(level=0) st ~x ~y img t = 145 | wall_gl_texture_update st t ~level ~is_float:(is_float img) 146 | ~x ~y ~width:(Stb_image.width img) ~height:(Stb_image.height img) 147 | ~channels:(channels img) 148 | (Stb_image.data img) 149 | ~offset:img.Stb_image.offset ~stride:img.Stb_image.stride 150 | 151 | let generate_mipmap = wall_gl_texture_generate_mipmap 152 | end 153 | 154 | module Shader = struct 155 | 156 | let xfbuf = 157 | Bigarray.Array1.create 158 | Bigarray.float32 Bigarray.c_layout 159 | 9 160 | 161 | let set_xform t xf = 162 | xfbuf.{00} <- xf.x00; 163 | xfbuf.{01} <- xf.x01; 164 | xfbuf.{02} <- 0.0; 165 | xfbuf.{03} <- xf.x10; 166 | xfbuf.{04} <- xf.x11; 167 | xfbuf.{05} <- 0.0; 168 | xfbuf.{06} <- xf.x20; 169 | xfbuf.{07} <- xf.x21; 170 | xfbuf.{08} <- 1.0; 171 | wall_gl_bind_xform t xfbuf 172 | 173 | let buf = 174 | Bigarray.Array1.create 175 | Bigarray.float32 Bigarray.c_layout 176 | 44 177 | 178 | let set_zero_m34 c = 179 | buf.{c + 00} <- 0.0; 180 | buf.{c + 01} <- 0.0; 181 | buf.{c + 02} <- 0.0; 182 | buf.{c + 03} <- 0.0; 183 | buf.{c + 04} <- 0.0; 184 | buf.{c + 05} <- 0.0; 185 | buf.{c + 06} <- 0.0; 186 | buf.{c + 07} <- 0.0; 187 | buf.{c + 08} <- 0.0; 188 | buf.{c + 09} <- 0.0; 189 | buf.{c + 10} <- 0.0; 190 | buf.{c + 11} <- 0.0 191 | 192 | let set_inv_xform c xf invdet = 193 | let x00 = xf.x11 *. invdet in 194 | let x10 = -. xf.x10 *. invdet in 195 | let x20 = (xf.x10 *. xf.x21 -. xf.x11 *. xf.x20) *. invdet in 196 | let x01 = -. xf.x01 *. invdet in 197 | let x11 = xf.x00 *. invdet in 198 | let x21 = (xf.x01 *. xf.x20 -. xf.x00 *. xf.x21) *. invdet in 199 | buf.{c + 00} <- x00; 200 | buf.{c + 01} <- x01; 201 | buf.{c + 02} <- 0.0; 202 | buf.{c + 03} <- 0.0; 203 | buf.{c + 04} <- x10; 204 | buf.{c + 05} <- x11; 205 | buf.{c + 06} <- 0.0; 206 | buf.{c + 07} <- 0.0; 207 | buf.{c + 08} <- x20; 208 | buf.{c + 09} <- x21; 209 | buf.{c + 10} <- 1.0; 210 | buf.{c + 11} <- 0.0 211 | 212 | let set_inv_xform c xf = 213 | let det = xf.x00 *. xf.x11 -. xf.x10 *. xf.x01 in 214 | if det > -1e-6 && det < 1e-6 then ( 215 | buf.{c + 00} <- 1.0; 216 | buf.{c + 01} <- 0.0; 217 | buf.{c + 02} <- 0.0; 218 | buf.{c + 03} <- 0.0; 219 | buf.{c + 04} <- 0.0; 220 | buf.{c + 05} <- 1.0; 221 | buf.{c + 06} <- 0.0; 222 | buf.{c + 07} <- 0.0; 223 | buf.{c + 08} <- 0.0; 224 | buf.{c + 09} <- 0.0; 225 | buf.{c + 10} <- 1.0; 226 | buf.{c + 11} <- 0.0 227 | ) else 228 | set_inv_xform c xf (1.0 /. det) 229 | 230 | let set_4 c f0 f1 f2 f3 = 231 | buf.{c + 0} <- f0; 232 | buf.{c + 1} <- f1; 233 | buf.{c + 2} <- f2; 234 | buf.{c + 3} <- f3 235 | 236 | let set_color c a col = 237 | let r = Color.r col in 238 | let g = Color.g col in 239 | let b = Color.b col in 240 | let a = Color.a col *. a in 241 | set_4 c (r*.a) (g*.a) (b*.a) a 242 | 243 | let paint_mat = 12 244 | let sciss_mat = 0 245 | let inner_color = 24 246 | let outer_color = 28 247 | let sciss_extent_scale = 32 248 | let paint_extent_radius_feather = 36 249 | let strokemult_strokethr_textype_type = 40 250 | 251 | type shader_type = [ 252 | | `FILLGRAD 253 | | `FILLIMG 254 | | `SIMPLE 255 | | `IMG 256 | ] 257 | 258 | let shader_type = function 259 | | `FILLGRAD -> 0. 260 | | `FILLIMG -> 1. 261 | | `SIMPLE -> 2. 262 | | `IMG -> 3. 263 | 264 | let clampf min x max : float = 265 | if x < min then x else if x > max then max else x 266 | 267 | let set_tool t ?typ prj paint frame width stroke_thr = 268 | let sextent = frame.extent in 269 | let sxform = frame.xform in 270 | let alpha = frame.alpha in 271 | let alpha = 272 | (*if width < 1.0 then 273 | let da = clampf 0.0 (width (*/. fringe_width*)) 1.0 in 274 | alpha *. da *. da 275 | else*) alpha 276 | in 277 | set_color inner_color alpha paint.inner; 278 | set_color outer_color alpha paint.outer; 279 | set_inv_xform paint_mat paint.xform; 280 | let sw = Size2.w sextent and sh = Size2.h sextent in 281 | if sw < -0.5 || sh < -0.5 then begin 282 | set_zero_m34 sciss_mat; 283 | set_4 sciss_extent_scale 284 | 1.0 1.0 1.0 1.0 285 | end else begin 286 | set_inv_xform sciss_mat sxform; 287 | set_4 sciss_extent_scale sw sh 288 | (sqrt (sxform.x00 *. sxform.x00 +. sxform.x10 *. sxform.x10) /. fringe) 289 | (sqrt (sxform.x01 *. sxform.x01 +. sxform.x11 *. sxform.x11) /. fringe) 290 | end; 291 | let pw = Size2.w paint.extent and ph = Size2.h paint.extent in 292 | set_4 paint_extent_radius_feather pw ph paint.radius paint.feather; 293 | let typ = match typ, paint.texture with 294 | | None, Some _ -> `FILLIMG 295 | | None, None -> `FILLGRAD 296 | | Some typ, _ -> typ 297 | in 298 | let texType = match paint.texture with 299 | | None -> 2.0 300 | | Some tex -> 301 | let {Texture. premultiplied; channels; gl_tex} = prj tex in 302 | wall_gl_bind_texture t gl_tex; 303 | if channels >= 3 then 304 | if premultiplied then 0.0 else 1.0 305 | else 306 | 2.0 307 | in 308 | set_4 strokemult_strokethr_textype_type 309 | (if stroke_thr = -2.0 then 0.0 else width) (*((width +. fringe) *. 0.5 /. fringe)*) 310 | stroke_thr 311 | texType (shader_type typ); 312 | wall_gl_bind_paint t buf 313 | 314 | let set_simple t stroke_thr typ = 315 | for i = 0 to 43 do 316 | buf.{i} <- 0.0; 317 | done; 318 | buf.{strokemult_strokethr_textype_type + 0} <- 0.0; 319 | buf.{strokemult_strokethr_textype_type + 1} <- stroke_thr; 320 | buf.{strokemult_strokethr_textype_type + 3} <- shader_type typ; 321 | wall_gl_bind_paint t buf 322 | end 323 | 324 | module Fill = struct 325 | let prepare_stencil t = 326 | (* Draw shapes *) 327 | wall_gl_fill_prepare_stencil t; 328 | (* set bindpoint for solid loc *) 329 | Shader.set_simple t (-1.0) `SIMPLE 330 | 331 | let draw_stencil = wall_gl_draw_triangle_fan 332 | 333 | let prepare_cover t prj paint frame = 334 | wall_gl_fill_prepare_cover t; 335 | Shader.set_tool t prj paint frame 1.0 (-2.0) 336 | 337 | let prepare_aa = wall_gl_prepare_aa 338 | 339 | let draw_aa = wall_gl_draw_triangle_strip 340 | 341 | let finish_and_cover = wall_gl_fill_finish_and_cover 342 | end 343 | 344 | module Convex_fill = struct 345 | let prepare t prj paint frame = 346 | Shader.set_tool t prj paint frame 1.0 (-2.0) 347 | 348 | let draw = wall_gl_draw_triangle_fan 349 | 350 | let draw_aa = wall_gl_draw_triangle_strip 351 | end 352 | 353 | module Stencil_stroke = struct 354 | let prepare_stencil t prj paint frame width = 355 | (* Fill the stroke base without overlap *) 356 | wall_gl_stencil_stroke_prepare_stencil t; 357 | Shader.set_tool t prj paint frame width (1.0 -. 0.5 /. 255.0) 358 | 359 | let draw_stencil = wall_gl_draw_triangle_strip 360 | 361 | let prepare_aa t prj paint frame width = 362 | Shader.set_tool t prj paint frame width (-1.0); 363 | wall_gl_prepare_aa t 364 | 365 | let draw_aa = wall_gl_draw_triangle_strip 366 | 367 | let prepare_clear = wall_gl_stencil_stroke_prepare_clear 368 | 369 | let draw_clear = wall_gl_draw_triangle_strip 370 | 371 | let finish = wall_gl_stencil_stroke_finish 372 | end 373 | 374 | module Direct_stroke = struct 375 | let prepare t prj paint frame width = 376 | Shader.set_tool t prj paint frame width (-1.0) 377 | 378 | let draw = wall_gl_draw_triangle_strip 379 | end 380 | 381 | module Triangles = struct 382 | let prepare t prj paint frame = 383 | Shader.set_tool t ~typ:`IMG prj paint frame 1.0 (-2.0) 384 | 385 | let draw = wall_gl_draw_triangles 386 | end 387 | 388 | let gl_reversed = ref false 389 | 390 | let force_set_reversed t flag = 391 | wall_gl_set_reversed t flag; 392 | gl_reversed := flag 393 | 394 | let set_reversed t xf = 395 | let reversing = xf.x00 *. xf.x11 < xf.x01 *. xf.x10 in 396 | if reversing <> !gl_reversed then 397 | force_set_reversed t reversing 398 | 399 | let set_xform t xf = 400 | Shader.set_xform t xf; 401 | set_reversed t xf 402 | 403 | let prepare t ~width ~height data = 404 | gl_reversed := false; 405 | (* Setup gl state *) 406 | wall_gl_frame_prepare t ~width ~height data 407 | 408 | let finish = wall_gl_frame_finish 409 | 410 | external memory_spent : unit -> int = "wall_memory_spent" [@@noalloc] 411 | external time_spent : unit -> int = "wall_time_spent" [@@noalloc] 412 | -------------------------------------------------------------------------------- /lib/wall__backend.mli: -------------------------------------------------------------------------------- 1 | open Wall_types 2 | type state 3 | 4 | val create : antialias:bool -> state 5 | val delete : state -> unit 6 | 7 | module Texture : sig 8 | type t = int 9 | 10 | type specification = { 11 | gl_tex : int; 12 | premultiplied : bool; 13 | channels : int; 14 | } 15 | 16 | val create : state -> t 17 | val delete : state -> t -> unit 18 | 19 | val upload : ?level:int -> state -> _ Stb_image.t -> t -> unit 20 | val update : ?level:int -> state -> x:int -> y:int -> _ Stb_image.t -> t -> unit 21 | 22 | val generate_mipmap : state -> t -> unit 23 | end 24 | 25 | module Fill : sig 26 | val prepare_stencil : state -> unit 27 | val draw_stencil : state -> first:int -> count:int -> unit 28 | 29 | val prepare_cover : state -> ('tex -> Texture.specification) -> 'tex paint -> frame -> unit 30 | 31 | val prepare_aa : state -> unit 32 | val draw_aa : state -> first:int -> count:int -> unit 33 | 34 | val finish_and_cover : state -> first:int -> count:int -> unit 35 | end 36 | 37 | module Convex_fill : sig 38 | val prepare : state -> ('tex -> Texture.specification) -> 'tex paint -> frame -> unit 39 | 40 | val draw : state -> first:int -> count:int -> unit 41 | val draw_aa : state -> first:int -> count:int -> unit 42 | end 43 | 44 | module Stencil_stroke : sig 45 | val prepare_stencil : state -> ('tex -> Texture.specification) -> 'tex paint -> frame -> float -> unit 46 | val draw_stencil : state -> first:int -> count:int -> unit 47 | 48 | val prepare_aa : state -> ('tex -> Texture.specification) -> 'tex paint -> frame -> float -> unit 49 | val draw_aa : state -> first:int -> count:int -> unit 50 | 51 | val prepare_clear : state -> unit 52 | val draw_clear : state -> first:int -> count:int -> unit 53 | 54 | val finish : state -> unit 55 | end 56 | 57 | module Direct_stroke : sig 58 | val prepare : state -> ('tex -> Texture.specification) -> 'tex paint -> frame -> float -> unit 59 | val draw : state -> first:int -> count:int -> unit 60 | end 61 | 62 | module Triangles : sig 63 | val prepare : state -> ('tex -> Texture.specification) -> 'tex paint -> frame -> unit 64 | val draw : state -> first:int -> count:int -> unit 65 | end 66 | 67 | val prepare : state -> width:float -> height:float -> Wall__geom.B.bigarray -> unit 68 | val set_xform : state -> transform -> unit 69 | val finish : state -> unit 70 | 71 | val memory_spent: unit -> int 72 | val time_spent: unit -> int 73 | -------------------------------------------------------------------------------- /lib/wall__backend_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | #include 11 | #define GL3 12 | 13 | #ifdef __APPLE__ 14 | # include 15 | # ifndef CLOCK_MONOTONIC 16 | # define WORKAROUND_APPLE_CLOCK 17 | # endif 18 | # ifdef WORKAROUND_APPLE_CLOCK 19 | # include 20 | # endif 21 | #else 22 | # include 23 | # ifdef GL3 24 | # include 25 | # endif 26 | #endif 27 | 28 | typedef struct { 29 | void (*glActiveTexture) (GLenum texture); 30 | void (*glAttachShader) (GLuint program, GLuint shader); 31 | void (*glBindAttribLocation) (GLuint program, GLuint index, const GLchar *name); 32 | void (*glBindBuffer) (GLenum target, GLuint buffer); 33 | void (*glBindTexture) (GLenum target, GLuint texture); 34 | void (*glBindVertexArray) (GLuint array); 35 | void (*glBlendFunc) (GLenum sfactor, GLenum dfactor); 36 | void (*glBufferData) (GLenum target, GLsizeiptr size, const void *data, GLenum usage); 37 | void (*glColorMask) (GLboolean red, GLboolean green, GLboolean blue, GLboolean alpha); 38 | void (*glCompileShader) (GLuint shader); 39 | GLuint (*glCreateProgram) (void); 40 | GLuint (*glCreateShader) (GLenum type); 41 | void (*glCullFace) (GLenum mode); 42 | void (*glDeleteBuffers) (GLsizei n, const GLuint *buffers); 43 | void (*glDeleteProgram) (GLuint program); 44 | void (*glDeleteShader) (GLuint shader); 45 | void (*glDeleteTextures) (GLsizei n, const GLuint *textures); 46 | void (*glDeleteVertexArrays) (GLsizei n, const GLuint *arrays); 47 | void (*glDisable) (GLenum cap); 48 | void (*glDisableVertexAttribArray) (GLuint index); 49 | void (*glDrawArrays) (GLenum mode, GLint first, GLsizei count); 50 | void (*glEnable) (GLenum cap); 51 | void (*glEnableVertexAttribArray) (GLuint index); 52 | void (*glFrontFace) (GLenum mode); 53 | void (*glGenBuffers) (GLsizei n, GLuint *buffers); 54 | void (*glGenerateMipmap) (GLenum target); 55 | void (*glGenTextures) (GLsizei n, GLuint *textures); 56 | void (*glGenVertexArrays) (GLsizei n, GLuint *arrays); 57 | void (*glGetProgramInfoLog) (GLuint program, GLsizei bufSize, GLsizei *length, GLchar *infoLog); 58 | void (*glGetProgramiv) (GLuint program, GLenum pname, GLint *params); 59 | void (*glGetShaderInfoLog) (GLuint shader, GLsizei bufSize, GLsizei *length, GLchar *infoLog); 60 | void (*glGetShaderiv) (GLuint shader, GLenum pname, GLint *params); 61 | GLint (*glGetUniformLocation) (GLuint program, const GLchar *name); 62 | void (*glLinkProgram) (GLuint program); 63 | void (*glPixelStorei) (GLenum pname, GLint param); 64 | void (*glShaderSource) (GLuint shader, GLsizei count, const GLchar *const*string, const GLint *length); 65 | void (*glStencilFunc) (GLenum func, GLint ref, GLuint mask); 66 | void (*glStencilMask) (GLuint mask); 67 | void (*glStencilOp) (GLenum fail, GLenum zfail, GLenum zpass); 68 | void (*glStencilOpSeparate) (GLenum face, GLenum sfail, GLenum dpfail, GLenum dppass); 69 | void (*glTexSubImage2D) (GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLenum type, const void *pixels); 70 | void (*glTexParameteri) (GLenum target, GLenum pname, GLint param); 71 | void (*glUseProgram) (GLuint program); 72 | void (*glValidateProgram) (GLuint program); 73 | void (*glVertexAttribPointer) (GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, const void *pointer); 74 | void (*glUniform1i) (GLint location, GLint v0); 75 | void (*glUniform2f) (GLint location, GLfloat v0, GLfloat v1); 76 | void (*glTexImage2D) (GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, const void *pixels); 77 | void (*glUniform3fv) (GLint location, GLsizei count, const GLfloat *value); 78 | void (*glUniform1f) (GLint location, GLfloat v0); 79 | void (*glUniform4fv) (GLint location, GLsizei count, const GLfloat *value); 80 | 81 | GLuint program, viewsize, viewxform, strokewidth, tex, frag, vert_vbo; 82 | #ifdef GL3 83 | GLuint vert_vao; 84 | #endif 85 | int valid; 86 | } gl_state; 87 | 88 | static const char *source_vertex_shader = 89 | "uniform vec2 viewSize;\n" 90 | "uniform float strokeWidth;\n" 91 | "uniform vec3 viewXform[3];\n" 92 | "attribute vec2 vertex;\n" 93 | "attribute vec2 tcoord;\n" 94 | "varying vec3 ftcoord;\n" 95 | "varying vec2 fpos;\n" 96 | "\n" 97 | "void main(void) {\n" 98 | " fpos = (mat3(viewXform[0], viewXform[1], viewXform[2]) * vec3(vertex,1.0)).xy;\n" 99 | " if (tcoord.x < -1.0)\n" 100 | " {\n" 101 | " ftcoord = vec3(- floor(tcoord) / 2.0 - 1.0, 1.0);\n" 102 | " vec2 d = (fract(tcoord) - 0.5) * 1024.0;\n" 103 | " float len = length(d);\n" 104 | " if (len > 0.0001)\n" 105 | " {\n" 106 | " vec2 dm = mat2(viewXform[0].xy, viewXform[1].xy) * d;\n" 107 | " if (strokeWidth > 0.0)\n" 108 | " {\n" 109 | " float lenm = length(dm);\n" 110 | " ftcoord.z = ((strokeWidth * lenm / len + 1.0) * 0.5) * max(ftcoord.y,1.0);\n" 111 | " ftcoord.y = min(ftcoord.y,1.0);\n" 112 | " }\n" 113 | " fpos += normalize(dm) * len;\n" 114 | " }\n" 115 | " }\n" 116 | " else\n" 117 | " {\n" 118 | " ftcoord = vec3(tcoord, 1.0);\n" 119 | " };\n" 120 | " gl_Position = vec4(2.0 * fpos.x / viewSize.x - 1.0,\n" 121 | " 1.0 - 2.0 * fpos.y / viewSize.y, 0, 1);\n" 122 | "}\n"; 123 | 124 | static const char *source_fragment_shader = 125 | "#define innerCol frag[6]\n" 126 | "#define outerCol frag[7]\n" 127 | "#define paintMat mat3(frag[3].xyz, frag[4].xyz, frag[5].xyz)\n" 128 | "#define scissorMat mat3(frag[0].xyz, frag[1].xyz, frag[2].xyz)\n" 129 | "#define scissorExt frag[8].xy\n" 130 | "#define scissorScale frag[8].zw\n" 131 | "#define extent frag[9].xy\n" 132 | "#define radius frag[9].z\n" 133 | "#define feather frag[9].w\n" 134 | "#define strokeMult frag[10].x\n" 135 | "#define strokeThr frag[10].y\n" 136 | "#define texType int(frag[10].z)\n" 137 | "#define type int(frag[10].w)\n" 138 | "\n" 139 | "uniform vec4 frag[11];\n" 140 | "uniform sampler2D tex;\n" 141 | "varying vec3 ftcoord;\n" 142 | "varying vec2 fpos;\n" 143 | "\n" 144 | "float sdroundrect(vec2 pt, vec2 ext, float rad) {\n" 145 | " vec2 ext2 = ext - vec2(rad,rad);\n" 146 | " vec2 d = abs(pt) - ext2;\n" 147 | " return min(max(d.x,d.y),0.0) + length(max(d,0.0)) - rad;\n" 148 | "}\n" 149 | "\n" 150 | "// Scissoring\n" 151 | "float scissorMask(vec2 p) {\n" 152 | " vec2 sc = (abs((scissorMat * vec3(p,1.0)).xy) - scissorExt);\n" 153 | " sc = vec2(0.5,0.5) - sc * scissorScale;\n" 154 | " return clamp(sc.x,0.0,1.0) * clamp(sc.y,0.0,1.0);\n" 155 | "}\n" 156 | "#ifdef EDGE_AA\n" 157 | "// Stroke - from [0..1] to clipped pyramid, where the slope is 1px.\n" 158 | "float strokeMask() {\n" 159 | " return clamp((0.5-abs(ftcoord.x-0.5))*2.0*ftcoord.z, 0.0, 1.0)*ftcoord.y;\n" 160 | "}\n" 161 | "#endif\n" 162 | "\n" 163 | "void main(void) {\n" 164 | " vec4 result;\n" 165 | " float scissor = scissorMask(fpos);\n" 166 | "#ifdef EDGE_AA\n" 167 | " float strokeAlpha = strokeMask();\n" 168 | " if (strokeAlpha < strokeThr) discard;\n" 169 | "#else\n" 170 | " float strokeAlpha = 1.0;\n" 171 | "#endif\n" 172 | " if (type == 0) { // Gradient\n" 173 | " // Calculate gradient color using box gradient\n" 174 | " vec2 pt = (paintMat * vec3(fpos,1.0)).xy;\n" 175 | " float d = clamp((sdroundrect(pt, extent, radius) + feather*0.5) / feather, 0.0, 1.0);\n" 176 | " vec4 color = mix(innerCol,outerCol,d);\n" 177 | " // Combine alpha\n" 178 | " color *= strokeAlpha * scissor;\n" 179 | " result = color;\n" 180 | " } else if (type == 1) { // Image\n" 181 | " // Calculate color from texture\n" 182 | " vec2 pt = (paintMat * vec3(fpos,1.0)).xy / extent;\n" 183 | " vec4 color = texture2D(tex, pt);\n" 184 | " if (texType == 1) color = vec4(color.xyz*color.w,color.w);\n" 185 | " if (texType == 2) color = vec4(color.x);\n" 186 | " // Apply color tint and alpha.\n" 187 | " color *= innerCol;\n" 188 | " // Combine alpha\n" 189 | " color *= strokeAlpha * scissor;\n" 190 | " result = color;\n" 191 | " } else if (type == 2) { // Stencil fill\n" 192 | " result = vec4(1,1,1,1);\n" 193 | " } else if (type == 3) { // Texture atlas\n" 194 | " vec4 color = texture2D(tex, ftcoord.xy, -0.66);\n" 195 | " if (texType == 1) color = vec4(color.xyz*color.w,color.w);\n" 196 | " if (texType == 2) color = vec4(color.x);\n" 197 | " color *= scissor;\n" 198 | " result = color * innerCol;\n" 199 | " }\n" 200 | " gl_FragColor = result;\n" 201 | "}\n"; 202 | 203 | static const char *shader_info_log(gl_state *state, GLuint shader) 204 | { 205 | char *buffer = calloc(2048, sizeof(char)); 206 | GLsizei length; 207 | state->glGetShaderInfoLog(shader, 2048, &length, buffer); 208 | if (length >= 2048) length = 2047; 209 | buffer[length] = '\0'; 210 | return buffer; 211 | } 212 | 213 | static const char *program_info_log(gl_state *state, GLuint program) 214 | { 215 | char *buffer = calloc(2048, sizeof(char)); 216 | GLsizei length; 217 | state->glGetProgramInfoLog(program, 2048, &length, buffer); 218 | if (length >= 2048) length = 2047; 219 | buffer[length] = '\0'; 220 | return buffer; 221 | } 222 | 223 | static GLuint create_shader(gl_state *state, const char *version, const char *prefix, const char *source, GLenum kind) 224 | { 225 | const char *buffer[3]; 226 | buffer[0] = version ? version : ""; 227 | buffer[1] = prefix ? prefix : ""; 228 | buffer[2] = source ? source : ""; 229 | 230 | GLuint shader = state->glCreateShader(kind); 231 | state->glShaderSource(shader, 3, buffer, 0); 232 | state->glCompileShader(shader); 233 | 234 | GLint result = GL_FALSE; 235 | state->glGetShaderiv(shader, GL_COMPILE_STATUS, &result); 236 | 237 | if (result != GL_TRUE) { 238 | const char *log = shader_info_log(state, shader); 239 | fprintf(stderr, "ERROR: GL shader %d did not compile\n%s\n", shader, log); 240 | free((void*)log); 241 | } 242 | 243 | return shader; 244 | } 245 | 246 | static int validate_program(gl_state *state, GLuint program) 247 | { 248 | state->glValidateProgram(program); 249 | GLint result = GL_FALSE; 250 | state->glGetProgramiv(program, GL_VALIDATE_STATUS, &result); 251 | 252 | if (result != GL_TRUE) 253 | { 254 | const char *log = program_info_log(state, program); 255 | fprintf(stderr, "ERROR: GL program %d did not compile\n%s\n", program, log); 256 | free((void*)log); 257 | 258 | return 0; 259 | } 260 | 261 | return 1; 262 | } 263 | 264 | static int create_program(gl_state *state, GLuint *program, const char *version, const char *prefix) 265 | { 266 | GLuint vs, fs, ps; 267 | vs = create_shader(state, version, prefix, source_vertex_shader, GL_VERTEX_SHADER), 268 | fs = create_shader(state, version, prefix, source_fragment_shader, GL_FRAGMENT_SHADER), 269 | ps = state->glCreateProgram(); 270 | 271 | state->glAttachShader(ps, vs); 272 | state->glAttachShader(ps, fs); 273 | state->glBindAttribLocation(ps, 0, "vertex"); 274 | state->glBindAttribLocation(ps, 1, "tcoord"); 275 | 276 | state->glLinkProgram(ps); 277 | GLint result = GL_FALSE; 278 | state->glGetProgramiv(ps, GL_LINK_STATUS, &result); 279 | 280 | if (result != GL_TRUE) 281 | { 282 | const char *log = program_info_log(state, ps); 283 | fprintf(stderr, "ERROR: could not link GL program %d\n%s\n", ps, log); 284 | free((void*)log); 285 | return 0; 286 | } 287 | if (!validate_program(state, ps)) abort(); 288 | state->glDeleteShader(vs); 289 | state->glDeleteShader(fs); 290 | *program = ps; 291 | return 1; 292 | } 293 | 294 | static void gl_state_initialize(gl_state *state) 295 | { 296 | *(void**)&state->glActiveTexture = SDL_GL_GetProcAddress("glActiveTexture"); 297 | *(void**)&state->glAttachShader = SDL_GL_GetProcAddress("glAttachShader"); 298 | *(void**)&state->glBindAttribLocation = SDL_GL_GetProcAddress("glBindAttribLocation"); 299 | *(void**)&state->glBindBuffer = SDL_GL_GetProcAddress("glBindBuffer"); 300 | *(void**)&state->glBindTexture = SDL_GL_GetProcAddress("glBindTexture"); 301 | *(void**)&state->glBindVertexArray = SDL_GL_GetProcAddress("glBindVertexArray"); 302 | *(void**)&state->glBlendFunc = SDL_GL_GetProcAddress("glBlendFunc"); 303 | *(void**)&state->glBufferData = SDL_GL_GetProcAddress("glBufferData"); 304 | *(void**)&state->glColorMask = SDL_GL_GetProcAddress("glColorMask"); 305 | *(void**)&state->glCompileShader = SDL_GL_GetProcAddress("glCompileShader"); 306 | *(void**)&state->glCreateProgram = SDL_GL_GetProcAddress("glCreateProgram"); 307 | *(void**)&state->glCreateShader = SDL_GL_GetProcAddress("glCreateShader"); 308 | *(void**)&state->glCullFace = SDL_GL_GetProcAddress("glCullFace"); 309 | *(void**)&state->glDeleteBuffers = SDL_GL_GetProcAddress("glDeleteBuffers"); 310 | *(void**)&state->glDeleteProgram = SDL_GL_GetProcAddress("glDeleteProgram"); 311 | *(void**)&state->glDeleteShader = SDL_GL_GetProcAddress("glDeleteShader"); 312 | *(void**)&state->glDeleteTextures = SDL_GL_GetProcAddress("glDeleteTextures"); 313 | *(void**)&state->glDeleteVertexArrays = SDL_GL_GetProcAddress("glDeleteVertexArrays"); 314 | *(void**)&state->glDisable = SDL_GL_GetProcAddress("glDisable"); 315 | *(void**)&state->glDisableVertexAttribArray = SDL_GL_GetProcAddress("glDisableVertexAttribArray"); 316 | *(void**)&state->glDrawArrays = SDL_GL_GetProcAddress("glDrawArrays"); 317 | *(void**)&state->glEnable = SDL_GL_GetProcAddress("glEnable"); 318 | *(void**)&state->glEnableVertexAttribArray = SDL_GL_GetProcAddress("glEnableVertexAttribArray"); 319 | *(void**)&state->glFrontFace = SDL_GL_GetProcAddress("glFrontFace"); 320 | *(void**)&state->glGenBuffers = SDL_GL_GetProcAddress("glGenBuffers"); 321 | *(void**)&state->glGenerateMipmap = SDL_GL_GetProcAddress("glGenerateMipmap"); 322 | *(void**)&state->glGenTextures = SDL_GL_GetProcAddress("glGenTextures"); 323 | *(void**)&state->glGenVertexArrays = SDL_GL_GetProcAddress("glGenVertexArrays"); 324 | *(void**)&state->glGetProgramInfoLog = SDL_GL_GetProcAddress("glGetProgramInfoLog"); 325 | *(void**)&state->glGetProgramiv = SDL_GL_GetProcAddress("glGetProgramiv"); 326 | *(void**)&state->glGetShaderInfoLog = SDL_GL_GetProcAddress("glGetShaderInfoLog"); 327 | *(void**)&state->glGetShaderiv = SDL_GL_GetProcAddress("glGetShaderiv"); 328 | *(void**)&state->glGetUniformLocation = SDL_GL_GetProcAddress("glGetUniformLocation"); 329 | *(void**)&state->glLinkProgram = SDL_GL_GetProcAddress("glLinkProgram"); 330 | *(void**)&state->glPixelStorei = SDL_GL_GetProcAddress("glPixelStorei"); 331 | *(void**)&state->glShaderSource = SDL_GL_GetProcAddress("glShaderSource"); 332 | *(void**)&state->glStencilFunc = SDL_GL_GetProcAddress("glStencilFunc"); 333 | *(void**)&state->glStencilMask = SDL_GL_GetProcAddress("glStencilMask"); 334 | *(void**)&state->glStencilOp = SDL_GL_GetProcAddress("glStencilOp"); 335 | *(void**)&state->glStencilOpSeparate = SDL_GL_GetProcAddress("glStencilOpSeparate"); 336 | *(void**)&state->glTexSubImage2D = SDL_GL_GetProcAddress("glTexSubImage2D"); 337 | *(void**)&state->glTexParameteri = SDL_GL_GetProcAddress("glTexParameteri"); 338 | *(void**)&state->glUseProgram = SDL_GL_GetProcAddress("glUseProgram"); 339 | *(void**)&state->glValidateProgram = SDL_GL_GetProcAddress("glValidateProgram"); 340 | *(void**)&state->glVertexAttribPointer = SDL_GL_GetProcAddress("glVertexAttribPointer"); 341 | *(void**)&state->glUniform1i = SDL_GL_GetProcAddress("glUniform1i"); 342 | *(void**)&state->glUniform2f = SDL_GL_GetProcAddress("glUniform2f"); 343 | *(void**)&state->glTexImage2D = SDL_GL_GetProcAddress("glTexImage2D"); 344 | *(void**)&state->glUniform3fv = SDL_GL_GetProcAddress("glUniform3fv"); 345 | *(void**)&state->glUniform1f = SDL_GL_GetProcAddress("glUniform1f"); 346 | *(void**)&state->glUniform4fv = SDL_GL_GetProcAddress("glUniform4fv"); 347 | } 348 | 349 | static int gl_state_create(gl_state *state, int antialias) 350 | { 351 | GLuint program; 352 | 353 | gl_state_initialize(state); 354 | if (!create_program(state, &program, NULL, antialias ? "#define EDGE_AA 1\n" : NULL)) 355 | return 0; 356 | 357 | state->program = program; 358 | state->viewsize = state->glGetUniformLocation(program, "viewSize"); 359 | state->viewxform = state->glGetUniformLocation(program, "viewXform"); 360 | state->strokewidth = state->glGetUniformLocation(program, "strokeWidth"); 361 | state->tex = state->glGetUniformLocation(program, "tex"); 362 | state->frag = state->glGetUniformLocation(program, "frag"); 363 | #ifdef GL3 364 | state->glGenVertexArrays(1, &state->vert_vao); 365 | #endif 366 | state->glGenBuffers(1, &state->vert_vbo); 367 | 368 | state->valid = 1; 369 | 370 | return 1; 371 | } 372 | 373 | static void gl_state_delete(gl_state *state) 374 | { 375 | if (state->valid) 376 | { 377 | state->glDeleteProgram(state->program); 378 | #ifdef GL3 379 | state->glDeleteVertexArrays(1, &state->vert_vao); 380 | #endif 381 | state->glDeleteBuffers(1, &state->vert_vbo); 382 | state->valid = 0; 383 | } 384 | } 385 | 386 | #define Gl_state_val(v) ((gl_state*)(Data_custom_val(v))) 387 | 388 | static void gl_state_finalize(value v) 389 | { 390 | gl_state *state = Gl_state_val(v); 391 | if (state->valid) 392 | { 393 | fprintf(stderr, "wall warning: gl_state collected by Gc, explicit deletion is preferable\n"); 394 | gl_state_delete(state); 395 | } 396 | } 397 | 398 | static struct custom_operations gl_state_custom_ops = { 399 | .identifier = "wall_gl_state", 400 | .finalize = gl_state_finalize, 401 | .compare = custom_compare_default, 402 | .hash = custom_hash_default, 403 | .serialize = custom_serialize_default, 404 | .deserialize = custom_deserialize_default 405 | }; 406 | 407 | 408 | CAMLprim value wall_gl_create(value antialias) 409 | { 410 | gl_state result; 411 | 412 | if (!gl_state_create(&result, Long_val(antialias))) 413 | caml_failwith("wall: cannot initialize OpenGL"); 414 | 415 | value v = caml_alloc_custom(&gl_state_custom_ops, sizeof(gl_state), 0, 1); 416 | *Gl_state_val(v) = result; 417 | 418 | return v; 419 | } 420 | 421 | CAMLprim value wall_gl_delete(value v) 422 | { 423 | gl_state_delete(Gl_state_val(v)); 424 | return Val_unit; 425 | } 426 | 427 | CAMLprim value wall_gl_is_valid(value v) 428 | { 429 | return Val_bool(Gl_state_val(v)); 430 | } 431 | 432 | CAMLprim value wall_gl_bind_xform(value t, value buf) 433 | { 434 | gl_state *state = Gl_state_val(t); 435 | float *data = Caml_ba_data_val(buf); 436 | state->glUniform3fv(state->viewxform, 3, data); 437 | return Val_unit; 438 | } 439 | 440 | CAMLprim value wall_gl_bind_paint(value t, value buf) 441 | { 442 | gl_state *state = Gl_state_val(t); 443 | float *data = Caml_ba_data_val(buf); 444 | state->glUniform1f(state->strokewidth, data[40]); 445 | state->glUniform4fv(state->frag, 11, data); 446 | return Val_unit; 447 | } 448 | 449 | CAMLprim value wall_gl_bind_texture(value t, value texture) 450 | { 451 | gl_state *state = Gl_state_val(t); 452 | state->glBindTexture(GL_TEXTURE_2D, Long_val(texture)); 453 | return Val_unit; 454 | } 455 | 456 | 457 | CAMLprim value wall_gl_draw_triangle_fan(value t, value first, value count) 458 | { 459 | gl_state *state = Gl_state_val(t); 460 | state->glDrawArrays(GL_TRIANGLE_FAN, Long_val(first), Long_val(count)); 461 | return Val_unit; 462 | } 463 | 464 | CAMLprim value wall_gl_draw_triangle_strip(value t, value first, value count) 465 | { 466 | gl_state *state = Gl_state_val(t); 467 | state->glDrawArrays(GL_TRIANGLE_STRIP, Long_val(first), Long_val(count)); 468 | return Val_unit; 469 | } 470 | 471 | CAMLprim value wall_gl_draw_triangles(value t, value first, value count) 472 | { 473 | gl_state *state = Gl_state_val(t); 474 | state->glDrawArrays(GL_TRIANGLES, Long_val(first), Long_val(count)); 475 | return Val_unit; 476 | } 477 | 478 | CAMLprim value wall_gl_fill_prepare_stencil(value t) 479 | { 480 | gl_state *state = Gl_state_val(t); 481 | state->glEnable(GL_STENCIL_TEST); 482 | state->glStencilMask(0xFF); 483 | state->glStencilFunc(GL_ALWAYS, 0x00, 0xFF); 484 | state->glColorMask(GL_FALSE, GL_FALSE, GL_FALSE, GL_FALSE); 485 | state->glStencilOpSeparate(GL_FRONT, GL_KEEP, GL_KEEP, GL_INCR_WRAP); 486 | state->glStencilOpSeparate(GL_BACK, GL_KEEP, GL_KEEP, GL_DECR_WRAP); 487 | state->glDisable(GL_CULL_FACE); 488 | return Val_unit; 489 | } 490 | 491 | CAMLprim value wall_gl_fill_prepare_cover(value t) 492 | { 493 | gl_state *state = Gl_state_val(t); 494 | state->glEnable(GL_CULL_FACE); 495 | state->glColorMask(GL_TRUE, GL_TRUE, GL_TRUE, GL_TRUE); 496 | return Val_unit; 497 | } 498 | 499 | CAMLprim value wall_gl_prepare_aa(value t) 500 | { 501 | gl_state *state = Gl_state_val(t); 502 | state->glStencilFunc(GL_EQUAL, 0x00, 0xFF); 503 | state->glStencilOp(GL_KEEP, GL_KEEP, GL_KEEP); 504 | return Val_unit; 505 | } 506 | 507 | CAMLprim value wall_gl_fill_finish_and_cover(value t, value first, value count) 508 | { 509 | gl_state *state = Gl_state_val(t); 510 | state->glStencilFunc(GL_NOTEQUAL, 0x00, 0xff); 511 | state->glStencilOp(GL_ZERO, GL_ZERO, GL_ZERO); 512 | (void)wall_gl_draw_triangle_strip(t, first, count); 513 | state->glDisable(GL_STENCIL_TEST); 514 | return Val_unit; 515 | } 516 | 517 | CAMLprim value wall_gl_stencil_stroke_prepare_stencil(value t) 518 | { 519 | gl_state *state = Gl_state_val(t); 520 | state->glEnable(GL_STENCIL_TEST); 521 | state->glStencilMask(0xff); 522 | state->glStencilFunc(GL_EQUAL, 0x0, 0xff); 523 | state->glStencilOp(GL_KEEP, GL_KEEP, GL_INCR); 524 | return Val_unit; 525 | } 526 | 527 | CAMLprim value wall_gl_stencil_stroke_prepare_clear(value t) 528 | { 529 | gl_state *state = Gl_state_val(t); 530 | state->glStencilFunc(GL_ALWAYS, 0x00, 0xFF); 531 | state->glColorMask(GL_FALSE, GL_FALSE, GL_FALSE, GL_FALSE); 532 | state->glStencilOp(GL_ZERO, GL_ZERO, GL_ZERO); 533 | return Val_unit; 534 | } 535 | 536 | CAMLprim value wall_gl_stencil_stroke_finish(value t) 537 | { 538 | gl_state *state = Gl_state_val(t); 539 | state->glColorMask(GL_TRUE, GL_TRUE, GL_TRUE, GL_TRUE); 540 | state->glDisable(GL_STENCIL_TEST); 541 | return Val_unit; 542 | } 543 | 544 | CAMLprim value wall_gl_set_reversed(value t, value b) 545 | { 546 | gl_state *state = Gl_state_val(t); 547 | state->glFrontFace(Long_val(b) ? GL_CW : GL_CCW); 548 | return Val_unit; 549 | } 550 | 551 | CAMLprim value wall_gl_frame_prepare(value t, value width, value height, value data) 552 | { 553 | CAMLparam4(t, width, height, data); 554 | 555 | gl_state *state = Gl_state_val(t); 556 | if (!state->valid) 557 | caml_failwith("wall: use of gl context after delete"); 558 | 559 | state->glUseProgram(state->program); 560 | state->glBlendFunc(GL_ONE, GL_ONE_MINUS_SRC_ALPHA); 561 | state->glEnable(GL_CULL_FACE); 562 | state->glCullFace(GL_BACK); 563 | state->glFrontFace(GL_CCW); 564 | state->glEnable(GL_BLEND); 565 | state->glDisable(GL_DEPTH_TEST); 566 | state->glDisable(GL_SCISSOR_TEST); 567 | state->glColorMask(GL_TRUE, GL_TRUE, GL_TRUE, GL_TRUE); 568 | state->glStencilMask(0XFFFFFFFF); 569 | state->glStencilOp(GL_KEEP, GL_KEEP, GL_KEEP); 570 | state->glStencilFunc(GL_ALWAYS, 0, 0xFFFFFFFF); 571 | state->glActiveTexture(GL_TEXTURE0); 572 | state->glBindTexture(GL_TEXTURE_2D, 0); 573 | 574 | /* Upload vertex data */ 575 | #ifdef GL3 576 | state->glBindVertexArray(state->vert_vao); 577 | #endif 578 | state->glBindBuffer(GL_ARRAY_BUFFER, state->vert_vbo); 579 | state->glBufferData(GL_ARRAY_BUFFER, 580 | caml_ba_byte_size(Caml_ba_array_val(data)), 581 | Caml_ba_data_val(data), 582 | GL_STREAM_DRAW); 583 | 584 | state->glEnableVertexAttribArray(0); 585 | state->glEnableVertexAttribArray(1); 586 | state->glVertexAttribPointer(0, 2, GL_FLOAT, GL_FALSE, 4 * 4, (void*)0); 587 | state->glVertexAttribPointer(1, 2, GL_FLOAT, GL_FALSE, 4 * 4, (void*)(2 * 4)); 588 | 589 | /* Set view and texture just once per frame. */ 590 | state->glUniform1i(state->tex, 0); 591 | state->glUniform2f(state->viewsize, Double_val(width), Double_val(height)); 592 | 593 | CAMLreturn(Val_unit); 594 | } 595 | 596 | CAMLprim value wall_gl_frame_finish(value t) 597 | { 598 | gl_state *state = Gl_state_val(t); 599 | state->glDisableVertexAttribArray(0); 600 | state->glDisableVertexAttribArray(1); 601 | state->glDisable(GL_CULL_FACE); 602 | state->glBindBuffer(GL_ARRAY_BUFFER, 0); 603 | #ifdef GL3 604 | state->glBindVertexArray(0); 605 | #endif 606 | state->glUseProgram(0); 607 | state->glBindTexture(GL_TEXTURE_2D, 0); 608 | 609 | return Val_unit; 610 | } 611 | 612 | /* Texture */ 613 | 614 | CAMLprim value wall_gl_texture_create(value t) 615 | { 616 | gl_state *state = Gl_state_val(t); 617 | GLuint result = 0; 618 | state->glGenTextures(1, &result); 619 | return Val_long(result); 620 | } 621 | 622 | CAMLprim value wall_gl_texture_delete(value t) 623 | { 624 | gl_state *state = Gl_state_val(t); 625 | GLuint tex = Long_val(t); 626 | state->glDeleteTextures(1, &tex); 627 | return Val_unit; 628 | } 629 | 630 | static void *pack_image(unsigned char *data, size_t width, size_t height, size_t stride) 631 | { 632 | static unsigned char *buffer = NULL; 633 | if (!data) 634 | { 635 | if (buffer) 636 | { 637 | free(buffer); 638 | buffer = NULL; 639 | } 640 | return NULL; 641 | } 642 | 643 | if (stride == width) 644 | return data; 645 | 646 | if (buffer) 647 | buffer = realloc(buffer, width * height); 648 | else 649 | buffer = malloc(width * height); 650 | 651 | if (!buffer) 652 | abort(); 653 | 654 | size_t y; 655 | for (y = 0; y < height; ++y) 656 | memcpy(buffer + y * width, data + y * stride, width); 657 | 658 | return buffer; 659 | } 660 | 661 | static GLenum gl_format_from_channels(value channels) 662 | { 663 | switch(Long_val(channels)) 664 | { 665 | case 1: 666 | #ifdef __APPLE__ 667 | return GL_RED; 668 | #else 669 | return GL_LUMINANCE; 670 | #endif 671 | case 3: 672 | return GL_RGB; 673 | case 4: 674 | return GL_RGBA; 675 | default: 676 | abort(); 677 | } 678 | } 679 | 680 | static GLenum gl_type(value is_float) 681 | { 682 | return Bool_val(is_float) ? GL_FLOAT : GL_UNSIGNED_BYTE; 683 | } 684 | 685 | static void gl_tex_param(gl_state *state) 686 | { 687 | state->glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); 688 | state->glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); 689 | state->glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); 690 | state->glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR); 691 | } 692 | 693 | CAMLprim value wall_gl_texture_upload(value st, 694 | value t, value level, value is_float, 695 | value width, value height, value channels, 696 | value data, value offset, value stride) 697 | { 698 | gl_state *state = Gl_state_val(st); 699 | int elem_size = Bool_val(is_float) ? 4 : 1; 700 | void *ptr = pack_image(Caml_ba_data_val(data), 701 | Long_val(width) * Long_val(channels) * elem_size, 702 | Long_val(height), Long_val(stride) * elem_size); 703 | state->glActiveTexture(GL_TEXTURE0); 704 | state->glBindTexture(GL_TEXTURE_2D, Long_val(t)); 705 | state->glPixelStorei(GL_UNPACK_ALIGNMENT, 1); 706 | state->glTexImage2D(GL_TEXTURE_2D, Long_val(level), 707 | Long_val(channels), Long_val(width), Long_val(height), 0, 708 | gl_format_from_channels(channels), gl_type(is_float), ptr 709 | ); 710 | state->glPixelStorei(GL_UNPACK_ALIGNMENT, 4); 711 | gl_tex_param(state); 712 | pack_image(NULL, 0, 0, 0); 713 | return Val_unit; 714 | } 715 | 716 | CAMLprim value wall_gl_texture_upload_bc(value *argv, int argn) 717 | { 718 | return wall_gl_texture_upload( 719 | argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], 720 | argv[6], argv[7], argv[8], argv[9] 721 | ); 722 | } 723 | 724 | CAMLprim value wall_gl_texture_update(value st, 725 | value t, value level, value is_float, 726 | value x, value y, value width, value height, value channels, 727 | value data, value offset, value stride) 728 | { 729 | gl_state *state = Gl_state_val(st); 730 | int elem_size = Bool_val(is_float) ? 4 : 1; 731 | void *ptr = pack_image(Caml_ba_data_val(data), 732 | Long_val(width) * Long_val(channels) * elem_size, 733 | Long_val(height), Long_val(stride) * elem_size); 734 | state->glActiveTexture(GL_TEXTURE0); 735 | state->glBindTexture(GL_TEXTURE_2D, Long_val(t)); 736 | state->glPixelStorei(GL_UNPACK_ALIGNMENT, 1); 737 | state->glTexSubImage2D(GL_TEXTURE_2D, Long_val(level), 738 | Long_val(x), Long_val(y), 739 | Long_val(width), Long_val(height), 740 | gl_format_from_channels(channels), gl_type(is_float), ptr 741 | ); 742 | state->glPixelStorei(GL_UNPACK_ALIGNMENT, 4); 743 | gl_tex_param(state); 744 | pack_image(NULL, 0, 0, 0); 745 | return Val_unit; 746 | } 747 | 748 | CAMLprim value wall_gl_texture_update_bc(value *argv, int argn) 749 | { 750 | return wall_gl_texture_update( 751 | argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], 752 | argv[6], argv[7], argv[8], argv[9], argv[10], argv[11] 753 | ); 754 | } 755 | 756 | CAMLprim value wall_gl_texture_generate_mipmap(value st, value t) 757 | { 758 | gl_state *state = Gl_state_val(st); 759 | state->glActiveTexture(GL_TEXTURE0); 760 | state->glBindTexture(GL_TEXTURE_2D, Long_val(t)); 761 | state->glGenerateMipmap(GL_TEXTURE_2D); 762 | state->glBindTexture(GL_TEXTURE_2D, 0); 763 | return Val_unit; 764 | } 765 | 766 | /* Only used to measure deltas, so overflow is not a problem */ 767 | 768 | #ifdef WORKAROUND_APPLE_CLOCK 769 | static double microseconds_per_clockticks(void) 770 | { 771 | static double f = 0.0; 772 | if (f == 0.0) 773 | { 774 | mach_timebase_info_data_t timebase; 775 | mach_timebase_info(&timebase); 776 | f = (double)timebase.numer / timebase.denom / 1000.0; 777 | } 778 | return f; 779 | } 780 | #endif 781 | 782 | CAMLprim value wall_time_spent(value unit) 783 | { 784 | #ifdef WORKAROUND_APPLE_CLOCK 785 | return Val_long(mach_absolute_time() * microseconds_per_clockticks()); 786 | #else 787 | struct timespec tp; 788 | if (clock_gettime(CLOCK_MONOTONIC, &tp) == 0) 789 | return Val_long(tp.tv_sec * 1000000 + tp.tv_nsec / 1000); 790 | return Val_long(0); 791 | #endif 792 | } 793 | 794 | #if OCAML_VERSION < 41000 795 | 796 | extern uintnat caml_allocated_words; 797 | extern value *caml_young_alloc_end, *caml_young_ptr; 798 | 799 | extern double 800 | caml_stat_minor_words, 801 | caml_stat_promoted_words, 802 | caml_stat_major_words; 803 | 804 | #else 805 | 806 | #define CAML_INTERNALS 807 | 808 | #include 809 | #include 810 | #include 811 | 812 | #endif 813 | 814 | CAMLprim value wall_memory_spent(value unit) 815 | { 816 | long base = 817 | caml_stat_minor_words + caml_stat_major_words - caml_stat_promoted_words; 818 | long minwords = (caml_young_alloc_end - caml_young_ptr); 819 | long majwords = caml_allocated_words; 820 | 821 | return Val_long(base + minwords + majwords); 822 | } 823 | -------------------------------------------------------------------------------- /lib/wall__geom.mli: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2015 Frédéric Bour 3 | 4 | This software is provided 'as-is', without any express or implied 5 | warranty. In no event will the authors be held liable for any damages 6 | arising from the use of this software. 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 1. The origin of this software must not be misrepresented; you must not 11 | claim that you wrote the original software. If you use this software 12 | in a product, an acknowledgment in the product documentation would be 13 | appreciated but is not required. 14 | 2. Altered source versions must be plainly marked as such, and must not be 15 | misrepresented as being the original software. 16 | 3. This notice may not be removed or altered from any source distribution. 17 | *) 18 | 19 | (* Float buffer *) 20 | module B : sig 21 | type bigarray = (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t 22 | 23 | type t = { 24 | mutable data: bigarray; 25 | mutable cursor: int; 26 | } 27 | 28 | val make : unit -> t 29 | val clear : t -> unit 30 | val reserve : t -> int -> unit 31 | val release : t -> int -> unit 32 | 33 | val data : t -> bigarray 34 | val alloc : t -> int -> int 35 | val offset : t -> int 36 | 37 | val sub : t -> bigarray 38 | end 39 | 40 | (* Tesselator *) 41 | module T : sig 42 | type t 43 | 44 | type winding = CW | CCW 45 | 46 | type path = private { 47 | path_first : int; 48 | mutable path_count : int; 49 | mutable path_closed : bool; 50 | mutable path_winding: winding; 51 | mutable path_convex : bool; 52 | mutable path_nbevel : int; 53 | } 54 | 55 | type bounds = { 56 | minx: float; 57 | miny: float; 58 | maxx: float; 59 | maxy: float; 60 | } 61 | 62 | val flag_corner : int 63 | val flag_bevel : int 64 | val flag_left : int 65 | val flag_innerbevel : int 66 | 67 | val make : unit -> t 68 | val flush : t -> bounds * path list 69 | val clear : t -> unit 70 | 71 | val set_tol : t -> dist:float -> tess:float -> unit 72 | val set_tess_tol : t -> float -> unit 73 | val tess_tol : t -> float 74 | 75 | val has_path : t -> bool 76 | val close_path : t -> unit 77 | val set_winding : t -> winding -> unit 78 | val observed_tol : t -> bool 79 | 80 | val move_to : t -> float -> float -> unit 81 | val line_to : t -> float -> float -> unit 82 | val bezier_to : 83 | t -> 84 | x1:float -> y1:float -> 85 | x2:float -> y2:float -> 86 | x3:float -> y3:float -> 87 | unit 88 | 89 | val calculate_joins : t -> width:float -> 90 | line_join:[ `BEVEL | `MITER | `ROUND ] -> miter_limit:float -> path list -> unit 91 | 92 | val get_x : t -> int -> float 93 | val get_y : t -> int -> float 94 | val get_flags : t -> int -> int 95 | val get_dx : t -> int -> float 96 | val get_dy : t -> int -> float 97 | val get_dlen : t -> int -> float 98 | val get_dmx : t -> int -> float 99 | val get_dmy : t -> int -> float 100 | 101 | val last_x : t -> float 102 | val last_y : t -> float 103 | end 104 | 105 | (* Vertex emitter *) 106 | module V : sig 107 | type path = { 108 | convex: bool; 109 | fill_first: int; 110 | fill_count: int; 111 | stroke_first: int; 112 | stroke_count: int; 113 | } 114 | 115 | val fill : 116 | T.t -> B.t -> 117 | edge_antialias:bool -> scale:float -> 118 | T.path list -> path list 119 | 120 | val stroke : 121 | T.t -> B.t -> 122 | width:float -> 123 | line_join:[ `BEVEL | `MITER | `ROUND ] -> 124 | line_cap:[ `BUTT | `ROUND | `SQUARE ] -> 125 | miter_limit:float -> 126 | T.path list -> path list 127 | end 128 | -------------------------------------------------------------------------------- /lib/wall_text.ml: -------------------------------------------------------------------------------- 1 | open Wall 2 | open Wall__geom 3 | 4 | (* utf-8 decoding dfa, from http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ *) 5 | 6 | let bufsize = 2048 7 | let ibufsize = 1.0 /. float bufsize 8 | 9 | let utf8d = 10 | "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 11 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 12 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 13 | \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ 14 | \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\ 15 | \007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\ 16 | \b\b\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\ 17 | \n\003\003\003\003\003\003\003\003\003\003\003\003\004\003\003\ 18 | \011\006\006\006\005\b\b\b\b\b\b\b\b\b\b\b\ 19 | \000\001\002\003\005\b\007\001\001\001\004\006\001\001\001\001\ 20 | \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\000\001\000\001\001\001\001\001\001\ 21 | \001\002\001\001\001\001\001\002\001\002\001\001\001\001\001\001\001\001\001\001\001\001\001\002\001\001\001\001\001\001\001\001\ 22 | \001\002\001\001\001\001\001\001\001\002\001\001\001\001\001\001\001\001\001\001\001\001\001\003\001\003\001\001\001\001\001\001\ 23 | \001\003\001\001\001\001\001\003\001\003\001\001\001\001\001\001\001\003\001\001\001\001\001\001\001\001\001\001\001\001\001\001" 24 | 25 | let utf8_decode index str = 26 | let codep = ref 0 in 27 | let state = ref 0 in 28 | let len = String.length str in 29 | let index' = ref !index in 30 | while ( 31 | !index' < len && 32 | let c = Char.code (String.get str !index') in 33 | let t = Char.code (String.unsafe_get utf8d c) in 34 | codep := (if !state <> 0 then (c land 0x3f) lor (!codep lsl 6) else (0xff lsr t) land c); 35 | state := Char.code (String.unsafe_get utf8d (256 + !state * 16 + t) ); 36 | incr index'; 37 | !state > 1 38 | ) do () 39 | done; 40 | index := !index'; 41 | if !state = 0 then !codep else (-1) 42 | 43 | module Font = struct 44 | type glyph_placement = [ `Aligned | `Subpixel ] 45 | 46 | type t = { 47 | glyphes: Stb_truetype.t; 48 | size: float; 49 | blur: float; 50 | spacing: float; 51 | line_height: float; 52 | placement : glyph_placement; 53 | } 54 | 55 | let make ?(size=16.0) ?(blur=0.0) ?(spacing=0.0) ?(line_height=1.0) ?(placement=`Aligned) glyphes = 56 | { glyphes; blur; size; spacing; line_height; placement } 57 | 58 | type metrics = { 59 | ascent : float; 60 | descent : float; 61 | line_gap : float; 62 | } 63 | 64 | let font_metrics t = 65 | let scale = Stb_truetype.scale_for_pixel_height t.glyphes t.size in 66 | let {Stb_truetype. ascent; descent; line_gap} = 67 | Stb_truetype.vmetrics t.glyphes in 68 | { ascent = float ascent *. scale; 69 | descent = float descent *. scale; 70 | line_gap = float line_gap *. scale; 71 | } 72 | 73 | let text_width t text = 74 | let len = String.length text in 75 | let index = ref 0 in 76 | let width = ref 0 in 77 | let last = ref Stb_truetype.invalid_glyph in 78 | while !index < len do 79 | match utf8_decode index text with 80 | | -1 -> last := Stb_truetype.invalid_glyph 81 | | cp -> 82 | let glyph = Stb_truetype.get t.glyphes cp in 83 | width := !width 84 | + Stb_truetype.kern_advance t.glyphes !last glyph 85 | + Stb_truetype.glyph_advance t.glyphes glyph; 86 | last := glyph 87 | done; 88 | (float !width *. Stb_truetype.scale_for_pixel_height t.glyphes t.size) 89 | 90 | type measure = { 91 | width : float; 92 | height : float; 93 | depth : float; 94 | } 95 | 96 | let text_measure t text = 97 | let len = String.length text in 98 | let index = ref 0 in 99 | let width = ref 0 in 100 | let ascent = ref 0 in 101 | let descent = ref 0 in 102 | let maxi a b : int = if a >= b then a else b in 103 | let mini a b : int = if a <= b then a else b in 104 | let last = ref Stb_truetype.invalid_glyph in 105 | while !index < len do 106 | match utf8_decode index text with 107 | | -1 -> last := Stb_truetype.invalid_glyph 108 | | cp -> 109 | let glyph = Stb_truetype.get t.glyphes cp in 110 | let box = Stb_truetype.glyph_box t.glyphes glyph in 111 | ascent := maxi !ascent box.y1; 112 | descent := mini !descent box.y0; 113 | width := !width 114 | + Stb_truetype.kern_advance t.glyphes !last glyph 115 | + Stb_truetype.glyph_advance t.glyphes glyph; 116 | last := glyph 117 | done; 118 | let scale = Stb_truetype.scale_for_pixel_height t.glyphes t.size in 119 | { width = float !width *. scale; 120 | height = float !ascent *. scale; 121 | depth = float (- !descent) *. scale } 122 | end 123 | 124 | module Glyph = struct 125 | let decimal_quantize x = int_of_float (x *. 10.0) 126 | 127 | let subpixel_quantize x = 128 | let rec aux x n = 129 | if n >= x then n 130 | else aux x (n lsl 1) 131 | in 132 | (aux (int_of_float (x *. 1.70)) 4) * 10 133 | 134 | let estimate_scale sx sy {Font. size; placement} = 135 | let factor = sqrt (sx *. sx +. sy *. sy) in 136 | let scale = factor *. size in 137 | match placement with 138 | | `Aligned -> 139 | let x = decimal_quantize scale in 140 | if x > 2000 141 | then (float x /. 2000.0 /. factor, 2000) 142 | else (1.0 /. factor, x) 143 | | `Subpixel -> 144 | let x = subpixel_quantize scale in 145 | ((scale /. (float x /. 10.0)) /. factor, x) 146 | 147 | type key = { 148 | cp : int; 149 | scale : int; 150 | ttf : Stb_truetype.t; 151 | blur : int; 152 | } 153 | 154 | let key ~sx ~sy font = 155 | let ttf = font.Font.glyphes in 156 | let blur = decimal_quantize font.Font.blur in 157 | let factor, scale = estimate_scale sx sy font in 158 | (factor, (fun cp -> { cp; scale; ttf; blur })) 159 | 160 | type cell = { 161 | box : Stb_truetype.box; 162 | uv : Stb_truetype.box; 163 | glyph : Stb_truetype.glyph; 164 | mutable frame : int; 165 | } 166 | end 167 | 168 | type font_buffer = { 169 | image: Stb_image.int8 Stb_image.t; 170 | texture: Texture.t; 171 | mutable room : unit Maxrects.t; 172 | } 173 | 174 | let null_cell = 175 | let null_box = {Stb_truetype. x0 = 0; y0 = 0; x1 = 0; y1 = 0} in 176 | {Glyph. box = null_box; uv = null_box; 177 | glyph = Stb_truetype.invalid_glyph; frame = -1 } 178 | 179 | type font_stash = { 180 | font_glyphes: (Glyph.key, Glyph.cell) Hashtbl.t; 181 | font_todo: (Glyph.key, unit) Hashtbl.t; 182 | mutable font_buffer: font_buffer option; 183 | } 184 | 185 | let font_stash () = { 186 | font_glyphes = Hashtbl.create 8; 187 | font_todo = Hashtbl.create 8; 188 | font_buffer = None; 189 | } 190 | 191 | let align_place factor x = 192 | let x = x +. factor *. 0.5 in x -. mod_float x factor 193 | 194 | let place factor = function 195 | | `Subpixel -> (fun x -> x) 196 | | `Aligned -> align_place factor 197 | 198 | let render_glyphes stash _ xform (font,pos,text) quad ~(push : unit -> unit) = 199 | let x = Gg.P2.x pos and y = Gg.P2.y pos in 200 | let glyphes = font.Font.glyphes in 201 | let scale = Stb_truetype.scale_for_pixel_height glyphes font.Font.size in 202 | let factor, key = Glyph.key 203 | ~sx:(Transform.scale_x xform) 204 | ~sy:(Transform.scale_y xform) 205 | font 206 | in 207 | let xoff = ref 0 in 208 | let last = ref Stb_truetype.invalid_glyph in 209 | let place = place factor font.Font.placement in 210 | let y = place y in 211 | let r = ref 0 in 212 | let len = String.length text in 213 | while !r < len do 214 | match utf8_decode r text with 215 | | -1 -> last := Stb_truetype.invalid_glyph 216 | | cp -> 217 | let key = key cp in 218 | match Hashtbl.find stash.font_glyphes key with 219 | | cell when cell == null_cell -> 220 | last := Stb_truetype.invalid_glyph 221 | | { Glyph. box; uv; glyph; _ } -> 222 | let open Stb_truetype in 223 | xoff := !xoff + Stb_truetype.kern_advance glyphes !last glyph; 224 | last := glyph; 225 | (*Printf.eprintf 226 | "character { x0 = %d; y0 = %d; x1 = %d; y1 = %d }, factor %.02fx\n%!" 227 | box.x0 box.y0 box.x1 box.y1 factor;*) 228 | let x = place (x +. float !xoff *. scale) in 229 | let open Typesetter in 230 | quad.x0 <- x +. float (box.x0 - 2) *. factor; 231 | quad.y0 <- y +. float (box.y0 - 2) *. factor; 232 | quad.x1 <- x +. float (box.x1 + 2) *. factor; 233 | quad.y1 <- y +. float (box.y1 + 2) *. factor; 234 | quad.u0 <- float (uv.x0 - 2) *. ibufsize; 235 | quad.v0 <- float (uv.y0 - 2) *. ibufsize; 236 | quad.u1 <- float (uv.x1 + 2) *. ibufsize; 237 | quad.v1 <- float (uv.y1 + 2) *. ibufsize; 238 | push (); 239 | xoff := !xoff + Stb_truetype.glyph_advance glyphes glyph; 240 | | exception Not_found -> 241 | last := Stb_truetype.invalid_glyph 242 | done; 243 | match stash.font_buffer with 244 | | None -> failwith "wall_glyph: not font buffer" 245 | | Some buf -> buf.texture 246 | 247 | let ok = function 248 | | Result.Ok x -> x 249 | | Result.Error (`Msg msg) -> failwith msg 250 | 251 | let new_font_buffer renderer width height = 252 | let data = Bigarray.(Array1.create int8_unsigned c_layout (width * height)) in 253 | Bigarray.Array1.fill data 0; 254 | let image = ok (Stb_image.image ~width ~height ~channels:1 data) in 255 | let texture = Texture.from_image renderer ~name:"font atlas" image in 256 | let room = Maxrects.add_bin () width height Maxrects.empty in 257 | { image; texture; room } 258 | 259 | let box_offset {Stb_truetype. x0; x1; y0; y1 } p = 260 | {Stb_truetype. x0 = x0 - p; x1 = x1 + p; y0 = y0 - p; y1 = y1 + p } 261 | 262 | let frame_nr = ref 0 263 | 264 | let padding = 3 265 | 266 | let bake_glyphs renderer t = 267 | let buffer = match t.font_buffer with 268 | | Some buffer -> buffer 269 | | None -> 270 | let buffer = new_font_buffer renderer bufsize bufsize in 271 | t.font_buffer <- Some buffer; 272 | buffer 273 | in 274 | let add_box ({ Glyph. scale; cp; ttf; blur } as key) () boxes = 275 | match Stb_truetype.find ttf cp with 276 | | None -> 277 | Hashtbl.add t.font_glyphes key null_cell; 278 | boxes 279 | | Some glyph -> 280 | let scale = Stb_truetype.scale_for_pixel_height ttf (float scale /. 10.0) in 281 | let box = Stb_truetype.get_glyph_bitmap_box ttf glyph ~scale_x:scale ~scale_y:scale in 282 | let {Stb_truetype. x0; y0; x1; y1} = box in 283 | let blur_pad = (blur + 9) / 10 in 284 | let pad = (padding + blur_pad) * 2 in 285 | let box = 286 | Maxrects.box 287 | (key, ttf, glyph, scale, box) 288 | (x1 - x0 + pad) 289 | (y1 - y0 + pad) 290 | in 291 | box :: boxes 292 | in 293 | let todo = Hashtbl.fold add_box t.font_todo [] in 294 | let room, boxes = Maxrects.insert_batch buffer.room todo in 295 | let room, boxes = 296 | if List.exists (function None -> true | _ -> false) boxes then ( 297 | let todo = Hashtbl.fold 298 | (fun key cell todo -> 299 | if cell.Glyph.frame = !frame_nr then add_box key () todo else todo) 300 | t.font_glyphes todo 301 | in 302 | Hashtbl.reset t.font_glyphes; 303 | Bigarray.Array1.fill (Stb_image.data buffer.image) 0; 304 | let room = Maxrects.add_bin () 305 | (Stb_image.width buffer.image) 306 | (Stb_image.height buffer.image) 307 | Maxrects.empty 308 | in 309 | Maxrects.insert_batch room todo 310 | ) else (room, boxes) 311 | in 312 | buffer.room <- room; 313 | List.iter (function 314 | | None -> () 315 | | Some {Maxrects. x; y; w; h; box; bin =_} -> 316 | let (key, ttf, glyph, scale, box) = box.Maxrects.tag in 317 | let pad = padding + (key.Glyph.blur + 9) / 20 in 318 | let uv = {Stb_truetype. x0 = x + pad; x1 = x + w - pad; 319 | y0 = y + pad; y1 = y + h - pad} in 320 | Stb_truetype.make_glyph_bitmap 321 | ttf 322 | buffer.image.Stb_image.data 323 | ~width:buffer.image.Stb_image.width 324 | ~height:buffer.image.Stb_image.height 325 | ~scale_x:scale 326 | ~scale_y:scale 327 | uv 328 | glyph; 329 | let uv, box = if key.Glyph.blur = 0 then uv, box else ( 330 | let uv = {Stb_truetype. x0 = x; x1 = x + w - 1; 331 | y0 = y; y1 = y + h - 1} in 332 | let box = box_offset box pad in 333 | Stb_truetype.blur_glyph_bitmap 334 | buffer.image.Stb_image.data 335 | ~width:buffer.image.Stb_image.width 336 | ~height:buffer.image.Stb_image.height 337 | uv 338 | (float key.Glyph.blur /. 10.0); 339 | uv, box 340 | ) 341 | in 342 | Hashtbl.add t.font_glyphes key { Glyph. box; uv; frame = !frame_nr; glyph } 343 | ) boxes; 344 | Hashtbl.reset t.font_todo; 345 | Texture.update buffer.texture buffer.image; 346 | incr frame_nr 347 | 348 | let has_todo stash = Hashtbl.length stash.font_todo > 0 349 | 350 | let allocate_glyphes stash renderer ~sx ~sy (font,_pos,text) = 351 | let _, key = Glyph.key sx sy font in 352 | let r = ref 0 in 353 | let len = String.length text in 354 | let frame_nr = !frame_nr in 355 | let has_todo0 = has_todo stash in 356 | while !r < len do 357 | match utf8_decode r text with 358 | | -1 -> () 359 | | cp -> 360 | let key = key cp in 361 | match Hashtbl.find stash.font_glyphes key with 362 | | cache -> cache.Glyph.frame <- frame_nr 363 | | exception Not_found -> 364 | if not (Hashtbl.mem stash.font_todo key) then 365 | (*(prerr_endline ("new glyph: " ^ string_of_int cp);*) 366 | (Hashtbl.add stash.font_todo key ()) 367 | done; 368 | if not has_todo0 && (has_todo stash) then 369 | Some (fun () -> bake_glyphs renderer stash) 370 | else 371 | None 372 | 373 | type simple_typesetter = (Font.t * Gg.p2 * string) typesetter 374 | 375 | let simple_typesetter () = 376 | let stash = font_stash () in 377 | Wall.Typesetter.make 378 | ~allocate:(allocate_glyphes stash) 379 | ~render:(render_glyphes stash) 380 | 381 | let a_simple_typesetter = lazy (simple_typesetter ()) 382 | 383 | let simple_text 384 | ?(typesetter=Lazy.force a_simple_typesetter) 385 | ?(halign=`LEFT) ?(valign=`BASELINE) font ~x ~y str 386 | = 387 | let x = match halign with 388 | | `LEFT -> x 389 | | `CENTER -> (x -. Font.text_width font str *. 0.5) 390 | | `RIGHT -> (x -. Font.text_width font str) 391 | in 392 | let y = match valign with 393 | | `TOP -> y +. (Font.font_metrics font).Font.ascent 394 | | `BASELINE -> y 395 | | `BOTTOM -> y +. (Font.font_metrics font).Font.descent 396 | | `MIDDLE -> 397 | let {Font. ascent; descent} = Font.font_metrics font in 398 | (y +. (ascent +. descent) *. 0.5) 399 | in 400 | Image.typeset typesetter (font, Gg.P2.v x y, str) 401 | 402 | -------------------------------------------------------------------------------- /lib/wall_text.mli: -------------------------------------------------------------------------------- 1 | open Wall 2 | 3 | val utf8_decode : int ref -> string -> int 4 | (** [utf8_decode r s] returns the unicode codepoint starting at offset [!r], 5 | advancing [r] to the beginning of next codepoint ot [String.length s] when 6 | the end is reached. 7 | If the string was not properly encoded, [-1] is returned and [r] is 8 | advanced to hopefully resume parsing. *) 9 | 10 | module Font : sig 11 | type glyph_placement = [ `Aligned | `Subpixel ] 12 | 13 | type t = { 14 | glyphes : Stb_truetype.t; 15 | size : float; 16 | blur : float; 17 | spacing : float; 18 | line_height : float; 19 | placement : glyph_placement; 20 | } 21 | 22 | val make: 23 | ?size:float -> ?blur:float -> ?spacing:float -> ?line_height:float -> 24 | ?placement:glyph_placement -> Stb_truetype.t -> t 25 | 26 | type metrics = { 27 | ascent : float; 28 | descent : float; 29 | line_gap : float; 30 | } 31 | 32 | val font_metrics: t -> metrics 33 | 34 | val text_width: t -> string -> float 35 | 36 | type measure = { 37 | width : float; 38 | height : float; 39 | depth : float; 40 | } 41 | 42 | val text_measure : t -> string -> measure 43 | end 44 | 45 | type simple_typesetter = (Font.t * Gg.p2 * string) typesetter 46 | 47 | val simple_typesetter : unit -> simple_typesetter 48 | 49 | (** [simple_text ?frame ?halign ?valign font ~x ~y text] is a shape that 50 | represents [text] drawn using [font] at position [x,y]. 51 | 52 | The optionals [halign] and [valign] arguments describe how the text should 53 | be positioned w.r.t point [x,y]. 54 | 55 | halign values: 56 | - [`LEFT], text will start at coordinate [x] ([x] is the leftmost point) 57 | - [`CENTER], text will be centered around [x] 58 | - [`RIGHT], text will end at coordinate [x] ([x] is the rightmost point) 59 | 60 | valign values: 61 | - [`TOP], top of the text will be at coordinate [y], drawing will go below 62 | - [`MIDDLE], text will be vertically centered at coordinate [y] 63 | - [`BOTTOM], bottom of the text will be at coordinate [y], drawing will be 64 | above 65 | - [`BASELINE], the baseline of the text will be at coordinate [y], most 66 | letters will be above but descender (as in letters such as y, p, j, q) 67 | will go below. 68 | *) 69 | val simple_text 70 | : ?typesetter:simple_typesetter 71 | -> ?halign:[`LEFT | `CENTER | `RIGHT] 72 | -> ?valign:[`TOP | `MIDDLE | `BOTTOM | `BASELINE] 73 | -> Font.t -> x:float -> y:float -> string -> Wall.image 74 | -------------------------------------------------------------------------------- /lib/wall_types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2017 Frédéric Bour 3 | 4 | This software is provided 'as-is', without any express or implied 5 | warranty. In no event will the authors be held liable for any damages 6 | arising from the use of this software. 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 1. The origin of this software must not be misrepresented; you must not 11 | claim that you wrote the original software. If you use this software 12 | in a product, an acknowledgment in the product documentation would be 13 | appreciated but is not required. 14 | 2. Altered source versions must be plainly marked as such, and must not be 15 | misrepresented as being the original software. 16 | 3. This notice may not be removed or altered from any source distribution. 17 | *) 18 | 19 | open Gg 20 | 21 | type color = Gg.color 22 | 23 | type transform = { 24 | x00 : float; 25 | x01 : float; 26 | x10 : float; 27 | x11 : float; 28 | x20 : float; 29 | x21 : float; 30 | } 31 | 32 | type 'texture paint = { 33 | xform : transform; 34 | extent : size2; 35 | radius : float; 36 | feather : float; 37 | inner : color; 38 | outer : color; 39 | texture : 'texture option; 40 | } 41 | 42 | type outline = { 43 | stroke_width : float; 44 | miter_limit : float; 45 | line_join : [ `BEVEL | `MITER | `ROUND ]; 46 | line_cap : [ `BUTT | `ROUND | `SQUARE ]; 47 | } 48 | 49 | type frame = { 50 | xform : transform; 51 | extent : size2; 52 | alpha : float; 53 | } 54 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "@opam/wall", 3 | "version": "0.0.1", 4 | "dependencies": { 5 | "@esy-ocaml/esy-installer": "^0.0.0", 6 | "@esy-ocaml/substs": "^0.0.1", 7 | "@opam/gg": "*", 8 | "@opam/grenier": "*", 9 | "@opam/ocamlfind": "", 10 | "@opam/result": "*", 11 | "@opam/stb_image": "*", 12 | "@opam/stb_truetype": "*", 13 | "@opam/tgls": "*", 14 | "@opam/tsdl": "*", 15 | "@opam/conf-pkg-config": "*", 16 | "@opam/dune": "*" 17 | }, 18 | "esy": { 19 | "build": [ 20 | [ "dune", "build"] 21 | ], 22 | "install": [ 23 | [ "esy-installer" ] 24 | ], 25 | "buildsInSource": "_build" 26 | }, 27 | "peerDependencies": { 28 | "ocaml": "~4.6.0" 29 | }, 30 | "devDependencies": { 31 | "ocaml": "~4.6.0" 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /slideshow/Makefile: -------------------------------------------------------------------------------- 1 | slideshow: 2 | dune build presentation.cma 3 | hotcaml-lwt -package lwt.unix -package lwt -package tsdl -package tgls.tgles2 -package wall presentation.ml 4 | -------------------------------------------------------------------------------- /slideshow/Roboto-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/slideshow/Roboto-Regular.ttf -------------------------------------------------------------------------------- /slideshow/RobotoMono-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/slideshow/RobotoMono-Regular.ttf -------------------------------------------------------------------------------- /slideshow/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name presentation) 3 | (libraries lwt lwt.unix tsdl tgls.tgles2 wall hotcaml.hotlink)) 4 | -------------------------------------------------------------------------------- /slideshow/nyan_cat.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/wall/42acca539d2797c6038a8b69b567babcee2bb0bf/slideshow/nyan_cat.png -------------------------------------------------------------------------------- /slideshow/old/driver.ml: -------------------------------------------------------------------------------- 1 | let packages, sources = 2 | let add l x = l := x :: !l in 3 | let packages = ref [] in 4 | let sources = ref [] in 5 | let spec = [ 6 | ("-package", Arg.String (add packages), "Load a findlib package") 7 | ] in 8 | Arg.parse spec (add sources) 9 | (Printf.sprintf "Usage: %s [-package findlib-package ...] source.ml ..." 10 | Sys.argv.(0)); 11 | (List.rev !packages, List.rev !sources) 12 | 13 | let add_dir = 14 | let directories = ref [] in 15 | fun dir -> 16 | if not (List.mem dir !directories) then ( 17 | Printf.ksprintf prerr_endline "Loading %S" dir; 18 | Topdirs.dir_directory dir; 19 | directories := dir :: !directories 20 | ) 21 | 22 | let () = add_dir 23 | (Filename.concat (Filename.dirname Sys.executable_name) ".driver.eobjs/byte") 24 | 25 | let rec dedup = function 26 | | x :: xs when List.mem x xs -> dedup xs 27 | | x :: xs -> x :: dedup xs 28 | | [] -> [] 29 | 30 | let loaded = ref [] 31 | 32 | let load packages = 33 | loaded := packages @ !loaded; 34 | packages 35 | |> List.map Findlib.package_directory 36 | |> dedup 37 | |> List.iter add_dir 38 | 39 | let load_and_link packages = 40 | let packages = List.filter (fun pkg -> not (List.mem pkg !loaded)) packages in 41 | load packages; 42 | Fl_dynload.load_packages packages 43 | 44 | let () = 45 | Toploop.initialize_toplevel_env (); 46 | Findlib.init (); 47 | load ["wall"; "tgls.tgles2"; "tsdl"; "findlib.dynload"; "result"; 48 | "compiler-libs.toplevel"; "stb_image"; "stb_truetype"; "gg"]; 49 | load_and_link packages; 50 | Slideshow.auto_reload sources 51 | -------------------------------------------------------------------------------- /slideshow/old/mod_use.ml: -------------------------------------------------------------------------------- 1 | let mod_use fname = 2 | let buf = Buffer.create 256 in 3 | let fmt = Format.formatter_of_buffer buf in 4 | if not (Toploop.mod_use_file fmt fname) then ( 5 | Format.pp_print_flush fmt (); 6 | prerr_endline (Buffer.contents buf) 7 | ) 8 | -------------------------------------------------------------------------------- /slideshow/pres_state.ml: -------------------------------------------------------------------------------- 1 | open Wall 2 | 3 | let background = 4 | Paint.linear_gradient ~sx:0.0 ~sy:0.0 ~ex:1024.0 ~ey:0.0 5 | ~inner:Color.white ~outer:(Color.with_a Color.blue 0.5) 6 | 7 | let mediabox = Path.make @@ fun t -> 8 | Path.rect t ~x:0.0 ~y:0.0 ~w:1024.0 ~h:768.0 9 | 10 | let load_font name = 11 | let ic = open_in_bin name in 12 | let dim = in_channel_length ic in 13 | let fd = Unix.descr_of_in_channel ic in 14 | let buffer = 15 | Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [|dim|] 16 | |> Bigarray.array1_of_genarray 17 | in 18 | let offset = List.hd (Stb_truetype.enum buffer) in 19 | match Stb_truetype.init buffer offset with 20 | | None -> assert false 21 | | Some font -> font 22 | 23 | let font_sans = load_font "Roboto-Regular.ttf" 24 | let font_mono = load_font "RobotoMono-Regular.ttf" 25 | 26 | let nyan_cat = 27 | let last = ref None in 28 | fun t -> 29 | match !last with 30 | | Some (t', tex) when t == t' -> tex 31 | | _ -> 32 | let result = match Stb_image.load "nyan_cat.png" with 33 | | Result.Error (`Msg x) -> 34 | Printf.ksprintf prerr_endline "loading nyan_cat: %s" x; 35 | failwith "No image" 36 | | Result.Ok img -> Wall.Texture.from_image t ~name:"nyan" img 37 | in 38 | last := Some (t, result); 39 | result 40 | -------------------------------------------------------------------------------- /slideshow/presentation.ml: -------------------------------------------------------------------------------- 1 | [@@@ocaml.warning "-6"] 2 | open Wall 3 | open Wall_text 4 | open Pres_state 5 | ;; 6 | 7 | let default_font ?(size=1.0) () = 8 | Font.make ~size:(64.0 *. size) font_sans 9 | ~placement:`Subpixel 10 | 11 | let title_banner = Path.make (fun ctx -> 12 | Path.rect ctx ~x:0.0 ~y:0.0 ~w:1024.0 ~h:128.0 13 | ) 14 | 15 | let b2 x y w h = Gg.Box2.v (Gg.P2.v x y) (Gg.Size2.v w h) 16 | let body_box = b2 0.0 128.0 1024.0 640.0 17 | 18 | let light_blue = Color.lerp_rgba 0.2 Color.white Color.blue 19 | let light_yellow = Color.v 1.0 1.0 0.0 1.0 20 | 21 | let title = 22 | let color = Paint.rgba 0.0 0.0 0.0 1.0 in 23 | let title_fg = Font.make ~size:96.0 font_sans in 24 | let title_bg = Font.make ~blur:6.0 ~size:96.0 font_sans in 25 | fun text content-> 26 | [ Image.paint Paint.white (Image.fill mediabox); 27 | Image.paint background (Image.fill title_banner); 28 | Image.paint color ( 29 | Image.seq [ 30 | simple_text title_bg text 31 | ~x:514.0 ~y:18.0 ~halign:`CENTER ~valign:`TOP; 32 | simple_text title_fg text 33 | ~x:512.0 ~y:16.0 ~halign:`CENTER ~valign:`TOP; 34 | ] 35 | ); 36 | Image.scissor body_box (Image.seq content) 37 | ] 38 | 39 | let draw_arrow ~x ~y ~size color = 40 | Image.paint (Paint.color color) 41 | (Image.fill_path @@ fun t -> 42 | Path.move_to t x y; 43 | Path.line_to t (x-.size) (y+.size); 44 | Path.line_to t (x-.size) (y-.size); 45 | Path.close t; 46 | ) 47 | 48 | let text ?(halign=`LEFT) ?size ~x ~y str = 49 | simple_text ~x ~y ~halign ~valign:`BASELINE (default_font ?size ()) str 50 | 51 | let text_arrow ~x ~y str = 52 | Image.seq [ 53 | draw_arrow ~x ~y ~size:16.0 Color.blue; 54 | text ~x:(x +. 20.0) ~y:(y +. 14.0) str 55 | ] 56 | 57 | let make_outlines a_title steps step = 58 | let render_step i (step', title) = 59 | let text = text_arrow ~x:220.0 ~y:(250.0 +. 100.0 *. float i) title in 60 | if step = step' then 61 | text 62 | else 63 | Image.alpha 0.5 text 64 | in 65 | let steps = List.mapi render_step steps in 66 | title a_title steps 67 | 68 | let code fmt = 69 | let size = 36.0 in 70 | let interline = size +. 4.0 in 71 | let font = Font.make ~size font_mono in 72 | Printf.ksprintf 73 | (fun source -> 74 | let rec lines i = 75 | match String.index_from source i '\n' with 76 | | j -> String.sub source i (j - i) :: lines (j + 1) 77 | | exception Not_found -> [String.sub source i (String.length source - i)] 78 | in 79 | let lines = lines 0 in 80 | let h = 768.0 -. interline *. float (List.length lines) in 81 | Image.seq ( 82 | List.mapi (fun i line -> 83 | Wall_text.simple_text font line 84 | ~halign:`LEFT ~valign:`BASELINE 85 | ~x:10.0 ~y:(h +. float i *. interline) 86 | ) lines 87 | )) 88 | fmt 89 | 90 | let pf () f = 91 | if f < 0.0 then 92 | Printf.sprintf "(%.02f)" f 93 | else 94 | Printf.sprintf "%.02f" f 95 | 96 | type outline = [ 97 | | `Problem_solved 98 | | `Model 99 | | `API 100 | | `Execution 101 | | `Conclusion 102 | ] 103 | 104 | type api_outline = [ 105 | | `Path 106 | | `Shape 107 | | `Paint 108 | | `Transformation 109 | | `Composition 110 | ] 111 | 112 | let outline : outline -> _ = 113 | make_outlines "Outline" [ 114 | `Problem_solved , "The problem solved"; 115 | `Model , "Model"; 116 | `API , "API"; 117 | `Execution , "Execution"; 118 | `Conclusion , "Conclusion"; 119 | ] 120 | 121 | let api_outline : api_outline -> _ = 122 | make_outlines "API" [ 123 | `Path , "Path ([0,1] -> Point)"; 124 | `Shape , "Shape (Point -> Bool)"; 125 | `Paint , "Paint (Point -> Color)"; 126 | `Transformation , "Transformation (Point -> Point)"; 127 | `Composition , "Composition (Image* -> Image)"; 128 | ] 129 | 130 | let shape_slide = 131 | let square = Path.make (fun ctx -> 132 | Path.rect ctx (-150.0) (-50.0) 100.0 100.0 133 | ) in 134 | let circle = Path.make (fun ctx -> 135 | Path.circle ctx 100.0 0.0 100.0 136 | ) in 137 | title "Shapes" [ 138 | Image.transform (Transform.translation 512.0 444.0) 139 | (Image.seq [ Image.fill square; Image.fill circle ]); 140 | code "Point = R * R\n\ 141 | Shape ~= Point -> Bool" 142 | ] 143 | ;; 144 | 145 | let sample_path = Path.make (fun ctx -> 146 | Path.move_to ctx 0.0 0.0; 147 | Path.line_to ctx 50.0 0.0; 148 | Path.bezier_to ctx 100.0 (-30.0) 100.0 (-90.0) 50.0 (-60.0); 149 | Path.bezier_to ctx 60.0 (-120.0) (-20.0) (-120.0) 0.0 0.0; 150 | ) 151 | ;; 152 | open Slideshow;; 153 | 154 | Slideshow.set_slides Slideshow.window ([ 155 | (fun _ -> title "The Wall library" 156 | [ 157 | text ~halign:`CENTER ~x:512.0 ~y:250.0 "Frédéric Bour"; 158 | text ~halign:`CENTER ~x:512.0 ~y:350.0 "OCaml Workshop 2018"; 159 | text ~halign:`CENTER ~x:512.0 ~y:450.0 "Thursday, September 27"; 160 | text_arrow ~x:152.0 ~y:600.0 "Graphics"; 161 | text_arrow ~x:412.0 ~y:600.0 "in OCaml"; 162 | text_arrow ~x:672.0 ~y:600.0 "with fun"; 163 | ] 164 | ); 165 | (fun _ -> outline `Problem_solved); 166 | (fun _ -> title "Key points" 167 | [ 168 | text ~x:80.0 ~y:280.0 "1) Declarative vector graphics"; 169 | text ~x:80.0 ~y:450.0 "2) Rendered with OpenGL"; 170 | text ~x:80.0 ~y:620.0 "3) Independent from a windowing system"; 171 | ] 172 | ); 173 | (fun _ -> title "Tradeoffs" 174 | [ 175 | text_arrow ~x:100.0 ~y:200.0 "Made for user interfaces"; 176 | text_arrow ~x:100.0 ~y:300.0 "Goals:"; 177 | text ~x:140.0 ~y:380.0 "(1) High output quality"; 178 | text ~x:140.0 ~y:440.0 "(2) Performance"; 179 | text ~x:140.0 ~y:500.0 "(3) Simplicity"; 180 | text_arrow ~x:100.0 ~y:580.0 "Non-goal: expressivity"; 181 | ] 182 | ); 183 | (fun _ -> outline `Model); 184 | (fun _ -> shape_slide); 185 | (fun st -> 186 | let paint_slide = 187 | let rect = Path.make (fun ctx -> 188 | Path.rect ctx 0.0 128.0 1024.0 640.0 189 | ) in 190 | title "Paint" [ 191 | Image.paint (Paint.color (Color.v_srgb 1.0 1.0 0.0)) 192 | (Image.fill rect); 193 | code "Color = [0,1]^4\n\ 194 | Paint ~= Point -> Color" 195 | ] 196 | in 197 | if st.time > 0.25 198 | then paint_slide 199 | else 200 | let progress = st.time /. 0.25 in 201 | [ 202 | Image.transform 203 | (Transform.translation (-. progress *. 1024.0) 0.0) 204 | (Image.seq shape_slide); 205 | Image.transform 206 | (Transform.translation ((1.0 -. progress) *. 1024.0) 0.0) 207 | (Image.seq paint_slide); 208 | ] 209 | ); 210 | (fun st -> 211 | let circle = Path.make (fun ctx -> 212 | Path.circle ctx 0.0 0.0 100.0 213 | ) in 214 | let paint = Paint.color (Color.v_srgb 1.0 1.0 0.0) in 215 | title "Painted shapes" [ 216 | Image.transform (Transform.translation 512.0 444.0) 217 | (Image.transform 218 | (let f = max (10.0 *. (1.0 -. st.time)) 1.0 in Transform.scale f f) 219 | (Image.paint paint (Image.fill circle))); 220 | code "Image ~= Point -> Color\n\ 221 | primitive(shape, paint) ~=\n\ 222 | \ fun point -> if shape point then paint point\n\ 223 | \ else zero" 224 | ]); 225 | (fun st -> 226 | let circle = Path.make (fun ctx -> 227 | Path.circle ctx 0.0 0.0 100.0 228 | ) in 229 | let paint = Paint.color (Color.v_srgb 1.0 1.0 0.0) in 230 | title "Transform" [ 231 | Image.transform (Transform.translation 512.0 444.0) 232 | (Image.transform 233 | (let f = (1.0 +. min st.time 1.0) in 234 | Transform.rescale ~sx:(1.0 +. f /. 4.0) ~sy:f 235 | (Transform.translation ~x:0.0 ~y:(f *. -30.0))) 236 | (Image.paint paint (Image.fill circle))); 237 | code "Transformation ~= Point -> Point\n\ 238 | transform(image, t) ~=\n\ 239 | \ fun point -> image(t(point))" 240 | ]); 241 | (fun _st -> 242 | let outline = Outline.make ~cap:`ROUND ~width:10.0 () in 243 | let circle = Path.make (fun ctx -> 244 | Path.circle ctx 0.0 0.0 100.0 245 | ) in 246 | let eye = 247 | let contour = Path.make (fun ctx -> 248 | Path.circle ctx 0.0 0.0 30.0 249 | ) in 250 | let dot = Path.make (fun ctx -> 251 | Path.circle ctx 0.0 0.0 10.0 252 | ) in 253 | Image.seq [ 254 | Image.paint Paint.white (Image.fill contour); 255 | Image.stroke outline contour; 256 | Image.fill dot; 257 | ] 258 | in 259 | let smile = 260 | let path = Path.make (fun ctx -> 261 | Path.move_to ctx (-50.0) 0.0; 262 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 263 | ) 264 | in 265 | Image.stroke outline path 266 | in 267 | let base = Color.v_srgb 1.0 1.0 0.0 in 268 | let paint = 269 | Paint.linear_gradient (-100.0) 0.0 350.0 300.0 base Color.black 270 | in 271 | title "Repeat!" [ 272 | Image.transform (Transform.translation 512.0 384.0) (Image.seq [ 273 | Image.transform 274 | (Transform.scale 1.5 2.0) 275 | (Image.paint paint (Image.fill circle)); 276 | Image.transform (Transform.translation (-60.0) (-90.0)) eye; 277 | Image.transform (Transform.translation (60.0) (-90.0)) eye; 278 | Image.transform (Transform.translation 0.0 10.0) smile; 279 | ]); 280 | code "blend(image_0, image_1, ...)" 281 | ]); 282 | (fun _ -> outline `API); 283 | (fun _ -> api_outline `Path); 284 | (fun _ -> 285 | let p = Path.make (fun ctx -> 286 | Path.move_to ctx 0.0 0.0; 287 | ) 288 | in 289 | title "Path" [ 290 | Image.transform 291 | (Transform.rescale 2.0 2.0 (Transform.translation 512.0 444.0)) 292 | (Image.stroke Outline.default p); 293 | code "let path = Path.make (fun ctx ->\n\ 294 | \ \n\ 295 | \ \n\ 296 | \ \n\ 297 | \ \n\ 298 | )" 299 | ]); 300 | (fun _ -> 301 | let p = Path.make (fun ctx -> 302 | Path.move_to ctx 0.0 0.0; 303 | ) 304 | in 305 | title "Path" [ 306 | Image.transform 307 | (Transform.rescale 2.0 2.0 (Transform.translation 512.0 444.0)) 308 | (Image.stroke Outline.default p); 309 | code "let path = Path.make (fun ctx ->\n\ 310 | \ Path.move_to ctx 0. 0.;\n\ 311 | \ \n\ 312 | \ \n\ 313 | \ \n\ 314 | )" 315 | ]); 316 | (fun _ -> 317 | let p = Path.make (fun ctx -> 318 | Path.move_to ctx 0.0 0.0; 319 | Path.line_to ctx 50.0 0.0; 320 | ) 321 | in 322 | title "Path" [ 323 | Image.transform 324 | (Transform.rescale 2.0 2.0 (Transform.translation 512.0 444.0)) 325 | (Image.stroke Outline.default p); 326 | code "let path = Path.make (fun ctx ->\n\ 327 | \ Path.move_to ctx 0. 0.;\n\ 328 | \ Path.line_to ctx 50. 0.;\n\ 329 | \ \n\ 330 | \ \n\ 331 | )" 332 | ]); 333 | (fun _ -> 334 | let p = Path.make (fun ctx -> 335 | Path.move_to ctx 0.0 0.0; 336 | Path.line_to ctx 50.0 0.0; 337 | Path.bezier_to ctx 100.0 (-30.0) 100.0 (-90.0) 50.0 (-60.0); 338 | ) 339 | in 340 | title "Path" [ 341 | Image.transform 342 | (Transform.rescale 2.0 2.0 (Transform.translation 512.0 444.0)) 343 | (Image.stroke Outline.default p); 344 | code "let path = Path.make (fun ctx ->\n\ 345 | \ Path.move_to ctx 0. 0.;\n\ 346 | \ Path.line_to ctx 50. 0.;\n\ 347 | \ Path.bezier_to ctx 10. (-3.) 10. (-9.) 5. (-6.);\n\ 348 | \ \n\ 349 | )" 350 | ]); 351 | (fun _ -> 352 | title "Path" [ 353 | Image.transform 354 | (Transform.rescale 2.0 2.0 (Transform.translation 512.0 444.0)) 355 | (Image.stroke Outline.default sample_path); 356 | code "let path = Path.make (fun ctx ->\n\ 357 | \ Path.move_to ctx 0. 0.;\n\ 358 | \ Path.line_to ctx 50. 0.;\n\ 359 | \ Path.bezier_to ctx 10. (-3.) 10. (-9.) 5. (-6.);\n\ 360 | \ Path.bezier_to ctx 6. (-12.) (-2.) (-12.) 0. 0.;\n\ 361 | )" 362 | ]); 363 | (fun _ -> api_outline `Shape); 364 | (fun _ -> 365 | title "Filling path" [ 366 | Image.transform 367 | (Transform.rescale 2.0 2.0 (Transform.translation 512.0 444.0)) 368 | (Image.fill sample_path); 369 | code "Image.fill path"; 370 | ]); 371 | (fun st -> 372 | let width = (sin st.time *. sin st.time) *. 10.0 in 373 | title "Stroking path" [ 374 | Image.transform 375 | (Transform.rescale 2.0 2.0 (Transform.translation 512.0 444.0)) 376 | (Image.stroke (Outline.make ~width ()) sample_path); 377 | code "Image.stroke (Outline.make ~width:%a ()) path" pf width; 378 | ]); 379 | (fun _ -> 380 | title "Glyphes & Masks" [ 381 | text_arrow ~x:100.0 ~y:200.0 "For complex or external shapes:"; 382 | text ~x:150.0 ~y:280.0 "use a bitmap as a discrete"; 383 | text ~x:150.0 ~y:340.0 "approximation of (Point -> Bool)"; 384 | text ~x:150.0 ~y:400.0 "([0..n] * [0..m] -> [0..255])"; 385 | text_arrow ~x:100.0 ~y:460.0 "Adjust resolution dynamically"; 386 | text_arrow ~x:100.0 ~y:540.0 "Abstraction for laying out glyphes"; 387 | code "type 'a typesetter\n\ 388 | Image.typeset : 'a typesetter -> 'a -> image"; 389 | ]); 390 | (fun _ -> api_outline `Paint); 391 | (fun _ -> 392 | title "Paint: color" [ 393 | Image.paint (Paint.color light_yellow) 394 | (Image.fill mediabox); 395 | code "Paint.color light_yellowred" 396 | ]); 397 | (fun st -> 398 | let t = st.time /. 4.0 in 399 | let s = sin (t *. 2.0) and c = cos (t *. 3.0) in 400 | let sx = 24.0 +. abs_float s *. 200.0 in 401 | let ex = 1000.0 -. abs_float c *. 200.0 in 402 | title "Paint: linear" [ 403 | Image.paint (Paint.linear_gradient sx 0.0 ex 0.0 404 | light_yellow light_blue) 405 | (Image.fill mediabox); 406 | code "Paint.linear_gradient %a 0.0 %a 0.0" pf sx pf ex 407 | ]); 408 | (fun st -> 409 | let t = st.time /. 4.0 in 410 | let s = sin (t *. 2.0) and c = cos (t *. 3.0) in 411 | let r = abs_float (s *. 100.0) in 412 | let f = abs_float (c *. 50.0) in 413 | title "Paint: box" [ 414 | Image.paint (Paint.box_gradient 160.0 228.0 704.0 360.0 r f 415 | light_yellow light_blue) 416 | (Image.fill mediabox); 417 | code "Paint.box_gradient ~x ~y ~w ~h\n\ 418 | \ ~r:%a ~f:%a light_yellow light_blue" pf r pf f 419 | ]); 420 | (fun st -> 421 | let t = st.time /. 4.0 in 422 | let s = sin (t *. 2.0) and c = cos (t *. 3.0) in 423 | let inner = s *. s *. 200.0 in 424 | let outer = inner +. c *. c *. 100.0 in 425 | title "Paint: radial" [ 426 | Image.paint (Paint.radial_gradient 512.0 444.0 inner outer 427 | light_yellow light_blue) 428 | (Image.fill mediabox); 429 | code "Paint.radial_gradient ~cx ~cy\n\ 430 | \ ~inner:%a ~outer:%a" pf inner pf outer; 431 | ]); 432 | (fun st -> 433 | let angle = sin st.time /. 2.0 in 434 | let alpha = 0.5 +. abs_float (sin (st.time *. 4.0)) /. 2.0 in 435 | title "Paint: pixmaps" [ 436 | Image.paint 437 | (Paint.transform 438 | (Paint.image_pattern 439 | (Gg.V2.v (-1146.0/.4.0) (-700.0/.4.0)) 440 | (Gg.V2.v (1146.0 /. 2.0) (696.0 /. 2.0)) 441 | ~angle 442 | ~alpha 443 | (Pres_state.nyan_cat st.wall)) 444 | (Transform.translation 500.0 400.0) 445 | ) (Image.fill mediabox); 446 | code "Paint.image_pattern (x,y) (w,h) \n\ 447 | \ ~angle:%.02f ~alpha:%a nyan_cat" 448 | (mod_float angle (pi *. 2.0)) pf alpha; 449 | ]); 450 | (fun _ -> api_outline `Transformation); 451 | (fun st -> 452 | let rect = 453 | Path.make (fun ctx -> Path.rect ctx (-60.0) (-20.0) 120.0 40.0) 454 | in 455 | let sx = sin (st.time *. 2.0) *. 200.0 in 456 | let sy = cos (st.time *. 3.0) *. 200.0 in 457 | title "Transformation: translation" [ 458 | Image.transform 459 | (Transform.translation 512.0 444.0) 460 | (Image.transform 461 | (Transform.translation sx sy) 462 | (Image.fill rect)); 463 | code "Image.transform (translation %a %a) rect" pf sx pf sy; 464 | ]); 465 | (fun st -> 466 | let rect = 467 | Path.make (fun ctx -> Path.rect ctx (-60.0) (-20.0) 120.0 40.0) 468 | in 469 | let a = st.time *. 2.0 in 470 | title "Transformation: rotation" [ 471 | Image.transform 472 | (Transform.translation 512.0 444.0) 473 | (Image.transform 474 | (Transform.rotation a) 475 | (Image.fill rect)); 476 | code "Image.transform (rotation %a) rect" pf a; 477 | ]); 478 | (fun st -> 479 | let rect = 480 | Path.make (fun ctx -> Path.rect ctx (-60.0) (-20.0) 120.0 40.0) 481 | in 482 | let sx = 1.0 +. sin (st.time *. 2.0) *. 2.0 in 483 | let sy = 1.0 +. cos (st.time *. 3.0) *. 4.0 in 484 | title "Transformation: scaling" [ 485 | Image.transform 486 | (Transform.translation 512.0 444.0) 487 | (Image.transform (Transform.scale sx sy) (Image.fill rect)); 488 | code "Image.transform (scale %a %a) rect" pf sx pf sy; 489 | ]); 490 | (fun st -> 491 | let rect = 492 | Path.make (fun ctx -> Path.rect ctx (-60.0) (-20.0) 120.0 40.0) 493 | in 494 | let sx = sin (st.time *. 2.0) in 495 | let sy = cos (st.time *. 3.0) in 496 | title "Transformation: skewing" [ 497 | Image.transform 498 | (Transform.translation 512.0 444.0) 499 | (Image.transform (Transform.skew sx sy) (Image.fill rect)); 500 | code "Image.transform (skew %a %a) rect" pf sx pf sy; 501 | ]); 502 | (fun _ -> api_outline `Composition); 503 | (fun _st -> 504 | let rect = 505 | Path.make (fun ctx -> Path.rect ctx (-120.0) (-120.0) 240.0 240.0) 506 | in 507 | title "Composition: paint" [ 508 | Image.transform 509 | (Transform.translation 512.0 444.0) 510 | (Image.paint 511 | (Paint.linear_gradient (-120.0) (-120.0) 120.0 120.0 512 | light_yellow light_blue) 513 | (Image.fill rect)); 514 | code "Image.paint linear_gradient square"; 515 | ]); 516 | (fun st -> 517 | let rect = 518 | Path.make (fun ctx -> Path.rect ctx (-120.0) (-120.0) 240.0 240.0) 519 | in 520 | let circle = 521 | Path.make (fun ctx -> Path.circle ctx 0.0 0.0 120.0) 522 | in 523 | let t = st.time *. 3.0 in 524 | let y = 200.0 *. sin t in 525 | let a = t /. 10.0 in 526 | title "Composition: superposition" [ 527 | Image.transform 528 | (Transform.translation 512.0 444.0) 529 | (Image.seq [ 530 | Image.paint 531 | (Paint.linear_gradient (-120.0) (-120.0) 120.0 120.0 532 | light_yellow light_blue) 533 | (Image.fill rect); 534 | Image.transform 535 | (Transform.translate 0.0 y (Transform.rotation a)) 536 | (Image.paint 537 | (Paint.radial_gradient 0.0 0.0 20.0 180.0 538 | light_yellow light_blue) 539 | (Image.fill circle)); 540 | ]); 541 | code 542 | "Image.superpose square\n\ 543 | \ (moving_circle ~offset:%a ~angle:%a)" 544 | pf y pf a 545 | ]); 546 | (fun st -> 547 | let circle = 548 | Path.make (fun ctx -> Path.circle ctx 0.0 0.0 120.0) 549 | in 550 | let t = st.time *. 3.0 in 551 | let y = 200.0 *. sin t in 552 | let a = t /. 10.0 in 553 | title "Composition: scissor" [ 554 | Image.transform 555 | (Transform.translation 512.0 444.0) 556 | (Image.seq [ 557 | Image.scissor (b2 (-120.0) (-120.0) 240.0 240.0) 558 | (Image.transform 559 | (Transform.translate 0.0 y 560 | (Transform.rotation a)) 561 | (Image.paint 562 | (Paint.radial_gradient 0.0 0.0 20.0 180.0 563 | light_yellow light_blue) 564 | (Image.fill circle))) 565 | ]); 566 | code 567 | "Image.scissor box\n\ 568 | \ (moving_circle ~offset:%a ~angle:%a)" 569 | pf y pf a 570 | ]); 571 | (fun st -> 572 | let rect = 573 | Path.make (fun ctx -> Path.rect ctx (-120.0) (-120.0) 240.0 240.0) 574 | in 575 | let circle = 576 | Path.make (fun ctx -> Path.circle ctx 0.0 0.0 120.0) 577 | in 578 | let v_alpha = (0.5 +. sin st.time /. 2.0) in 579 | title "Composition: alpha" [ 580 | Image.transform 581 | (Transform.translation 512.0 444.0) 582 | (Image.seq [ 583 | Image.paint 584 | (Paint.linear_gradient (-120.0) (-120.0) 120.0 120.0 585 | light_yellow light_blue) 586 | (Image.fill rect); 587 | Image.alpha v_alpha 588 | (Image.paint 589 | (Paint.radial_gradient 0.0 0.0 20.0 180.0 590 | light_yellow light_blue) 591 | (Image.fill circle)); 592 | ]); 593 | code "Image.superpose square (Image.alpha %a circle)" pf v_alpha 594 | ]); 595 | (fun _ -> outline `Execution) 596 | ] @ Tree_slides.slides @ [ 597 | (fun _ -> outline `Conclusion); 598 | (fun _ -> title "Current state" 599 | [ 600 | text_arrow ~x:100.0 ~y:200.0 "Versatile vector graphics renderer"; 601 | text_arrow ~x:100.0 ~y:300.0 "Declarative API"; 602 | text_arrow ~x:100.0 ~y:400.0 "Attention to performance and portability"; 603 | text_arrow ~x:100.0 ~y:500.0 "Codebase understandable by 1 person"; 604 | ] 605 | ); 606 | (fun _ -> title "Future work" 607 | [ 608 | text_arrow ~x:100.0 ~y:200.0 "(maybe) a video game rendering path"; 609 | text_arrow ~x:100.0 ~y:300.0 "Cleanup, tweak performance..."; 610 | text_arrow ~x:100.0 ~y:400.0 "Build the rest of a graphic stack"; 611 | ] 612 | ); 613 | (fun _ -> title "Acknowledgements" 614 | [ 615 | text ~x:100.0 ~y:250.0 "Thanks to Pierre Chambart,"; 616 | text ~x:110.0 ~y:350.0 "Sébastien Mondet and Jordan Walke."; 617 | text ~x:100.0 ~y:550.0 "Thanks to Mikko Mononen for NanoVG,"; 618 | text ~x:110.0 ~y:650.0 "the original engine behind Wall."; 619 | ] 620 | ); 621 | (fun st -> title "Acknowledgements" 622 | [ 623 | text ~x:100.0 ~y:450.0 "And one last thing..."; 624 | Image.transform (Transform.rotate st.time (Transform.translation 100.0 250.0)) ( 625 | Image.seq ( 626 | if true then [ 627 | text ~x:0.0 ~y:(-20.0) "Thanks for your attention"; 628 | text ~x:0.0 ~y:(20.0) "Live coding is cool"; 629 | ] else [] 630 | )); 631 | text ~x:100.0 ~y:650.0 "Ph'nglui mglw'nafh"; 632 | text ~x:100.0 ~y:710.0 "Cthulhu R'lyeh wgah'nagl fhtagn!"; 633 | ] 634 | )] 635 | ) 636 | ;; 637 | 638 | let () = print_endline "foo" 639 | -------------------------------------------------------------------------------- /slideshow/slide.top: -------------------------------------------------------------------------------- 1 | #require "tgls.tgles2.top,tsdl.top,wall";; 2 | #load "mod_use.cmo";; 3 | #mod_use "slideshow.ml";; 4 | -------------------------------------------------------------------------------- /slideshow/slideshow.ml: -------------------------------------------------------------------------------- 1 | [@@@ocaml.warning "-6-9-27"] 2 | open Tsdl 3 | open Tgles2 4 | 5 | let (>>=) x f = match x with 6 | | Ok a -> f a 7 | | Error x as result -> result 8 | 9 | let on_failure ~cleanup result = 10 | begin match result with 11 | | Ok _ -> () 12 | | Error _ -> cleanup () 13 | end; 14 | result 15 | 16 | let get_result = function 17 | | Ok x -> x 18 | | Error (`Msg msg) -> failwith msg 19 | 20 | let initialized = lazy (Sdl.init Sdl.Init.video) 21 | 22 | type state = { 23 | time: float; 24 | wall: Wall.renderer; 25 | } 26 | 27 | type slide = state -> Wall.image list 28 | 29 | let ticks () = 30 | Int32.to_int (Sdl.get_ticks ()) 31 | 32 | type window = { 33 | win: Sdl.window; 34 | gl: Sdl.gl_context; 35 | wall: Wall.renderer; 36 | event: Sdl.event; 37 | mutable quit: bool; 38 | mutable running_since: int option; 39 | mutable prev_slides : slide list; 40 | mutable next_slides : slide list; 41 | mutable time_acc: float; 42 | mutable fullscreen: bool; 43 | } 44 | 45 | let make_window ~w ~h = 46 | Lazy.force initialized >>= fun () -> 47 | Sdl.create_window ~w ~h "Slideshow" 48 | Sdl.Window.(opengl + allow_highdpi + resizable + hidden) 49 | >>= fun win -> 50 | ignore (Sdl.gl_set_swap_interval (-1)); 51 | ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); 52 | on_failure ( 53 | Sdl.gl_create_context win >>= fun gl -> 54 | let wall = Wall.Renderer.create ~antialias:true ~stencil_strokes:true () in 55 | Ok { win; gl; wall; event = Sdl.Event.create (); 56 | prev_slides = []; next_slides = []; 57 | quit = false; running_since = None; time_acc = 0.0; fullscreen = false } 58 | ) ~cleanup:(fun () -> Sdl.destroy_window win) 59 | 60 | let get_time t = 61 | match t.running_since with 62 | | None -> t.time_acc 63 | | Some tick0 -> t.time_acc +. float (ticks () - tick0) /. 1000.0 64 | 65 | let set_pause t pause = 66 | if pause then ( 67 | t.time_acc <- get_time t; 68 | t.running_since <- None; 69 | ) else ( 70 | t.running_since <- Some (ticks ()) 71 | ) 72 | 73 | let reset_time t = 74 | t.time_acc <- 0.0; 75 | set_pause t false 76 | 77 | let set_slides t slides = 78 | let rec select_slides acc prevs nexts = 79 | match prevs, nexts with 80 | | (_ :: prevs'), (next :: nexts') -> 81 | select_slides (next :: acc) prevs' nexts' 82 | | _, _ -> acc, nexts 83 | in 84 | let prev_slides, next_slides = select_slides [] t.prev_slides slides in 85 | t.prev_slides <- prev_slides; 86 | t.next_slides <- next_slides 87 | 88 | let render_slide t slide = 89 | Sdl.gl_make_current t.win t.gl >>= fun () -> 90 | let (width, height) as physical_size = Sdl.gl_get_drawable_size t.win in 91 | Gl.viewport 0 0 width height; 92 | Gl.clear_color 0.0 0.0 0.0 1.0; 93 | Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); 94 | Gl.enable Gl.blend; 95 | Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha; 96 | Gl.enable Gl.cull_face_enum; 97 | Gl.disable Gl.depth_test; 98 | let width = float width and height = float height in 99 | let transform = 100 | let r = 1024.0 /. 768.0 in 101 | let r' = width /. height in 102 | let r = 103 | if r' > r then 104 | (height /. 768.0) 105 | else 106 | (width /. 1024.0) 107 | in 108 | let x = (width -. 1024.0 *. r) /. 2.0 in 109 | let y = (height -. 768.0 *. r) /. 2.0 in 110 | Wall.Transform.rescale r r 111 | (Wall.Transform.translation x y) 112 | (*Wall.Transform.translate ~x ~y (Wall.Transform.scale r r)*) 113 | in 114 | Wall.Renderer.render t.wall ~width ~height 115 | (Wall.Image.transform transform slide); 116 | Sdl.gl_swap_window t.win; 117 | Ok () 118 | 119 | let process_events t = 120 | while Sdl.poll_event (Some t.event) do 121 | let run_action = function 122 | | `Quit -> t.quit <- true 123 | | `Prev -> 124 | begin match t.prev_slides with 125 | | x :: xs -> 126 | t.next_slides <- x :: t.next_slides; 127 | t.prev_slides <- xs; 128 | reset_time t 129 | | [] -> () 130 | end 131 | | `Next -> 132 | begin match t.next_slides with 133 | | x :: xs -> 134 | t.prev_slides <- x :: t.prev_slides; 135 | t.next_slides <- xs; 136 | reset_time t 137 | | [] -> () 138 | end 139 | | `Pause -> set_pause t (t.running_since <> None) 140 | | `Fullscreen -> 141 | t.fullscreen <- not t.fullscreen; 142 | ignore (Sdl.show_cursor (not t.fullscreen) : _ result); 143 | ignore (Sdl.set_window_fullscreen t.win 144 | (if t.fullscreen 145 | then Sdl.Window.fullscreen_desktop 146 | else Sdl.Window.windowed) 147 | : _ result) 148 | in 149 | let bindings = [ 150 | (Sdl.K.[q], `Quit); 151 | (Sdl.K.[p], `Pause); 152 | (Sdl.K.[left; up], `Prev); 153 | (Sdl.K.[right; down], `Next); 154 | (Sdl.K.[f], `Fullscreen); 155 | ] 156 | in 157 | match Sdl.Event.enum (Sdl.Event.get t.event Sdl.Event.typ) with 158 | | `Key_up -> 159 | let key = Sdl.Event.get t.event Sdl.Event.keyboard_keycode in 160 | begin match List.find (fun (keys, _) -> List.mem key keys) bindings with 161 | | exception Not_found -> () 162 | | (_, action) -> run_action action 163 | end 164 | | `Quit -> run_action `Quit 165 | | _ -> () 166 | done; 167 | let slide = match t.next_slides with 168 | | slide :: _ -> Wall.Image.seq (slide {time = get_time t; wall = t.wall}) 169 | | [] -> Wall.Image.empty 170 | in 171 | match render_slide t slide with 172 | | Result.Ok () -> () 173 | | Result.Error (`Msg msg) -> 174 | prerr_endline ("Render error?: " ^ msg) 175 | 176 | let destroy_window { win; gl; wall } = 177 | Wall.Renderer.delete wall; 178 | Sdl.gl_delete_context gl; 179 | Sdl.destroy_window win 180 | 181 | let window = 182 | get_result (make_window ~w:1024 ~h:768) 183 | 184 | let () = Hotlink.on_unload (fun () -> window.quit <- true) 185 | 186 | let unix_stat fname = 187 | match Unix.stat fname with 188 | | stat -> {stat with Unix.st_atime = stat.Unix.st_mtime} 189 | | exception (Unix.Unix_error (Unix.ENOENT, _, _)) -> 190 | raise Not_found 191 | 192 | let rec main () = 193 | Sdl.show_window window.win; 194 | if window.quit then ( 195 | Sdl.hide_window window.win; 196 | Lwt.return_unit 197 | ) else ( 198 | process_events window; 199 | Lwt.bind (Lwt_unix.sleep 0.01) main 200 | ) 201 | 202 | let () = Lwt.async main 203 | -------------------------------------------------------------------------------- /slideshow/tree_slides.ml: -------------------------------------------------------------------------------- 1 | [@@@ocaml.warning "-6"] 2 | open Wall 3 | open Wall_text 4 | open Pres_state 5 | ;; 6 | 7 | let default_font ?(size=1.0) () = 8 | Font.make ~size:(64.0 *. size) font_sans 9 | ~placement:`Subpixel 10 | 11 | let title_banner = Path.make (fun ctx -> 12 | Path.rect ctx ~x:0.0 ~y:0.0 ~w:1024.0 ~h:128.0 13 | ) 14 | 15 | let b2 x y w h = Gg.Box2.v (Gg.P2.v x y) (Gg.Size2.v w h) 16 | let body_box = b2 0.0 128.0 1024.0 640.0 17 | 18 | let title = 19 | let color = Paint.rgba 0.0 0.0 0.0 1.0 in 20 | let title_fg = Font.make ~size:96.0 font_sans in 21 | let title_bg = Font.make ~blur:6.0 ~size:96.0 font_sans in 22 | fun text content-> 23 | [ Image.paint Paint.white (Image.fill mediabox); 24 | Image.paint background (Image.fill title_banner); 25 | Image.paint color ( 26 | Image.seq [ 27 | simple_text title_bg text 28 | ~x:514.0 ~y:18.0 ~halign:`CENTER ~valign:`TOP; 29 | simple_text title_fg text 30 | ~x:512.0 ~y:16.0 ~halign:`CENTER ~valign:`TOP; 31 | ] 32 | ); 33 | Image.scissor body_box (Image.seq content) 34 | ] 35 | 36 | let text ?(halign=`LEFT) ?size ~x ~y str = 37 | simple_text ~x ~y ~halign ~valign:`BASELINE (default_font ?size ()) str 38 | 39 | let slides = [ 40 | (fun _ -> 41 | let circle = Path.make (fun ctx -> 42 | Path.circle ctx 0.0 0.0 100.0 43 | ) in 44 | let dot = 45 | let dot = Path.make (fun ctx -> 46 | Path.circle ctx 0.0 0.0 15.0 47 | ) in 48 | Image.fill dot; 49 | in 50 | let smile = 51 | let path = Path.make (fun ctx -> 52 | Path.move_to ctx (-50.0) 0.0; 53 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 54 | ) 55 | in 56 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 57 | Image.stroke outline path 58 | in 59 | let base = Color.v 0.95 0.95 0.0 1.0 in 60 | let node ?connect x y str = 61 | Image.seq [ 62 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 63 | Image.alpha 0.5 ( 64 | match connect with 65 | | None -> Image.empty 66 | | Some (ox, oy) -> 67 | let oy = oy -. 30.0 in 68 | let y = y -. 40.0 in 69 | let dx = x -. ox in 70 | let dy = y -. oy in 71 | let x = ox +. dx *. 0.55 in 72 | let y = oy +. dy *. 0.55 in 73 | Image.stroke_path (Outline.make ~cap:`ROUND ~width:3.0 ()) 74 | (fun p -> 75 | Path.move_to p ~x:ox ~y:oy; 76 | Path.line_to p ~x ~y; 77 | ) 78 | ) 79 | ] 80 | in 81 | let paint = Paint.color base in 82 | title "Image representation" [ 83 | Image.transform (Transform.translation 812.0 384.0) (Image.seq [ 84 | Image.transform 85 | (Transform.scale 1.5 1.5) 86 | (Image.paint paint (Image.fill circle)); 87 | Image.transform (Transform.translation (-50.0) (-50.0)) dot; 88 | Image.transform (Transform.translation (50.0) (-50.0)) dot; 89 | Image.transform (Transform.translation 0.0 40.0) smile; 90 | ]); 91 | node 300.0 600.0 "superpose"; 92 | node 100.0 500.0 "paint(yellow)" ~connect:(300.0,600.0); 93 | node 100.0 400.0 "Circle" ~connect:(100.0,500.0); 94 | node 450.0 500.0 "paint(black)" ~connect:(300.0,600.0); 95 | node 280.0 400.0 "transform" ~connect:(450.0,500.0); 96 | node 280.0 300.0 "Circle" ~connect:(280.0,400.0); 97 | node 430.0 400.0 "transform" ~connect:(450.0,500.0); 98 | node 430.0 300.0 "Circle" ~connect:(430.0,400.0); 99 | node 580.0 400.0 "transform" ~connect:(450.0,500.0); 100 | node 580.0 300.0 "Smile" ~connect:(580.0,400.0); 101 | Image.alpha 0.8 (Image.seq [ 102 | Image.transform 103 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 240.0)) 104 | smile; 105 | Image.transform 106 | (Transform.rescale 0.6 0.6 (Transform.translation 430.0 240.0)) 107 | dot; 108 | Image.transform 109 | (Transform.rescale 0.6 0.6 (Transform.translation 280.0 240.0)) 110 | dot; 111 | Image.transform 112 | (Transform.rescale 0.6 0.6 (Transform.translation 100.0 340.0)) 113 | dot; 114 | ]); 115 | ] 116 | ); 117 | (fun _ -> 118 | let circle = Path.make (fun ctx -> 119 | Path.circle ctx 0.0 0.0 100.0 120 | ) in 121 | let dot = 122 | let dot = Path.make (fun ctx -> 123 | Path.circle ctx 0.0 0.0 15.0 124 | ) in 125 | Image.fill dot; 126 | in 127 | let smile = 128 | let path = Path.make (fun ctx -> 129 | Path.move_to ctx (-50.0) 0.0; 130 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 131 | ) 132 | in 133 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 134 | Image.stroke outline path 135 | in 136 | let base = Color.v 0.95 0.95 0.0 1.0 in 137 | let node ?(connect=[]) x y str = 138 | Image.seq [ 139 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 140 | Image.alpha 0.5 ( 141 | Image.seq (List.map (fun (ox, oy) -> 142 | let oy = oy -. 30.0 in 143 | let y = y -. 40.0 in 144 | let dx = x -. ox in 145 | let dy = y -. oy in 146 | let ratio = 147 | let dy =abs_float dy in 148 | (dy -. 50.0) /. dy 149 | in 150 | let x = ox +. dx *. ratio in 151 | let y = oy +. dy *. ratio in 152 | Image.stroke_path 153 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 154 | Path.move_to p ~x:ox ~y:oy; 155 | Path.line_to p ~x ~y; 156 | ) 157 | ) connect) 158 | ) 159 | ] 160 | in 161 | let paint = Paint.color base in 162 | title "With sharing" [ 163 | Image.transform (Transform.translation 812.0 384.0) (Image.seq [ 164 | Image.transform 165 | (Transform.scale 1.5 1.5) 166 | (Image.paint paint (Image.fill circle)); 167 | Image.transform (Transform.translation (-50.0) (-50.0)) dot; 168 | Image.transform (Transform.translation (50.0) (-50.0)) dot; 169 | Image.transform (Transform.translation 0.0 40.0) smile; 170 | ]); 171 | node 300.0 600.0 "superpose"; 172 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 173 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 174 | node 450.0 500.0 "paint(black)" ~connect:[300.0,600.0]; 175 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 176 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 177 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 178 | node 430.0 300.0 "Primitive" ~connect:[430.0,400.0]; 179 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 180 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 181 | node 330.0 200.0 "Circle" ~connect:[ 182 | 100.0,400.0; 183 | 280.0,300.0; 184 | 430.0,300.0; 185 | ]; 186 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 187 | Image.alpha 0.8 (Image.seq [ 188 | Image.transform 189 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 190 | smile; 191 | Image.transform 192 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 193 | dot; 194 | ]); 195 | ] 196 | ); 197 | (fun _ -> 198 | let dot = 199 | let dot = Path.make (fun ctx -> 200 | Path.circle ctx 0.0 0.0 15.0 201 | ) in 202 | Image.fill dot; 203 | in 204 | let smile = 205 | let path = Path.make (fun ctx -> 206 | Path.move_to ctx (-50.0) 0.0; 207 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 208 | ) 209 | in 210 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 211 | Image.stroke outline path 212 | in 213 | let node ?(connect=[]) x y str = 214 | Image.seq [ 215 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 216 | Image.alpha 0.5 ( 217 | Image.seq (List.map (fun (ox, oy) -> 218 | let oy = oy -. 30.0 in 219 | let y = y -. 40.0 in 220 | let dx = x -. ox in 221 | let dy = y -. oy in 222 | let ratio = 223 | let dy =abs_float dy in 224 | (dy -. 50.0) /. dy 225 | in 226 | let x = ox +. dx *. ratio in 227 | let y = oy +. dy *. ratio in 228 | Image.stroke_path 229 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 230 | Path.move_to p ~x:ox ~y:oy; 231 | Path.line_to p ~x ~y; 232 | ) 233 | ) connect) 234 | ) 235 | ] 236 | in 237 | title "Allocating GPU memory" [ 238 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 239 | Image.stroke_path (Outline.make ~width:2.0 ()) 240 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 241 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 242 | Image.stroke_path (Outline.make ~width:2.0 ()) 243 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 244 | (* Nodes *) 245 | node 300.0 600.0 "superpose"; 246 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 247 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 248 | node 450.0 500.0 "paint(black)" ~connect:[300.0,600.0]; 249 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 250 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 251 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 252 | node 430.0 300.0 "Primitive" ~connect:[430.0,400.0]; 253 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 254 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 255 | node 330.0 200.0 "Circle" ~connect:[ 256 | 100.0,400.0; 257 | 280.0,300.0; 258 | 430.0,300.0; 259 | ]; 260 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 261 | Image.alpha 0.8 (Image.seq [ 262 | Image.transform 263 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 264 | smile; 265 | Image.transform 266 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 267 | dot; 268 | ]); 269 | ] 270 | ); 271 | (fun _ -> 272 | let dot = 273 | let dot = Path.make (fun ctx -> 274 | Path.circle ctx 0.0 0.0 15.0 275 | ) in 276 | Image.fill dot; 277 | in 278 | let smile = 279 | let path = Path.make (fun ctx -> 280 | Path.move_to ctx (-50.0) 0.0; 281 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 282 | ) 283 | in 284 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 285 | Image.stroke outline path 286 | in 287 | let node ?(connect=[]) x y str = 288 | Image.seq [ 289 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 290 | Image.alpha 0.5 ( 291 | Image.seq (List.map (fun (ox, oy) -> 292 | let oy = oy -. 30.0 in 293 | let y = y -. 40.0 in 294 | let dx = x -. ox in 295 | let dy = y -. oy in 296 | let ratio = 297 | let dy =abs_float dy in 298 | (dy -. 50.0) /. dy 299 | in 300 | let x = ox +. dx *. ratio in 301 | let y = oy +. dy *. ratio in 302 | Image.stroke_path 303 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 304 | Path.move_to p ~x:ox ~y:oy; 305 | Path.line_to p ~x ~y; 306 | ) 307 | ) connect) 308 | ) 309 | ] 310 | in 311 | title "Allocating GPU memory" [ 312 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 313 | Image.stroke_path (Outline.make ~width:2.0 ()) 314 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 315 | 316 | Image.paint (Paint.color Color.red) 317 | (Image.fill_path (fun p -> Path.rect p 700.0 200.0 300.0 60.0)); 318 | text ~size:0.8 ~x:720.0 ~y:245.0 "Circle"; 319 | 320 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 321 | Image.stroke_path (Outline.make ~width:2.0 ()) 322 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 323 | (* Nodes *) 324 | node 300.0 600.0 "superpose"; 325 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 326 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 327 | node 450.0 500.0 "paint(black)" ~connect:[300.0,600.0]; 328 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 329 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 330 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 331 | node 430.0 300.0 "Primitive" ~connect:[430.0,400.0]; 332 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 333 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 334 | Image.paint (Paint.color Color.red) @@ 335 | node 330.0 200.0 "Circle" ~connect:[ 336 | 100.0,400.0; 337 | 280.0,300.0; 338 | 430.0,300.0; 339 | ]; 340 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 341 | Image.alpha 0.8 (Image.seq [ 342 | Image.transform 343 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 344 | smile; 345 | Image.transform 346 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 347 | dot; 348 | ]); 349 | ] 350 | ); 351 | (fun _ -> 352 | let dot = 353 | let dot = Path.make (fun ctx -> 354 | Path.circle ctx 0.0 0.0 15.0 355 | ) in 356 | Image.fill dot; 357 | in 358 | let smile = 359 | let path = Path.make (fun ctx -> 360 | Path.move_to ctx (-50.0) 0.0; 361 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 362 | ) 363 | in 364 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 365 | Image.stroke outline path 366 | in 367 | let node ?(connect=[]) x y str = 368 | Image.seq [ 369 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 370 | Image.alpha 0.5 ( 371 | Image.seq (List.map (fun (ox, oy) -> 372 | let oy = oy -. 30.0 in 373 | let y = y -. 40.0 in 374 | let dx = x -. ox in 375 | let dy = y -. oy in 376 | let ratio = 377 | let dy =abs_float dy in 378 | (dy -. 50.0) /. dy 379 | in 380 | let x = ox +. dx *. ratio in 381 | let y = oy +. dy *. ratio in 382 | Image.stroke_path 383 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 384 | Path.move_to p ~x:ox ~y:oy; 385 | Path.line_to p ~x ~y; 386 | ) 387 | ) connect) 388 | ) 389 | ] 390 | in 391 | title "Allocating GPU memory" [ 392 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 393 | Image.stroke_path (Outline.make ~width:2.0 ()) 394 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 395 | 396 | Image.paint (Paint.color Color.red) 397 | (Image.fill_path (fun p -> Path.rect p 700.0 200.0 300.0 60.0)); 398 | text ~size:0.8 ~x:720.0 ~y:245.0 "Circle"; 399 | 400 | Image.paint (Paint.color Color.green) 401 | (Image.fill_path (fun p -> Path.rect p 700.0 260.0 300.0 60.0)); 402 | text ~size:0.8 ~x:720.0 ~y:305.0 "Smile"; 403 | 404 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 405 | Image.stroke_path (Outline.make ~width:2.0 ()) 406 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 407 | (* Nodes *) 408 | node 300.0 600.0 "superpose"; 409 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 410 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 411 | node 450.0 500.0 "paint(black)" ~connect:[300.0,600.0]; 412 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 413 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 414 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 415 | node 430.0 300.0 "Primitive" ~connect:[430.0,400.0]; 416 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 417 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 418 | node 330.0 200.0 "Circle" ~connect:[ 419 | 100.0,400.0; 420 | 280.0,300.0; 421 | 430.0,300.0; 422 | ]; 423 | Image.paint (Paint.color (Color.lerp_rgba 0.5 Color.black Color.green)) @@ 424 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 425 | Image.alpha 0.8 (Image.seq [ 426 | Image.transform 427 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 428 | smile; 429 | Image.transform 430 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 431 | dot; 432 | ]); 433 | ] 434 | ); 435 | (fun _ -> 436 | let dot = 437 | let dot = Path.make (fun ctx -> 438 | Path.circle ctx 0.0 0.0 15.0 439 | ) in 440 | Image.fill dot; 441 | in 442 | let smile = 443 | let path = Path.make (fun ctx -> 444 | Path.move_to ctx (-50.0) 0.0; 445 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 446 | ) 447 | in 448 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 449 | Image.stroke outline path 450 | in 451 | let node ?(connect=[]) x y str = 452 | Image.seq [ 453 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 454 | Image.alpha 0.5 ( 455 | Image.seq (List.map (fun (ox, oy) -> 456 | let oy = oy -. 30.0 in 457 | let y = y -. 40.0 in 458 | let dx = x -. ox in 459 | let dy = y -. oy in 460 | let ratio = 461 | let dy =abs_float dy in 462 | (dy -. 50.0) /. dy 463 | in 464 | let x = ox +. dx *. ratio in 465 | let y = oy +. dy *. ratio in 466 | Image.stroke_path 467 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 468 | Path.move_to p ~x:ox ~y:oy; 469 | Path.line_to p ~x ~y; 470 | ) 471 | ) connect) 472 | ) 473 | ] 474 | in 475 | title "Traversing tree" [ 476 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 477 | Image.stroke_path (Outline.make ~width:2.0 ()) 478 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 479 | 480 | Image.alpha 0.5 (Image.seq [ 481 | Image.paint (Paint.color Color.red) 482 | (Image.fill_path (fun p -> Path.rect p 700.0 200.0 300.0 60.0)); 483 | text ~size:0.8 ~x:720.0 ~y:245.0 "Circle"; 484 | Image.paint (Paint.color Color.green) 485 | (Image.fill_path (fun p -> Path.rect p 700.0 260.0 300.0 60.0)); 486 | text ~size:0.8 ~x:720.0 ~y:305.0 "Smile"; 487 | ]); 488 | 489 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 490 | Image.stroke_path (Outline.make ~width:2.0 ()) 491 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 492 | (* Nodes *) 493 | node 300.0 600.0 "superpose"; 494 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 495 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 496 | node 450.0 500.0 "paint(black)" ~connect:[300.0,600.0]; 497 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 498 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 499 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 500 | node 430.0 300.0 "Primitive" ~connect:[430.0,400.0]; 501 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 502 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 503 | node 330.0 200.0 "Circle" ~connect:[ 504 | 100.0,400.0; 505 | 280.0,300.0; 506 | 430.0,300.0; 507 | ]; 508 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 509 | Image.alpha 0.8 (Image.seq [ 510 | Image.transform 511 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 512 | smile; 513 | Image.transform 514 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 515 | dot; 516 | ]); 517 | ] 518 | ); 519 | (fun _ -> 520 | let dot = 521 | let dot = Path.make (fun ctx -> 522 | Path.circle ctx 0.0 0.0 15.0 523 | ) in 524 | Image.fill dot; 525 | in 526 | let smile = 527 | let path = Path.make (fun ctx -> 528 | Path.move_to ctx (-50.0) 0.0; 529 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 530 | ) 531 | in 532 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 533 | Image.stroke outline path 534 | in 535 | let node ?color ?(color_connect=[]) ?(connect=[]) x y str = 536 | let line (ox, oy) = 537 | let oy = oy -. 30.0 in 538 | let y = y -. 40.0 in 539 | let dx = x -. ox in 540 | let dy = y -. oy in 541 | let ratio = 542 | let dy =abs_float dy in 543 | (dy -. 50.0) /. dy 544 | in 545 | let x = ox +. dx *. ratio in 546 | let y = oy +. dy *. ratio in 547 | Image.stroke_path 548 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 549 | Path.move_to p ~x:ox ~y:oy; 550 | Path.line_to p ~x ~y; 551 | ) 552 | in 553 | match color with 554 | | None -> 555 | Image.seq [ 556 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 557 | Image.alpha 0.5 ( 558 | Image.seq (List.map line (connect @ color_connect)) 559 | ) 560 | ] 561 | | Some color -> 562 | let paint = Paint.color color in 563 | Image.seq [ 564 | Image.paint paint (text ~halign:`CENTER ~x ~y ~size:0.6 str); 565 | Image.alpha 0.5 (Image.seq [ 566 | Image.seq (List.map line connect); 567 | Image.paint paint (Image.seq (List.map line color_connect)) 568 | ] 569 | ) 570 | ] 571 | in 572 | title "Traversing tree" [ 573 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 574 | Image.stroke_path (Outline.make ~width:2.0 ()) 575 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 576 | 577 | Image.paint (Paint.color Color.red) 578 | (Image.fill_path (fun p -> Path.rect p 700.0 200.0 300.0 60.0)); 579 | text ~size:0.8 ~x:720.0 ~y:245.0 "Circle"; 580 | Image.alpha 0.5 (Image.seq [ 581 | Image.paint (Paint.color Color.green) 582 | (Image.fill_path (fun p -> Path.rect p 700.0 260.0 300.0 60.0)); 583 | text ~size:0.8 ~x:720.0 ~y:305.0 "Smile"; 584 | ]); 585 | 586 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 587 | Image.stroke_path (Outline.make ~width:2.0 ()) 588 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 589 | text ~size:0.6 ~x:720.0 ~y:610.0 "fill(circle,yellow,xf0)"; 590 | (* Nodes *) 591 | node 300.0 600.0 ~color:Color.red "superpose"; 592 | node 100.0 500.0 "paint(yellow)" 593 | ~color:Color.red 594 | ~color_connect:[300.0,600.0]; 595 | node 100.0 400.0 "Primitive" 596 | ~color:Color.red 597 | ~color_connect:[100.0,500.0]; 598 | node 450.0 500.0 "paint(black)" ~connect:[300.0,600.0]; 599 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 600 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 601 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 602 | node 430.0 300.0 "Primitive" ~connect:[430.0,400.0]; 603 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 604 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 605 | node 330.0 200.0 "Circle" 606 | ~color:Color.red 607 | ~color_connect:[100.0,400.0] 608 | ~connect:[280.0,300.0; 430.0,300.0]; 609 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 610 | Image.alpha 0.8 (Image.seq [ 611 | Image.transform 612 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 613 | smile; 614 | Image.transform 615 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 616 | dot; 617 | ]); 618 | ] 619 | ); 620 | (fun _ -> 621 | let dot = 622 | let dot = Path.make (fun ctx -> 623 | Path.circle ctx 0.0 0.0 15.0 624 | ) in 625 | Image.fill dot; 626 | in 627 | let smile = 628 | let path = Path.make (fun ctx -> 629 | Path.move_to ctx (-50.0) 0.0; 630 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 631 | ) 632 | in 633 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 634 | Image.stroke outline path 635 | in 636 | let node ?color ?(color_connect=[]) ?(connect=[]) x y str = 637 | let line (ox, oy) = 638 | let oy = oy -. 30.0 in 639 | let y = y -. 40.0 in 640 | let dx = x -. ox in 641 | let dy = y -. oy in 642 | let ratio = 643 | let dy =abs_float dy in 644 | (dy -. 50.0) /. dy 645 | in 646 | let x = ox +. dx *. ratio in 647 | let y = oy +. dy *. ratio in 648 | Image.stroke_path 649 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 650 | Path.move_to p ~x:ox ~y:oy; 651 | Path.line_to p ~x ~y; 652 | ) 653 | in 654 | match color with 655 | | None -> 656 | Image.seq [ 657 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 658 | Image.alpha 0.5 ( 659 | Image.seq (List.map line (connect @ color_connect)) 660 | ) 661 | ] 662 | | Some color -> 663 | let paint = Paint.color color in 664 | Image.seq [ 665 | Image.paint paint (text ~halign:`CENTER ~x ~y ~size:0.6 str); 666 | Image.alpha 0.5 (Image.seq [ 667 | Image.seq (List.map line connect); 668 | Image.paint paint (Image.seq (List.map line color_connect)) 669 | ] 670 | ) 671 | ] 672 | in 673 | title "Traversing tree" [ 674 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 675 | Image.stroke_path (Outline.make ~width:2.0 ()) 676 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 677 | 678 | Image.paint (Paint.color Color.red) 679 | (Image.fill_path (fun p -> Path.rect p 700.0 200.0 300.0 60.0)); 680 | text ~size:0.8 ~x:720.0 ~y:245.0 "Circle"; 681 | Image.alpha 0.5 (Image.seq [ 682 | Image.paint (Paint.color Color.green) 683 | (Image.fill_path (fun p -> Path.rect p 700.0 260.0 300.0 60.0)); 684 | text ~size:0.8 ~x:720.0 ~y:305.0 "Smile"; 685 | ]); 686 | 687 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 688 | Image.stroke_path (Outline.make ~width:2.0 ()) 689 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 690 | text ~size:0.6 ~x:720.0 ~y:610.0 "fill(circle,black,xf1)"; 691 | (* Nodes *) 692 | node 300.0 600.0 ~color:Color.red "superpose"; 693 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 694 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 695 | node 450.0 500.0 "paint(black)" 696 | ~color:Color.red 697 | ~color_connect:[300.0,600.0]; 698 | node 280.0 400.0 "transform" 699 | ~color:Color.red 700 | ~color_connect:[450.0,500.0]; 701 | node 280.0 300.0 "Primitive" 702 | ~color:Color.red 703 | ~color_connect:[280.0,400.0]; 704 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 705 | node 430.0 300.0 "Primitive" ~connect:[430.0,400.0]; 706 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 707 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 708 | node 330.0 200.0 "Circle" 709 | ~color:Color.red 710 | ~color_connect:[280.0,300.0;] 711 | ~connect:[100.0,400.0;430.0,300.0]; 712 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 713 | Image.alpha 0.8 (Image.seq [ 714 | Image.transform 715 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 716 | smile; 717 | Image.transform 718 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 719 | dot; 720 | ]); 721 | ] 722 | ); 723 | (fun _ -> 724 | let dot = 725 | let dot = Path.make (fun ctx -> 726 | Path.circle ctx 0.0 0.0 15.0 727 | ) in 728 | Image.fill dot; 729 | in 730 | let smile = 731 | let path = Path.make (fun ctx -> 732 | Path.move_to ctx (-50.0) 0.0; 733 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 734 | ) 735 | in 736 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 737 | Image.stroke outline path 738 | in 739 | let node ?color ?(color_connect=[]) ?(connect=[]) x y str = 740 | let line (ox, oy) = 741 | let oy = oy -. 30.0 in 742 | let y = y -. 40.0 in 743 | let dx = x -. ox in 744 | let dy = y -. oy in 745 | let ratio = 746 | let dy =abs_float dy in 747 | (dy -. 50.0) /. dy 748 | in 749 | let x = ox +. dx *. ratio in 750 | let y = oy +. dy *. ratio in 751 | Image.stroke_path 752 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 753 | Path.move_to p ~x:ox ~y:oy; 754 | Path.line_to p ~x ~y; 755 | ) 756 | in 757 | match color with 758 | | None -> 759 | Image.seq [ 760 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 761 | Image.alpha 0.5 ( 762 | Image.seq (List.map line (connect @ color_connect)) 763 | ) 764 | ] 765 | | Some color -> 766 | let paint = Paint.color color in 767 | Image.seq [ 768 | Image.paint paint (text ~halign:`CENTER ~x ~y ~size:0.6 str); 769 | Image.alpha 0.5 (Image.seq [ 770 | Image.seq (List.map line connect); 771 | Image.paint paint (Image.seq (List.map line color_connect)) 772 | ] 773 | ) 774 | ] 775 | in 776 | title "Traversing tree" [ 777 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 778 | Image.stroke_path (Outline.make ~width:2.0 ()) 779 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 780 | 781 | Image.paint (Paint.color Color.red) 782 | (Image.fill_path (fun p -> Path.rect p 700.0 200.0 300.0 60.0)); 783 | text ~size:0.8 ~x:720.0 ~y:245.0 "Circle"; 784 | Image.alpha 0.5 (Image.seq [ 785 | Image.paint (Paint.color Color.green) 786 | (Image.fill_path (fun p -> Path.rect p 700.0 260.0 300.0 60.0)); 787 | text ~size:0.8 ~x:720.0 ~y:305.0 "Smile"; 788 | ]); 789 | 790 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 791 | Image.stroke_path (Outline.make ~width:2.0 ()) 792 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 793 | text ~size:0.6 ~x:720.0 ~y:610.0 "fill(circle,black,xf2)"; 794 | (* Nodes *) 795 | node 300.0 600.0 ~color:Color.red "superpose"; 796 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 797 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 798 | node 450.0 500.0 "paint(black)" 799 | ~color:Color.red 800 | ~color_connect:[300.0,600.0]; 801 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 802 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 803 | node 430.0 400.0 "transform" 804 | ~color:Color.red 805 | ~color_connect:[450.0,500.0]; 806 | node 430.0 300.0 "Primitive" 807 | ~color:Color.red 808 | ~color_connect:[430.0,400.0]; 809 | node 580.0 400.0 "transform" ~connect:[450.0,500.0]; 810 | node 580.0 300.0 "Primitive" ~connect:[580.0,400.0]; 811 | node 330.0 200.0 "Circle" 812 | ~color:Color.red 813 | ~color_connect:[430.0,300.0] 814 | ~connect:[100.0,400.0;280.0,300.0]; 815 | node 580.0 200.0 "Smile" ~connect:[580.0,300.0]; 816 | Image.alpha 0.8 (Image.seq [ 817 | Image.transform 818 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 819 | smile; 820 | Image.transform 821 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 822 | dot; 823 | ]); 824 | ] 825 | ); 826 | (fun _ -> 827 | let dot = 828 | let dot = Path.make (fun ctx -> 829 | Path.circle ctx 0.0 0.0 15.0 830 | ) in 831 | Image.fill dot; 832 | in 833 | let smile = 834 | let path = Path.make (fun ctx -> 835 | Path.move_to ctx (-50.0) 0.0; 836 | Path.bezier_to ctx (-30.0) 30.0 30.0 30.0 50.0 0.0; 837 | ) 838 | in 839 | let outline = Outline.make ~cap:`ROUND ~width:15.0 () in 840 | Image.stroke outline path 841 | in 842 | let node ?color ?(color_connect=[]) ?(connect=[]) x y str = 843 | let line (ox, oy) = 844 | let oy = oy -. 30.0 in 845 | let y = y -. 40.0 in 846 | let dx = x -. ox in 847 | let dy = y -. oy in 848 | let ratio = 849 | let dy =abs_float dy in 850 | (dy -. 50.0) /. dy 851 | in 852 | let x = ox +. dx *. ratio in 853 | let y = oy +. dy *. ratio in 854 | Image.stroke_path 855 | (Outline.make ~cap:`ROUND ~width:3.0 ()) (fun p -> 856 | Path.move_to p ~x:ox ~y:oy; 857 | Path.line_to p ~x ~y; 858 | ) 859 | in 860 | match color with 861 | | None -> 862 | Image.seq [ 863 | text ~halign:`CENTER ~x ~y ~size:0.6 str; 864 | Image.alpha 0.5 ( 865 | Image.seq (List.map line (connect @ color_connect)) 866 | ) 867 | ] 868 | | Some color -> 869 | let paint = Paint.color color in 870 | Image.seq [ 871 | Image.paint paint (text ~halign:`CENTER ~x ~y ~size:0.6 str); 872 | Image.alpha 0.5 (Image.seq [ 873 | Image.seq (List.map line connect); 874 | Image.paint paint (Image.seq (List.map line color_connect)) 875 | ] 876 | ) 877 | ] 878 | in 879 | let green = Color.lerp_rgba 0.5 Color.black Color.green in 880 | title "Traversing tree" [ 881 | text ~size:0.8 ~x:700.0 ~y:180.0 "GPU memory"; 882 | Image.stroke_path (Outline.make ~width:2.0 ()) 883 | (fun p -> Path.rect p 700.0 200.0 300.0 300.0); 884 | 885 | Image.alpha 0.5 (Image.seq [ 886 | Image.paint (Paint.color Color.red) 887 | (Image.fill_path (fun p -> Path.rect p 700.0 200.0 300.0 60.0)); 888 | text ~size:0.8 ~x:720.0 ~y:245.0 "Circle"; 889 | ]); 890 | Image.paint (Paint.color Color.green) 891 | (Image.fill_path (fun p -> Path.rect p 700.0 260.0 300.0 60.0)); 892 | text ~size:0.8 ~x:720.0 ~y:305.0 "Smile"; 893 | 894 | text ~size:0.8 ~x:700.0 ~y:550.0 "GPU command"; 895 | Image.stroke_path (Outline.make ~width:2.0 ()) 896 | (fun p -> Path.rect p 700.0 570.0 300.0 60.0); 897 | text ~size:0.6 ~x:720.0 ~y:610.0 "fill(smile,black,xf3)"; 898 | (* Nodes *) 899 | node 300.0 600.0 ~color:green "superpose"; 900 | node 100.0 500.0 "paint(yellow)" ~connect:[300.0,600.0]; 901 | node 100.0 400.0 "Primitive" ~connect:[100.0,500.0]; 902 | node 450.0 500.0 "paint(black)" 903 | ~color:green 904 | ~color_connect:[300.0,600.0]; 905 | node 280.0 400.0 "transform" ~connect:[450.0,500.0]; 906 | node 280.0 300.0 "Primitive" ~connect:[280.0,400.0]; 907 | node 430.0 400.0 "transform" ~connect:[450.0,500.0]; 908 | node 430.0 300.0 "Primitive" 909 | ~connect:[430.0,400.0]; 910 | node 580.0 400.0 "transform" 911 | ~color:green ~color_connect:[450.0,500.0]; 912 | node 580.0 300.0 "Primitive" 913 | ~color:green ~color_connect:[580.0,400.0]; 914 | node 330.0 200.0 "Circle" 915 | ~connect:[100.0,400.0;280.0,300.0;430.0,300.0]; 916 | node 580.0 200.0 "Smile" 917 | ~color:green 918 | ~color_connect:[580.0,300.0]; 919 | Image.alpha 0.8 (Image.seq [ 920 | Image.transform 921 | (Transform.rescale 0.4 0.4 (Transform.translation 580.0 160.0)) 922 | smile; 923 | Image.transform 924 | (Transform.rescale 0.6 0.6 (Transform.translation 330.0 160.0)) 925 | dot; 926 | ]); 927 | ] 928 | ); 929 | (fun _ -> title "Performance" 930 | [ 931 | text ~size:0.9 ~x:80.0 ~y:195.0 "Geometry: g, Tree: n, Sharing: m"; 932 | text ~x:80.0 ~y:300.0 "1) Processing geometry on leaves, O(g/m)"; 933 | text ~x:80.0 ~y:385.0 "2) Other nodes have fixed size, O(1)"; 934 | text ~x:80.0 ~y:470.0 "3) Traversal is O(n)"; 935 | text ~x:80.0 ~y:555.0 "4) Rasterization is O(g), massively parallel"; 936 | text ~size:0.9 ~x:80.0 ~y:660.0 "... devil is in the level of detail"; 937 | ] 938 | ); 939 | ] 940 | ;; 941 | -------------------------------------------------------------------------------- /wall.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Realtime Vector Graphics with OpenGL" 4 | description: 5 | "Lightweight, fast and declarative vector graphics rasterization using OpenGL" 6 | maintainer: ["frederic.bour@lakaban.net"] 7 | authors: ["Frédéric Bour"] 8 | license: "BSD3" 9 | homepage: "https://github.com/let-def/wall" 10 | doc: "https://let-def.github.io/wall/doc" 11 | bug-reports: "https://github.com/let-def/wall/issues" 12 | depends: [ 13 | "dune" {>= "2.0"} 14 | "ocaml" 15 | "gg" 16 | "result" 17 | "grenier" 18 | "conf-gles2" 19 | "stb_image" 20 | "stb_truetype" {>= "0.5"} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {pinned} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/let-def/wall.git" 37 | --------------------------------------------------------------------------------