diff --git a/sw/lib/ocaml/Makefile b/sw/lib/ocaml/Makefile index 3fc3f6736e..cc32250ddd 100644 --- a/sw/lib/ocaml/Makefile +++ b/sw/lib/ocaml/Makefile @@ -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 # diff --git a/sw/lib/ocaml/expr_lexer.mll b/sw/lib/ocaml/expr_lexer.mll new file mode 100644 index 0000000000..695409d5a9 --- /dev/null +++ b/sw/lib/ocaml/expr_lexer.mll @@ -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 +} diff --git a/sw/lib/ocaml/expr_parser.mly b/sw/lib/ocaml/expr_parser.mly new file mode 100644 index 0000000000..c2f63b4a00 --- /dev/null +++ b/sw/lib/ocaml/expr_parser.mly @@ -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 +%token FLOAT +%token 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 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 } +; diff --git a/sw/lib/ocaml/expr_syntax.ml b/sw/lib/ocaml/expr_syntax.ml new file mode 100644 index 0000000000..be15604c8d --- /dev/null +++ b/sw/lib/ocaml/expr_syntax.ml @@ -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 diff --git a/sw/lib/ocaml/expr_syntax.mli b/sw/lib/ocaml/expr_syntax.mli new file mode 100644 index 0000000000..0d266c2354 --- /dev/null +++ b/sw/lib/ocaml/expr_syntax.mli @@ -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 *) diff --git a/sw/lib/ocaml/papget.ml b/sw/lib/ocaml/papget.ml index f8910a5c1b..e73b934f9d 100644 --- a/sw/lib/ocaml/papget.ml +++ b/sw/lib/ocaml/papget.ml @@ -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 diff --git a/sw/lib/ocaml/papget.mli b/sw/lib/ocaml/papget.mli index d202521440..d939ff64ea 100644 --- a/sw/lib/ocaml/papget.mli +++ b/sw/lib/ocaml/papget.mli @@ -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 diff --git a/sw/lib/ocaml/papget_renderer.ml b/sw/lib/ocaml/papget_renderer.ml index 81ed6478bf..e5ef38d0a5 100644 --- a/sw/lib/ocaml/papget_renderer.ml +++ b/sw/lib/ocaml/papget_renderer.ml @@ -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]