mirror of
https://github.com/paparazzi/paparazzi.git
synced 2026-06-07 09:36:19 +08:00
add papget for multi message fields expressions
This commit is contained in:
Pascal Brisset
+20
-3
@@ -26,10 +26,12 @@ INCLUDES= -I +xml-light -I +pcre -I +netstring
|
||||
XINCLUDES= -I +lablgl -I +lablgtk2 -I +xml-light
|
||||
OCAMLC=ocamlc
|
||||
OCAMLOPT=ocamlopt
|
||||
OCAMLLEX=ocamllex
|
||||
OCAMLYACC=ocamlyacc
|
||||
OCAMLLIBDIR=$(shell ocamlc -where)
|
||||
|
||||
|
||||
SRC = fig.ml debug.ml base64.ml serial.ml ocaml_tools.ml extXml.ml env.ml xml2h.ml latlong.ml egm96.ml srtm.ml http.ml gm.ml iGN.ml geometry_2d.ml cserial.o convert.o ubx.ml pprz.ml xbee.ml logpprz.ml xmlCom.ml editAirframe.ml
|
||||
SRC = fig.ml debug.ml base64.ml serial.ml ocaml_tools.ml expr_syntax.ml expr_parser.ml expr_lexer.ml extXml.ml env.ml xml2h.ml latlong.ml egm96.ml srtm.ml http.ml gm.ml iGN.ml geometry_2d.ml cserial.o convert.o ubx.ml pprz.ml xbee.ml logpprz.ml xmlCom.ml editAirframe.ml
|
||||
CMO = $(SRC:.ml=.cmo)
|
||||
CMX = $(SRC:.ml=.cmx)
|
||||
|
||||
@@ -104,7 +106,22 @@ caml_from_c_example : cserial.o convert.o caml_from_c_example.o camltm.o
|
||||
|
||||
%.cmi : %.ml
|
||||
@echo OC $<
|
||||
$(Q)$(OCAMLC) $(XINCLUDES) $<
|
||||
$(Q)$(OCAMLC) $(XINCLUDES) -c $<
|
||||
|
||||
%.ml : %.mll
|
||||
@echo OCL $<
|
||||
$(Q)$(OCAMLLEX) $<
|
||||
|
||||
%.ml %.mli : %.mly
|
||||
@echo OCY $<
|
||||
$(Q)$(OCAMLYACC) $<
|
||||
|
||||
expr_parser.cmo expr_parser.cmx : expr_parser.cmi expr_syntax.cmi
|
||||
expr_parser.cmi : expr_parser.ml expr_syntax.cmi
|
||||
expr_lexer.cmi : expr_syntax.cmi
|
||||
expr_lexer.cmo : expr_lexer.cmi
|
||||
expr_syntax.cmo : expr_syntax.cmi
|
||||
|
||||
|
||||
gtk_papget_editor.ml : widgets.glade
|
||||
lablgladecc2 -root papget_editor -hide-default $< | grep -B 1000000 " end" > $@
|
||||
@@ -116,7 +133,7 @@ gtk_papget_gauge_editor.ml : widgets.glade
|
||||
lablgladecc2 -root table_gauge_editor -hide-default $< | grep -B 1000000 " end" > $@
|
||||
|
||||
clean :
|
||||
rm -f *~ *.cm* *.out *.opt .depend *.a *.o *.so tests gtk_papget_*.ml
|
||||
rm -f *~ *.cm* *.out *.opt .depend *.a *.o *.so tests gtk_papget_*.ml expr_parser.ml expr_parser.mli expr_lexer.ml expr_lexer.mli
|
||||
|
||||
|
||||
#
|
||||
|
||||
@@ -0,0 +1,73 @@
|
||||
(*
|
||||
* $Id$
|
||||
*
|
||||
* Lexical tokens à la C
|
||||
*
|
||||
* Copyright (C) 2003-2010 Antoine Drouin, Pascal Brisset, 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 Expr_parser
|
||||
}
|
||||
rule token = parse
|
||||
[' ' '\t' '\n'] { token lexbuf}
|
||||
| "/*"([^'*']|'*'[^'/'])*'*'*'/' { token lexbuf}
|
||||
| ['0'-'9']+ { INT (int_of_string (Lexing.lexeme lexbuf)) }
|
||||
| ['0'-'9']+'.'['0'-'9']* { FLOAT (float_of_string (Lexing.lexeme lexbuf)) }
|
||||
| '$'?['a'-'z' '_' 'A'-'Z'] (['a'-'z' 'A'-'Z' '_' '0'-'9']*) { IDENT (Lexing.lexeme lexbuf) }
|
||||
| '\''[^'\'']+'\'' { let s = Lexing.lexeme lexbuf in IDENT (String.sub s 1 (String.length s - 2)) }
|
||||
| ',' { COMMA }
|
||||
| '.' { DOT }
|
||||
| ';' { SEMICOLON }
|
||||
| ':' { COLON }
|
||||
| '(' { LP }
|
||||
| ')' { RP }
|
||||
| '{' { LC }
|
||||
| '}' { RC }
|
||||
| '[' { LB }
|
||||
| ']' { RB }
|
||||
| "==" { EQ }
|
||||
| "&&" { AND }
|
||||
| "||" { OR }
|
||||
| ">" { GT }
|
||||
| "%" { MOD }
|
||||
| ">=" { GEQ }
|
||||
| "+" { PLUS }
|
||||
| "=" { ASSIGN }
|
||||
| "-" { MINUS }
|
||||
| "*" { MULT }
|
||||
| "/" { DIV }
|
||||
| "!" { NOT }
|
||||
| eof { EOF }
|
||||
|
||||
{
|
||||
let parse = fun s ->
|
||||
let lexbuf = Lexing.from_string s in
|
||||
try
|
||||
Expr_parser.expression token lexbuf
|
||||
with
|
||||
Failure("lexing: empty token") ->
|
||||
Printf.fprintf stderr "Lexing error in '%s': unexpected char: '%c' \n"
|
||||
s (Lexing.lexeme_char lexbuf 0);
|
||||
exit 1
|
||||
| Parsing.Parse_error ->
|
||||
Printf.fprintf stderr "Parsing error in '%s', token '%s' ?\n"
|
||||
s (Lexing.lexeme lexbuf);
|
||||
exit 1
|
||||
}
|
||||
@@ -0,0 +1,77 @@
|
||||
/*
|
||||
* $Id$
|
||||
*
|
||||
* Grammar à la C
|
||||
*
|
||||
* Copyright (C) 2003-2010 Antoine Drouin, Pascal Brisset, 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 Expr_syntax
|
||||
%}
|
||||
%token <int> INT
|
||||
%token <float> FLOAT
|
||||
%token <string> IDENT
|
||||
%token EOF
|
||||
%token DOT COMMA SEMICOLON LP RP LC RC LB RB AND COLON OR
|
||||
%token EQ GT ASSIGN GEQ NOT
|
||||
%token PLUS MINUS
|
||||
%token MULT DIV MOD
|
||||
|
||||
%left AND OR /* lowest precedence */
|
||||
%left EQ GT ASSIGN GEQ
|
||||
%left PLUS MINUS
|
||||
%left MULT DIV MOD
|
||||
%nonassoc NOT
|
||||
%nonassoc UMINUS /* highest precedence */
|
||||
|
||||
%start expression /* the entry point */
|
||||
%type <Expr_syntax.expression> expression
|
||||
|
||||
%%
|
||||
|
||||
expression:
|
||||
expression GT expression { CallOperator (">",[$1;$3]) }
|
||||
| expression GEQ expression { CallOperator (">=",[$1;$3]) }
|
||||
| expression EQ expression { CallOperator ("==",[$1;$3]) }
|
||||
| expression AND expression { CallOperator ("&&",[$1;$3]) }
|
||||
| expression OR expression { CallOperator ("||",[$1;$3]) }
|
||||
| expression PLUS expression { CallOperator ("+",[$1;$3]) }
|
||||
| expression MINUS expression { CallOperator ("-",[$1;$3]) }
|
||||
| expression MULT expression { CallOperator ("*",[$1;$3]) }
|
||||
| expression DIV expression { CallOperator ("/",[$1;$3]) }
|
||||
| expression MOD expression { CallOperator ("%",[$1;$3]) }
|
||||
| MINUS expression %prec UMINUS { CallOperator ("-",[$2]) }
|
||||
| NOT expression { CallOperator ("!",[$2]) }
|
||||
| INT { Int $1 }
|
||||
| FLOAT { Float $1 }
|
||||
| IDENT { Ident $1 }
|
||||
| IDENT DOT IDENT { Field ($1,$3) }
|
||||
| IDENT LP Args RP { Call ($1, $3) }
|
||||
| LP expression RP { $2 }
|
||||
| IDENT LB expression RB { Index ($1, $3) }
|
||||
;
|
||||
|
||||
Args: { [] }
|
||||
| expression NextArgs { $1::$2 }
|
||||
;
|
||||
|
||||
NextArgs: { [] }
|
||||
| COMMA expression NextArgs { $2::$3 }
|
||||
;
|
||||
@@ -0,0 +1,115 @@
|
||||
(*
|
||||
* $Id$
|
||||
*
|
||||
* Syntax of expressions à la C
|
||||
*
|
||||
* Copyright (C) 2003-2010 Antoine Drouin, Pascal Brisset, 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
|
||||
|
||||
type ident = string
|
||||
|
||||
type operator = string
|
||||
type expression =
|
||||
| Ident of ident
|
||||
| Int of int
|
||||
| Float of float
|
||||
| Call of ident * (expression list)
|
||||
| CallOperator of ident * (expression list)
|
||||
| Index of ident * expression
|
||||
| Field of ident * ident
|
||||
|
||||
let c_var_of_ident = fun x -> "_var_" ^ x
|
||||
|
||||
let rec sprint = function
|
||||
Ident i when i.[0] = '$' -> sprintf "%s" (c_var_of_ident (String.sub i 1 (String.length i - 1)))
|
||||
| Ident i -> sprintf "%s" i
|
||||
| Int i -> sprintf "%d" i
|
||||
| Float i -> sprintf "%f" i
|
||||
| CallOperator (op, [e1;e2]) ->
|
||||
sprintf "(%s%s%s)" (sprint e1) op (sprint e2)
|
||||
| CallOperator (op, [e1]) ->
|
||||
sprintf "%s(%s)" op (sprint e1)
|
||||
| CallOperator (_,_) -> failwith "Operator should be binary or unary"
|
||||
| Call (i, es) ->
|
||||
let ses = List.map sprint es in
|
||||
sprintf "%s(%s)" i (String.concat "," ses)
|
||||
| Index (i,e) -> sprintf "%s[%s]" i (sprint e)
|
||||
| Field (i,f) -> sprintf "%s.%s" i f
|
||||
|
||||
(* Valid functions : FIXME *)
|
||||
let functions = [
|
||||
"Qdr";
|
||||
"And";
|
||||
"Or";
|
||||
"RcRoll";
|
||||
"RcEvent1";
|
||||
"RcEvent2";
|
||||
"RadOfDeg"]
|
||||
|
||||
(* Valid identifiers : FIXME *)
|
||||
let variables = [
|
||||
"launch";
|
||||
"estimator_z";
|
||||
"estimator_flight_time";
|
||||
"estimator_hspeed_mod";
|
||||
"estimator_theta";
|
||||
"circle_count";
|
||||
"vsupply";
|
||||
"stage_time";
|
||||
"stage_time_ds";
|
||||
"block_time";
|
||||
"SECURITY_ALT";
|
||||
"ground_alt"; "GROUND_ALT";
|
||||
"TRUE";
|
||||
"FALSE";
|
||||
"QFU";
|
||||
"gps_mode"; "gps_utm_east"; "gps_utm_north"; "gps_utm_zone";
|
||||
"nav_utm_east0"; "nav_utm_north0"; "nav_utm_zone0"; "cruise_throttle"; "gps_lost"
|
||||
|
||||
]
|
||||
|
||||
exception Unknown_ident of string
|
||||
exception Unknown_operator of string
|
||||
exception Unknown_function of string
|
||||
|
||||
let unexpected = fun kind x ->
|
||||
fprintf stderr "Warning: unexpected %s in expression: '%s' \n" kind x
|
||||
|
||||
let rec check_expression = fun e ->
|
||||
match e with
|
||||
Ident i when i.[0] = '$' -> ()
|
||||
| Ident i ->
|
||||
if not (List.mem i variables) then
|
||||
unexpected "ident" i
|
||||
| Int _ | Float _ | CallOperator _ -> ()
|
||||
| Call (i, es) ->
|
||||
if not (List.mem i functions) then
|
||||
unexpected "function" i;
|
||||
List.iter check_expression es
|
||||
| Index (i,e) ->
|
||||
if not (List.mem i variables) then
|
||||
unexpected "ident" i;
|
||||
check_expression e
|
||||
| Field (i, _field) ->
|
||||
if not (List.mem i variables) then
|
||||
unexpected "ident" i
|
||||
@@ -0,0 +1,49 @@
|
||||
(*
|
||||
* $Id$
|
||||
*
|
||||
* Syntax of expressions à la C
|
||||
*
|
||||
* Copyright (C) 2003-2010 CENA/ENAC, Pascal Brisset, Antoine Drouin
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*)
|
||||
|
||||
type ident = string
|
||||
type operator = string
|
||||
type expression =
|
||||
| Ident of ident
|
||||
| Int of int
|
||||
| Float of float
|
||||
| Call of ident * expression list
|
||||
| CallOperator of ident * expression list
|
||||
| Index of ident * expression
|
||||
| Field of ident * ident
|
||||
|
||||
val c_var_of_ident : ident -> string
|
||||
(** Encapsulate a user ident into a C variable *)
|
||||
|
||||
val sprint : expression -> string
|
||||
|
||||
exception Unknown_ident of string
|
||||
exception Unknown_operator of string
|
||||
exception Unknown_function of string
|
||||
|
||||
val check_expression : expression -> unit
|
||||
(** May raise [Unknown_ident], [Unknown_operator] or [Unknown_function]
|
||||
exceptions *)
|
||||
+120
-45
@@ -27,6 +27,7 @@
|
||||
open Printf
|
||||
module PC = Papget_common
|
||||
module PR = Papget_renderer
|
||||
module E = Expr_syntax
|
||||
let (//) = Filename.concat
|
||||
|
||||
class type item = object
|
||||
@@ -34,6 +35,16 @@ class type item = object
|
||||
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
|
||||
@@ -44,36 +55,110 @@ let base_and_index =
|
||||
else
|
||||
(field_descr, 0)
|
||||
|
||||
class message = fun ?sender ?(class_name="telemetry") msg_name ->
|
||||
|
||||
class message_field = fun ?sender ?(class_name="telemetry") msg_name field_descr ->
|
||||
object
|
||||
val mutable callbacks = []
|
||||
method connect = fun f cb -> callbacks <- (f, cb) :: callbacks
|
||||
method msg_name = msg_name
|
||||
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
|
||||
[ PC.property "field" field ]
|
||||
method type_ = "message_field"
|
||||
|
||||
initializer
|
||||
let module P = Pprz.Messages (struct let name = class_name end) in
|
||||
let cb = fun _sender values ->
|
||||
List.iter
|
||||
(fun (field_descr, cb) ->
|
||||
let (field_name, index) = base_and_index field_descr in
|
||||
let value =
|
||||
match Pprz.assoc field_name values with
|
||||
Pprz.Array array -> array.(index)
|
||||
| scalar -> scalar in
|
||||
cb (Pprz.string_of_value value))
|
||||
callbacks in
|
||||
ignore (P.message_bind ?sender msg_name cb)
|
||||
let process_message = fun _sender values ->
|
||||
let (field_name, index) = base_and_index field_descr in
|
||||
let value =
|
||||
match Pprz.assoc field_name values with
|
||||
Pprz.Array array -> array.(index)
|
||||
| scalar -> scalar in
|
||||
|
||||
last_value <- Pprz.string_of_value value;
|
||||
|
||||
List.iter (fun cb -> cb last_value) callbacks in
|
||||
ignore (P.message_bind ?sender msg_name process_message)
|
||||
end
|
||||
|
||||
class field = fun msg_obj field_name ->
|
||||
object (self)
|
||||
val mutable last_val = ""
|
||||
method update_field = fun value -> last_val <- value
|
||||
|
||||
let hash_vars = fun 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.Field (i, f) ->
|
||||
if not (Hashtbl.mem htable (i,f)) then
|
||||
let msg_obj = new message_field 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 ( /. )
|
||||
| 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.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=[]) expr ->
|
||||
let h = hash_vars 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 () ->
|
||||
[ PC.property "expr" (Expr_syntax.sprint expr)]
|
||||
|
||||
method type_ = "expression"
|
||||
|
||||
initializer
|
||||
msg_obj#connect field_name self#update_field
|
||||
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
|
||||
@@ -221,9 +306,14 @@ class canvas_float_item = fun ~config canvas_renderer ->
|
||||
val mutable affine = "1"
|
||||
|
||||
method update = fun value ->
|
||||
let (a, b) = Ocaml_tools.affine_transform affine
|
||||
and fvalue = float_of_string value in
|
||||
super#update (string_of_float (fvalue *. a +. b))
|
||||
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 ();
|
||||
@@ -240,44 +330,29 @@ class canvas_float_item = fun ~config canvas_renderer ->
|
||||
end
|
||||
|
||||
|
||||
class canvas_display_float_item = fun ~config (msg_obj:message) field_name (canvas_renderer:PR.t) ->
|
||||
object
|
||||
inherit field msg_obj field_name as super
|
||||
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"
|
||||
affine <- PC.get_prop "scale" config "1";
|
||||
msg_obj#connect self#update_field
|
||||
|
||||
method update_field = fun value ->
|
||||
if not deleted then begin
|
||||
super#update_field value;
|
||||
item#update value
|
||||
end
|
||||
|
||||
method config = fun () ->
|
||||
let props = renderer#config () in
|
||||
let field = sprintf "%s:%s" msg_obj#msg_name field_name in
|
||||
let field_prop = PC.property "field" field
|
||||
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", "message_field";
|
||||
[ "type", msg_obj#type_;
|
||||
"display", String.lowercase item#renderer#tag;
|
||||
"x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
|
||||
Xml.Element ("papget", attrs, field_prop::scale_prop::props)
|
||||
end
|
||||
|
||||
|
||||
(****************************************************************************)
|
||||
class canvas_setting_item = fun ~config variable canvas_renderer ->
|
||||
object
|
||||
inherit canvas_float_item ~config canvas_renderer as item
|
||||
|
||||
method clicked = fun value ->
|
||||
(variable#set : float -> unit) value
|
||||
|
||||
initializer
|
||||
variable#connect item#update
|
||||
Xml.Element ("papget", attrs, scale_prop::val_props@renderer_props)
|
||||
end
|
||||
|
||||
|
||||
|
||||
+16
-7
@@ -30,15 +30,25 @@ class type item =
|
||||
method deleted : bool
|
||||
end
|
||||
|
||||
class message :
|
||||
class type value =
|
||||
object
|
||||
method last_value : string
|
||||
method connect : (string -> unit) -> unit
|
||||
method config : unit -> Xml.xml list
|
||||
method type_ : string
|
||||
end
|
||||
|
||||
class message_field :
|
||||
?sender:string ->
|
||||
?class_name:string ->
|
||||
string ->
|
||||
object
|
||||
method connect : string -> (string -> unit) -> unit
|
||||
method msg_name : string
|
||||
end
|
||||
string ->
|
||||
value
|
||||
|
||||
class expression :
|
||||
?extra_functions:(string * (string list -> string)) list ->
|
||||
Expr_syntax.expression ->
|
||||
value
|
||||
|
||||
class type canvas_item_type =
|
||||
object
|
||||
@@ -53,8 +63,7 @@ class type canvas_item_type =
|
||||
|
||||
class canvas_display_float_item :
|
||||
config:Xml.xml list ->
|
||||
message ->
|
||||
string ->
|
||||
value ->
|
||||
Papget_renderer.t ->
|
||||
object
|
||||
inherit canvas_item_type
|
||||
|
||||
@@ -60,7 +60,8 @@ class canvas_text = fun ?(config=[]) canvas_group x y ->
|
||||
PC.float_property "size" size;
|
||||
PC.property "color" color ]
|
||||
method update = fun (value : string) ->
|
||||
let renderer = fun x -> sprintf (Obj.magic format) (float_of_string x) in
|
||||
let renderer = fun x ->
|
||||
try sprintf (Obj.magic format) (float_of_string x) with _ -> x in
|
||||
text#set [`SIZE_POINTS size; `TEXT (renderer value); `FILL_COLOR color; `ANCHOR `NW]
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user