X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Fpxp%2Fpxp%2Fexamples%2Fxmlforms%2Fds_style.ml;fp=helm%2FDEVEL%2Fpxp%2Fpxp%2Fexamples%2Fxmlforms%2Fds_style.ml;h=08d0daa0353173722e0445f894a5bb1e6327dd19;hb=c03d2c1fdab8d228cb88aaba5ca0f556318bebc5;hp=0000000000000000000000000000000000000000;hpb=758057e85325f94cd88583feb1fdf6b038e35055;p=helm.git

diff --git a/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_style.ml b/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_style.ml
new file mode 100644
index 000000000..08d0daa03
--- /dev/null
+++ b/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_style.ml
@@ -0,0 +1,778 @@
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+open Pxp_types
+open Pxp_document
+open Ds_context
+
+
+let get_dimension s =
+  let re = Str.regexp "\\([0-9]*\\(.[0-9]+\\)?\\)[ \t\n]*\\(px\\|cm\\|in\\|mm\\|pt\\)" in
+  if Str.string_match re s 0 then begin
+    let number = Str.matched_group 1 s in
+    let dim = Str.matched_group 3 s in
+    match dim with
+	"px" -> Tk.Pixels (int_of_float (float_of_string number))
+      | "cm" -> Tk.Centimeters (float_of_string number)
+      | "in" -> Tk.Inches (float_of_string number)
+      | "mm" -> Tk.Millimeters (float_of_string number)
+      | "pt" -> Tk.PrinterPoint (float_of_string number)
+      | _ -> assert false
+  end
+  else
+    failwith ("Bad dimension: " ^ s)
+;;
+
+
+class virtual shared =
+  object(self)
+
+    (* --- default_ext --- *)
+
+    val mutable node = (None : shared node option)
+
+    method clone = {< >}
+    method node =
+      match node with
+          None ->
+            assert false
+        | Some n -> n
+    method set_node n =
+      node <- Some n
+
+    (* --- shared attributes: color & font settings --- *)
+
+    val mutable fgcolor = (None : string option)
+    val mutable bgcolor = (None : string option)
+    val mutable font = (None : string option)
+
+    method fgcolor =
+      (* Get the foreground color: If there is a local value, return it;
+       * otherwise ask parent node
+       *)
+      match fgcolor with
+	  Some c -> c
+	| None   -> try self # node # parent # extension # fgcolor with
+	            Not_found -> failwith "#fgcolor"
+
+    method bgcolor =
+      (* Get the background color: If there is a local value, return it;
+       * otherwise ask parent node
+       *)
+      match bgcolor with
+	  Some c -> c
+	| None   -> try self # node # parent # extension # bgcolor with
+	            Not_found -> failwith "#bgcolor"
+
+    method font =
+      (* Get the current font: If there is a local value, return it;
+       * otherwise ask parent node
+       *)
+      match font with
+	  Some c -> c
+	| None   -> try self # node # parent # extension # font with
+	            Not_found -> failwith "#font"
+
+    method private init_color_and_font =
+      let get_color n =
+      	try
+	  match self # node # attribute n with
+	      Value v -> Some v
+	    | Implied_value -> None
+	    | _ -> assert false
+      	with Not_found -> None in
+      fgcolor <- get_color "fgcolor";
+      bgcolor <- get_color "bgcolor";
+      font    <- get_color "font";      (* sic! *)
+
+
+    method private bg_color_opt =
+      [ Tk.Background (Tk.NamedColor (self # bgcolor)) ]
+
+    method private fg_color_opt =
+      [ Tk.Foreground (Tk.NamedColor (self # fgcolor)) ]
+
+    method private font_opt =
+      [ Tk.Font (self # font) ]
+
+    (* --- virtual --- *)
+
+    method virtual prepare : shared Pxp_yacc.index -> unit
+    method virtual create_widget : Widget.widget -> context -> Widget.widget
+
+    method pack_opts = ( [] : Tk.options list )
+    method xstretchable = false
+    method ystretchable = false
+
+    method accept (c:context) = ()
+
+    method private get_mask =
+      (* find parent which is a mask *)
+      let rec search n =
+	match n # node_type with
+	    T_element "mask" ->
+	      n # extension
+	  | T_element _ ->
+	      search (n # parent)
+	  | _ ->
+	      assert false
+      in
+      search (self # node)
+
+
+    method private accept_mask (c:context) =
+      let rec iterate n =
+	n # extension # accept c;
+	List.iter iterate (n # sub_nodes)
+      in
+      iterate (self # get_mask # node)
+
+
+    method start_node_name =
+      (failwith "#start_node_name" : string)
+
+    (* --- debug --- *)
+
+    method private name =
+      let nt = self # node # node_type in
+      match nt with
+	  T_element n -> n
+	| T_data      -> "#PCDATA"
+	| _           -> assert false
+
+  end
+;;
+
+
+class default =
+  object (self)
+    inherit shared
+
+    method prepare idx =
+      self # init_color_and_font
+
+    method create_widget w c =
+      failwith "default # create_widget"
+  end
+;;
+
+
+let dummy_node = new element_impl (new default);;
+
+class application =
+  object (self)
+    inherit shared
+
+    val mutable start_node = dummy_node
+
+    method prepare idx =
+      (* prepare this node *)
+      self # init_color_and_font;
+      if fgcolor = None then fgcolor <- Some "black";
+      if bgcolor = None then bgcolor <- Some "white";
+      if font = None then font <- Some "fixed";
+      let start =
+	match self # node # attribute "start" with
+	    Value v -> v
+	  | _       -> assert false in
+      start_node <- (try idx # find start with
+	  Not_found -> failwith "Start node not found");
+      (* iterate over the subtree *)
+      let rec iterate n =
+	n # extension # prepare idx;
+	List.iter iterate (n # sub_nodes)
+      in
+      List.iter iterate (self # node # sub_nodes)
+
+
+    method start_node_name =
+      match self # node # attribute "start" with
+	  Value v -> v
+	| _       -> assert false
+
+    method create_widget w c =
+      start_node # extension # create_widget w c
+
+    method pack_opts =
+      start_node # extension # pack_opts
+  end
+;;
+
+
+class sequence =
+  object (self)
+    inherit shared
+
+    method prepare idx =
+      self # init_color_and_font;
+
+    method create_widget w c =
+      let node = List.hd (self # node # sub_nodes) in
+      node # extension # create_widget w c
+
+    method pack_opts =
+      let node = List.hd (self # node # sub_nodes) in
+      node # extension # pack_opts
+  end
+;;
+
+
+class vbox =
+  object (self)
+    inherit shared
+
+    val mutable att_halign = "left"
+
+    method prepare idx =
+      self # init_color_and_font;
+      match self # node # attribute "halign" with
+	  Value v -> att_halign <- v
+	| _ -> assert false
+
+    method create_widget w c =
+      let f = Frame.create w (self # bg_color_opt) in
+      let nodes = self # node # sub_nodes in
+      let options =
+	match att_halign with
+	    "left"     -> [ Tk.Anchor Tk.W ]
+	  | "right"    -> [ Tk.Anchor Tk.E ]
+	  | "center"   -> [ Tk.Anchor Tk.Center ]
+	  | _ -> assert false
+      in
+      List.iter
+	(fun n ->
+	   let opts = n # extension # pack_opts in
+	   let wdg = n # extension # create_widget f c in
+	   Tk.pack [wdg] (options @ opts);
+	)
+	nodes;
+      f
+
+    method pack_opts =
+      match self # xstretchable, self # ystretchable with
+	  true, false  -> [ Tk.Fill Tk.Fill_X; (* Tk.Expand true *) ]
+	| false, true  -> [ Tk.Fill Tk.Fill_Y;  (* Tk.Expand true *) ]
+	| true, true   -> [ Tk.Fill Tk.Fill_Both; (* Tk.Expand true *) ]
+	| false, false -> []
+
+    method xstretchable =
+      let nodes = self # node # sub_nodes in
+      List.exists (fun n -> n # extension # xstretchable) nodes
+
+    method ystretchable =
+      let nodes = self # node # sub_nodes in
+      List.exists (fun n -> n # extension # ystretchable) nodes
+
+  end
+
+;;
+
+
+class mask =
+  object (self)
+
+    inherit vbox
+
+    method prepare idx =
+      self # init_color_and_font;
+      att_halign <- "left"
+  end
+;;
+
+
+class hbox =
+  object (self)
+    inherit shared
+
+    val mutable att_width = None
+    val mutable att_halign = "left"
+    val mutable att_valign = "top"
+
+    method prepare idx =
+      self # init_color_and_font;
+      begin match self # node # attribute "halign" with
+	  Value v -> att_halign <- v
+	| _ -> assert false
+      end;
+      begin match self # node # attribute "valign" with
+	  Value v -> att_valign <- v
+	| _ -> assert false
+      end;
+      begin match self # node # attribute "width" with
+	  Value v       -> att_width <- Some (get_dimension v)
+	| Implied_value -> att_width <- None
+	| _ -> assert false
+      end
+
+    method create_widget w c =
+      let f1 = Frame.create w (self # bg_color_opt) in
+      let f_extra =
+	match att_width with
+	    None    -> []
+	  | Some wd ->
+	      [ Canvas.create f1
+		  ( [ Tk.Width wd; Tk.Height (Tk.Pixels 0);
+		      Tk.Relief Tk.Flat;
+		      Tk.HighlightThickness (Tk.Pixels 0);
+		    ] @
+		    self # bg_color_opt ) ]
+      in
+      let f2 = Frame.create f1 (self # bg_color_opt) in
+      let nodes = self # node # sub_nodes in
+
+      let outer_pack_opts =
+      	match att_halign with
+	    "left"     -> [ Tk.Anchor Tk.W ]
+	  | "right"    -> [ Tk.Anchor Tk.E ]
+	  | "center"   -> [ Tk.Anchor Tk.Center ]
+	  | _ -> assert false
+      in
+      let inner_pack_opts =
+	match att_valign with
+	    "top"      -> [ Tk.Anchor Tk.N ]
+	  | "bottom"   -> [ Tk.Anchor Tk.S ]
+	  | "center"   -> [ Tk.Anchor Tk.Center ]
+	  | _ -> assert false
+      in
+      List.iter
+	(fun n ->
+	   let opts = n # extension # pack_opts in
+	   let wdg = n # extension # create_widget f2 c in
+	   Tk.pack [wdg] (inner_pack_opts @ [ Tk.Side Tk.Side_Left ] @ opts);
+	)
+	nodes;
+      let extra_opts = self # pack_opts in
+      Tk.pack (f_extra @ [f2]) (outer_pack_opts @ extra_opts);
+      f1
+
+    method pack_opts =
+      match self # xstretchable, self # ystretchable with
+	  true, false  -> [ Tk.Fill Tk.Fill_X;  (* Tk.Expand true *) ]
+	| false, true  -> [ Tk.Fill Tk.Fill_Y;  (* Tk.Expand true *) ]
+	| true, true   -> [ Tk.Fill Tk.Fill_Both;  (* Tk.Expand true *) ]
+	| false, false -> []
+
+    method xstretchable =
+      let nodes = self # node # sub_nodes in
+      List.exists (fun n -> n # extension # xstretchable) nodes
+
+    method ystretchable =
+      let nodes = self # node # sub_nodes in
+      List.exists (fun n -> n # extension # ystretchable) nodes
+
+  end
+;;
+
+class vspace =
+  object (self)
+    inherit shared
+
+    val mutable att_height = Tk.Pixels 0
+    val mutable att_fill  = false
+
+    method prepare idx =
+      self # init_color_and_font;
+      begin match self # node # attribute "height" with
+	  Value v       -> att_height <- get_dimension v
+	| _ -> assert false
+      end;
+      begin match self # node # attribute "fill" with
+	  Value "yes" -> att_fill <- true
+	| Value "no"  -> att_fill <- false
+	| _ -> assert false
+      end
+
+
+    method create_widget w c =
+      let f = Frame.create w ( self # bg_color_opt ) in
+      let strut =
+      	Canvas.create f
+	  ( [ Tk.Height att_height; Tk.Width (Tk.Pixels 0);
+	      Tk.Relief Tk.Flat;
+	      Tk.HighlightThickness (Tk.Pixels 0);
+	    ] @
+	    self # bg_color_opt ) in
+      if att_fill then
+	Tk.pack [strut] [Tk.Fill Tk.Fill_Y; Tk.Expand true]
+      else
+	Tk.pack [strut] [];
+      f
+
+    method pack_opts =
+      if att_fill then [ Tk.Fill Tk.Fill_Y; Tk.Expand true ] else []
+
+    method ystretchable = att_fill
+  end
+;;
+
+class hspace =
+  object (self)
+    inherit shared
+
+
+    val mutable att_width = Tk.Pixels 0
+    val mutable att_fill  = false
+
+    method prepare idx =
+      self # init_color_and_font;
+      begin match self # node # attribute "width" with
+	  Value v       -> att_width <- get_dimension v
+	| _ -> assert false
+      end;
+      begin match self # node # attribute "fill" with
+	  Value "yes" -> att_fill <- true
+	| Value "no"  -> att_fill <- false
+	| _ -> assert false
+      end
+
+
+    method create_widget w c =
+      let f = Frame.create w ( self # bg_color_opt ) in
+      let strut =
+      	Canvas.create f
+	  ( [ Tk.Width att_width; Tk.Height (Tk.Pixels 0);
+	      Tk.Relief Tk.Flat;
+	      Tk.HighlightThickness (Tk.Pixels 0);
+	    ] @
+	    self # bg_color_opt ) in
+      if att_fill then
+	Tk.pack [strut] [Tk.Fill Tk.Fill_X; Tk.Expand true]
+      else
+	Tk.pack [strut] [];
+      f
+
+    method pack_opts =
+      if att_fill then [ Tk.Fill Tk.Fill_X; Tk.Expand true ] else []
+
+    method xstretchable = att_fill
+  end
+;;
+
+class label =
+  object (self)
+    inherit shared
+
+    val mutable att_textwidth = (-1)
+    val mutable att_halign = "left"
+
+    method prepare idx =
+      self # init_color_and_font;
+      att_textwidth <- (match self # node # attribute "textwidth" with
+			    Value v ->
+			      let w = try int_of_string v
+			      with _ -> failwith ("Not an integer: " ^ v) in
+			      w
+			  | Implied_value ->
+			      (-1)
+			  | _ -> assert false);
+      att_halign <- (match self # node # attribute "halign" with
+			 Value v -> v
+		       | _ -> assert false);
+
+
+    method create_widget w c =
+      let opts_textwidth = if att_textwidth < 0 then [] else
+	                                       [ Tk.TextWidth att_textwidth ] in
+      let opts_halign =
+	match att_halign with
+	    "left"     -> [ Tk.Anchor Tk.W ]
+	  | "right"    -> [ Tk.Anchor Tk.E ]
+	  | "center"   -> [ Tk.Anchor Tk.Center ]
+	  | _ -> assert false
+      in
+      let opts_content =
+	[ Tk.Text (self # node # data) ] in
+      let label = Label.create w (opts_textwidth @ opts_halign @
+				  opts_content @ self # bg_color_opt @
+				  self # fg_color_opt @ self # font_opt) in
+      label
+
+  end
+;;
+
+class entry =
+  object (self)
+    inherit shared
+
+    val mutable tv = lazy (Textvariable.create())
+    val mutable att_textwidth = (-1)
+    val mutable att_slot = ""
+
+    method prepare idx =
+      self # init_color_and_font;
+      tv <- lazy (Textvariable.create());
+      att_textwidth <- (match self # node # attribute "textwidth" with
+			    Value v ->
+			      let w = try int_of_string v
+			      with _ -> failwith ("Not an integer: " ^ v) in
+			      w
+			  | Implied_value ->
+			      (-1)
+			  | _ -> assert false);
+      att_slot <- (match self # node # attribute "slot" with
+	  Value v -> v
+	| _ -> assert false);
+
+    method create_widget w c =
+      let opts_textwidth = if att_textwidth < 0 then [] else
+	                                       [ Tk.TextWidth att_textwidth ] in
+      let e = Entry.create w ( [ Tk.TextVariable (Lazy.force tv) ] @
+			       self # fg_color_opt @
+			       self # bg_color_opt @
+			       self # font_opt @
+			       opts_textwidth
+			     ) in
+      let s =
+	try c # get_slot att_slot with
+	    Not_found -> self # node # data in
+      Textvariable.set (Lazy.force tv) s;
+      e
+
+    method accept c =
+      c # set_slot att_slot (Textvariable.get (Lazy.force tv))
+
+  end
+;;
+
+class textbox =
+  object (self)
+    inherit shared
+
+    val mutable att_textwidth = (-1)
+    val mutable att_textheight = (-1)
+    val mutable att_slot = ""
+    val mutable last_widget = None
+
+    method prepare idx =
+      self # init_color_and_font;
+      att_textwidth <- (match self # node # attribute "textwidth" with
+			    Value v ->
+			      let w = try int_of_string v
+			      with _ -> failwith ("Not an integer: " ^ v) in
+			      w
+			  | Implied_value ->
+			      (-1)
+			  | _ -> assert false);
+      att_textheight <- (match self # node # attribute "textheight" with
+			    Value v ->
+			      let w = try int_of_string v
+			      with _ -> failwith ("Not an integer: " ^ v) in
+			      w
+			  | Implied_value ->
+			      (-1)
+			  | _ -> assert false);
+      att_slot <- (match self # node # attribute "slot" with
+		       Value v -> v
+		     | Implied_value -> ""
+		     | _ -> assert false);
+
+
+    method create_widget w c =
+      let opts_textwidth = if att_textwidth < 0 then [] else
+	                                       [ Tk.TextWidth att_textwidth ] in
+      let opts_textheight = if att_textheight < 0 then [] else
+	                                    [ Tk.TextHeight att_textheight ] in
+      let f = Frame.create w (self # bg_color_opt) in
+      let vscrbar = Scrollbar.create f [ Tk.Orient Tk.Vertical ] in
+      let e = Text.create f ( [ ] @
+			      self # fg_color_opt @
+			      self # bg_color_opt @
+			      self # font_opt @
+			      opts_textwidth @ opts_textheight
+			    ) in
+      last_widget <- Some e;
+      Scrollbar.configure vscrbar [ Tk.ScrollCommand
+				      (fun s -> Text.yview e s);
+				    Tk.Width (Tk.Pixels 9) ];
+      Text.configure e [ Tk.YScrollCommand
+			   (fun a b -> Scrollbar.set vscrbar a b) ];
+      let s =
+	if att_slot <> "" then
+	  try c # get_slot att_slot with
+	      Not_found -> self # node # data 
+	else 
+	  self # node # data 
+      in
+      (* Text.insert appends always a newline to the last line; so strip 
+       * an existing newline first
+       *)
+      let s' = 
+	if s <> "" & s.[String.length s - 1] = '\n' then
+	  String.sub s 0 (String.length s - 1)
+	else 
+	  s in
+      Text.insert e (Tk.TextIndex(Tk.End,[])) s' [];
+      if att_slot = "" then
+	Text.configure e [ Tk.State Tk.Disabled ];
+      Tk.pack [e] [ Tk.Side Tk.Side_Left ];
+      Tk.pack [vscrbar] [ Tk.Side Tk.Side_Left; Tk.Fill Tk.Fill_Y ];
+      f
+
+    method accept c =
+      if att_slot <> "" then
+	match last_widget with
+	    None -> ()
+	  | Some w ->
+	      let s =
+		Text.get
+		  w
+		  (Tk.TextIndex(Tk.LineChar(1,0),[]))
+		  (Tk.TextIndex(Tk.End,[])) in
+	      c # set_slot att_slot s
+
+  end
+;;
+
+class button =
+  object (self)
+    inherit shared
+
+    val mutable att_label = ""
+    val mutable att_action = ""
+    val mutable att_goto = ""
+
+    method prepare idx =
+      self # init_color_and_font;
+      att_label <- (match self # node # attribute "label" with
+			Value v -> v
+		      | _ -> assert false);
+      att_action <- (match self # node # attribute "action" with
+			 Value v -> v
+		       | _ -> assert false);
+      att_goto <- (match self # node # attribute "goto" with
+		       Value v -> v
+		     | Implied_value -> ""
+		     | _ -> assert false);
+      if att_action = "goto" then begin
+	try let _ = idx # find att_goto in () with
+	    Not_found -> failwith ("Target `" ^ att_goto ^ "' not found")
+      end;
+      if att_action = "list-prev" or att_action = "list-next" then begin
+	let m = self # get_mask in
+	if m # node # parent # node_type <> T_element "sequence" then
+	  failwith ("action " ^ att_action ^ " must not be used out of <sequence>");
+      end;
+
+
+    method create_widget w c =
+      let cmd () =
+	self # accept_mask c;
+	match att_action with
+	    "goto" ->
+	      c # goto att_goto
+	  | "save" ->
+	      c # save_obj
+	  | "exit" ->
+	      Protocol.closeTk()
+	  | "save-exit" ->
+	      c # save_obj;
+	      Protocol.closeTk()
+	  | "list-prev" ->
+	      let m = self # get_mask # node in
+	      let s = m # parent in
+	      let rec search l =
+		match l with
+		    x :: y :: l' ->
+		      if y == m then
+			match x # attribute "name" with
+			    Value s -> c # goto s
+			  | _ -> assert false
+		      else
+			search (y :: l')
+		  | _ -> ()
+	      in
+	      search (s # sub_nodes)
+	  | "list-next" ->
+	      let m = self # get_mask # node in
+	      let s = m # parent in
+	      let rec search l =
+		match l with
+		    x :: y :: l' ->
+		      if x == m then
+			match y # attribute "name" with
+			    Value s -> c # goto s
+			  | _ -> assert false
+		      else
+			search (y :: l')
+		  | _ -> ()
+	      in
+	      search (s # sub_nodes)
+	  | "hist-prev" ->
+	      (try c # previous with Not_found -> ())
+	  | "hist-next" ->
+	      (try c # next with Not_found -> ())
+	  | _ -> ()
+      in
+      let b = Button.create w ( [ Tk.Text att_label; Tk.Command cmd ] @
+			      	self # fg_color_opt @
+			      	self # bg_color_opt @
+			      	self # font_opt ) in
+      b
+
+
+  end
+;;
+
+
+(**********************************************************************)
+
+open Pxp_yacc
+
+let tag_map =
+  make_spec_from_mapping
+    ~data_exemplar:(new data_impl (new default))
+    ~default_element_exemplar:(new element_impl (new default))
+    ~element_mapping:
+       (let m = Hashtbl.create 50 in
+	Hashtbl.add m "application"
+	 	      (new element_impl (new application));
+	Hashtbl.add m "sequence"
+		      (new element_impl (new sequence));
+	Hashtbl.add m "mask"
+		      (new element_impl (new mask));
+	Hashtbl.add m "vbox"
+	              (new element_impl (new vbox));
+	Hashtbl.add m "hbox"
+		      (new element_impl (new hbox));
+	Hashtbl.add m "vspace"
+		      (new element_impl (new vspace));
+	Hashtbl.add m "hspace"
+		      (new element_impl (new hspace));
+	Hashtbl.add m "label"
+		      (new element_impl (new label));
+	Hashtbl.add m "entry"
+		      (new element_impl (new entry));
+	Hashtbl.add m "textbox"
+		      (new element_impl (new textbox));
+	Hashtbl.add m "button"
+		      (new element_impl (new button));
+	m)
+    ()
+;;
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1  2000/11/17 09:57:31  lpadovan
+ * Initial revision
+ *
+ * Revision 1.5  2000/08/30 15:58:49  gerd
+ * 	Updated.
+ *
+ * Revision 1.4  2000/07/16 19:36:03  gerd
+ * 	Updated.
+ *
+ * Revision 1.3  2000/07/08 22:03:11  gerd
+ * 	Updates because of PXP interface changes.
+ *
+ * Revision 1.2  2000/06/04 20:29:19  gerd
+ * 	Updates because of renamed PXP modules.
+ *
+ * Revision 1.1  1999/08/21 19:11:05  gerd
+ * 	Initial revision.
+ *
+ *
+ *)