/
papgets.ml
229 lines (203 loc) · 8.28 KB
/
papgets.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
(*
* Handling papgets in the geomap canvas
*
* 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
let papgets = Hashtbl.create 5
let register_papget = fun p -> Hashtbl.add papgets p p
let dump_store = fun () ->
Hashtbl.fold
(fun _ p r ->
if not p#deleted then
p#config ()::r
else
r)
papgets
[]
let papget_listener =
let sep = Str.regexp "[:\\.]" in
fun papget ->
try
let field = Papget_common.get_property "field" papget in
let sender = Papget_common.get_property "sender" papget in
prerr_endline field; flush stderr;
match Str.split sep field with
[msg_name; field_name] ->
(new Papget.message_field ~sender msg_name field_name)
| _ -> failwith (sprintf "Unexpected field spec: %s" field)
with
_ -> failwith (sprintf "field attr expected in '%s" (Xml.to_string papget))
let block_name_of_index = function
[ i ] ->
let i = sprintf "%.0f" (float_of_string i) in
if Hashtbl.length Live.aircrafts = 1 then
Hashtbl.fold
(fun ac_id ac _r ->
let blocks = ExtXml.child ac.Live.fp "blocks" in
let block = ExtXml.child blocks i in
ExtXml.attrib block "name")
Live.aircrafts
"N/A"
else
"N/A"
| _ -> failwith "Papgets.block_name_of_index"
let extra_functions =
["BlockName", block_name_of_index ]
let expression_listener = fun papget ->
let expr = Papget_common.get_property "expr" papget in
let expr = Expr_lexer.parse expr in
let sender = Papget_common.get_property "sender" papget in
new Papget.expression ~extra_functions ~sender expr
let display_float_papget = fun canvas_group config display x y listener ->
let renderer =
match display with
"text" ->
(new Papget_renderer.canvas_text ~config canvas_group x y :> Papget_renderer.t)
| "ruler" ->
(new Papget_renderer.canvas_ruler canvas_group ~config x y :> Papget_renderer.t)
| "gauge" ->
(new Papget_renderer.canvas_gauge ~config canvas_group x y :> Papget_renderer.t)
| "led" ->
(new Papget_renderer.canvas_led ~config canvas_group x y :> Papget_renderer.t)
| _ -> failwith (sprintf "Unexpected papget display: %s" display) in
let p = new Papget.canvas_display_float_item ~config listener renderer in
let p = (p :> Papget.item) in
register_papget p
let locked = fun config ->
try
[PC.property "locked" (PC.get_property "locked" config)]
with _ -> []
let create = fun canvas_group papget ->
try
let type_ = ExtXml.attrib papget "type"
and display = ExtXml.attrib papget "display"
and x = ExtXml.float_attrib papget "x"
and y = ExtXml.float_attrib papget "y"
and config = Xml.children papget in
match type_ with
"expression" ->
let expr_listener = expression_listener papget in
display_float_papget canvas_group config display x y expr_listener
| "message_field" ->
let msg_listener = papget_listener papget in
display_float_papget canvas_group config display x y msg_listener
| "goto_block" ->
let renderer =
match display with
"button" ->
(new Papget_renderer.canvas_button canvas_group ~config x y :> Papget_renderer.t)
| _ -> failwith (sprintf "Unexpected papget display: %s" display) in
let block_name = Papget_common.get_property "block_name" papget in
let clicked = fun () ->
prerr_endline "Warning: goto_block papget sends to all A/C";
let sender = Papget_common.get_property "sender" papget in
printf "%s\n" sender; flush stdout;
Hashtbl.iter
(fun ac_id ac ->
printf "%s %s\n" sender ac_id; flush stdout;
if ac_id = sender then begin
let blocks = ExtXml.child ac.Live.fp "blocks" in
let block = ExtXml.child ~select:(fun x -> ExtXml.attrib x "name" = block_name) blocks "block" in
let block_id = ExtXml.int_attrib block "no" in
Live.jump_to_block ac_id block_id
end
)
Live.aircrafts
in
let properties =
[ Papget_common.property "block_name" block_name ] @ locked papget in
let p = new Papget.canvas_goto_block_item properties clicked renderer in
let p = (p :> Papget.item) in
register_papget p
| "variable_setting" ->
let renderer =
match display with
"button" ->
(new Papget_renderer.canvas_button canvas_group ~config x y :> Papget_renderer.t)
| _ -> failwith (sprintf "Unexpected papget display: %s" display) in
let varname = Papget_common.get_property "variable" papget
and value = float_of_string (Papget_common.get_property "value" papget) in
let clicked = fun () ->
prerr_endline "Warning: variable_setting papget sending to all active A/C";
Hashtbl.iter
(fun ac_id ac ->
match ac.Live.dl_settings_page with
None -> ()
| Some settings ->
let var_id = settings#assoc varname in
Live.dl_setting ac_id var_id value)
Live.aircrafts
in
let properties =
[ Papget_common.property "variable" varname;
Papget_common.float_property "value" value ]
@ locked papget in
let p = new Papget.canvas_variable_setting_item properties clicked renderer in
let p = (p :> Papget.item) in
register_papget p
| "video_plugin" ->
let renderer =
match display with
"mplayer" ->
(new Papget_renderer.canvas_mplayer canvas_group ~config x y :> Papget_renderer.t)
| "plugin" ->
(new Papget_renderer.canvas_plugin canvas_group ~config x y :> Papget_renderer.t)
| _ -> failwith (sprintf "Unexpected papget display: %s" display) in
let properties = locked papget in
let p = new Papget.canvas_video_plugin_item properties renderer in
let p = (p :> Papget.item) in
register_papget p
| _ -> failwith (sprintf "Unexpected papget type: %s" type_)
with
exc -> fprintf stderr "Papgets.create: %s\n%!" (Printexc.to_string exc)
exception Parse_message_dnd of string
(* Drag and drop handler for papgets *)
let parse_message_dnd =
let sep = Str.regexp ":" in
fun s ->
match Str.split sep s with
[s; c; m; f;scale] -> (s, c, m, f,scale)
| _ -> raise (Parse_message_dnd (Printf.sprintf "parse_dnd: %s" s))
let dnd_data_received = fun canvas_group _context ~x ~y data ~info ~time ->
try (* With the format sent by Messages *)
let (sender, _class_name, msg_name, field_name,scale) = parse_message_dnd data#data in
let attrs =
[ "type", "message_field";
"display", "text";
"x", sprintf "%d" x; "y", sprintf "%d" y ]
and props =
[ Papget_common.property "field" (sprintf "%s:%s" msg_name field_name);
Papget_common.property "sender" sender;
Papget_common.property "scale" scale ] in
let papget_xml = Xml.Element ("papget", attrs, props) in
create canvas_group papget_xml
with
Parse_message_dnd _ ->
try (* XML spec *)
let xml = Xml.parse_string data#data in
(* Add x and y attributes *)
let attrs = Xml.attribs xml @ ["x", string_of_int x; "y", string_of_int y] in
let papget_xml = Xml.Element (Xml.tag xml,attrs,Xml.children xml) in
create canvas_group papget_xml
with
exc -> prerr_endline (Printexc.to_string exc)