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
open Bimage
let windows : (string, GWindow.window * GMisc.image) Hashtbl.t =
Hashtbl.create 32
let pixbuf_of_mat width height channels ptr =
let ptr = Gpointer.region_of_bigarray ptr in
GdkPixbuf.from_data ~rowstride:(width * channels) ~has_alpha:(channels = 4)
~width ~height ~bits:8 ptr
type t = string
let create ?(width = 800) ?(height = 600) ?mousedown ?mouseup ?keydown ?keyup
?timer title m =
if Image.layout m = Image.Planar then Error.exc `Invalid_layout;
GMain.init () |> ignore;
let window = GWindow.window ~title ~width ~height ~deletable:true () in
let scroll = GBin.scrolled_window ~width ~height ~show:true () in
let image = GMisc.image () in
let width, height, channels = Image.shape m in
let pixbuf = pixbuf_of_mat width height channels m.Image.data in
image#set_pixbuf pixbuf;
scroll#add_with_viewport image#coerce;
window#add scroll#coerce;
let timer =
match timer with
| None ->
None
| Some (ms, callback) ->
Some (GMain.Timeout.add ~ms ~callback)
in
(window#connect)#destroy ~callback:(fun () ->
Hashtbl.remove windows title;
let () =
match timer with
| None ->
()
| Some timer ->
ignore (GMain.Timeout.remove timer)
in
if Hashtbl.length windows = 0 then
ignore
(GMain.Timeout.add ~ms:100 ~callback:(fun () -> GMain.quit (); false))
)
|> ignore;
Hashtbl.replace windows title (window, image);
(window#event)#add [`BUTTON_PRESS; `BUTTON_RELEASE; `KEY_PRESS; `KEY_RELEASE];
let () =
match mousedown with
| Some mousedown ->
ignore
@@ ((window#event)#connect)#button_press ~callback:(fun event ->
mousedown
(GdkEvent.Button.x event |> int_of_float)
(GdkEvent.Button.y event |> int_of_float);
true )
| None ->
()
in
let () =
match mouseup with
| Some mouseup ->
ignore
@@ ((window#event)#connect)#button_release ~callback:(fun event ->
mouseup
(GdkEvent.Button.x event |> int_of_float)
(GdkEvent.Button.y event |> int_of_float);
true )
| None ->
()
in
let () =
match keydown with
| Some keydown ->
ignore
@@ ((window#event)#connect)#key_press ~callback:(fun event ->
let c = GdkEvent.Key.keyval event in
keydown c; true )
| None ->
()
in
let () =
match keyup with
| Some keyup ->
ignore
@@ ((window#event)#connect)#key_release ~callback:(fun event ->
let c = GdkEvent.Key.keyval event in
keyup c; true )
| None ->
()
in
title
let exists title = Hashtbl.mem windows title
let find title = try Some (Hashtbl.find windows title) with Not_found -> None
let get name = if exists name then Some name else None
let resize ~width ~height title =
match find title with
| Some (window, _) ->
window#resize ~width ~height
| None ->
()
let destroy title =
match find title with
| Some (window, _) ->
window#destroy ()
| None ->
()
let update title m =
match find title with
| Some (_, image) ->
let width, height, channels = Image.shape m in
if
width = GdkPixbuf.get_width image#pixbuf
&& height = GdkPixbuf.get_height image#pixbuf
then
let pixbuf = pixbuf_of_mat width height channels m.Image.data in
image#set_pixbuf pixbuf
| None ->
()
let show_all ?(ms = 0) () =
if Hashtbl.length windows = 0 then ()
else if ms > 0 then
GMain.Timeout.add ~ms ~callback:(fun () -> GMain.quit (); false) |> ignore;
Hashtbl.iter (fun _ (v, _) -> v#show ()) windows;
GMain.main ()