-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathwebgl_plot_textures.ml
163 lines (147 loc) · 5.37 KB
/
webgl_plot_textures.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
(* This file is released under the terms of an MIT-like license. *)
(* See the attached LICENSE file. *)
(* Copyright 2016 by LexiFi. *)
open Js_browser
open Canvas
module Math = Webgl_plot_math
type ticks = {
values: float array;
texts: string array;
}
(*
2 × real_size
----------------------
| | | 0.5 * (real_size - inner_size)
A + A E + E ]
B + B D + D ]
C + C C + C ] inner_size
D + D B + B ]
E + E A + A ]
| | | 0.5 * (real_size - inner_size)
----------------------
*)
let stack : [`Translate of float * float | `Scale of float * float | `Rotate of float] Stack.t = Stack.create ()
let push context t =
Stack.push t stack;
match t with
| `Translate (x,y) -> translate context x y
| `Scale (x,y) -> scale context x y
| `Rotate rho -> rotate context rho
let pop context =
match Stack.pop stack with
| `Translate (x,y) -> translate context (-. x) (-. y)
| `Scale (x,y) -> scale context (1. /. x) (1. /. y)
| `Rotate rho -> rotate context (-. rho)
let tick_height = 0.03
let real_size = 1024
let inner_size = 0.9 *. (float real_size)
let line_width = float real_size /. 256.0
let font_size = 10.0 *. line_width
let create_face_texture () =
let canvas = Document.create_element document "canvas" in
Element.set_attribute canvas "width" (string_of_int real_size);
Element.set_attribute canvas "height" (string_of_int real_size);
let context =
match get_context canvas with
| None -> failwith "get_context"
| Some x -> x
in
let size = float real_size in
clear_rect context 0.0 0.0 size size;
set_stroke_style context (`Color "black");
set_line_width context (4.0 *. line_width);
stroke_rect context 0.0 0.0 size size;
canvas
let draw_tick context text =
let tick_size = 0.01 *. (float real_size) in
move_to context (-. tick_size) 0.0;
line_to context tick_size 0.0;
let new_text = ref text in
let new_font_size = ref font_size in
let max_width = 0.25 *. inner_size in
let text_width = ref 0.0 in
while
set_font context (Printf.sprintf "%.0fpx Arial" !new_font_size);
text_width := TextMetrics.width (measure_text context !new_text);
!text_width > max_width && String.length !new_text > 4 do
if false then
Printf.printf "new = %S, width = %g < %g, size = %g\n%!" !new_text !text_width max_width !new_font_size;
if !new_font_size > 1.1 *. font_size then
new_font_size := 0.9 *. !new_font_size
else
new_text := (String.sub !new_text 0 ((String.length !new_text) - 4))^"..."
done;
fill_text context !new_text (-. tick_size -. line_width -. !text_width) (0.5 *. (font_size -. line_width));
fill_text context !new_text (tick_size +. line_width) (0.5 *. (font_size -. line_width));
set_font context (Printf.sprintf "%.0fpx Arial" font_size)
let create_ticks_texture ratio label {values; texts} =
let canvas = Document.create_element document "canvas" in
let number = Array.length values in
Element.set_attribute canvas "width" (string_of_int real_size);
Element.set_attribute canvas "height" (string_of_int real_size);
let context =
match get_context canvas with
| None -> failwith "get_context"
| Some x -> x
in
let size = float real_size in
clear_rect context 0.0 0.0 size size;
set_fill_style context (`Color "black");
set_line_width context line_width;
set_font context (Printf.sprintf "%.0fpx Arial" font_size);
let padding = 0.5 *. (size -. inner_size) in
let size_y = inner_size *. ratio in
let draw_ticks reverse =
begin_path context;
for k = 0 to number-1 do
let y, s =
if reverse then
let k = number - 1 - k in
(1.0 -. values.(k)) *. size_y, texts.(k)
else
values.(k) *. size_y, texts.(k)
in
push context (`Translate (0.0, y));
draw_tick context s;
pop context;
done;
close_path context;
stroke context;
in
let text_width = TextMetrics.width (measure_text context label) in
push context (`Scale (1.0, 1.0 /. ratio));
push context (`Translate (0.25 *. size, padding *. ratio));
draw_ticks false;
begin
push context (`Translate (-. 0.25 *. size +. 0.5 *. font_size, 0.5 *. (size -. text_width) *. ratio));
push context (`Rotate (0.5 *. Math.pi));
fill_text context label 0.0 0.0;
pop context;
pop context;
push context (`Translate (0.25 *. size -. 0.5 *. font_size, 0.5 *. (size +. text_width) *. ratio));
push context (`Rotate (-0.5 *. Math.pi));
fill_text context label 0.0 0.0;
pop context;
pop context;
end;
pop context;
push context (`Translate (0.75 *. size, padding *. ratio));
draw_ticks true;
begin
push context (`Translate (-. 0.25 *. size +. 0.5 *. font_size, 0.5 *. (size -. text_width) *. ratio));
push context (`Rotate (0.5 *. Math.pi));
fill_text context label 0.0 0.0;
pop context;
pop context;
push context (`Translate (0.25 *. size -. 0.5 *. font_size, 0.5 *. (size +. text_width) *.ratio));
push context (`Rotate (-0.5 *. Math.pi));
fill_text context label 0.0 0.0;
pop context;
pop context;
end;
pop context;
pop context;
assert (Stack.is_empty stack);
if false then
Element.append_child (Document.body document) canvas;
canvas