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
164
165
166
167
|
(*
This file is part of licht.
licht is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
licht is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with licht. If not, see <http://www.gnu.org/licenses/>.
*)
let u = UTF8.from_utf8string
module Option = struct
let map f = function Some x -> Some (f x) | None -> None
let iter f = function Some x -> f x | None -> ()
let bind f = function None -> None | Some x -> f x
let default v = function None -> v | Some x -> x
let test f v = match f v with Some x -> x | None -> v
end
module String = struct
include String
let split str ~by:sep =
let p = String.index str sep in
let slen = String.length str in
(String.sub str 0 p, String.sub str (p + 1) (slen - p - 1))
let string_of_ints v =
let buff = Buffer.create 1 in
let rec convert value =
Buffer.add_char buff @@ char_of_int @@ (value land 0xFF);
let rem = value lsr 8 in
match rem with 0 -> Buffer.contents buff | x -> (convert [@tailcall]) x
in
let res = convert v in
let buff' = Buffer.create @@ String.length res in
for i = String.length res - 1 downto 0 do
Buffer.add_char buff' @@ String.get res i
done;
Buffer.contents buff'
let print_buffer f t =
let buff = UTF8.Buffer.create 16 in
f buff t;
UTF8.Buffer.contents buff
let filter_float str =
let l = String.length str in
if l > 0 && String.get str (l - 1) = '.' then String.sub str 0 (l - 1)
else str
end
module List = struct
(** fold_left over only the first element *)
let fst f init = function hd :: tl -> f init hd | [] -> init
let printb ?(first = u "(") ?(last = u ")") ?(sep = u ",") f buffer elems =
let rec print = function
| [] -> ()
| [ hd ] -> f buffer hd
| hd :: tl ->
f buffer hd;
UTF8.Buffer.add_string buffer sep;
(print [@tailcall]) tl
in
UTF8.Buffer.add_string buffer first;
print elems;
UTF8.Buffer.add_string buffer last
let rec find_map f = function
| [] -> raise Not_found
| hd :: tl -> (
match f hd with Some x -> x | None -> (find_map [@tailcall]) f tl)
and find_map2 p = function
| [] -> raise Not_found
| x :: l -> (
try find_map p x with Not_found -> (find_map2 [@tailcall]) p l)
end
module Tuple2 = struct
let fst = Stdlib.fst
let snd = Stdlib.snd
let map1 f (a, b) = (f a, b)
let map2 f (a, b) = (a, f b)
let replace1 v (a, b) = (v, b)
let replace2 v (a, b) = (a, v)
let printb ?(first = "(") ?(last = ")") ?(sep = ",") format1 format2 out (a, b)
=
UTF8.Printf.bprintf out "%s%a%s%a%s" first format1 a sep format2 b last
end
module NCurses = struct
type mouse_event =
| BUTTON1_PRESSED
| BUTTON1_RELEASED
| BUTTON1_CLICKED
| BUTTON1_DOUBLE_CLICKED
| BUTTON1_TRIPLE_CLICKED
| BUTTON2_PRESSED
| BUTTON2_RELEASED
| BUTTON2_CLICKED
| BUTTON2_DOUBLE_CLICKED
| BUTTON2_TRIPLE_CLICKED
| BUTTON3_PRESSED
| BUTTON3_RELEASED
| BUTTON3_CLICKED
| BUTTON3_DOUBLE_CLICKED
| BUTTON3_TRIPLE_CLICKED
| BUTTON4_PRESSED
| BUTTON4_RELEASED
| BUTTON4_CLICKED
| BUTTON4_DOUBLE_CLICKED
| BUTTON4_TRIPLE_CLICKED
| BUTTON_SHIFT
| BUTTON_CTRL
| BUTTON_ALT
| ALL_MOUSE_EVENTS
| REPORT_MOUSE_POSITION
type event_type
external set_mouse_event : mouse_event list -> unit = "c_set_mouse_event"
external get_mouse_event :
unit -> (int * event_type * (int * int * int)) option = "c_get_mouse_event"
external is_event_of_type : mouse_event -> event_type -> bool
= "c_is_event_of_type"
end
let try_finally f except =
try
let res = f () in
except ();
res
with e ->
except ();
raise e
type (_, _) cmp = Eq : ('a, 'a) cmp | Lt : ('a, 'b) cmp | Gt : ('a, 'b) cmp
(** Existencial type for comparing two types.
This type has no utility, except for structural comparison between two
values.
*)
type existencial = Ex : 'a -> existencial
module type COMPARABLE_TYPE = sig
type 'a t
val comp : 'a t -> 'b t -> ('a, 'b) cmp
end
let fold_for f a b init =
let rec _fold res i = if i >= b then res else _fold (f i res) (i + 1) in
(_fold [@tailcall]) init a
|
