/
papget.ml
423 lines (356 loc) · 13.7 KB
/
papget.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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
(*
* Paparazzi widgets
*
* Copyright (C) 2008 ENAC
*
* This file is part of paparazzi.
*
* paparazzi 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 2, or (at your option)
* any later version.
*
* paparazzi 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 paparazzi; see the file COPYING. If not, write to
* the Free Software Foundation, 59 Temple Place - Suite 330,
* Boston, MA 02111-1307, USA.
*
*)
open Printf
module PC = Papget_common
module PR = Papget_renderer
module E = Expr_syntax
let (//) = Filename.concat
class type item = object
method config : unit -> Xml.xml
method deleted : bool
end
class type value =
object
method last_value : string
method connect : (string -> unit) -> unit
method config : unit -> Xml.xml list
method type_ : string
end
(** [index_of_fields s] Returns i if s matches x[i] else 0. *)
let base_and_index =
let field_regexp = Str.regexp "\\([^\\.]+\\)\\[\\([0-9]+\\)\\]" in
fun field_descr ->
if Str.string_match field_regexp field_descr 0 then
( Str.matched_group 1 field_descr,
int_of_string (Str.matched_group 2 field_descr))
else
(field_descr, 0)
class message_field = fun ?sender ?(class_name="telemetry") msg_name field_descr ->
object
val mutable callbacks = []
val mutable last_value = "0."
method last_value = last_value
method connect = fun cb -> callbacks <- cb :: callbacks
method config = fun () ->
let field = sprintf "%s:%s" msg_name field_descr in
let ac_id = match sender with None -> [] | Some id -> [PC.property "ac_id" id] in
[ PC.property "field" field ] @ ac_id
method type_ = "message_field"
initializer
let module P = PprzLink.Messages (struct let name = class_name end) in
let process_message = fun _sender values ->
let (field_name, index) = base_and_index field_descr in
let value =
match PprzLink.assoc field_name values with
PprzLink.Array array -> array.(index)
| scalar -> scalar in
last_value <- PprzLink.string_of_value value;
List.iter (fun cb -> cb last_value) callbacks in
ignore (P.message_bind ?sender msg_name process_message)
end
let hash_vars = fun ?sender expr ->
let htable = Hashtbl.create 3 in
let rec loop = function
E.Ident i -> prerr_endline i
| E.Int _ | E.Float _ -> ()
| E.Call (_id, list) | E.CallOperator (_id, list) -> List.iter loop list
| E.Index (_id, e) -> loop e
| E.Deref (_e, _f) as deref -> fprintf stderr "Warning: Deref operator is not allowed in Papgets expressions (%s)" (E.sprint deref)
| E.Field (i, f) ->
if not (Hashtbl.mem htable (i,f)) then
let msg_obj = new message_field ?sender i f in
Hashtbl.add htable (i, f) msg_obj in
loop expr;
htable
let wrap = fun f ->
fun x y -> string_of_float (f (float_of_string x) (float_of_string y))
let eval_bin_op = function
| "*" -> wrap ( *. )
| "+" -> wrap ( +. )
| "-" -> wrap ( -. )
| "/" -> wrap ( /. )
| "**" -> wrap ( ** )
| op -> failwith (sprintf "Papget.eval_expr '%s'" op)
let eval_expr = fun (extra_functions:(string * (string list -> string)) list) h e ->
let rec loop = function
E.Ident ident -> failwith (sprintf "Papget.eval_expr '%s'" ident)
| E.Int int -> string_of_int int
| E.Float float -> string_of_float float
| E.CallOperator (ident, [e1; e2]) ->
eval_bin_op ident (loop e1) (loop e2)
| E.Call (ident, args) when List.mem_assoc ident extra_functions ->
(List.assoc ident extra_functions) (List.map loop args)
| E.Call (ident, _l) | E.CallOperator (ident, _l) ->
failwith (sprintf "Papget.eval_expr '%s(...)'" ident)
| E.Index (ident, _e) -> failwith (sprintf "Papget.eval_expr '%s[...]'" ident)
| E.Deref (_e, _f) as deref -> failwith (sprintf "Papget.eval_expr Deref operator is not allowed in Papgets expressions (%s)" (E.sprint deref))
| E.Field (i, f) ->
try
(Hashtbl.find h (i,f))#last_value
with
Not_found -> failwith (sprintf "Papget.eval_expr '%s.%s'" i f)
in loop e
class expression = fun ?(extra_functions=[]) ?sender expr ->
let h = hash_vars ?sender expr in
object
val mutable callbacks = []
val mutable last_value = "0."
method last_value = last_value
method connect = fun cb -> callbacks <- cb :: callbacks
method config = fun () ->
let ac_id = match sender with None -> [] | Some id -> [PC.property "ac_id" id] in
[ PC.property "expr" (Expr_syntax.sprint expr)] @ ac_id
method type_ = "expression"
initializer
Hashtbl.iter
(fun (i,f) (msg_obj:value) ->
let val_updated = fun _new_val ->
last_value <- eval_expr extra_functions h expr;
List.iter (fun cb -> cb last_value) callbacks
in
msg_obj#connect val_updated)
h
end
class type canvas_item_type =
object
method connect : unit -> unit
method deleted : bool
method edit : unit -> unit
method event : GnoCanvas.item_event -> bool
method renderer : Papget_renderer.t
method update : string -> unit
method xy : float * float
end
class canvas_item = fun ~config canvas_renderer ->
let canvas_renderer = (canvas_renderer :> PR.t) in
object (self)
val mutable motion = false
val mutable renderer = canvas_renderer
val mutable x_press = 0.
val mutable y_press = 0.
val mutable deleted = false
val mutable dialog_widget = None
method renderer = renderer
method xy =
let (x0, y0) = renderer#item#i2w 0. 0. in
renderer#item#parent#w2i x0 y0
method deleted = deleted
method update = fun value ->
try
(renderer#update:string->unit) value
with
exc -> prerr_endline (Printexc.to_string exc)
method event = fun (ev : GnoCanvas.item_event) ->
let item = (renderer#item :> PR.movable_item) in
match ev with
`BUTTON_PRESS ev ->
begin
match GdkEvent.Button.button ev with
| 1 ->
motion <- false;
let x = GdkEvent.Button.x ev and y = GdkEvent.Button.y ev in
let (xm, ym) = renderer#item#parent#w2i x y in
let (x0, y0) = renderer#item#i2w 0. 0. in
let (xi, yi) = renderer#item#parent#w2i x0 y0 in
x_press <- xm -. xi; y_press <- ym -. yi;
let curs = Gdk.Cursor.create `FLEUR in
item#grab [`POINTER_MOTION; `BUTTON_RELEASE] curs
(GdkEvent.Button.time ev)
| _ -> ()
end;
true
| `MOTION_NOTIFY ev ->
let state = GdkEvent.Motion.state ev in
if Gdk.Convert.test_modifier `BUTTON1 state then begin
motion <- true;
let x = GdkEvent.Motion.x ev
and y = GdkEvent.Motion.y ev in
let (xw, yw) = renderer#item#parent#w2i x y in
item#set [`X (xw-.x_press); `Y (yw-.y_press)];
renderer#item#parent#affine_relative [|1.;0.;0.;1.;0.;0.|]
end;
true
| `BUTTON_RELEASE ev ->
if GdkEvent.Button.button ev = 1 then begin
item#ungrab (GdkEvent.Button.time ev);
(* get item and window size *)
let bounds = item#get_bounds in
let w, h = Gdk.Drawable.get_size item#canvas#misc#window in
if not motion then begin
self#edit ()
end
else if (truncate bounds.(0) > w) || (truncate bounds.(2) < 0) || (truncate bounds.(1) > h) || (truncate bounds.(3) < 0) then begin
(* delete an item if placed out of the window on the left or top side *)
item#destroy ();
deleted <- true
end;
motion <- false
end;
true
| _ -> false
method edit = fun () ->
let file = Env.paparazzi_src // "sw" // "lib" // "ocaml" // "widgets.glade" in
let dialog = new Gtk_papget_editor.papget_editor ~file () in
let ac_id = PC.get_prop "ac_id" config "Any" in
dialog#toplevel#set_title ("Papget Editor (A/C: "^ac_id^")");
let tagged_renderers = Lazy.force PR.lazy_tagged_renderers in
let strings = List.map fst tagged_renderers in
let (combo, (tree, column)) = GEdit.combo_box_text ~packing:dialog#box_item_chooser#add ~strings () in
tree#foreach
(fun _path row ->
if tree#get ~row ~column = renderer#tag then begin
combo#set_active_iter (Some row);
true
end else
false);
let connect_item_editor = fun () ->
begin (* Remove the current child ? *)
try
let child = dialog#box_item_editor#child in
dialog#box_item_editor#remove child
with
Gpointer.Null -> ()
end;
renderer#edit dialog#box_item_editor#add in
connect_item_editor ();
(* Connect the renderer chooser *)
ignore (combo#connect#changed
(fun () ->
match combo#active_iter with
| None -> ()
| Some row ->
let data = combo#model#get ~row ~column in
if data <> renderer#tag then
let new_renderer = List.assoc data tagged_renderers in
let group = renderer#item#parent in
let (x, y) = renderer#item#i2w 0. 0. in
let (x, y) = group#w2i x y in
renderer#item#destroy ();
renderer <- new_renderer group x y;
self#connect ();
connect_item_editor ()));
(* Connect the buttons *)
ignore (dialog#button_delete#connect#clicked
(fun () ->
dialog#papget_editor#destroy ();
renderer#item#destroy ();
deleted <- true));
ignore (dialog#button_ok#connect#clicked (fun () -> dialog#papget_editor#destroy ()));
dialog_widget <- Some dialog
val mutable connection =
canvas_renderer#item#connect#event (fun _ -> false)
method connect = fun () ->
if PC.get_prop "locked" config "false" = "false" then
let item = (renderer#item :> PR.movable_item) in
connection <- item#connect#event self#event
initializer
self#connect ()
end
class canvas_float_item = fun ~config canvas_renderer ->
object
inherit canvas_item ~config canvas_renderer as super
val mutable affine = "1"
method update = fun value ->
let scaled_value =
try
let (a, b) = Ocaml_tools.affine_transform affine
and fvalue = float_of_string value in
string_of_float (fvalue *. a +. b)
with
_ -> value in
super#update scaled_value
method edit = fun () ->
super#edit ();
match dialog_widget with
None -> ()
| Some dialog ->
(* Set the current value *)
dialog#entry_scale#set_text affine;
(* Connect the scale entry *)
let callback = fun () ->
affine <- dialog#entry_scale#text in
ignore (dialog#entry_scale#connect#activate ~callback);
dialog#hbox_scale#misc#show ()
end
class canvas_display_float_item = fun ~config (msg_obj:value) (canvas_renderer:PR.t) ->
object (self)
inherit canvas_float_item ~config canvas_renderer as item
initializer
affine <- PC.get_prop "scale" config "1";
msg_obj#connect self#update_field
method update_field = fun value ->
if not deleted then begin
item#update value
end
method config = fun () ->
let renderer_props = renderer#config ()
and val_props = msg_obj#config ()
and scale_prop = PC.property "scale" affine in
let (x, y) = item#xy in
let attrs =
[ "type", msg_obj#type_;
"display", Compat.lowercase_ascii item#renderer#tag;
"x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
Xml.Element ("papget", attrs, scale_prop::val_props@renderer_props)
end
(****************************************************************************)
(** A clickable item is not editable: The #edit method is overiden with a
provided callback *)
class canvas_clickable_item = fun type_ properties callback canvas_renderer ->
object
inherit canvas_item ~config:properties canvas_renderer as item
method edit = fun () -> callback ()
method config = fun () ->
let props = renderer#config () in
let (x, y) = item#xy in
let attrs =
[ "type", type_;
"display", Compat.lowercase_ascii item#renderer#tag;
"x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
Xml.Element ("papget", attrs, properties@props)
end
class canvas_goto_block_item = fun properties callback (canvas_renderer:PR.t) ->
object
inherit canvas_clickable_item "goto_block" properties callback canvas_renderer as item
end
class canvas_variable_setting_item = fun properties callback (canvas_renderer:PR.t) ->
object
inherit canvas_clickable_item "variable_setting" properties callback canvas_renderer
end
(****************************************************************************)
class canvas_video_plugin_item = fun properties (canvas_renderer:PR.t) (adj:GData.adjustment) ->
object (self)
inherit canvas_item ~config:properties canvas_renderer as item
method update_zoom = fun zoom ->
item#update zoom
method config = fun () ->
let props = renderer#config () in
let (x, y) = item#xy in
let attrs =
[ "type", "video_plugin";
"display", Compat.lowercase_ascii item#renderer#tag;
"x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
Xml.Element ("papget", attrs, properties@props)
initializer ignore(adj#connect#value_changed (fun () -> self#update_zoom (string_of_float adj#value)))
end