X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2FDEVEL%2Fpxp%2Fpxp%2Fexamples%2Fxmlforms%2Fds_style.ml;fp=helm%2FDEVEL%2Fpxp%2Fpxp%2Fexamples%2Fxmlforms%2Fds_style.ml;h=0000000000000000000000000000000000000000;hp=08d0daa0353173722e0445f894a5bb1e6327dd19;hb=3ef089a4c58fbe429dd539af6215991ecbe11ee2;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff diff --git a/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_style.ml b/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_style.ml deleted file mode 100644 index 08d0daa03..000000000 --- a/helm/DEVEL/pxp/pxp/examples/xmlforms/ds_style.ml +++ /dev/null @@ -1,778 +0,0 @@ -(* $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 "); - 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. - * - * - *)