prooftree-0.13/0000755000175000017500000000000013032677177012205 5ustar tewstewsprooftree-0.13/README0000644000175000017500000000416213032677177013070 0ustar tewstews============================================================================ prooftree --- proof tree display for Proof General ============================================================================ Prooftree is a program for proof tree visualization during interactive proof development in a theorem prover. It is currently being developed for Coq and Proof General. See http://askra.de/software/prooftree/ for more information. Prooftree requires Proof General >= 4.3pre130327 and Coq version >= 8.4beta. These versions of Proof General and Coq must be installed separately. Binary packages are available Debian Jessie, for instance. ============================================================================ USAGE ============================================================================ Start Emacs and load any Coq file. Proof display with prooftree is initially disabled. To enable it, hit the prooftree tool-bar icon, select menu Proof-General -> Start/Stop Prooftree or type C-c C-d. If you are inside a proof any of these actions will launch a proof-tree display for the current proof. Otherwise prooftree will be launched as soon as you start the next proof. Comprehensive usage information is provided by the help menu item inside Prooftree and by the Prooftree man page. ============================================================================ CREDITS / CONTACT / COPYRIGHT ============================================================================ Prooftree is more or less a reimplementation of the graphical proof display of Pvs. The Pvs version is implemented in Tcl/Tk and controlled directly by the Pvs prover process, which has some advantages over the prooftree approach. Please send bug reports, comments, patches, donations to Hendrik Tews Instructions about adding support for a new proof assistant is contained in the Proof General Adapting manual. Prooftree is distributed under GPL version 3. Copyright (C) 2011 - 2016 Hendrik Tews ============================================================================ Local Variables: mode: indented-text fill-column: 75 End: prooftree-0.13/compatibility0000644000175000017500000000042513032677177015002 0ustar tewstewsprotocol prooftree Proof General 3 0.11 >= 4.3pre130327 2 0.9 - 0.10 4.2; 4.2pre120110 - 4.3pre130111 1 0.8 4.2pre120104 prooftree-0.13/draw_tree.ml0000644000175000017500000017323113032677177014522 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: draw_tree.ml,v 1.54 2016/01/23 12:57:13 tews Exp $ *) (** Layout and drawing of the elements of the proof tree. Internally a proof tree is organized as an n-ary tree, where the nodes are proof goals and proof commands and the vertices connect them appropriately. This module is responsible for manipulating and displaying these trees and for locating nodes (e.g., on mouse clicks). A real proof tree has a number of properties, about which this module is completely ignorant. For instance, the root node is always a proof goal; proof goal nodes have zero or more successor nodes, all of which are proof commands; and, finally, every proof command has precisely one proof-goal successor. These properties are neither assumed nor checked, they hopefully hold, because the tree is created in the right way. The common code of both proof-goal and proof-command nodes is in the class {!class: Draw_tree.proof_tree_element}. The class for proof goals, {!turnstile} and the class {!class: proof_command} are derived from it. To work around the impossible down-casts, {!proof_tree_element} contains some virtual method hooks for stuff that is really specific for just one of its subclasses. The tree layout functionallity has been designed such that its running time is independent of the size of the complete tree. When a new node is inserted into the tree, only its direct and indirect parent nodes need to recompute their layout data. No sibling node must be visited. To achieve this the nodes do not store absolut positions. Instead, nodes only store the width and height of themselves and of their subtrees. Adjusting the tree layout when new elements are inserted works bottom up. Drawing the tree or looking up nodes (for mouse events) works top down. Therefore the nodes are organized in a doubly-linked tree, where children nodes contain a link to their parent. The doubly-linked tree functionality is in {!class: doubly_linked_tree}. *) open Util open Configuration open Gtk_ext (** {2 Utility types and functions} *) (*****************************************************************************) (*****************************************************************************) (** {3 Existential variables} *) (*****************************************************************************) (*****************************************************************************) (** The code for marking and displaying existential variables depends on proper sharing of these records: For each proof-tree window there must only be one record for each existential variable. The same existential variable in different (cloned) proof trees must have exactly one record for each proof-tree window. The proof-tree record ({!Proof_tree.proof_tree}) contains a hash table containing all existential variables for a given proof. Changing the state of an existental variable and marking one in the proof-tree display works by side effect: All proof tree nodes refer to the very same instance and therefore see the state change. Sets of existential variables are stored as lists, whoose order is usually not important. Therefore most functions that manipulate lists of existential variables do not preserve the order. *) (** Status of an existential variable. The tree of existentials is only scanned for redisplay. Therefore, a fully instantiated existential might have state [Partially_instantiated] until the next scan. *) type existential_status = | Uninstantiated (** open, not instantiated *) | Partially_instantiated (** instantiated, but the instantiation uses some existentials that are still open *) | Fully_instantiated (** fully instantiated *) (** Representation of existential variables. The [status] field is lazily updated in {!Proof_tree.update_existential_status}. Therefore, a fully instantiated existential might have status {!existential_status.Partially_instantiated} for some time. *) type existential_variable = { existential_name : string; (** The name *) mutable status : existential_status; (** instantiation status *) mutable existential_mark : bool; (** [true] if this existential should be marked in the proof-tree display *) mutable dependencies : existential_variable list; (** The list of evars that are used in the instantiation, if instantiated *) } (** Filter the non-instantiated existentials from the argument. *) let filter_uninstantiated exl = list_filter_rev (fun ex -> ex.status = Uninstantiated) exl (** Filter the partially instantiated existentials from the argument *) let filter_partially_instantiated exl = list_filter_rev (fun ex -> ex.status = Partially_instantiated) exl (** Derive the existential status for drawing a node or a connection line in the proof tree. *) let combine_existential_status_for_tree exl = if List.for_all (fun ex -> ex.status = Fully_instantiated) exl then Fully_instantiated else if List.exists (fun ex -> ex.status = Uninstantiated) exl then Uninstantiated else Partially_instantiated (** Convert a set of existential variables into a single string for display purposes. *) let string_of_existential_list exl = String.concat " " (List.map (fun ex -> ex.existential_name) exl) (*****************************************************************************) (*****************************************************************************) (** {3 Misc types} *) (*****************************************************************************) (*****************************************************************************) (** Kind of nodes in the proof-tree display. The two kinds correspond to the two subclasses {!proof_command} and {!turnstile} of {!proof_tree_element}. *) type node_kind = | Proof_command (** proof command *) | Turnstile (** sequent *) (** Proof state of a node in the proof-tree display. *) type branch_state_type = | Unproven (** no finished yet *) | CurrentNode (** current sequent in prover *) | Current (** on the path from the current sequent to the root of the tree *) | Cheated (** proved, but with a cheating command *) | Proven (** proved *) (* * write doc when used * let string_of_branch_state = function * | Unproven -> "Unproven" * | CurrentNode -> "CurrentNode" * | Current -> "Current" * | Cheated -> "Cheated" * | Proven -> "Proven" *) (*****************************************************************************) (*****************************************************************************) (** {3 Graphics context color manipulations} *) (*****************************************************************************) (*****************************************************************************) (** The following functions implement a simple save/restore feature for the forground color of the graphics context. A saved state is a color option. The value [None] means that the foreground color has not been changed and that there is therefore no need to restore it. *) (** Save the current foreground color in a value suitable for {!restore_gc}. *) let save_gc drawable = Some drawable#get_foreground (** Restore the saved foreground color. Do nothing if the foreground color has not been changed. *) let restore_gc drawable fc_opt = match fc_opt with | None -> () | Some fc -> drawable#set_foreground (`COLOR fc) (** [save_and_set_gc drawable state existentials] sets the foreground color to one of the configured colors, depending on [state] and [existentials]. The function returns a value suitable for {!restore_gc} to restore the old foreground color. *) let save_and_set_gc drawable state existentials = (* * if List.exists (fun e -> e.existential_mark) existentials * then begin * let res = save_gc drawable in * drawable#set_foreground (`COLOR !mark_subtree_gdk_color); * res * end else *) match state with | Unproven -> None | CurrentNode | Current -> let res = save_gc drawable in drawable#set_foreground (`COLOR !current_gdk_color); res | Proven -> let res = save_gc drawable in let color = match combine_existential_status_for_tree existentials with | Fully_instantiated -> !proved_complete_gdk_color | Partially_instantiated -> !proved_partial_gdk_color | Uninstantiated -> !proved_incomplete_gdk_color in drawable#set_foreground (`COLOR color); res | Cheated -> let res = save_gc drawable in drawable#set_foreground (`COLOR !cheated_gdk_color); res (*****************************************************************************) (*****************************************************************************) (** {3 Double linked trees} *) (*****************************************************************************) (*****************************************************************************) (** The proof trees in the proof-tree display are organized as doubly-linked trees, where children contain a link to their parent nodes. This is needed, because, for efficiency, the tree layout computation starts at the last inserted child and walks upwards to the root of the tree. *) (** Abstract base class for doubly linked trees. Because of type-checking problems the functionality for setting and clearing children nodes is not inside the class but outside, in the functions {!Draw_tree.set_children} and {!Draw_tree.clear_children}. *) class virtual ['a] doubly_linked_tree = object (** The parent link. *) val mutable parent = None (** The childrens list. *) val mutable children = [] (** Accessor method for the parent field. *) method parent = parent (** Low-level setter for the {!parent} field. To insert child nodes into the tree, use {!Draw_tree.set_children}. *) method set_parent (p : 'a) = parent <- Some p (** Another low-level setter for the parent field. To delete nodes from the tree, use {!Draw_tree.clear_children} on the parent. *) method clear_parent = parent <- None (** Accessor for the children field. *) method children = children (** Low-level setter for the children field. To insert child nodes into the tree, use {!Draw_tree.set_children}. *) method set_children (cs : 'a list) = children <- cs (** Method to be called when the children list has been changed. *) method virtual children_changed : unit end (** [set_children parent children] correctly insert [children] into the doubly linked tree as children of node [parent]. After the change {!doubly_linked_tree.children_changed} is called on [parent]. Asserts that the children list of [parent] is empty. *) let set_children parent children = assert(parent#children = []); parent#set_children children; List.iter (fun c -> c#set_parent parent) children; parent#children_changed (** [clear_children parent] removes all children from [parent] from the doubly linked tree. After the change {!doubly_linked_tree.children_changed} is called on [parent]. *) let clear_children parent = List.iter (fun c -> c#clear_parent) parent#children; parent#set_children []; parent#children_changed (* * let add_child parent child = * parent#set_children (parent#children @ [child]); * child#set_parent parent; * parent#children_changed *) (* * let remove_child child = * match child#parent with * | None -> () * | Some p -> * p#set_children (List.filter (fun c -> c <> child) p#children); * child#clear_parent; * p#children_changed *) (*****************************************************************************) (*****************************************************************************) (** {3 Tree layer interface} *) (*****************************************************************************) (*****************************************************************************) (** Abstract interface for {!class: Tree_layers.tree_layer} and {!class: Tree_layers.tree_layer_stack}. Root nodes of proof trees and layers contain a pointer to the layer or layer stack containing them. This pointer is used to invalidate the size information in these structures and to query location information. This class type breaks the mutual dependency between root nodes and layers and layers and the layer stack. The type parameter stands for the structure containing the upward pointer, because it passes [self] as first argument to {!child_offsets}. *) class type ['a] abstract_tree_container = object (** Invalidate the size information in this container and all bigger structures containing it. *) method clear_size_cache : unit (** Compute the left and top offset of this container relative to the upper-left corner of the complete display. *) method left_top_offset : int * int (** Compute the x and y offset of one child relative to the upper left corner of this container. *) method child_offsets : 'a -> int * int end (*****************************************************************************) (*****************************************************************************) (** {3 External window interface} *) (*****************************************************************************) (*****************************************************************************) (** Abstract class type for external {!class: Node_window.node_window}'s containing just those methods that are needed here. This class type is used to break the circular dependency between {!Draw_tree} and {!Node_window}. All {!proof_tree_element}'s keep a list of their external windows to update them. External node windows have a pointer to proof-tree elements to deregister themselves when they get deleted or orphaned. Before external node windows are passed to functions in this module, they must be cast to this class type. *) class type external_node_window = object (** Number of this node window. Used to correlate node windows with the proof-tree display. *) method window_number : string (** Update the content in the text buffer of this node window. The argument is the updated {!proof_tree_element.sequent_text_history}. *) method update_content : string list -> unit (** Reconfigure and redraw the node window. Needs to be called when the configuration has been changed. Actually only the font of the buffer text is changed. *) method configuration_updated : unit (** Delete this node window if it is not sticky. Needs to be called when the corresponding element in the proof-tree display is deleted. *) method delete_attached_node_window : unit end (*****************************************************************************) (*****************************************************************************) (** {2 Generic tree element} *) (*****************************************************************************) (*****************************************************************************) (** Abstract base class for turnstiles and proof commands. Contains the code for (relativ) layout, (absolute) coordinates, locating mouse button clicks, marking branches and the general drawing functions. Argument undo_state saves the undo state for the current proof. It's value is arbitrary for cloned proof trees. *) class virtual proof_tree_element drawable undo_state debug_name inst_existentials fresh_existentials = object (self) inherit [proof_tree_element] doubly_linked_tree (***************************************************************************) (***************************************************************************) (** {2 Internal State Fields} *) (***************************************************************************) (***************************************************************************) (** ID for debugging purposes *) method debug_name = (debug_name : string) (** The kind of this element. *) method virtual node_kind : node_kind (** The existentials created for this element. Only non-nil when this is a proof command. *) method fresh_existentials = fresh_existentials (** The existentials instantiated by this element. Only non-nil when this is a proof command. *) method inst_existentials : existential_variable list = inst_existentials (** Return the state for this sequent. *) method undo_state = (undo_state : int) (** The {!class: Gtk_ext.better_drawable} into which this element draws itself. *) val drawable = drawable (***************** inside proof_tree_element *) (** The width of this node alone in pixels. Set in the initializer of the heirs. *) val mutable width = 0 (** The height of this node alone in pixels. Set in the initializer of the heirs. *) val mutable height = 0 (** The total width in pixels of the subtree which has this node as root. Computed in {!Draw_tree.proof_tree_element.update_subtree_size}. *) val mutable subtree_width = 0 (** The x-offset of the left border of the first child. Or, in other words, the distance (in pixels) between the left border of the subtree which has this node as root and the the left border of the subtree which has the first child as root. Always non-negative. Zero if this node has no children. Usually zero, non-zero only in unusual cases, for instance if the {!width} of this node is larger than the total width of all children. *) val mutable first_child_offset = 0 (** The x-offset of the centre of this node. In other words the distance (in pixels) between the left border of this node's subtree and the x-coordinate of this node. *) val mutable x_offset = 0 (***************** inside proof_tree_element *) (** The height of this nodes subtree, counted in tree levels. At least 1, because this element occupies already some level. *) val mutable subtree_levels = 0 (** The proof state of this node. *) val mutable branch_state = Unproven (** [true] if this node is selected and displayed in the sequent area of the proof-tree window. *) val mutable selected = false (** The list of external node windows. *) val mutable external_windows : external_node_window list = [] (** The set of all existentials for this node. *) val mutable existential_variables = fresh_existentials (** Upward pointer to the layer containing this proof tree. Must be set for root nodes. *) val mutable tree_layer = (None : proof_tree_element abstract_tree_container option) (** This field is really used only inside {!turnstile}. In a turnstile element, it holds the list of all previous versions of the sequent text without existential information, except for the head, with contains the current sequent {b with} existential info. For uniform treatment of external node windows, the reference is also used for proof commands. There, it holds just one element, the proof command with existentials info. The existential info is omitted from old versions of the sequent text, because this info is incorrect for sequents that get updated. The problem is that the exisitentials change already with {!Proof_tree.add_new_goal}, which happens long before {!Proof_tree.update_sequent}. A fix for this would require a protocol change, which is a bit too much for this little feature. *) val mutable sequent_text_history = [] (***************************************************************************) (***************************************************************************) (** {2 Accessors / Setters} *) (***************************************************************************) (***************************************************************************) (***************** inside proof_tree_element *) (** Accessor method of {!attribute: width}. *) method width = width (** Accessor method of {!attribute: height}. *) method height = height (** Accessor method of {!attribute: subtree_width}. *) method subtree_width = subtree_width (** Accessor method of {!attribute: subtree_levels}. *) method subtree_levels = subtree_levels (** Accessor method of {!attribute: x_offset}. *) method x_offset = x_offset (** Accessor method of {!attribute: branch_state}. *) method branch_state = branch_state (** Modification method of {!attribute: branch_state}. *) method set_branch_state s = branch_state <- s (** Accessor method of {!attribute: selected}. *) method is_selected = selected (** Modification method of {!attribute: selected}. *) method selected b = selected <- b (***************** inside proof_tree_element *) (** Accessor method of {!attribute: existential_variables}. *) method existential_variables = existential_variables (** [inherit_existentials exl] sets this nodes {!attribute: existential_variables} as union of {!fresh_existentials} and [exl]. *) method inherit_existentials existentials = existential_variables <- List.rev_append fresh_existentials existentials (** The original text content associated with this element. For turnstiles this is the sequent text and for proof commands this is the complete proof command. *) method virtual content : string (** [true] if the proof command is abbreviated in the display. Always [false] for turnstiles. Used to decide whether to display tooltips for proof commands. *) method virtual content_shortened : bool (** Return the sequent ID for turnstiles and the empty string for proof commands. For turnstiles the sequent ID is used as {!debug_name}. *) method virtual id : string (** Register the proof tree layer containing this root node. *) method register_tree_layer tl = assert(tree_layer = None); tree_layer <- Some tl (** Make {!sequent_text_history} accessible for cloning and for reattaching external node windows. *) method sequent_text_history = sequent_text_history (** This method is only used inside {!turnstile} but declared here to avoid downcasting during cloning. Set the sequent text history, used when cloning. *) method set_sequent_text_history history = sequent_text_history <- history (***************************************************************************) (***************************************************************************) (** {2 Children Iterators} *) (***************************************************************************) (***************************************************************************) (***************** inside proof_tree_element *) (** General iterator for all children. [iter_children left y a f] successively computes the [left] and [y] value of each child and calls [f left y c a] for each child [c] (starting with the leftmost child) until [f] returns [false]. The [a] value is an accumulator. The returned [a] is passed to the invocation of [f] for the next child. The last returned [a] is the result of the total call of this function. *) method private iter_children : 'a . int -> int -> 'a -> (int -> int -> 'a -> proof_tree_element -> ('a * bool)) -> 'a = fun left y a f -> let left = left + first_child_offset in let y = y + !current_config.level_distance in let rec doit left a = function | [] -> a | c::cs -> let (na, cont) = f left y a c in if cont then doit (left + c#subtree_width) na cs else na in doit left a children (** Unit iterator for all children. Calls [f left y c] for each child [c]. *) method private iter_all_children_unit left y (f : int -> int -> proof_tree_element -> unit) = self#iter_children left y () (fun left y () c -> f left y c; ((), true)) (***************************************************************************) (***************************************************************************) (** {2 Layout and Size Computation} *) (***************************************************************************) (***************************************************************************) (***************** inside proof_tree_element *) (** Compute the height of the subtree of this element in pixels. *) method subtree_height = (subtree_levels - 1) * !current_config.level_distance + 2 * !current_config.turnstile_radius + 2 * !current_config.turnstile_line_width (** Sets the {!width} and {!height} fields. Called in the initializer of the heirs and when the configuration has been updated. *) method private virtual set_node_size : unit (** (Re-)compute all (relative) layout information for this node. Computes and sets {!attribute: subtree_levels}, {!attribute: subtree_width}, {!attribute: x_offset} and {!first_child_offset}. *) method private update_subtree_size = let (children_width, max_levels, last_child) = List.fold_left (fun (sum_width, max_levels, _last_child) c -> (* * (if parent = None || (match parent with Some p -> p#parent = None) * then Printf.fprintf (debugc()) * "USS child width %d\n%!" c#subtree_width); *) (sum_width + c#subtree_width, (if c#subtree_levels > max_levels then c#subtree_levels else max_levels), Some c)) (0, 0, None) children in (***************** inside proof_tree_element *) subtree_levels <- max_levels + 1; subtree_width <- children_width; x_offset <- (match children with | [] -> 0 | [c] -> c#x_offset | first :: _ -> match last_child with | None -> assert false | Some last -> let last_x_offset = subtree_width - last#subtree_width + last#x_offset in (first#x_offset + last_x_offset) / 2 ); (* * Printf.fprintf (debugc()) * "USS %s childrens width %d first x_offset %d\n%!" * self#debug_name * children_width * x_offset; *) (* Now x_offset is nicely in the middle of all children nodes and * subtree_width holds the width of all children nodes. * However, the width of this node might be larger than all the * children together, or it may be placed asymmetrically. In both * cases it can happen that some part of this node is outside the * boundaries of all the children. In this case we must increase * the width of subtree and adjust the x_offset. *) if x_offset < width / 2 then begin (* part of this node is left of leftmost child *) first_child_offset <- width / 2 - x_offset; x_offset <- x_offset + first_child_offset; subtree_width <- subtree_width + first_child_offset; end else begin (* this node's left side is right of the left margin of the first child *) first_child_offset <- 0; end; (***************** inside proof_tree_element *) (* The real condition for the next if is * subtree_width - x_offset < width / 2 * but it has rounding issues when width is odd. *) if 2 * (subtree_width - x_offset) < width then begin (* Part of this node is right of rightmost child. * Need to increase subtree_width about the outside part, * which is width / 2 - (subtree_width - x_offset). * Now * subtree_width + width / 2 - (subtree_width - x_offset) = * x_offset + width / 2 *) subtree_width <- x_offset + (width + 1) / 2; end else begin (* This node's right side is left of right margin of last child. * Nothing to do. *) end; (* * Printf.fprintf (debugc()) * "USS %s END subtree width %d x_offset %d \ * first_child_offset %d height %d\n%!" * self#debug_name * subtree_width * x_offset * first_child_offset * subtree_levels; *) (***************** inside proof_tree_element *) (** Do {!update_subtree_size} in this element and all parent elements up to the root of the tree. *) method update_sizes_in_branch = (* * let old_subtree_width = subtree_width in * let old_x_offset = x_offset in *) self#update_subtree_size; (* * if x_offset <> old_x_offset || subtree_width <> old_subtree_width * then *) match parent with | None -> (match tree_layer with | None -> (* during bottom-up clone copy there is no parent and the * tree_layer will be installed later *) () | Some sco -> sco#clear_size_cache ) | Some p -> p#update_sizes_in_branch (***************************************************************************) (***************************************************************************) (** {2 Coordinates} *) (***************************************************************************) (***************************************************************************) (***************** inside proof_tree_element *) (** Computes the left offset of [child] relative to the bounding box of its parent, which must be this node. *) method child_offset child = self#iter_children 0 0 0 (fun left _y _a oc -> (left, child <> oc)) (** Computes the pair [(left_off, y_off)]. [left_off] is the offset of the left hand side of the bounding box of this node's subtree. [y_off] is the offset of the y-coordinate of this node. The offsets are relative to the left and top of the layer stack, respectively. *) method left_y_offsets = match parent with | None -> (match tree_layer with | None -> assert false | Some tl -> let (tl_left, tl_top) = tl#left_top_offset in let (me_left, me_top) = tl#child_offsets (self :> proof_tree_element) in (tl_left + me_left, tl_top + me_top + height / 2) ) | Some p -> let (parent_left, parent_y) = p#left_y_offsets in let y_off = parent_y + !current_config.level_distance in let left_off = parent_left + p#child_offset (self :> proof_tree_element) in (left_off, y_off) (***************** inside proof_tree_element *) (** Computes the bounding box (that is a 4-tuple [(x_low, x_high, y_low, y_high)]) relative to the upper-left corner of the complete display. *) method bounding_box_offsets = let (left, y) = self#left_y_offsets in let x = self#get_x_coordinate left in (* * Printf.fprintf (debugc()) * "BBO %s\n%!" * self#debug_name; *) (* * Printf.fprintf (debugc()) * "BBO left %d width %d height %d | x %d-%d y %d-%d\n%!" * left width height * left (left + width) (y - height / 2) (y + height / 2); *) (x - width / 2, x + width / 2, y - height / 2, y + height / 2) (** [bounding_box left top] computes the bounding box (that is a 4-tuple [(x_low, x_high, y_low, y_high)]) of this node in absolute values as floats. Arguments [left] and [top] specify the upper left corner of the root node of the proof tree. *) method bounding_box left top = let (x_l, x_u, y_l, y_u) = self#bounding_box_offsets in (float_of_int (x_l + left), float_of_int (x_u + left), float_of_int (y_l + top), float_of_int (y_u + top)) (***************** inside proof_tree_element *) (** Computes the x-coordinate of this node. Argument [left] must be the x-coordinate of the left side of the bounding box of this node's subtree. *) method get_x_coordinate left = left + x_offset (***************************************************************************) (***************************************************************************) (** {2 Drawing} *) (***************************************************************************) (***************************************************************************) (** Draw just this element (without connecting lines) at the indicated position. First argument [left] is the left border, second argument [y] is the y-coordinate. *) method private virtual draw : int -> int -> unit (** [line_offset inverse_slope] computes the start offset (as [(x_off, y_off)]) for drawing a line that start or ends in this node with inverse slope [inverse_slope]. These offsets are needed to avoid overdrawing elements with connecting lines. The parameter is the inverse slope, because it is always defined, because we never draw horizontal lines. Vertical lines do appear, for them the real slope is infinite. *) method virtual line_offset : float -> (int * int) (***************** inside proof_tree_element *) (** Draw the lines from this node to all its children. @param left x-coordinate of the left side of the bounding box of this node's subtree @param y y-coordinate of this node *) method private draw_lines left y = let x = self#get_x_coordinate left in self#iter_all_children_unit left y (fun left cy child -> let cx = child#get_x_coordinate left in let slope = float_of_int(cx - x) /. float_of_int(cy - y) in let (d_x, d_y) = self#line_offset slope in let (c_d_x, c_d_y) = child#line_offset slope in let gc_opt = save_and_set_gc drawable child#branch_state child#existential_variables in drawable#line ~x:(x + d_x) ~y:(y + d_y) ~x:(cx - c_d_x) ~y:(cy - c_d_y); restore_gc drawable gc_opt) (***************** inside proof_tree_element *) (** Draw this element's subtree given the left side of the bounding box and the y-coordinate of this node. This is the internal draw method that iterates through the tree. @param left x-coordinate of the left side of the bounding box of this node's subtree @param y y-coordinate of this node *) method draw_subtree left y = (* * Printf.fprintf (debugc()) * "DST %s parent %s childs %s width %d tree_width %d\n%!" * self#debug_name * (match parent with * | None -> "None" * | Some p -> p#debug_name) * (String.concat ", " (List.map (fun c -> c#debug_name) children)) * width * subtree_width; *) let gc_opt = save_and_set_gc drawable branch_state existential_variables in self#draw left y; restore_gc drawable gc_opt; self#draw_lines left y; self#iter_all_children_unit left y (fun left y child -> child#draw_subtree left y) (***************** inside proof_tree_element *) (** Draw this node's subtree given the left and top side of the bounding box. This is the external draw method that is called from the outside for the root of the tree. @param left x-coordinate of the left side of the bounding box of this node's subtree @param top y-coordinate of the top side of the bounding box of this node's subtree *) method draw_tree_root left top = self#draw_subtree left (top + height / 2) (***************************************************************************) (***************************************************************************) (** {2 Locate Mouse Button Clicks} *) (***************************************************************************) (***************************************************************************) (***************** inside proof_tree_element *) (** Iterate over the proof tree to determine the node that contains the point [(bx, by)]. Returns [None] if there is no node that contains this point. (If [bx] and [by] are the coordinates of a mouse click, then this method returns the node that was clicked.) @param left x-coordinate of the left side of the bounding box of this node's subtree @param y y-coordinate of this node @param bx x-coordinate of point @param by y-coordinate of point *) method find_node_for_point left y bx by = let top = y - height / 2 in if bx >= left && bx <= left + subtree_width && by >= top && by <= top + self#subtree_height then let x = self#get_x_coordinate left in if bx >= x - width/2 && bx <= x + width/2 && by >= y - height/2 && by <= y + height/2 then Some (self :> proof_tree_element) else self#iter_children left y None (fun left y _a child -> let cres = child#find_node_for_point left y bx by in (cres, cres = None)) else None (***************** inside proof_tree_element *) (** Iterate over the proof tree to determine the node that contains the point [(bx, by)]. Returns [None] if there is no node that contains this point. This is the external version that is called from the outside to determine nodes for mouse clicks. @param left x-coordinate of the left side of the bounding box of this node's subtree @param top y-coordinate of the top side of the bounding box of this node's subtree @param bx x-coordinate of point @param by y-coordinate of point *) method find_node_for_point_root left top bx by = self#find_node_for_point left (top + height/2) bx by (***************************************************************************) (***************************************************************************) (** {2 Mark Branches and Nodes} *) (***************************************************************************) (***************************************************************************) (** Apply (the marking function) [f] on this node and all parent nodes until [f] returns [false] or the root is reached. *) method mark_branch (f : proof_tree_element -> bool) = if f (self :> proof_tree_element) then match parent with | Some p -> p#mark_branch f | None -> () (***************** inside proof_tree_element *) (** Mark this element as [CurrentNode] and all the parent nodes as [Current] branch, see {!branch_state_type}. Relies on the invariant that the parent of a [Current] element is also marked [Current]. *) method mark_current = self#mark_branch (fun (self : proof_tree_element) -> if self#branch_state = Current then false else (self#set_branch_state Current; true)); branch_state <- CurrentNode (** Mark this element as [Proven] and mark all parents [Proven] until one parent has an unproven child, see {!branch_state_type}. *) method mark_proved = self#mark_branch (fun (self : proof_tree_element) -> if (List.for_all (fun c -> c#branch_state = Proven) self#children) then (self#set_branch_state Proven; (* * Printf.fprintf (debugc()) * "Mark %s proven\n%!" self#debug_name; *) true) else false ) (***************** inside proof_tree_element *) (** Mark this node as [Cheated] and mark all parents that have only [Cheated] children as [Cheated] as well, see {!branch_state_type}. *) method mark_cheated = self#mark_branch (fun (self : proof_tree_element) -> if (List.for_all (fun c -> c#branch_state = Cheated) self#children) then (self#set_branch_state Cheated; true) else false ) (** Remove the [Current] and [CurrentNode] marking for the current branch up to the root and set the marking of these nodes to [Unproven], see {!branch_state_type}. *) method unmark_current = self#mark_branch (fun (self : proof_tree_element) -> match self#branch_state with | CurrentNode | Current -> self#set_branch_state Unproven; true | Unproven -> false | Proven | Cheated -> assert false ) (***************** inside proof_tree_element *) (** Remove the [Proved] or [Cheated] mark of this element and all parent elements until an [Unproven] or [Current] element is met, see {!branch_state_type}. *) method unmark_proved_or_cheated = self#mark_branch (fun (self : proof_tree_element) -> match self#branch_state with | Cheated | Proven -> self#set_branch_state Unproven; true | Unproven | CurrentNode | Current -> false ) (** Set all [Current] and [CurrentNode] markings in the subtree of this element to [Unproven], see {!branch_state_type}. Used when the proof-tree window gets disconnected from the current proof. *) method disconnect_proof = (match branch_state with | Current | CurrentNode -> branch_state <- Unproven | Unproven | Proven | Cheated -> () ); List.iter (fun c -> c#disconnect_proof) children; (***************************************************************************) (***************************************************************************) (** {2 Misc} *) (***************************************************************************) (***************************************************************************) (***************** inside proof_tree_element *) (** Return the displayed text for proof-tree elements, which contains additional information about uninstantiated and partially instantiated existentials. *) method displayed_text = let uninst_ex = filter_uninstantiated existential_variables in let partial_ex = filter_partially_instantiated existential_variables in if uninst_ex = [] && partial_ex = [] then self#content else self#content ^ "\n\n" ^ (if uninst_ex <> [] then "Open Existentials: " ^ (string_of_existential_list uninst_ex) else "") ^ (if uninst_ex <> [] && partial_ex <> [] then "; " else "") ^ (if partial_ex <> [] then "Partially instantiated: " ^ (string_of_existential_list partial_ex) else "") (** Register an external window for this element. *) method register_external_window win = external_windows <- win :: external_windows (** Delete an external window from the list of registered external windows. *) method delete_external_window win = external_windows <- List.filter (fun w -> w <> win) external_windows (***************** inside proof_tree_element *) (** Delete all non-sticky external node windows of this node. *) method delete_non_sticky_external_windows = List.iter (fun w -> w#delete_attached_node_window) external_windows (** Propagate this nodes existentials to all its children. This method is not recursive. It is used during normal operation, where newly added children have themselves no children. *) method private set_children_existentials = List.iter (fun c -> c#inherit_existentials existential_variables) children (** Propagate existentials recursively down to all children in the complete subtree of this element. Necessary after proof-tree cloning, because cloning works bottom-up. *) method propagate_existentials = self#set_children_existentials; List.iter (fun c -> c#propagate_existentials) children (** Update the list of existential variables in displayed sequent text and proof commands in the whole subtree of this element. This needs to be called when some existential got instantiated or when an undo uninstantiates some existential. *) method update_existentials_info = (match sequent_text_history with | [] -> () | _ :: history -> sequent_text_history <- self#displayed_text :: history ); (if external_windows <> [] && existential_variables <> [] then List.iter (fun ew -> ew#update_content sequent_text_history) external_windows ); List.iter (fun c -> c#update_existentials_info) children (***************** inside proof_tree_element *) (** Hook to be called when the list of children has been changed. Adjusts the relative layout information of this element and all its parents and (non-recursively) propagates the existentials to all children. *) method children_changed = (* prerr_endline("CHILDS at " ^ self#debug_name ^ " CHANGED"); *) self#update_sizes_in_branch; self#set_children_existentials (* prerr_endline "END CHILD CHANGED" *) (** Adjust layout and size information after the configuration has been changed. *) method configuration_updated = List.iter (fun c -> c#configuration_updated) children; List.iter (fun ex -> ex#configuration_updated) external_windows; self#set_node_size; self#update_subtree_size end (*****************************************************************************) (*****************************************************************************) (** {3 The tree element for sequents} *) (*****************************************************************************) (*****************************************************************************) (** Specific element class for sequents, which draw themselves as turnstile symbols. This class specializes the abstract {!proof_tree_element} class for sequent nodes in the proof tree. Argument undo_state saves the undo state for the current proof. It's value is arbitrary for cloned proof trees. *) class turnstile (drawable : better_drawable) undo_state sequent_id sequent_text_option = object (self) inherit proof_tree_element drawable undo_state sequent_id [] [] as super (** The pure sequent text. *) val mutable sequent_text = match sequent_text_option with | Some t -> t | None -> "waiting for sequent text" (** Pango layout for rendering text. Only created if an ID for an external window must be put into the display. *) val mutable layout = None (** This is a [Turnstile] node. *) method node_kind = Turnstile (** Return the pure sequent text as content. *) method content = sequent_text (** This method is not relevant for sequent elements. Return always false. *) method content_shortened = false (** Make the sequent ID accessible, which is used as debugging name for sequent elements. *) method id = sequent_id (***************** inside turnstile *) (** Update the sequent text to a new version. *) method update_sequent new_text = (match sequent_text_history with | [] -> () | _ :: old -> sequent_text_history <- sequent_text :: old ); sequent_text <- new_text; sequent_text_history <- self#displayed_text :: sequent_text_history; List.iter (fun ew -> ew#update_content sequent_text_history) external_windows (** Restore the previous version of the sequent text. *) method undo_update_sequent = (match sequent_text_history with | [] -> assert false | _ :: [] -> (* This happens when undoing the initial update sequent * command for additional subgoals. *) sequent_text_history <- []; sequent_text <- "no sequent text available" | _ :: old :: rest -> sequent_text <- old; sequent_text_history <- self#displayed_text :: rest ); List.iter (fun ew -> ew#update_content sequent_text_history) external_windows (** Return the pango layout object of {!layout}. Create one if there is none. *) method private get_layout = match layout with | None -> drawable#pango_context#set_font_description !proof_tree_font_desc; let l = drawable#pango_context#create_layout in layout <- Some l; l | Some l -> l (** Update fonts, sizes and layout after the configuration has been changed. *) method configuration_updated = layout <- None; super#configuration_updated (***************** inside turnstile *) (** Draw the turnstile symbol for this sequent at the indicated coordinates. *) method private draw_turnstile x y = let radius = !current_config.turnstile_radius in if branch_state = CurrentNode then drawable#arc ~x:(x - radius) ~y:(y - radius) ~width:(2 * radius) ~height:(2 * radius) (); (if selected then let wh_2 = radius + !current_config.turnstile_line_width in drawable#rectangle ~x:(x - wh_2) ~y:(y - wh_2) ~width:(2 * wh_2) ~height:(2 * wh_2) (); ); drawable#line ~x:(x + !current_config.turnstile_left_bar_x_offset) ~y:(y - !current_config.turnstile_left_bar_y_offset) ~x:(x + !current_config.turnstile_left_bar_x_offset) ~y:(y + !current_config.turnstile_left_bar_y_offset); drawable#line ~x:(x + !current_config.turnstile_left_bar_x_offset) ~y ~x:(x + !current_config.turnstile_horiz_bar_x_offset) ~y; (match external_windows with | [] -> () | win::_ -> let layout = self#get_layout in Pango.Layout.set_text layout win#window_number; let (w, h) = Pango.Layout.get_pixel_size layout in drawable#put_layout ~x:(x + !current_config.turnstile_number_x_offset - w) ~y:(y - h / 2) layout ) (***************** inside turnstile *) (** Draw this turnstile node. @param left x-coordinate of the left side of the bounding box of this node's subtree @param y y-coordinate of this node *) method private draw left y = let x = self#get_x_coordinate left in (* * Printf.fprintf (debugc()) "DRAW TURN %s l %d t %d x %d y %d\n%!" * self#debug_name left top x y; *) self#draw_turnstile x y (** Compute the line offsets for sequent nodes, see {!proof_tree_element.line_offset} *) method line_offset slope = let radius = !current_config.turnstile_radius + !current_config.line_sep in let d_y = sqrt(float_of_int(radius * radius) /. (slope *. slope +. 1.0)) in let d_x = slope *. d_y in (int_of_float(d_x +. 0.5), int_of_float(d_y +. 0.5)) (** Set width and height of this node. *) method private set_node_size = width <- 2 * !current_config.turnstile_radius + 2 * !current_config.turnstile_line_width + !current_config.subtree_sep; height <- 2 * !current_config.turnstile_radius + 2 * !current_config.turnstile_line_width (***************** inside turnstile *) initializer self#set_node_size; (* * Printf.fprintf (debugc()) "INIT %s width %d height %d\n%!" * self#debug_name width height; *) self#update_subtree_size; (match sequent_text_option with | None -> () | Some _ -> sequent_text_history <- [self#displayed_text] ); () end (*****************************************************************************) (*****************************************************************************) (** {3 The tree element for proof commands} *) (*****************************************************************************) (*****************************************************************************) (** Create a new layout with fonts from the current configuration. This function exists, because (I) Pango.Layout.set_font_description is missing in Debian Squeeze and (II) one cannot call a method in the initializer of the instance variable layout. *) let make_layout context = context#set_font_description !proof_tree_font_desc; context#create_layout (** Specific element class for proof commands. This class specializes the generic and abstract {!proof_tree_element} for proof-command nodes. Argument undo_state saves the undo state for the current proof. It's value is arbitrary for cloned proof trees. *) class proof_command (drawable_arg : better_drawable) undo_state command debug_name inst_existentials fresh_existentials = object (self) inherit proof_tree_element drawable_arg undo_state debug_name inst_existentials fresh_existentials as super (** The part of the proof command that is displayed inside the tree. Maybe shorter than {!command}. *) val mutable displayed_command = "" (** The original proof command. If it exceeds the length specified in field [proof_command_length] (see {!Configuration.t} and {!Configuration.current_config}) then only a part of it is displayed in the tree display. *) val command = command (** Flag to indicate that only a part of the proof command is displayed inside the proof-tree display. Used to decide whether to display tool-tips for this proof command. *) val mutable content_shortened = false (* XXX Pango.Layout.set_font_description is missing in debian * squeeze. Have to use Pango.Context.set_font_description and * create new layout objects on every font change. *) (** The pango layout for rendering the proof command text. *) val mutable layout = make_layout drawable_arg#pango_context (** Width (in pixels) of the rendered proof command text. *) val mutable layout_width = 0 (** Height (in pixels) of the rendered proof command text. *) val mutable layout_height = 0 (***************** inside proof_command_length *) (** This is a [Proof_command] element, see {!node_kind}. *) method node_kind = Proof_command (** Return the original complete proof command as content. *) method content = command (** Return whether the proof command has been shortend in the display. Used to decide whether to display tool-tips for this proof command. *) method content_shortened = content_shortened (** This method is not relevant for proof commands. Return the empty string. *) method id = "" (** Render the proof command in the pango layout. *) method private render_proof_command = let layout_text = match external_windows with | [] -> displayed_command | w :: _ -> w#window_number ^ ": " ^ displayed_command in Pango.Layout.set_text layout layout_text; let (w,h) = Pango.Layout.get_pixel_size layout in layout_width <- w; layout_height <- h (***************** inside proof_command_length *) (** Set {!displayed_command}. Called from the initializer and when the configuration has been changed. *) method private set_displayed_command = if Util.utf8_string_length command <= !current_config.proof_command_length then begin content_shortened <- false; displayed_command <- replace_char command '\n' ' ' end else begin content_shortened <- true; displayed_command <- (replace_char (Util.utf8_string_sub command (!current_config.proof_command_length - 1)) '\n' ' ') ^ "\226\128\166" (* append horizontal ellipsis *) end (** Set {!proof_tree_element.width} and {!proof_tree_element.height} after rendering the proof command. *) method private set_node_size = self#render_proof_command; width <- layout_width + !current_config.subtree_sep; height <- layout_height (** Update fonts, the displayed command, the size and layout information after the configuration has been updated. *) method configuration_updated = self#set_displayed_command; layout <- make_layout drawable_arg#pango_context; super#configuration_updated (***************** inside proof_command_length *) (** Override {!proof_tree_element.register_external_window} because the displayed proof command must be rerendered when an external window is registered. *) method register_external_window win = super#register_external_window win; self#render_proof_command (** Override {!proof_tree_element.delete_external_window} because the displayed proof command must be rerendered when an external window is deleted. *) method delete_external_window win = super#delete_external_window win; self#render_proof_command (***************** inside proof_command_length *) (** Draw just this command node. @param left x-coordinate of the left side of the bounding box of this node's subtree @param y y-coordinate of this node *) method private draw left y = let x = self#get_x_coordinate left in (* * Printf.fprintf (debugc()) "DRAW TURN %s l %d t %d x %d y %d\n%!" * self#debug_name left top x y; *) let crea = List.exists (fun e -> e.existential_mark) fresh_existentials in let inst = List.exists (fun e -> e.existential_mark) inst_existentials in if crea || inst then begin let w = layout_width + 1 * !current_config.subtree_sep in let h = layout_height + 2 * !current_config.subtree_sep in let gc = save_gc drawable in if crea then drawable#set_foreground (`COLOR !existential_create_gdk_color) else drawable#set_foreground (`COLOR !existential_instantiate_gdk_color); drawable#arc ~x:(x - w/2) ~y:(y - h/2) ~width:w ~height:h ~filled:true (); restore_gc drawable gc end; drawable#put_layout ~x:(x - layout_width/2) ~y:(y - layout_height/2) layout; if selected then let w = layout_width + !current_config.turnstile_line_width in let h = layout_height + !current_config.turnstile_line_width in drawable#rectangle ~x:(x - w/2) ~y:(y - h/2) ~width:w ~height:h (); (***************** inside proof_command_length *) (** Compute the line offsets for proof-command nodes, see {!proof_tree_element.line_offset} *) method line_offset slope = let sign = if slope >= 0.0 then 1 else -1 in let line_sep = !current_config.line_sep in let corner_slope = (float_of_int width) /. (float_of_int height) in (* slope and corner_slope are actually inverse slopes: * they are d_x / d_y. This is because d_y is guaranteed to be non_zero, * while d_x is not. *) if (abs_float slope) <= corner_slope then (* intersect with top or bottom *) (int_of_float(slope *. (float_of_int (height/2 + line_sep)) +. 0.5), height/2 + line_sep) else (* intersect with left or right side *) ((width/2 + line_sep) * sign, int_of_float(float_of_int(width/2 + line_sep) /. slope +. 0.5) * sign) initializer self#set_displayed_command; self#set_node_size; (* * Printf.fprintf (debugc()) "INIT %s w %d width %d height %d\n%!" * self#debug_name w width height; *) self#update_subtree_size; sequent_text_history <- [self#displayed_text]; (* Printf.fprintf (debugc()) "INIT PC %s done\n%!" self#debug_name; *) () end (*****************************************************************************) (*****************************************************************************) (** {2 Cloning} *) (*****************************************************************************) (*****************************************************************************) (** Helper for {!clone_tree_node} for cloning the existential variables. Uses the hash to lookup variables, such that for each variable only one {!existential_variable} record is created. *) let rec clone_existentials ex_hash ex = try Hashtbl.find ex_hash ex.existential_name with | Not_found -> let deps = List.map (clone_existentials ex_hash) ex.dependencies in let nex = { existential_name = ex.existential_name; status = ex.status; existential_mark = false; dependencies = deps; } in Hashtbl.add ex_hash ex.existential_name nex; nex (** Recursively clone all nodes in the given subtree, updating the reference for the selected node, if the old selected node is contained in the subtree. *) let rec clone_tree_node new_pc new_seq ex_hash old_selected cloned_selected node = let cloned_children = List.map (clone_tree_node new_pc new_seq ex_hash old_selected cloned_selected) node#children in let clone = match node#node_kind with | Proof_command -> (new_pc node#content (List.map (clone_existentials ex_hash) node#inst_existentials) (List.map (clone_existentials ex_hash) node#fresh_existentials) : proof_command :> proof_tree_element) | Turnstile -> let ts = new_seq node#id (Some node#content) in ts#set_sequent_text_history node#sequent_text_history; (ts : turnstile :> proof_tree_element) in if Some node = old_selected then cloned_selected := Some clone; set_children clone cloned_children; (match node#branch_state with | Cheated | Proven -> clone#set_branch_state node#branch_state | Unproven | CurrentNode | Current -> () ); clone (** Clone a complete proof tree. *) let clone_proof_tree new_pc new_seq ex_hash old_selected cloned_selected root = let cloned_root = clone_tree_node new_pc new_seq ex_hash old_selected cloned_selected root in cloned_root#propagate_existentials; cloned_root prooftree-0.13/about_window.ml0000644000175000017500000000502113032677177015236 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: about_window.ml,v 1.7 2016/01/23 12:57:13 tews Exp $ *) (** Creation and display of the about window *) (** Reference for the about window to ensure there is maximal one about window. *) let about_window = ref None (** Delete and destroy the about window. *) let delete_about () = match !about_window with | None -> () | Some about -> about#destroy (); about_window := None (** Hook for the response signal, which gets emitted when the "Close" button is hit. The "Close" button actually delivers a [`CANCEL], resulting in the about dialog being destroyed. *) let about_button = function | `CANCEL -> delete_about () | _ -> () (** Text for the about dialog. *) let about_comment = "Prooftree displays proof trees for Coq and HOL Light under control of \ the Proof General user interface. Prooftree has been developed by \ Hendrik Tews and is published under GPL version 3. For more information \ visit http://askra.de/software/prooftree/." (** Show the about window. If necessary, create one and connect all the signals. This is the hook for the "About" main menu entry. *) let show_about_window () = match !about_window with | Some about -> about#present () | None -> let about = GWindow.about_dialog ~name:"Prooftree" ~comments:about_comment ~copyright:("Prooftree version " ^ Version.version ^ " © Hendrik Tews") (* ~website_label:string -> *) (* ~parent:#window_skel -> *) (* ~destroy_with_parent:bool -> *) () in about_window := Some about; ignore(about#connect#destroy ~callback:delete_about); ignore(about#connect#response ~callback:about_button); about#show () prooftree-0.13/ext_dialog.ml0000644000175000017500000005426413032677177014671 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: ext_dialog.ml,v 1.18 2016/01/23 12:57:14 tews Exp $ *) (** The Existential Variable Dialog *) (* open Util *) open Gtk_ext open Configuration open Draw_tree (** Record for one line in the table of existential variables. This record links the {!Draw_tree.existential_variable} record and the necessary GTK widgets in order to update the table line when the status of the existential changes. For memory management is makes also sense to destroy all widgets when a line gets deleted. For easy access, these table line records are stored in the {!existential_variable_window.ext_hash} hash table with the name of the existential as key. *) type ext_table_line = { ext_table_ext : existential_variable; (** The existential record with all status information *) ext_table_row : int; (** The row number in the table *) ext_table_status_label : GMisc.label; (** Label for the status *) ext_table_using_label : GMisc.label; (** Label for using column *) ext_table_button : GButton.toggle_button; (** display toggle button *) ext_table_other : GObj.widget array; (** all other widgets in the line *) } (** Class for managing dialogs for existential variables. Objects are created when the widget tree is completely constructed. Contains the necessary state and methods to handle all callbacks. The callbacks must be set up by the function that creates objects. The existential dialog supports lazy update as the proof-tree window. This means that the table is only updated when Prooftree is idle because there are currently no commands to process. Requests for adding or deleting existentials are accumulated in {!to_add} and {!to_delete} until {!update_ext_dialog} is called. Actually, the display must be updated add and delete requests (which is currently not ensured). Arguments are - proof_window {!class: Proof_window.proof_window} to which this window is associated to - top_window {xref lablgtk class GWindow.window} of the top-level widget - ext_table {xref lablgtk class GPack.table} of the main table - table_v_adjustment {xref lablgtk class GData.adjustment} for the scrollbar of the table - border_vbars the left and the right vertical bar together with their column - inner_vbars the other vertical bars together with their column - start_row first row in the table - name_col column for names - status_col column for status - button_col column for buttons - last_col last column *) class existential_variable_window proof_window (top_window : GWindow.window) (ext_table : GPack.table) (table_v_adjustment : GData.adjustment) (border_vbars : (GObj.widget * int) array) (inner_vbars : (GObj.widget * int) array) start_row name_col status_col using_col button_col last_col = object (self) (** "no" label text for the instantiated column. *) val uninst_label = "no" (** "partially" label text for the instantiated column. Contains pango markup for the color. *) val mutable partially_inst_label = "" (** "fully" label text for the instantiated column. Contains pango markup for the color. *) val mutable fully_inst_label = "" (** Used to show the bottom of the existential variable table by default. If the user scrolls the table, then this flag remembers if he scrolled to the bottom, see {!scrollbar_value_changed_callback}. When the table size changes, the table is automatically scrolled to the bottom, if this flag is true. *) val mutable clamp_to_bottom = true (** The next free row in the table. Managed by all methods that add or delete rows in the table. *) val mutable next_row = start_row (** Hash mapping existential names to {!ext_table_line} records. The hash is used when updating the status and when deleting selected existentials from the table. *) val ext_hash = Hashtbl.create 251 (** Existentials queued for addition. This is a list of lists to avoid list concatenation. If this is non-nil then {!to_delete} must be nil. *) val mutable to_add = [] (** Existentials queued for deletion. This is a list of lists to avoid list concatenation. If this is non-nil then {!to_add} must be nil. *) val mutable to_delete = [] (** This array is non-empty precisely when the "no existential variables" line is displayed in the array. Contains the widgets of that line if non-empty. *) val mutable no_ext_label_widgets = [| |] (** Stores the currently pressed "mark" button if there is one. Used to ensure that maximal one mark button can be pressed. *) val mutable pressed_mark_button = None (** Create the pango markup text for the "partially" and "fully" labels. Called in the initializer and when the configuration has been updated. *) method make_inst_labels = partially_inst_label <- pango_markup_color "partially" !proved_partial_gdk_color; fully_inst_label <- pango_markup_color "fully" !proved_complete_gdk_color (** Schedule the existentials in the argument list to be added to the table. *) method change_and_add new_ext = assert(to_delete = []); if new_ext <> [] then to_add <- new_ext :: to_add (** Schedule the existentials in the argument list to be removed from the table. *) method change_and_delete remove_ext = assert(to_add = []); if remove_ext <> [] then to_delete <- remove_ext :: to_delete (** Adjust the length of the vertical bars in the table. The border bars are always drawn to the bottom of the table. The inner bars are only drawn up to row [bottom]. All vertical bars are created in the very beginning and then reused all the time by removing and adding them to the table. *) method private adjust_vbars bottom = Array.iter (fun (bar, col) -> ext_table#remove bar; ext_table#attach ~left:col ~top:0 ~bottom:next_row bar) border_vbars; Array.iter (fun (bar, col) -> ext_table#remove bar; ext_table#attach ~left:col ~top:0 ~bottom bar) inner_vbars (** Put a "no existential variables" line into the table and store its widgets in {!no_ext_label_widgets}. *) method private make_no_ext_label = let no_ext_label = GMisc.label ~text:"There are no existential variables" ~ypad:8 ~packing:(ext_table#attach ~left:name_col ~right:last_col ~top:next_row) () in next_row <- next_row + 1; let hbar = GMisc.separator `HORIZONTAL ~packing:(ext_table#attach ~left:0 ~right:last_col ~top:next_row) () in next_row <- next_row + 1; self#adjust_vbars (next_row - 2); no_ext_label_widgets <- [| hbar#coerce; no_ext_label#coerce |] (** Delete the "no existential variables" line from the table. *) method private delete_no_ext_label = Array.iter (fun w -> w#destroy ()) no_ext_label_widgets; no_ext_label_widgets <- [| |]; next_row <- start_row (** Release the currently pressed "mark" button, if there is one. *) method release_pressed_button = (match pressed_mark_button with | None -> () | Some button -> button#set_active false; pressed_mark_button <- None ); (** Return the pair of proof-tree nodes that create and instantiate the given existential. If the existential is not instantiated then the second component is [None]. *) method private get_ext_nodes existential = let crea_node = match proof_window#find_node (fun n -> List.memq existential n#fresh_existentials) with | None -> assert false | Some n -> n in (* * Printf.fprintf (debugc()) * "GEN ext %s status %s crea node %s\n%!" * existential.existential_name * (match existential.status with * | Uninstantiated -> "uninst" * | Partially_instantiated -> "partial" * | Fully_instantiated -> "fully") * crea_node#debug_name; *) if existential.status <> Uninstantiated then let inst_node = proof_window#find_node (fun n -> List.memq existential n#inst_existentials) in assert(inst_node <> None); (crea_node, inst_node) else (crea_node, None) (** Callback function for toggling some "mark" button. Marks or unmarks the existential, keeps {!pressed_mark_button} up to date, schedules the proof tree for redisplay and tries to show the marked nodes. *) method mark_button_toggled button existential () = if button#active then begin self#release_pressed_button; pressed_mark_button <- Some button; existential.existential_mark <- true; (match self#get_ext_nodes existential with | (crea, Some inst) -> proof_window#show_both_nodes crea inst | (crea, None) -> proof_window#show_node crea ); proof_window#invalidate_drawing_area; end else begin existential.existential_mark <- false; pressed_mark_button <- None; proof_window#invalidate_drawing_area; end (** Update the information in the argument table line. *) method private set_ext_line_status tl = tl.ext_table_status_label#set_label (match tl.ext_table_ext.status with | Uninstantiated -> uninst_label | Partially_instantiated -> partially_inst_label | Fully_instantiated -> fully_inst_label ); let color_ex_name ex = match ex.status with | Uninstantiated -> ex.existential_name | Partially_instantiated -> pango_markup_color ex.existential_name !proved_partial_gdk_color | Fully_instantiated -> pango_markup_color ex.existential_name !proved_complete_gdk_color in let colored_dep_names = String.concat ", " (List.map color_ex_name tl.ext_table_ext.dependencies) in tl.ext_table_using_label#set_label colored_dep_names (** Update the status of the complete table. *) method private update_existential_status = Hashtbl.iter (fun _ tl -> (* We don't have to update every line. However, the test is * rather complicated, because we have to check whether the * status of any of the dependencies changes. For that one * would have to through ext_hash, in order to find the last * status of the dependencies. *) self#set_ext_line_status tl ) ext_hash (** Add the existentials in the argument list to the table. Creates the necessary widgets and stores them in {!ext_hash}. This method must not be called with an empty argument list. *) method private process_fresh_existentials l = assert(l <> []); let doit ext = assert(Hashtbl.mem ext_hash ext.existential_name = false); let ext_row = next_row in let name_label = GMisc.label ~text:ext.existential_name ~packing:(ext_table#attach ~left:name_col ~top:ext_row) () in let status_label = GMisc.label (* ~xpad:7 *) ~packing:(ext_table#attach ~left:status_col ~top:ext_row) () in status_label#set_use_markup true; let using_label = GMisc.label ~packing:(ext_table#attach ~left:using_col ~top:ext_row) () in using_label#set_use_markup true; let button = GButton.toggle_button ~label:"mark" ~packing:(ext_table#attach ~fill:`NONE ~left:button_col ~top:ext_row) () in ignore(button#connect#toggled ~callback:(self#mark_button_toggled button ext)); next_row <- next_row + 1; let hbar = GMisc.separator `HORIZONTAL ~packing:(ext_table#attach ~left:0 ~right:last_col ~top:next_row) () in next_row <- next_row + 1; Hashtbl.add ext_hash ext.existential_name { ext_table_ext = ext; ext_table_row = ext_row; ext_table_status_label = status_label; ext_table_using_label = using_label; ext_table_button = button; ext_table_other = [| name_label#coerce; hbar#coerce; |] }; () in if Array.length no_ext_label_widgets <> 0 then self#delete_no_ext_label; List.iter doit l; self#adjust_vbars next_row (** Destroy all widgets in a table line. Takes care of releasing the "mark" button if necessary. *) method private destroy_ext_line ext_table_line = ext_table_line.ext_table_status_label#destroy (); ext_table_line.ext_table_using_label#destroy (); ext_table_line.ext_table_button#set_active false; ext_table_line.ext_table_button#destroy (); Array.iter (fun w -> w#destroy ()) ext_table_line.ext_table_other (** Delete an existential from the table. Destroys the widgets, releases the "mark" button if necessary and updates {!ext_hash}. *) method private undo_delete ext = let tl = Hashtbl.find ext_hash ext.existential_name in self#destroy_ext_line tl; Hashtbl.remove ext_hash ext.existential_name; if tl.ext_table_row < next_row then next_row <- tl.ext_table_row (** Process pending addition or deletion requests and make the whole table up-to-date. Only one of {!to_add} and {!to_delete} can be non-nil. *) method update_ext_dialog = assert(to_add = [] || to_delete = []); List.iter (fun l -> self#process_fresh_existentials l) (List.rev to_add); to_add <- []; List.iter (fun l -> List.iter (fun e -> self#undo_delete e) l) to_delete; to_delete <- []; self#update_existential_status; if next_row = start_row then self#make_no_ext_label (** Fist part of table initialization. Fill the table by processing all existentials in the proof tree of the given root node. This function can be called several times for different root nodes. *) method fill_table_lines (nodes : proof_tree_element list) = let rec iter node = if node#fresh_existentials <> [] then self#process_fresh_existentials node#fresh_existentials; List.iter iter node#children in List.iter iter nodes (** Second part of table initialization, to be called after all proof trees have been processed with {!fill_table_lines}. *) method finish_table_init = self#update_existential_status; if next_row = start_row then self#make_no_ext_label (** Update colors after the configuration has been updated. *) method configuration_updated = self#make_inst_labels; self#update_existential_status (** Clear the table for reuse. *) method clear_for_reuse = if Array.length no_ext_label_widgets = 0 then begin Hashtbl.iter (fun _ tl -> self#destroy_ext_line tl) ext_hash; Hashtbl.clear ext_hash; next_row <- start_row; end (** Callback for key events. Call the appropriate action for each key. *) method key_pressed_callback ev = match GdkEvent.Key.keyval ev with | ks when (ks = GdkKeysyms._Q || ks = GdkKeysyms._q) && (List.mem `CONTROL (GdkEvent.Key.state ev)) -> exit 0 | ks when (ks = GdkKeysyms._Q || ks = GdkKeysyms._q) -> self#destroy (); true | ks when ks = GdkKeysyms._Up -> scroll_adjustment table_v_adjustment (-1); true | ks when ks = GdkKeysyms._Down -> scroll_adjustment table_v_adjustment 1; true | _ -> false (** Callback for the [changed] signal of the scrollbar adjustment, which is emitted when anything but the [value] changes. This callback scrolls the table to the bottom, if {!clamp_to_bottom} is [true]. *) method scrollbar_changed_callback () = let a = table_v_adjustment in (* * Printf.fprintf (debugc()) "scroll changed %.1f - %.1f up %.1f\n%!" * a#value (a#value +. a#page_size) a#upper; *) if clamp_to_bottom then let upper = a#upper in a#clamp_page ~lower:upper ~upper:upper (** Callback for the [value-changed] signal of the scrollbar adjustment, which is emitted when the [value] changes. This callback remembers in {!clamp_to_bottom} whether the table was scrolled to the bottom. *) method scrollbar_value_changed_callback () = let a = table_v_adjustment in (* * Printf.fprintf (debugc()) "scroll value %.1f - %.1f up %.1f\n%!" * a#value (a#value +. a#page_size) a#upper; *) if a#value +. a#page_size >= a#upper then clamp_to_bottom <- true else clamp_to_bottom <- false (** Make this configuration dialog visible. *) method present = top_window#present() (** Action for the Close button and the destroy signal. *) method destroy () = self#release_pressed_button; proof_window#existential_clear (); top_window#destroy(); initializer self#make_inst_labels end (** Create a new dialog for existential variables. Creates the widget hierarchy, initializes the management object and registers all callbacks. The initial table fill must be initiated by the caller. *) let make_ext_dialog proof_window proof_name = let top_window = GWindow.window () in let top_v_box = GPack.vbox ~packing:top_window#add () in let _ext_title = GMisc.label ~line_wrap:true ~justify:`CENTER ~markup:("Existential Variables: " ^ proof_name ^ "") ~xpad:10 ~ypad:10 ~packing:top_v_box#pack () in (**************************************************************************** * * Scrollbar for table * ****************************************************************************) let scrolling_hbox = GPack.hbox ~packing:(top_v_box#pack ~expand:true) () in let table_scrolling = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`ALWAYS ~packing:(scrolling_hbox#pack ~expand:true ~fill:false) () in let table_v_adjustment = table_scrolling#vadjustment in (**************************************************************************** * * table of existentials * ****************************************************************************) let ext_table = GPack.table ~border_width:5 ~packing:table_scrolling#add_with_viewport () in let name_col = 1 in let status_col = 3 in let using_col = 5 in let button_col = 7 in let last_col = button_col + 2 in let xpadding = 7 in let ypadding = 3 in let row = 0 in let _hbar = GMisc.separator `HORIZONTAL ~packing:(ext_table#attach ~left:0 ~right:last_col ~top:row) () in let row = row + 1 in let bar_l = GMisc.separator `VERTICAL ~packing:(ext_table#attach ~left:0 ~top:row ~bottom:(row + 1)) () in let _name_heading = GMisc.label ~markup:"Name" ~xpad:xpadding ~ypad:ypadding ~packing:(ext_table#attach ~left:name_col ~top:row) () in let bar_1 = GMisc.separator `VERTICAL ~packing:(ext_table#attach ~left:(name_col + 1) ~top:row) () in let _status_heading = GMisc.label ~markup:"Instantiated" ~xpad:xpadding ~ypad:ypadding ~packing:(ext_table#attach ~left:status_col ~top:row) () in let bar_2 = GMisc.separator `VERTICAL ~packing:(ext_table#attach ~left:(status_col + 1) ~top:row) () in let _using_heading = GMisc.label ~markup:"Using" ~xpad:xpadding ~ypad:ypadding ~packing:(ext_table#attach ~left:using_col ~top:row) () in let bar_3 = GMisc.separator `VERTICAL ~packing:(ext_table#attach ~left:(using_col + 1) ~top:row) () in let _button_heading = GMisc.label ~markup:"Mark Nodes" ~xpad:xpadding ~ypad:ypadding ~packing:(ext_table#attach ~left:button_col ~top:row) () in let bar_r = GMisc.separator `VERTICAL ~packing:(ext_table#attach ~left:(button_col + 1) ~top:row ~bottom:(row + 1)) () in let border_vbars = [| (bar_l#coerce, 0); (bar_r#coerce, button_col + 1) |] in let inner_vbars = [| (bar_1#coerce, name_col + 1); (bar_2#coerce, status_col + 1); (bar_3#coerce, using_col + 1); |] in let row = row + 1 in let _hbar = GMisc.separator `HORIZONTAL ~packing:(ext_table#attach ~left:0 ~right:last_col ~top:row) () in let row = row + 1 in (**************************************************************************** * * compute size * ****************************************************************************) let context = ext_table#misc#pango_context in let layout = context#create_layout in Pango.Layout.set_text layout "X"; let (_, char_height) = Pango.Layout.get_pixel_size layout in top_window#set_default_size ~width:0 ~height:(8 * char_height + int_of_float ((float_of_int !current_config.ext_table_lines) *. 1.76 *. (float_of_int char_height))); (**************************************************************************** * * bottom button box * ****************************************************************************) let button_box = GPack.hbox ~spacing:5 ~border_width:5 ~packing:top_v_box#pack () in let show_current_button = GButton.button ~label:"Show current" ~packing:button_box#pack () in let close_button = GButton.button ~stock:`CLOSE ~packing:(button_box#pack ~from:`END) () in let ext_window = new existential_variable_window proof_window top_window ext_table table_v_adjustment border_vbars inner_vbars row name_col status_col using_col button_col last_col in top_window#set_title "Existential Variables"; ignore(table_v_adjustment#connect#changed ~callback:ext_window#scrollbar_changed_callback); ignore(table_v_adjustment#connect#value_changed ~callback:ext_window#scrollbar_value_changed_callback); ignore(top_window#event#connect#key_press ~callback:ext_window#key_pressed_callback); ignore(top_window#connect#destroy ~callback:ext_window#destroy); ignore(show_current_button#connect#clicked ~callback:proof_window#show_current_node); ignore(close_button#connect#clicked ~callback:ext_window#destroy); top_window#show (); ext_window prooftree-0.13/emacs_commands.ml0000644000175000017500000000371113032677177015512 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: emacs_commands.ml,v 1.6 2016/01/23 12:57:14 tews Exp $ *) (** Generate and output emacs callback requests *) (** Print [cmd] as emacs callback command. *) let emacs_callback cmd = Printf.printf "\nemacs exec: %s\n%!" cmd (** Print [cmd] as emacs callback command with a long data section. *) let emacs_long_callback cmd data = Printf.printf "\nemacs exec: %s %d\n%s\n%!" cmd (String.length data) data (* * let emacs_long_callback cmd data = * Printf.printf "\nemacs exec: %s %d\n%s%!" cmd (String.length data) * (String.sub data 0 2); * Unix.sleep 1; * Printf.printf "%s%!" (String.sub data 2 4); * Unix.sleep 1; * Printf.printf "%s\n%!" (String.sub data 4 (String.length data - 4)) *) (** Issue the stop-displaying emacs callback command. *) let emacs_callback_stop_display () = emacs_callback "stop-displaying" (** Send an undo command to emacs. *) let emacs_callback_undo undo_state = emacs_callback (Printf.sprintf "undo %d" undo_state) (** Send a piece of proof script to Proof General. *) let emacs_send_proof_script script = emacs_long_callback "insert-proof-script" script prooftree-0.13/Makefile.in0000644000175000017500000001147013032677177014255 0ustar tewstews## ## prooftree --- proof tree display for Proof General ## ## Copyright (C) 2011 - 2016 Hendrik Tews ## ## This file is part of "prooftree". ## ## "prooftree" 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 3 of the ## License, or (at your option) any later version. ## ## "prooftree" 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 in file COPYING in this or one of the parent ## directories for more details. ## ## You should have received a copy of the GNU General Public License ## along with "prooftree". If not, see . ## ## $Id: Makefile.in,v 1.29 2016/01/23 12:57:13 tews Exp $ ## ## Commentary: Makefile ## ############################################################################# ## ## CONFIGURATION SECTION ## ############################################################################# # The following variables are normally set by the configure script. # If this fails for some reason you can also rename Makefile.in to Makefile # and set these variables manually. # BINDIR: Directory where binaries are to be instelled. BINDIR:=@BINDIR@ # MANDIR: Directory where the man page is to be installed. MANDIR:=@MANDIR@ # Should be ``prooftree.opt'' if you have ocamlopt.opt available. # Should be ``prooftree.byte'' if you only have ocamlc. prooftree: @PROOFTREE@ # ocaml compiler: should be ``ocamlopt.opt'' if available, ``ocamlc'' otherwise OCAMLC:=@OCAMLC@ # ocaml dependency analyzer # should be ``ocamldep.opt'' if available, ``ocamldep'' otherwise OCAMLDEP:=@OCAMLDEP@ # ocaml documentation generator # should be ``ocamldoc.opt'' if available, ``ocamldep'' otherwise OCAMLDOC:=@OCAMLDOC@ # location of the lablgtk2 library LABLGTKDIR:=@LABLGTKDIR@ ############################################################################# ## ## END OF CONFIGURATION SECTION ## ############################################################################# ODOC_CHECK:=/home/tews/src/odoc_check/odoc_check.cmxs ODOC_XREF:=/home/tews/src/odoc_xref/odoc_xref.cmxs LABLGTKURL:=/usr/share/doc/liblablgtk2-ocaml-doc/html/api .PHONY: all all: prooftree ML_SOURCES:=\ version.ml \ util.ml \ gtk_ext.ml \ configuration.ml \ draw_tree.ml \ tree_layers.ml \ about_window.ml \ help_window.ml \ node_window.ml \ ext_dialog.ml \ emacs_commands.ml \ proof_window.ml \ proof_tree.ml \ coq.ml \ input.ml \ main.ml MLI_SOURCES:=\ version.mli \ proof_tree.mli \ input.mli SOURCES:=$(MLI_SOURCES) $(ML_SOURCES) CMO_OBJECTS:=$(ML_SOURCES:.ml=.cmo) CMX_OBJECTS:=$(ML_SOURCES:.ml=.cmx) TOCLEAN+=Makefile.deps Makefile.deps : $(SOURCES) $(OCAMLDEP) $^ > Makefile.deps include Makefile.deps OCAMLFLAGS:=-safe-string -w Aem-48 -g -I $(LABLGTKDIR) %.cmx: %.ml $(OCAMLC) -c $(OCAMLFLAGS) $< %.cmo: %.ml $(OCAMLC) -c $(OCAMLFLAGS) $< %.cmi: %.mli $(OCAMLC) -c $(OCAMLFLAGS) $< TOCLEAN+=prooftree .PHONY: prooftree.opt prooftree.opt: $(CMX_OBJECTS) $(OCAMLC) -g -I $(LABLGTKDIR) -o prooftree \ unix.cmxa lablgtk.cmxa gtkInit.cmx $^ .PHONY: prooftree.byte prooftree.byte: $(CMO_OBJECTS) $(OCAMLC) -g -I $(LABLGTKDIR) -o prooftree \ unix.cma lablgtk.cma gtkInit.cmo $^ TOCLEAN+=version.ml version.ml: version.txt echo '(* This file is automatically generated from version.txt *)' > $@ echo '(* DO NOT EDIT! *)' >> $@ echo "let version = \"`head -1 version.txt`\"" >> $@ .PHONY: install install: mkdir -p $(DESTDIR)$(BINDIR) cp prooftree $(DESTDIR)$(BINDIR) mkdir -p $(DESTDIR)$(MANDIR)/man1 cp prooftree.1 $(DESTDIR)$(MANDIR)/man1 TOCLEAN+=dump.odoc-dump dump.odoc-dump: $(SOURCES) $(OCAMLDOC) -I $(LABLGTKDIR) -d doc \ -inv-merge-ml-mli -m A -dump $@ $(SOURCES) .PHONY: doc doc: dump.odoc-dump rm -rf doc mkdir doc $(OCAMLDOC) -I $(LABLGTKDIR) -d doc \ -g $(ODOC_XREF) -libxref lablgtk $(LABLGTKURL) \ -inv-merge-ml-mli -m A -load dump.odoc-dump $(OCAMLDOC) -I $(LABLGTKURL) -dot -dot-reduce \ -o doc/dependencies.dot -load dump.odoc-dump dot -Tps doc/dependencies.dot > doc/dependencies.ps .PHONY: check-doc check-doc: dump.odoc-dump $(OCAMLDOC) -g $(ODOC_CHECK) -load dump.odoc-dump -check-all fcd clean: rm -f $(TOCLEAN) rm -f *.cmi *.cmo *.cmx *.o *.cma *.cmxa *.a TAGS: $(SOURCES) otags $(SOURCES) prooftree.man.txt: prooftree.1 nroff -man $< > $@ prooftree.man.html: prooftree.1 man2html $< | \ tail -n +3 |\ sed -e 's|man2html|HREF="http://www.nongnu.org/man2html/">man2html|' \ > $@ .PHONY: sloc sloc: wc $(SOURCES) | sort -n prooftree-0.13/configuration.ml0000644000175000017500000017675213032677177015430 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: configuration.ml,v 1.46 2016/01/23 12:57:13 tews Exp $ *) (** Prooftree Configuration and the Configuration Dialog *) open Util open Gtk_ext (**/**) module U = Unix (**/**) (***************************************************************************** *****************************************************************************) (** {2 Configuration record and global variables} *) (** Hardwired location of the user-specific configuration file. *) let config_file_location = Filename.concat (Sys.getenv "HOME") ".prooftree" (** Configuration record. For simplicity the user specific configuration file is (mostly) a marshaled configuration record. In order to be independent of Gdk marshaling, the configuration record consists only of pure OCaml values. Fonts and colors are therefore not accessed via the configuration record, but via their own references (of some suitable Gdk type). These references must, of course, be kept in sync with the current configuration. All other configurable values are accessed through the current configuration record, which is stored in {!current_config}. *) (* IMPORTANT: INCREASE config_file_version BELOW WHEN CHANGING THIS RECORD *) type t = { turnstile_radius : int; (** Radius (in pixel) of the circle around the turnstile symbol for the current node. Used also as kind of circular bounding box of the turnstile symbol. *) turnstile_left_bar_x_offset : int; (** X-offset of the vertical bar of the turnstile symbol. *) turnstile_left_bar_y_offset : int; (** Y-offset of the upper and lower end of the vertical bar of the turnstile symbol (with respect to the centre of the vertical bar). *) turnstile_horiz_bar_x_offset : int; (** Length of the horizontal bar of the turnstile symbol. *) turnstile_line_width : int; (** Line width of all lines (including the turnstile symbol). *) turnstile_number_x_offset : int; (** X-offset (with respect to the centre of the turnstile symbol) at which the number of the external sequent window is printed, if there is any. *) proof_command_length : int; (** Maximal number of characters that are displayed for a proof command in the proof-tree display. *) subtree_sep : int; (** Additional space added between two adjacent subtrees. (More precisely, this value is added to the width of every node in the proof-tree display.) *) line_sep : int; (** Space left between nodes and connecting lines. *) level_distance : int; (** Vertical distance between two levels of the proof tree. *) proof_tree_sep : int; (** Horizontal distance between two independent proof trees in one layer *) layer_sep : int; (** Vertical distance between two layers of proof trees *) button_1_drag_acceleration : float; (** Acceleration multiplier for dragging the proof-tree display inside its viewport. Positive values move the viewport (i.e., the tree underneath moves in the opposite direction of the mouse), negative values move the tree (i.e., the tree underneath moves in the same direction as the mouse). *) proof_tree_font : string; (** Font description (as for {xref lablgtk class GPango.font_description}) for the text inside the proof-tree display. *) sequent_font : string; (** Font description (as for {xref lablgtk class GPango.font_description}) for the text in the sequent display and in the additional node windows. *) current_color : (int * int * int); (** The color for the current branch, as 16-bit RGB value. *) cheated_color : (int * int * int); (** The color for branches that have been finished with a cheating command, as 16-bit RGB value *) proved_complete_color : (int * int * int); (** The color for branches that have been proved and which depend on no non-instantiated existential variables, as 16-bit RGB value. *) proved_incomplete_color : (int * int * int); (** The color for branches that have been proved and that have non-instantiated existential variables, as 16-bit RGB value. *) proved_partial_color : (int * int * int); (** The color for branches that have been proved and whose own existential variables are all instantiated, but where the instantiations depend on some not-yet instantiated existential variables. The value is the 16-bit RGB triple. *) (* * mark_subtree_color : (int * int * int); * (\** The color for marked subtrees, as 16 bit RGB value. *\) *) existential_create_color : (int * int * int); (** The color for marking nodes that introduce a given existential variable, as 16 bit RGB value. *) existential_instantiate_color : (int * int * int); (** The color for marking nodes that intantiate a given existential variable, as 16 bit RGB value. *) display_doc_tooltips : bool; (** Whether to display documentation/help tool-tips. *) display_turnstile_tooltips : bool; (** Whether to display complete sequents as tool-tips over sequent symbols. *) display_command_tooltips : bool; (** Whether to display complete proof commands as tool-tips over proof commands. *) default_width_proof_tree_window : int; (** Default width of the proof-tree window, used if there was no [-geometry] option. *) default_height_proof_tree_window : int; (** Default heigth of the proof-tree window, used if there was no [-geometry] option. *) internal_sequent_window_lines : int; (** Number of text lines in the internal sequent window. If [0] the internal sequent window is hidden. *) node_window_max_lines : int; (** Maximal number of text lines in external node windows. *) ext_table_lines : int; (** Default number of lines for the table of existential variables. *) debug_mode : bool; (** Print more exception backtraces for internal errors, if true. *) copy_input : bool; (** Write all read input into the file [copy_input_file], if true. *) copy_input_file : string; (** File to write read input to, if [copy_input] is true. *) } (** Set the fields [turnstile_left_bar_x_offset], [turnstile_left_bar_y_offset] and [turnstile_horiz_bar_x_offset] as function of the field [turnstile_radius]. Set [turnstile_number_x_offset] as function of [turnstile_line_width] (see {!t}). *) let update_sizes config = let radius = config.turnstile_radius in { config with turnstile_left_bar_x_offset = int_of_float(-0.23 *. (float_of_int radius) +. 0.5); turnstile_left_bar_y_offset = int_of_float(0.65 *. (float_of_int radius) +. 0.5); turnstile_horiz_bar_x_offset = int_of_float(0.7 *. (float_of_int radius) +. 0.5); turnstile_number_x_offset = -(config.turnstile_line_width + 1); } (** Create the default, builtin configuration record. *) let default_configuration = let radius = 10 in let blue = GDraw.color (`NAME "blue") in let red = GDraw.color (`NAME "red") in let c = { turnstile_radius = radius; turnstile_line_width = 2; proof_command_length = 15; subtree_sep = 5; line_sep = 3; level_distance = 38; proof_tree_sep = 15; layer_sep = 30; turnstile_left_bar_x_offset = 0; turnstile_left_bar_y_offset = 0; turnstile_horiz_bar_x_offset = 0; turnstile_number_x_offset = 0; button_1_drag_acceleration = 4.0; proof_tree_font = "Sans 8"; sequent_font = "Sans 8"; current_color = (Gdk.Color.red blue, Gdk.Color.green blue, Gdk.Color.blue blue); cheated_color = (Gdk.Color.red red, Gdk.Color.green red, Gdk.Color.blue red); proved_complete_color = (19 * 255, 197 * 256, 19 * 255); proved_partial_color = (100 * 256, 114 * 256, 0 * 256); proved_incomplete_color = (26 * 255, 226 * 256, 216 * 256); (* mark_subtree_color = (0,0,0); *) existential_create_color = (255 * 256, 0xF5 * 256, 0x8F * 256); existential_instantiate_color = (255 * 256, 0xB6 * 256, 0x6D * 256); display_doc_tooltips = true; display_turnstile_tooltips = true; display_command_tooltips = true; default_width_proof_tree_window = 400; default_height_proof_tree_window = 400; internal_sequent_window_lines = 1; node_window_max_lines = 35; ext_table_lines = 8; debug_mode = false; copy_input = false; copy_input_file = "/tmp/prooftree.log"; } in update_sizes c (** Reference of the internal configuration record. Most configuration values are accessed through this reference. For fonts and colors there are separate references, which are always updated, when the configuration changes. *) let current_config = ref default_configuration (** Font description for the text inside the proof-tree display, as value of {xref lablgtk class GPango.font_description} type. Should always be in sync with the [proof_tree_font] field of {!current_config}. *) let proof_tree_font_desc = ref(GPango.font_description default_configuration.proof_tree_font) (** Font description for the text in the sequent display and in the additional node windows, as value of {xref lablgtk class GPango.font_description} type. Should always be in sync with the [sequent_font] field of {!current_config}. *) let sequent_font_desc = ref(GPango.font_description default_configuration.sequent_font) (** Color for the current branch, as {xref lablgtk type Gdk.color}. Should always be in sync with the [current_color] field of {!current_config}. *) let current_gdk_color = ref(GDraw.color (`RGB default_configuration.current_color)) (** Color for branches that have been finished with a cheating command, as {xref lablgtk type Gdk.color}. Should always be in sync with the [cheated_color] field of {!current_config}. *) let cheated_gdk_color = ref(GDraw.color (`RGB default_configuration.cheated_color)) (** Color for branches that have been proved and which have no non-instantiated esistential variables, as {xref lablgtk type Gdk.color}. Should always be in sync with the [proved_complete_color] field of {!current_config}. *) let proved_complete_gdk_color = ref(GDraw.color (`RGB default_configuration.proved_complete_color)) (** Color for branches that have been proved and that have non-instantiated existential variables as {xref lablgtk type Gdk.color}. Should always be in sync with the [proved_incomplete_color] field of {!current_config}. *) let proved_incomplete_gdk_color = ref(GDraw.color (`RGB default_configuration.proved_incomplete_color)) (** Color for branches that have been proved and whose own existential variables are all instantiated, but where the instantiations depend on some not-yet instantiated existential variables. The value is given as {xref lablgtk type Gdk.color} and should always be in sync with the [proved_partial_color] field of {!current_config}. *) let proved_partial_gdk_color = ref(GDraw.color (`RGB default_configuration.proved_partial_color)) (* * (\** Color for marked subtrees, as {xref lablgtk type Gdk.color}. * Should always be in sync with the {!mark_subtree_color} field of * {!current_config}. * *\) * let mark_subtree_gdk_color = * ref(GDraw.color (`RGB default_configuration.mark_subtree_color)) *) (** Color for marking nodes that introduce a given existential variable, as {xref lablgtk type Gdk.color}. Should always be in sync with the [existential_create_color] field of {!current_config}. *) let existential_create_gdk_color = ref(GDraw.color (`RGB default_configuration.existential_create_color)) (** Color for marking nodes that instantiate a given existential variable, as {xref lablgtk type Gdk.color}. Should always be in sync with the [existential_instantiate_color] field of {!current_config}. *) let existential_instantiate_gdk_color = ref(GDraw.color (`RGB default_configuration.existential_instantiate_color)) (** Update the references for fonts and colors after the current configuration has been changed. *) let update_font_and_color () = proof_tree_font_desc := GPango.font_description !current_config.proof_tree_font; sequent_font_desc := GPango.font_description !current_config.sequent_font; current_gdk_color := GDraw.color (`RGB !current_config.current_color); cheated_gdk_color := GDraw.color (`RGB !current_config.cheated_color); proved_complete_gdk_color := GDraw.color (`RGB !current_config.proved_complete_color); proved_incomplete_gdk_color := GDraw.color (`RGB !current_config.proved_incomplete_color); proved_partial_gdk_color := GDraw.color (`RGB !current_config.proved_partial_color); (* * mark_subtree_gdk_color := * GDraw.color (`RGB !current_config.mark_subtree_color); *) existential_create_gdk_color := GDraw.color (`RGB !current_config.existential_create_color); existential_instantiate_gdk_color := GDraw.color (`RGB !current_config.existential_instantiate_color) (** This function reference solves the recursive module dependency between modules {!Proof_tree}, {!Input} and this module. It is filled with {!Main.configuration_updated} when [Main] is initialized. *) let configuration_updated_callback = ref (fun () -> ()) (** Update the configuration and all directly derived state variables. *) let update_configuration_record c = current_config := c; update_font_and_color () (** [update_configuration c] does all the necessary actions to make [c] the current configuration. It stores [c] in {!current_config}, updates the references for fonts and colors and calls all [configuration_updated] functions/methods. *) let update_configuration c = update_configuration_record c; !configuration_updated_callback () (** Reference for the argument of the [-geometry] option. *) let geometry_string = ref "" (** Flag for option [-config]. *) let start_config_dialog = ref false (***************************************************************************** *****************************************************************************) (** {2 Save / Restore configuration records} A configuration file consists of an ASCII header (followed by a newline) and a marshaled configuration record (of type {!t}). Because of the header one can easily identify the file by opening it in any editor. The header contains also a version field, which changes whenever the type of the marshaled value changes. *) (** Common header of all configuration files. *) let config_file_header_start = "Prooftree configuration file version " (** Version specific header of the current config file version. *) let config_file_version = "04" (** The complete ASCII header of configuration files. *) let config_file_header = config_file_header_start ^ config_file_version ^ "\n" (** [write_config_file file c] writes a config file at [file], containing the configuration record [c]. *) let write_config_file file_name (config : t) = let oc = open_out_bin file_name in output_string oc config_file_header; Marshal.to_channel oc config []; close_out oc (** Read a configuration file at the specified location. Raises [Sys_error] if the file is not present or not readable. Raises [Failure] if there is no configuration file or if the file has an incompatible version. Return the read configuration file on success. *) let read_config_file file_name : t = let header_len = String.length config_file_header in let ic = open_in_bin file_name in let header = really_input_string ic header_len in if header = config_file_header then begin let c = (Marshal.from_channel ic : t) in close_in ic; c end else if string_starts header config_file_header_start then raise(Failure "Incompatible configuration file version") else raise(Failure "Invalid configuration file") (** Try to load the configuration file at {!config_file_location}, ignoring all errors. If a valid configuration file is found, the current configuration record is updated. If an incompatible version is found, a warning message is displayed. Used during start-up. *) let try_load_config_file () = let copt = try (* print_endline "before read"; *) let res = Some(read_config_file config_file_location) in (* print_endline "after read"; *) res with | Failure "Incompatible configuration file version" -> print_endline "version error"; run_message_dialog ("File " ^ config_file_location ^ " is not compatible with this version of Prooftree!\n\ Using default configuration.") `WARNING; None | _ -> print_endline "other error"; None in match copt with | None -> () | Some c -> update_configuration_record c (***************************************************************************** *****************************************************************************) (** {2 Configuration Dialog} *) (** Reference to ensure that at most one configuration window does exist. *) let config_window = ref None (** Class for managing configuration windows. Objects are created when the widget tree is completely constructed. Contains the necessary state and methods to handle all callbacks. The callbacks must be set up by the function that creates objects. Arguments are - old_config current config at config window start time - top_window {xref lablgtk class GWindow.window} of the top-level widget - line_width_adjustment {xref lablgtk class GData.adjustment} for line width - turnstile_size_adjustment {xref lablgtk class GData.adjustment} for turnstile size - line_sep_adjustment {xref lablgtk class GData.adjustment} for line gap - proof_tree_sep_adjustment {xref lablgtk class GData.adjustment} for proof tree sep - subtree_sep_adjustment {xref lablgtk class GData.adjustment} for node padding - command_length_adjustment {xref lablgtk class GData.adjustment} for command length - level_dist_adjustment {xref lablgtk class GData.adjustment} for vertical distance - layer_sep_adjustment {xref lablgtk class GData.adjustment} layer sep - tree_font_button {xref lablgtk class GButton.font_button} for proof tree font - sequent_font_button {xref lablgtk class GButton.font_button} for sequent window font - current_color_button {xref lablgtk class GButton.color_button} for current color - cheated_color_button {xref lablgtk class GButton.color_button} for cheated color - proved_complete_color_button {xref lablgtk class GButton.color_button} for complete color - proved_incomplete_color_button {xref lablgtk class GButton.color_button} for incomplete color - proved_partial_color_button {xref lablgtk class GButton.color_button} for partial color - ext_create_color_button {xref lablgtk class GButton.color_button} for create exist. - ext_inst_color_button {xref lablgtk class GButton.color_button} for instant. exist. - drag_accel_adjustment {xref lablgtk class GData.adjustment} for drac acceleration - doc_tooltip_check_box {xref lablgtk class GButton.toggle_button} for the help tool-tips check bock - turnstile_tooltip_check_box {xref lablgtk class GButton.toggle_button} for the turnstile tool-tips check bock - command_tooltip_check_box {xref lablgtk class GButton.toggle_button} for the command tool-tips check bock - default_size_width_adjustment {xref lablgtk class GData.adjustment} for default window size width - default_size_height_adjustment {xref lablgtk class GData.adjustment} for default window size height - internal_seq_lines_adjustment {xref lablgtk class GData.adjustment} for lines in the internal sequent window - external_node_lines_adjustment {xref lablgtk class GData.adjustment} for lines in external node windows - ext_table_lines_adjustment {xref lablgtk class GData.adjustment} for lines in evar table - debug_check_box {xref lablgtk class GButton.toggle_button} for the more-debug-info check box - tee_file_box_check_box {xref lablgtk class GButton.toggle_button} for log-input check box - tee_file_name_entry {xref lablgtk class GEdit.entry} of the log-file text entry - tooltip_misc_objects list of {xref lablgtk class GObj.misc_ops} of config dialog elements that have a tool-tip to switch on and off *) class config_window old_config top_window line_width_adjustment turnstile_size_adjustment line_sep_adjustment proof_tree_sep_adjustment subtree_sep_adjustment command_length_adjustment level_dist_adjustment layer_sep_adjustment tree_font_button sequent_font_button current_color_button cheated_color_button proved_complete_color_button proved_incomplete_color_button proved_partial_color_button (* mark_subtree_color_button *) ext_create_color_button ext_inst_color_button drag_accel_adjustment doc_tooltip_check_box turnstile_tooltip_check_box command_tooltip_check_box default_size_width_adjustment default_size_height_adjustment internal_seq_lines_adjustment external_node_lines_adjustment ext_table_lines_adjustment debug_check_box tee_file_box_check_box tee_file_name_entry tooltip_misc_objects = object (self) (** The callbacks for the configuration update may trigger several config updates in a row. When this setting is [true], then the config update is not done. *) val mutable delay_config_update = false (** Set to [true] when the log-file chooser dialog sets the log-file name to avoid switching off the log file check box. *) val mutable clean_tee_file_check_box = true (** Make this configuration dialog visible. *) method present = top_window#present() (** [set_configuration c] changes spinners and buttons to show the configuration of the configuration record [c]. *) method set_configuration conf = (* print_endline "set config start"; *) line_width_adjustment#set_value (float_of_int conf.turnstile_line_width); turnstile_size_adjustment#set_value (float_of_int conf.turnstile_radius); subtree_sep_adjustment#set_value (float_of_int conf.subtree_sep); line_sep_adjustment#set_value (float_of_int conf.line_sep); proof_tree_sep_adjustment#set_value (float_of_int conf.proof_tree_sep); command_length_adjustment#set_value (float_of_int conf.proof_command_length); level_dist_adjustment#set_value (float_of_int conf.level_distance); layer_sep_adjustment#set_value (float_of_int conf.layer_sep); tree_font_button#set_font_name conf.proof_tree_font; sequent_font_button#set_font_name conf.sequent_font; current_color_button#set_color (GDraw.color (`RGB conf.current_color)); cheated_color_button#set_color (GDraw.color (`RGB conf.cheated_color)); proved_complete_color_button#set_color (GDraw.color (`RGB conf.proved_complete_color)); proved_incomplete_color_button#set_color (GDraw.color (`RGB conf.proved_incomplete_color)); proved_partial_color_button#set_color (GDraw.color (`RGB conf.proved_partial_color)); (* * mark_subtree_color_button#set_color * (GDraw.color (`RGB conf.mark_subtree_color)); *) ext_create_color_button#set_color (GDraw.color (`RGB conf.existential_create_color)); ext_inst_color_button#set_color (GDraw.color (`RGB conf.existential_instantiate_color)); drag_accel_adjustment#set_value conf.button_1_drag_acceleration; doc_tooltip_check_box#set_active conf.display_doc_tooltips; turnstile_tooltip_check_box#set_active conf.display_turnstile_tooltips; command_tooltip_check_box#set_active conf.display_command_tooltips; default_size_width_adjustment#set_value (float_of_int conf.default_width_proof_tree_window); default_size_height_adjustment#set_value (float_of_int conf.default_height_proof_tree_window); internal_seq_lines_adjustment#set_value (float_of_int conf.internal_sequent_window_lines); external_node_lines_adjustment#set_value (float_of_int conf.node_window_max_lines); ext_table_lines_adjustment#set_value (float_of_int conf.ext_table_lines); debug_check_box#set_active conf.debug_mode; tee_file_box_check_box#set_active conf.copy_input; tee_file_name_entry#set_text conf.copy_input_file; (* print_endline "set config end"; *) () (** Change spinners and buttons to show the compile-time default configuration. *) method reset_to_default () = self#change_config_and_config_window default_configuration (** Switch the help/documentation tool-tips on or off, according to the argument [flag]. *) method toggle_tooltips flag = List.iter (fun misc -> misc#set_has_tooltip flag) tooltip_misc_objects (** Start and manage the modal file selection dialog for the log-file button. If the user makes a selection, the log-file text entry is updated. The current configuration is then changed via the [notify_text] signal of this entry. *) method tee_file_button_click () = let file_chooser = GWindow.file_chooser_dialog ~action:`SAVE ~parent:top_window ~destroy_with_parent:true ~title:"Prooftree log file selection" ~focus_on_map:true ~modal:true () in file_chooser#add_select_button_stock `APPLY `SELECT; file_chooser#add_button_stock `CANCEL `CANCEL; ignore(file_chooser#set_current_folder (Filename.dirname tee_file_name_entry#text)); let chooser_file = match file_chooser#run() with | `SELECT -> file_chooser#filename | `CANCEL | `DELETE_EVENT -> None in file_chooser#destroy(); (match chooser_file with | Some file -> clean_tee_file_check_box <- false; tee_file_name_entry#set_text file | None -> () ); () (** Create a new configuration record with the current values of the spinners and buttons of this configuration dialog. *) method private extract_configuration = let round_to_int f = int_of_float(f +. 0.5) in let c = { turnstile_line_width = round_to_int line_width_adjustment#value; turnstile_radius = round_to_int turnstile_size_adjustment#value; line_sep = round_to_int line_sep_adjustment#value; proof_tree_sep = round_to_int proof_tree_sep_adjustment#value; subtree_sep = round_to_int subtree_sep_adjustment#value; proof_command_length = round_to_int command_length_adjustment#value; level_distance = round_to_int level_dist_adjustment#value; layer_sep = round_to_int layer_sep_adjustment#value; turnstile_left_bar_x_offset = 0; turnstile_left_bar_y_offset = 0; turnstile_horiz_bar_x_offset = 0; turnstile_number_x_offset = 0; button_1_drag_acceleration = drag_accel_adjustment#value; proof_tree_font = tree_font_button#font_name; sequent_font = sequent_font_button#font_name; current_color = (let c = current_color_button#color in (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); cheated_color = (let c = cheated_color_button#color in (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); proved_complete_color = (let c = proved_complete_color_button#color in (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); proved_incomplete_color = (let c = proved_incomplete_color_button#color in (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); proved_partial_color = (let c = proved_partial_color_button#color in (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); (* * mark_subtree_color = * (let c = mark_subtree_color_button#color in * (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); *) existential_create_color = (let c = ext_create_color_button#color in (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); existential_instantiate_color = (let c = ext_inst_color_button#color in (Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)); display_doc_tooltips = doc_tooltip_check_box#active; display_turnstile_tooltips = turnstile_tooltip_check_box#active; display_command_tooltips = command_tooltip_check_box#active; default_width_proof_tree_window = round_to_int default_size_width_adjustment#value; default_height_proof_tree_window = round_to_int default_size_height_adjustment#value; internal_sequent_window_lines = round_to_int internal_seq_lines_adjustment#value; node_window_max_lines = round_to_int external_node_lines_adjustment#value; ext_table_lines = round_to_int ext_table_lines_adjustment#value; debug_mode = debug_check_box#active; copy_input = tee_file_box_check_box#active; copy_input_file = tee_file_name_entry#text; } in update_sizes c (** Callback when any item of the configuration changed. This simply updates the complete configuration in the whole program. *) method config_changed () = (* Printf.printf "change config delay %b\n%!" delay_config_update; *) if not delay_config_update then begin (* let app_start = U.gettimeofday () in *) let c = self#extract_configuration in self#toggle_tooltips c.display_doc_tooltips; (try update_configuration c; with | Log_input_file_error msg -> run_message_dialog (Printf.sprintf "Opening the input log file failed with\n %s.\n\ Disabeling input logging." msg) `WARNING; tee_file_box_check_box#set_active false ); (* * let app_end = U.gettimeofday () in * Printf.printf "apply config %f ms\n%!" ((app_end -. app_start) *. 1000.) *) end (** Update the current configuration record and all displayed values in the config window. This method makes sure that the body of the callback {config_changed} is only executed ones and that the input logging flag is not reset. *) method private change_config_and_config_window c = delay_config_update <- true; clean_tee_file_check_box <- false; self#set_configuration c; delay_config_update <- false; self#config_changed () (** Callback for the case that the log file entry has changed. To avoid lots of file openings, the tee file check box is disabled. *) method log_file_entry_changed (_ : string) = (* Printf.printf "log entry start clean %b\n%!" clean_tee_file_check_box; *) if clean_tee_file_check_box then begin let delay = delay_config_update in delay_config_update <- true; tee_file_box_check_box#set_active false; delay_config_update <- delay; end; clean_tee_file_check_box <- true; (* print_endline "log entry middle"; *) self#config_changed (); (* print_endline "log entry end"; *) () (** Action for the Save button: Saves the current configuration in the user specific configuration file {!config_file_location}. If the values of this configuration dialog differ from the current configuration, a suitable warning is displayed. *) method save () = try write_config_file config_file_location !current_config with | Sys_error s when Util.string_ends s "Permission denied" -> run_message_dialog ("No permission to write the configuration file at " ^ config_file_location ^ "!") `WARNING | e -> let backtrace = Printexc.get_backtrace () in let buf = Buffer.create 4095 in let print_backtrace = ref !current_config.debug_mode in (match e with | e -> Buffer.add_string buf "Internal error: Escaping exception "; Buffer.add_string buf (Printexc.to_string e); Buffer.add_string buf " in write_config_file"; (match e with | U.Unix_error(error, _func, _info) -> Buffer.add_char buf '\n'; Buffer.add_string buf (U.error_message error); | _ -> () ) ); if !print_backtrace then begin Buffer.add_char buf '\n'; Buffer.add_string buf backtrace; end; prerr_endline (Buffer.contents buf); run_message_dialog (Buffer.contents buf) `WARNING; () (** Action for the Restore button: Restore the configuration in the the user specific configuration file {!config_file_location} as current configuration and update this dialog accordingly. *) method restore () = try let c = read_config_file config_file_location in self#change_config_and_config_window c with | Sys_error s when Util.string_ends s "No such file or directory" -> run_message_dialog ("No configuration file at " ^ config_file_location ^ "!") `WARNING | Failure "Incompatible configuration file version" -> run_message_dialog ("File " ^ config_file_location ^ " is not compatible with this version of Prooftree!") `WARNING | Failure "Invalid configuration file" -> run_message_dialog ("File " ^ config_file_location ^ " is not a valid Prooftree \ configuration file!") `WARNING | e -> let backtrace = Printexc.get_backtrace () in let buf = Buffer.create 4095 in let print_backtrace = ref !current_config.debug_mode in (match e with | e -> Buffer.add_string buf "Internal error: Escaping exception "; Buffer.add_string buf (Printexc.to_string e); Buffer.add_string buf " in read_config_file"; (match e with | U.Unix_error(error, _func, _info) -> Buffer.add_char buf '\n'; Buffer.add_string buf (U.error_message error); | _ -> () ) ); if !print_backtrace then begin Buffer.add_char buf '\n'; Buffer.add_string buf backtrace; end; prerr_endline (Buffer.contents buf); run_message_dialog (Buffer.contents buf) `WARNING; () (** Action for the Cancel button and the destroy signal. *) method destroy () = config_window := None; top_window#destroy(); if !start_config_dialog then exit 0 (** Action for the Cancel button: Reset config to start time. *) method cancel () = self#change_config_and_config_window old_config; self#destroy () (** Action of the OK button. *) method ok () = self#destroy () end (** [adjustment_set_pos_int ~lower adjustment] configures [adjustment] for integer values between [~lower] and [100]. *) let adjustment_set_pos_int ?(lower = 1.0) (adjustment : GData.adjustment) = adjustment#set_bounds ~lower ~upper:100.0 ~step_incr:1.0 ~page_incr:1.0 () (** Create a new configuation dialog. Creates the widget hierarchy, initializes the management object and registers all callbacks. *) let make_config_window () = let current_config = !current_config in let top_window = GWindow.window () in let top_v_box = GPack.vbox ~packing:top_window#add () in let _config_title = GMisc.label ~markup:"Prooftree Configuration" ~xpad:10 ~ypad:10 ~packing:top_v_box#pack () in let notebook = GPack.notebook ~show_border:true ~packing:top_v_box#pack () in let append_to_notebook label = let label = GMisc.label ~markup:label () in fun w -> ignore(notebook#append_page ~tab_label:label#coerce w) in (**************************************************************************** * * tree configuration frame * ****************************************************************************) let tree_frame = GBin.frame ~label:"Tree Layout Parameters" ~border_width:5 ~packing:(append_to_notebook "Layout") () in let tree_frame_table = GPack.table (* ~columns:2 ~rows:2 *) ~border_width:5 ~packing:tree_frame#add () in let _middle_separator = GMisc.label ~text:"" ~xpad:7 ~packing:(tree_frame_table#attach ~left:2 ~top:0) () in let _right_separator = GMisc.label ~text:"" ~xpad:2 ~packing:(tree_frame_table#attach ~left:5 ~top:0) () in (* Line width *) let line_width_tooltip = "Line width of all lines" in let line_width_label = GMisc.label ~text:"Line width" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:0 ~top:0) () in let line_width_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:1 ~top:0) () in let line_width_adjustment = line_width_spinner#adjustment in adjustment_set_pos_int line_width_adjustment; line_width_adjustment#set_value (float_of_int current_config.turnstile_line_width); line_width_label#misc#set_tooltip_text line_width_tooltip; line_width_spinner#misc#set_tooltip_text line_width_tooltip; (* turnstile radius *) let turnstile_size_tooltip = "Radius of the circle around the current turnstile; determines \ the size of the turnstile as well" in let turnstile_size_label = GMisc.label ~text:"Turnstile size" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:0 ~top:1) () in let turnstile_size_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:1 ~top:1) () in let turnstile_size_adjustment = turnstile_size_spinner#adjustment in adjustment_set_pos_int turnstile_size_adjustment; turnstile_size_adjustment#set_value (float_of_int current_config.turnstile_radius); turnstile_size_label#misc#set_tooltip_text turnstile_size_tooltip; turnstile_size_spinner#misc#set_tooltip_text turnstile_size_tooltip; (* line_sep *) let line_sep_tooltip = "Gap between the node connecting lines and the nodes" in let line_sep_label = GMisc.label ~text:"Line gap" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:0 ~top:2) () in let line_sep_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:1 ~top:2) () in let line_sep_adjustment = line_sep_spinner#adjustment in adjustment_set_pos_int ~lower:0.0 line_sep_adjustment; line_sep_adjustment#set_value (float_of_int current_config.line_sep); line_sep_label#misc#set_tooltip_text line_sep_tooltip; line_sep_spinner#misc#set_tooltip_text line_sep_tooltip; (* proof_tree_sep *) let proof_tree_sep_tooltip = "Additional padding between adjacent proof trees in one layer" in let proof_tree_sep_label = GMisc.label ~text:"Tree padding" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:0 ~top:3) () in let proof_tree_sep_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:1 ~top:3) () in let proof_tree_sep_adjustment = proof_tree_sep_spinner#adjustment in adjustment_set_pos_int ~lower:0.0 proof_tree_sep_adjustment; proof_tree_sep_adjustment#set_value (float_of_int current_config.proof_tree_sep); proof_tree_sep_label#misc#set_tooltip_text proof_tree_sep_tooltip; proof_tree_sep_spinner#misc#set_tooltip_text proof_tree_sep_tooltip; (* subtree_sep *) let subtree_sep_tooltip = "Additional padding added to the width of each node in the proof tree" in let subtree_sep_label = GMisc.label ~text:"Node padding" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:3 ~top:0) () in let subtree_sep_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:4 ~top:0) () in let subtree_sep_adjustment = subtree_sep_spinner#adjustment in adjustment_set_pos_int ~lower:0.0 subtree_sep_adjustment; subtree_sep_adjustment#set_value (float_of_int current_config.subtree_sep); subtree_sep_label#misc#set_tooltip_text subtree_sep_tooltip; subtree_sep_spinner#misc#set_tooltip_text subtree_sep_tooltip; (* proof_command_length *) let command_length_tooltip = "Number of characters displayed for proof commands" in let command_length_label = GMisc.label ~text:"Command length" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:3 ~top:1) () in let command_length_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:4 ~top:1) () in let command_length_adjustment = command_length_spinner#adjustment in adjustment_set_pos_int command_length_adjustment; command_length_adjustment#set_value (float_of_int current_config.proof_command_length); command_length_label#misc#set_tooltip_text command_length_tooltip; command_length_spinner#misc#set_tooltip_text command_length_tooltip; (* level distance *) let level_dist_tooltip = "Vertical distance between neighboring nodes" in let level_dist_label = GMisc.label ~text:"Vertical distance" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:3 ~top:2) () in let level_dist_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:4 ~top:2) () in let level_dist_adjustment = level_dist_spinner#adjustment in adjustment_set_pos_int level_dist_adjustment; level_dist_adjustment#set_value (float_of_int current_config.level_distance); level_dist_label#misc#set_tooltip_text level_dist_tooltip; level_dist_spinner#misc#set_tooltip_text level_dist_tooltip; (* layer_sep *) let layer_sep_tooltip = "Additional padding between adjacent layers of proof trees" in let layer_sep_label = GMisc.label ~text:"Layer padding" ~xalign:0.0 ~xpad:5 ~packing:(tree_frame_table#attach ~left:3 ~top:3) () in let layer_sep_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(tree_frame_table#attach ~left:4 ~top:3) () in let layer_sep_adjustment = layer_sep_spinner#adjustment in adjustment_set_pos_int layer_sep_adjustment; layer_sep_adjustment#set_value (float_of_int current_config.layer_sep); layer_sep_label#misc#set_tooltip_text layer_sep_tooltip; layer_sep_spinner#misc#set_tooltip_text layer_sep_tooltip; (**************************************************************************** * * Fonts * ****************************************************************************) let font_frame = GBin.frame ~label:"Fonts" ~border_width:5 ~packing:(append_to_notebook "Fonts") () in let font_frame_table = GPack.table ~border_width:5 ~packing:font_frame#add () in (* tree font *) let tree_font_tooltip = "Font for proof commands in the proof tree display" in let tree_font_label = GMisc.label ~text:"Proof Tree" ~xalign:0.0 ~xpad:5 ~packing:(font_frame_table#attach ~left:0 ~top:0) () in let tree_font_button = GButton.font_button ~title:"Proof Tree Font" ~font_name:current_config.proof_tree_font ~packing:(font_frame_table#attach ~left:1 ~top:0) () in tree_font_button#set_use_size true; tree_font_button#set_use_font true; tree_font_label#misc#set_tooltip_text tree_font_tooltip; tree_font_button#misc#set_tooltip_text tree_font_tooltip; (* sequent font *) let sequent_font_tooltip = "Font for sequent and proof command windows" in let sequent_font_label = GMisc.label ~text:"Sequent window" ~xalign:0.0 ~xpad:5 ~packing:(font_frame_table#attach ~left:0 ~top:1) () in let sequent_font_button = GButton.font_button ~title:"Sequent Window Font" ~font_name:current_config.sequent_font ~packing:(font_frame_table#attach ~left:1 ~top:1) () in sequent_font_button#set_use_size true; sequent_font_button#set_use_font true; sequent_font_label#misc#set_tooltip_text sequent_font_tooltip; sequent_font_button#misc#set_tooltip_text sequent_font_tooltip; (**************************************************************************** * * Colors * ****************************************************************************) let color_frame = GBin.frame ~label:"Colors" ~border_width:5 ~packing:(append_to_notebook "Colors") () in let color_frame_table = GPack.table ~border_width:5 ~packing:color_frame#add () in let _middle_separator = GMisc.label ~text:"" ~xpad:4 ~packing:(color_frame_table#attach ~left:2 ~top:0) () in let _right_separator = GMisc.label ~text:"" ~xpad:2 ~packing:(color_frame_table#attach ~left:5 ~top:0) () in let make_color_conf row column color label_text selection_dialog_title tooltip = let label = GMisc.label ~text:label_text ~xalign:0.0 ~xpad:5 ~packing:(color_frame_table#attach ~left:column ~top:row) () in let button = GButton.color_button ~title:selection_dialog_title ~color:color ~packing:(color_frame_table#attach ~left:(column + 1) ~top:row) () in (* button#set_use_alpha true; *) label#misc#set_tooltip_text tooltip; button#misc#set_tooltip_text tooltip; (label, button) in let row = 0 in let column = 0 in (* current color *) let (current_color_label, current_color_button) = make_color_conf row column !current_gdk_color "Current branch" "Current Branch Color" "Color for the current branch" in let column = column + 3 in (* proved incomplete color *) let (proved_incomplete_color_label, proved_incomplete_color_button) = make_color_conf row column !proved_incomplete_gdk_color "Proved incomplete" "Incompletely Proved Branches Color" "Color for proved branches which still have some non-instantiated \ existential variables" in let row = 1 in let column = 0 in (* cheated color *) let (cheated_color_label, cheated_color_button) = make_color_conf row column !cheated_gdk_color "Cheated" "Cheated Branches Color" "Color for branches terminated with a cheating proof command" in let column = column + 3 in (* existential create color *) let (ext_create_color_label, ext_create_color_button) = make_color_conf row column !existential_create_gdk_color "Create existential" "Create Existential Variable Color" "Color for marking the node that introduces some existential variable" in let row = 2 in let column = 0 in (* * (\* mark subtree color *\) * let (mark_subtree_color_label, mark_subtree_color_button) = * make_color_conf row column !mark_subtree_gdk_color "Mark" * "Mark Subtree Color" * "Color for marking subtrees, e.g., those that contain a certain \ * existential variable" in *) (* proved complete color *) let (proved_complete_color_label, proved_complete_color_button) = make_color_conf row column !proved_complete_gdk_color "Proved complete" "Completely Proved Branches Color" "Color for completely proved branches where all existential \ variables are fully instantiated" in let column = column + 3 in (* existential instantiate color *) let (ext_inst_color_label, ext_inst_color_button) = make_color_conf row column !existential_instantiate_gdk_color "Instantiate existential" "Instantiate Existential Variable Color" "Color for marking the node that instantiates some existential variable" in let row = 3 in let column = 0 in (* proved partial color *) let (proved_partial_color_label, proved_partial_color_button) = make_color_conf row column !proved_partial_gdk_color "Proved partial" "Partially Proved Branches Color" "Color for completely proved branches where all existential \ variables are instantiated but some of them use not-yet \ instantiated existential variables" in (**************************************************************************** * * Misc * ****************************************************************************) let misc_frame = GBin.frame ~label:"Miscellaneous" ~border_width:5 ~packing:(append_to_notebook "Misc") () in let misc_frame_table = GPack.table (* ~columns:2 ~rows:2 *) ~border_width:5 ~packing:misc_frame#add () in (* doc tooltips *) let misc_line = 0 in let doc_tooltip_tooltip = "Switch ordinary help tool tips on and off" in let doc_tooltip_alignment = GBin.alignment ~padding:(0,0,3,0) ~packing:(misc_frame_table#attach ~left:0 ~right:2 ~top:misc_line) () in let doc_tooltip_check_box = GButton.check_button ~label:"Display help tool tips" ~active:current_config.display_doc_tooltips ~packing:doc_tooltip_alignment#add () in doc_tooltip_alignment#misc#set_tooltip_text doc_tooltip_tooltip; (* turnstile tooltips *) let misc_line = 1 in let turnstile_tooltip_tooltip = "Switch sequent display as tool tip over the proof tree on and off" in let turnstile_tooltip_alignment = GBin.alignment ~padding:(0,0,3,0) ~packing:(misc_frame_table#attach ~left:0 ~right:2 ~top:misc_line) () in let turnstile_tooltip_check_box = GButton.check_button ~label:"Display turnstile tool tips" ~active:current_config.display_turnstile_tooltips ~packing:turnstile_tooltip_alignment#add () in turnstile_tooltip_alignment#misc#set_tooltip_text turnstile_tooltip_tooltip; (* command tooltips *) let misc_line = 2 in let command_tooltip_tooltip = "Switch display of truncated commands as tool tip on and off" in let command_tooltip_alignment = GBin.alignment ~padding:(0,0,3,0) ~packing:(misc_frame_table#attach ~left:0 ~right:2 ~top:misc_line) () in let command_tooltip_check_box = GButton.check_button ~label:"Display command tool tips" ~active:current_config.display_command_tooltips ~packing:command_tooltip_alignment#add () in command_tooltip_alignment#misc#set_tooltip_text command_tooltip_tooltip; (* drag accel *) let misc_line = 3 in let drag_accel_tooltip = "Acceleration for dragging the viewport to the proof tree" in let drag_accel_label = GMisc.label ~text:"Drag acceleration" ~xalign:0.0 ~xpad:5 ~packing:(misc_frame_table#attach ~left:0 ~top:misc_line) () in let drag_accel_spinner = GEdit.spin_button ~digits:2 ~numeric:true ~packing:(misc_frame_table#attach ~left:1 ~top:misc_line) () in let drag_accel_adjustment = drag_accel_spinner#adjustment in drag_accel_adjustment#set_bounds ~lower:(-99.0) ~upper:99.0 ~step_incr:0.01 ~page_incr:1.0 (); drag_accel_adjustment#set_value current_config.button_1_drag_acceleration; drag_accel_label#misc#set_tooltip_text drag_accel_tooltip; drag_accel_spinner#misc#set_tooltip_text drag_accel_tooltip; (* default size *) let misc_line = 4 in let default_size_tooltip = "Size for newly created proof tree windows" in let default_size_label = GMisc.label ~text:"Default window size" ~xalign:0.0 ~xpad:5 ~packing:(misc_frame_table#attach ~left:0 ~top:misc_line) () in let default_size_width_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(misc_frame_table#attach ~left:1 ~top:misc_line) () in let default_size_width_adjustment = default_size_width_spinner#adjustment in default_size_width_adjustment#set_bounds ~lower:(-9999.0) ~upper:9999.0 ~step_incr:1.0 ~page_incr:100.0 (); default_size_width_adjustment#set_value (float_of_int current_config.default_width_proof_tree_window); let _x_label = GMisc.label ~text:"\195\151" (* multiplication sign U+00D7 *) ~xpad:5 ~packing:(misc_frame_table#attach ~left:2 ~top:misc_line) () in let default_size_height_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(misc_frame_table#attach ~left:3 ~top:misc_line) () in let default_size_height_adjustment = default_size_height_spinner#adjustment in default_size_height_adjustment#set_bounds ~lower:(-9999.0) ~upper:9999.0 ~step_incr:1.0 ~page_incr:100.0 (); default_size_height_adjustment#set_value (float_of_int current_config.default_height_proof_tree_window); default_size_label#misc#set_tooltip_text default_size_tooltip; default_size_width_spinner#misc#set_tooltip_text default_size_tooltip; default_size_height_spinner#misc#set_tooltip_text default_size_tooltip; (* internal sequent window lines *) let misc_line = 5 in let internal_seq_lines_tooltip = "Initial height (in lines) of the sequent window \ below the proof tree display" in let internal_seq_lines_label = GMisc.label ~text:"Int. Sequent window" ~xalign:0.0 ~xpad:5 ~packing:(misc_frame_table#attach ~left:0 ~top:misc_line) () in let internal_seq_lines_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(misc_frame_table#attach ~left:1 ~top:misc_line) () in let internal_seq_lines_adjustment = internal_seq_lines_spinner#adjustment in adjustment_set_pos_int ~lower:0.0 internal_seq_lines_adjustment; internal_seq_lines_adjustment#set_value (float_of_int current_config.internal_sequent_window_lines); internal_seq_lines_label#misc#set_tooltip_text internal_seq_lines_tooltip; internal_seq_lines_spinner#misc#set_tooltip_text internal_seq_lines_tooltip; (* external node window lines *) let misc_line = 6 in let external_node_lines_tooltip = "Maximal height (in lines) of additional node windows" in let external_node_lines_label = GMisc.label ~text:"Ext. node window" ~xalign:0.0 ~xpad:5 ~packing:(misc_frame_table#attach ~left:0 ~top:misc_line) () in let external_node_lines_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(misc_frame_table#attach ~left:1 ~top:misc_line) () in let external_node_lines_adjustment = external_node_lines_spinner#adjustment in adjustment_set_pos_int external_node_lines_adjustment; external_node_lines_adjustment#set_value (float_of_int current_config.node_window_max_lines); external_node_lines_label#misc#set_tooltip_text external_node_lines_tooltip; external_node_lines_spinner#misc#set_tooltip_text external_node_lines_tooltip; (* existential table lines *) let misc_line = 7 in let ext_table_lines_tooltip = "Default number of lines for the existential variable table" in let ext_table_lines_label = GMisc.label ~text:"Evar table" ~xalign:0.0 ~xpad:5 ~packing:(misc_frame_table#attach ~left:0 ~top:misc_line) () in let ext_table_lines_spinner = GEdit.spin_button ~digits:0 ~numeric:true ~packing:(misc_frame_table#attach ~left:1 ~top:misc_line) () in let ext_table_lines_adjustment = ext_table_lines_spinner#adjustment in adjustment_set_pos_int ext_table_lines_adjustment; ext_table_lines_adjustment#set_value (float_of_int current_config.ext_table_lines); ext_table_lines_label#misc#set_tooltip_text ext_table_lines_tooltip; ext_table_lines_spinner#misc#set_tooltip_text ext_table_lines_tooltip; (* non-configurable config-file *) let misc_line = 8 in let config_file_tooltip = "The configuration file is determined at compilation time" in let config_file_label = GMisc.label ~text:"Configuration file" ~xalign:0.0 ~xpad:5 ~packing:(misc_frame_table#attach ~left:0 ~top:misc_line) () in let config_file_alignment = GBin.alignment ~padding:(0,0,3,0) ~packing:(misc_frame_table#attach ~left:1 ~right:4 ~top:misc_line) () in let _config_file_file = GMisc.label ~text:config_file_location ~xalign:0.0 ~packing:config_file_alignment#add () in config_file_label#misc#set_tooltip_text config_file_tooltip; config_file_alignment#misc#set_tooltip_text config_file_tooltip; (**************************************************************************** * * Debugging Options * ****************************************************************************) let debug_frame = GBin.frame ~label:"Debugging Options" ~border_width:5 ~packing:(append_to_notebook "Debug") () in let debug_frame_table = GPack.table (* ~columns:2 ~rows:2 *) ~border_width:5 ~packing:debug_frame#add () in (* debug *) let debug_tooltip = "Provide more information on fatal error conditions" in let debug_alignment = GBin.alignment ~padding:(0,0,3,0) ~packing:(debug_frame_table#attach ~left:0 ~right:4 ~top:0) () in let debug_check_box = GButton.check_button ~label:"More debug information" ~active:current_config.debug_mode ~packing:debug_alignment#add () in debug_alignment#misc#set_tooltip_text debug_tooltip; (* tee file checkbox*) let tee_file_box_tooltip = "Save all input from Proof General in log file" in let tee_file_box_alignment = GBin.alignment ~padding:(0,0,3,0) ~packing:(debug_frame_table#attach ~left:0 ~right:4 ~top:1) () in let tee_file_box_check_box = GButton.check_button ~label:"Log Proof General input" ~active:current_config.copy_input ~packing:tee_file_box_alignment#add () in tee_file_box_alignment#misc#set_tooltip_text tee_file_box_tooltip; (* tee file filename *) let _tee_file_name_label = GMisc.label ~text:"Log file" ~xalign:0.0 ~xpad:5 ~packing:(debug_frame_table#attach ~left:0 ~top:2) () in let tee_file_name_entry = GEdit.entry ~text:current_config.copy_input_file (* ~max_length:25 *) ~packing:(debug_frame_table#attach ~left:1 ~top:2) () in let _button_separator = GMisc.label ~text:"" ~xpad:5 ~packing:(debug_frame_table#attach ~left:2 ~top:2) () in let tee_file_name_button = GButton.button ~label:"Change log file" ~packing:(debug_frame_table#attach ~left:3 ~top:2) () in (* XXX try again when lablgtk has the file-set signal for * file chooser_button's. Tried last with lablgtk 2.16 for GTK 2.12. * * let file_chooser_button = GFile.chooser_button ~action:`SAVE * ~title:"title" ~packing:(debug_frame_table#attach ~left:3 ~top:3) () in *) (**************************************************************************** * * bottom button box * ****************************************************************************) (* * let _separator = GMisc.separator `HORIZONTAL * ~packing:top_v_box#pack () in *) let button_box = GPack.hbox ~spacing:5 (* ~border_width:5 *) ~packing:top_v_box#pack () in let reset_button = GButton.button (* XXX find stock item *) ~label:"Set defaults" ~packing:button_box#pack () in let cancel_button = GButton.button ~stock:`CANCEL ~packing:button_box#pack () in let ok_button = GButton.button ~stock:`OK ~packing:button_box#pack () in let restore_button = GButton.button ~stock:`REVERT_TO_SAVED ~packing:(button_box#pack ~from:`END) () in let save_button = GButton.button ~stock:`SAVE ~packing:(button_box#pack ~from:`END) () in let config_window = new config_window current_config top_window line_width_adjustment turnstile_size_adjustment line_sep_adjustment proof_tree_sep_adjustment subtree_sep_adjustment command_length_adjustment level_dist_adjustment layer_sep_adjustment tree_font_button sequent_font_button current_color_button cheated_color_button proved_complete_color_button proved_incomplete_color_button proved_partial_color_button (* mark_subtree_color_button *) ext_create_color_button ext_inst_color_button drag_accel_adjustment doc_tooltip_check_box turnstile_tooltip_check_box command_tooltip_check_box default_size_width_adjustment default_size_height_adjustment internal_seq_lines_adjustment external_node_lines_adjustment ext_table_lines_adjustment debug_check_box tee_file_box_check_box tee_file_name_entry [ line_width_label#misc; line_width_spinner#misc; turnstile_size_label#misc; turnstile_size_spinner#misc; line_sep_label#misc; line_sep_spinner#misc; proof_tree_sep_label#misc; proof_tree_sep_spinner#misc; subtree_sep_label#misc; subtree_sep_spinner#misc; command_length_label#misc; command_length_spinner#misc; level_dist_label#misc; level_dist_spinner#misc; layer_sep_label#misc; layer_sep_spinner#misc; tree_font_label#misc; tree_font_button#misc; sequent_font_label#misc; sequent_font_button#misc; current_color_label#misc; current_color_button#misc; cheated_color_label#misc; cheated_color_button#misc; proved_complete_color_label#misc; proved_complete_color_button#misc; proved_incomplete_color_label#misc; proved_incomplete_color_button#misc; proved_partial_color_label#misc; proved_partial_color_button#misc; (* mark_subtree_color_label#misc; mark_subtree_color_button#misc; *) ext_create_color_label#misc; ext_create_color_button#misc; ext_inst_color_label#misc; ext_inst_color_button#misc; doc_tooltip_alignment#misc; turnstile_tooltip_alignment#misc; command_tooltip_alignment#misc; drag_accel_label#misc; drag_accel_spinner#misc; default_size_label#misc; default_size_width_spinner#misc; default_size_height_spinner#misc; internal_seq_lines_label#misc; internal_seq_lines_spinner#misc; external_node_lines_label#misc; external_node_lines_spinner#misc; ext_table_lines_label#misc; ext_table_lines_spinner#misc; config_file_label#misc; config_file_alignment#misc; debug_alignment#misc; tee_file_box_alignment#misc; ] in top_window#set_title "Prooftree Configuration"; config_window#toggle_tooltips current_config.display_doc_tooltips; List.iter (fun adj -> ignore(adj#connect#value_changed ~callback:config_window#config_changed)) [line_width_adjustment; turnstile_size_adjustment; line_sep_adjustment; proof_tree_sep_adjustment; subtree_sep_adjustment; command_length_adjustment; level_dist_adjustment; layer_sep_adjustment; drag_accel_adjustment; default_size_width_adjustment; default_size_height_adjustment; internal_seq_lines_adjustment; external_node_lines_adjustment; ext_table_lines_adjustment; ]; List.iter (fun fb -> ignore (fb#connect#font_set ~callback:config_window#config_changed)) [tree_font_button; sequent_font_button]; List.iter (fun cb -> ignore (cb#connect#color_set ~callback:config_window#config_changed)) [current_color_button; cheated_color_button; proved_complete_color_button; proved_incomplete_color_button; proved_partial_color_button; ext_create_color_button; ext_inst_color_button ]; List.iter (fun cb -> ignore (cb#connect#toggled ~callback:config_window#config_changed)) [doc_tooltip_check_box; turnstile_tooltip_check_box; command_tooltip_check_box; debug_check_box; tee_file_box_check_box ]; ignore(tee_file_name_entry#connect#notify_text ~callback:config_window#log_file_entry_changed); ignore(tee_file_name_button#connect#clicked ~callback:config_window#tee_file_button_click); ignore(top_window#connect#destroy ~callback:config_window#destroy); ignore(reset_button#connect#clicked ~callback:config_window#reset_to_default); ignore(cancel_button#connect#clicked ~callback:config_window#cancel); ignore(ok_button#connect#clicked ~callback:config_window#ok); ignore(save_button#connect#clicked ~callback:config_window#save); ignore(restore_button#connect#clicked ~callback:config_window#restore); top_window#show (); config_window (** Show a configuration dialog. If there is currently none, a new one is created. *) let show_config_window () = match !config_window with | Some w -> w#present | None -> config_window := Some(make_config_window ()) prooftree-0.13/util.ml0000644000175000017500000002165713032677177013527 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: util.ml,v 1.26 2016/01/23 12:57:15 tews Exp $ *) (** Misc utility functions *) (****************************************************************************) (** {2 Exceptions} *) (****************************************************************************) (** Exception to be raised when input logging file cannot be opend. *) exception Log_input_file_error of string (****************************************************************************) (** {2 Option functions} *) (****************************************************************************) (** Return the content of an option type or [assert false] for [None]. *) let access_option = function | Some x -> x | None -> assert false (****************************************************************************) (** {2 Missing from the List module} *) (****************************************************************************) (** Return the last element of a list and [assert false] on the empty list. *) let rec list_last = function | [] -> assert false | [a] -> a | _ :: rest -> list_last rest (** Iterator function for {!list_filter_rev}. *) let rec list_filter_rev_accu p accu = function | [] -> accu | x :: l -> if p x then list_filter_rev_accu p (x :: accu) l else list_filter_rev_accu p accu l (** Like {xref stdlib val List.filter} but reverses the order of the filtered elements. Tail recursive. *) let list_filter_rev p l = list_filter_rev_accu p [] l (** Return the sublist of the first [n] elements. *) let rec firstn n l = if n <= 0 then [] else match l with | [] -> [] | a :: l -> a :: (firstn (n - 1) l) (****************************************************************************) (** {2 Lists as Sets: Simple Set Operations} *) (****************************************************************************) (** [list_set_subset s1 s2] returns true precisely if [s1] is a (non-necessarily strict) subset of [s2]. *) let list_set_subset s1 s2 = List.for_all (fun e -> List.mem e s2) s1 (** Return the set-difference of s1 and s2. That is, return a list with all elements of [s1] that are not in [s2]. In the returned list the elements are reversed with respect to the order of [s1]. *) let list_set_diff_rev s1 s2 = List.fold_left (fun res e -> if List.mem e s2 then res else e :: res) [] s1 (** Return the union of [s1] and [s2] under the assumption that s1 and s2 are disjoint. (So this is an ordinary union, NOT a disjoint union.) *) let list_set_union_disjoint s1 s2 = List.rev_append s1 s2 (** Add element [e] to set [s] under the assumption that [e] is not contained in [s]. Same as [list_set_union_disjoint [e] s]. *) let list_set_add_nonpresent_element e s = e :: s (** Internal tail-recursive worker function for {!list_set_remove_element}. *) let rec list_set_remove_element_rec e res = function | [] -> res | a :: s -> if e = a then List.rev_append res s else list_set_remove_element_rec e (a :: res) s (** [list_set_remove_element e s] removes element [e] from set [s]. Returns [s] without [e] (possibly differently ordered if [e] is not present in [s]. Only the first occurence of [e] is removed, so [s] should better be a proper set. Tail recursive. *) let list_set_remove_element e s = list_set_remove_element_rec e [] s (****************************************************************************) (** {2 Missing from the String module} *) (****************************************************************************) (** [search_char buf start stop c] searches for character [c] in the substring of [buf] starting at [start] and ending before [stop]. Similar to {xref stdlib val String.index_from} but stop searching before [stop] and wrap the result in an [option] instead of raising an exception. *) let rec search_char buf start stop c = if start < stop then if buf.[start] = c then Some start else search_char buf (start + 1) stop c else None (** [replace_char s c1 c2] replace all occurrences of [c1] in [s] with [c2]. *) let replace_char s c1 c2 = let r = Bytes.of_string s in for i = 0 to Bytes.length r - 1 do if Bytes.get r i = c1 then Bytes.set r i c2 done; Bytes.to_string r (** Remove all trailing newlines (['\n']) from the argument. *) let chop_final_newlines s = let i = ref (String.length s) in while !i > 0 && s.[!i - 1] = '\n' do decr i done; String.sub s 0 !i (** Split string [s] at occurrences of [c]. Return the list of (non-zero) strings between sequences of [c]. @param c split character @param s string to split *) let string_split c s = let len = String.length s in let rec iter i res = if i >= len then List.rev res else let j = try String.index_from s i c with Not_found -> len in iter (j + 1) (if i = j then res else (String.sub s i (j - i)) :: res) in iter 0 [] (** [string_starts buf start] returns [true] precisely if [start] is an initial prefix of [buf]. *) let string_starts buf start = let buf_len = String.length buf in let start_len = String.length start in if buf_len >= start_len then String.sub buf 0 start_len = start else false (** [string_ends buf tail] returns [true] if the last characters of [buf] equal [tail]. *) let string_ends buf tail = let buf_len = String.length buf in let tail_len = String.length tail in buf_len >= tail_len && (String.sub buf (buf_len - tail_len) tail_len) = tail (** Count the number of lines in argument [s]. Returns at least 1. A final newline in [s] adds one to the result. *) let number_of_lines s = let lines = ref 1 in for i = 0 to String.length s - 1 do if s.[i] = '\n' then incr lines done; !lines (****************************************************************************) (** {2 Simple logic operation} *) (****************************************************************************) (** Boolean implication. *) let imply b1 b2 = (not b1) || b2 (** Boolean if-and-only-if. *) let iff b1 b2 = (imply b1 b2) && (imply b2 b1) (****************************************************************************) (** {2 Basic UTF-8 support} *) (****************************************************************************) (** [utf8_sequence_length s i] returns the byte-length of character at index [i] in [s]. May raise [Invalid_argument] if there is no valid UTF-8 at this position. *) let utf8_sequence_length s i = if int_of_char(s.[i]) land 0x80 = 0x00 then 1 else if int_of_char(s.[i]) land 0xE0 = 0xC0 then 2 else if int_of_char(s.[i]) land 0xF0 = 0xE0 then 3 else if int_of_char(s.[i]) land 0xF8 = 0xF0 then 4 else if int_of_char(s.[i]) land 0xFC = 0xF8 then 5 else if int_of_char(s.[i]) land 0xFE = 0xFC then 6 else raise (Invalid_argument "invalid UTF-8 sequence start byte") (** Compute the number of characters in an UTF-8 string. May raise [Invalid_argument] if the argument is not valid UTF-8. *) let utf8_string_length s = let rec iter s len i res = if i >= len then res else iter s len (i + utf8_sequence_length s i) (res + 1) in iter s (String.length s) 0 0 (** [utf8_string_sub s len] returns the initial substring of the UTF-8 string [s] with [len] characters. Raises [Invalid_argument "utf8_string_sub"] if [len] is greater than the number of characters in [s]. May raise [Invalid_argument] if the argument is not valid UTF-8. *) let utf8_string_sub s len = let s_len = String.length s in let rec iter i len = if len <= 0 then String.sub s 0 i else if i < s_len then iter (i + utf8_sequence_length s i) (len - 1) else raise (Invalid_argument "utf8_string_sub") in iter 0 len (****************************************************************************) (** {2 Debugging support} *) (****************************************************************************) (** Return the filehandle for debugmessages. Only used during debugging sessions. *) let debugc = let copt = ref None in fun () -> match !copt with | Some c -> c | None -> let c = open_out "/tmp/prooftree-debug" in copt := Some c; c prooftree-0.13/help_window.ml0000644000175000017500000003243013032677177015060 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: help_window.ml,v 1.24 2016/01/23 12:57:14 tews Exp $ *) (** Creation and display of the help window *) (** {2 General remarks} The help text is formatted inside a GText.buffer, which is displayed in a GText.view. The help text needs some basic markup (colors, italic, bold). The markup system for Gdk text buffers is rather heavy weight and there is apparently no simple way to use some basic markup. The help text uses therefore its own rudimentary markup system. The help text itself is a list of pairs, where each pair consists of a style-tag and a string. The string is the help text and the style-tag (of type {!tags_symbols} determines the markup. To create the help text, one iterates over the list, translates the style-tags into appropriate {xref lablgtk class GText.tag}'s and inserts the text. *) open Configuration (** {2 Module contents} *) (** Style-tags for the help text *) type tags_symbols = | Default (** Default, no style *) | Color of Gdk.color (** Foreground color *) | Background of Gdk.color (** Background color *) | Italic (** Set in italic *) | Bold (** Set in bold *) | Heading (** bold and large *) (** The help text *) let help_text = let bold_proof_tree = (Bold, "Prooftree") in let bold_proof_general = (Bold, "Proof General") in (**************************************************************************) (***************************** Colors *************************************) (**************************************************************************) [(Heading, "Colors"); (Default, "\n\nThe meaning of the colors in the proof tree is as follows: "); (Color !proved_complete_gdk_color, "completely proved branches (green by default), "); (Color !proved_incomplete_gdk_color, "proved branches with some not (yet) instantiated existential variables \ (cyan by default), "); (Color !proved_partial_gdk_color, "proved branches with all their own existential variables instantiated \ that nevertheless depend on some not (yet) instantiated existential variable \ (dark green by default), "); (Color !current_gdk_color, "branch to the current goal (blue by default), "); (Default, "currently open branches (default foreground color) and "); (Color !cheated_gdk_color, "branches terminated with a cheating command such as admit"); (Default, ". Colors as well as many "); bold_proof_tree; (Default, " parameters \ can be changed in the configuration dialog.\n\ \n"); (*************************************************************************) (***************************** Navigation ********************************) (*************************************************************************) (Heading, "Navigation"); (Default, "\n\n\ In addition to scroll bars and the usual keys one can move the proof \ tree by dragging with mouse button 1 pressed. By default, dragging \ moves the viewport (i.e., the proof tree underneath moves in the \ opposite direction). After setting a negative value for "); (Italic, "Drag acceleration"); (Default, " in the Configuration dialog, dragging will move \ the proof tree instead (i.e, the proof tree moves in the same \ direction as the mouse).\n\ \n"); (*************************************************************************) (***************************** Sequent window ****************************) (*************************************************************************) (Heading, "The sequent window and additional displays"); (Default, "\n\n\ The sequent display below the proof tree \ normally shows the ancestor sequent of the current \ goal. With a single left mouse click one can display any goal or proof command \ in the sequent display. A single click outside the proof tree will switch \ back to default behavior. The initial size of the sequent display can \ be set in the configuration dialog. A value of 0 hides the sequent display.\n\ \n\ A double click or a shift-click displays any goal or proof command \ in an additional window. These additional windows are automatically updated, \ for instance, if an existential variable is instantiated. For additional \ sequent displays one can browse the instantiation history of the sequent \ using the forward and backward buttons. These additional windows can be "); (Italic, "detached"); (Default, " from the proof tree. A detached \ display is neither automatically updated nor automatically deleted.\n\ \n\ "); (*************************************************************************) (***************************** Tooltips **********************************) (*************************************************************************) (Heading, "Tooltips"); (Default, "\n\n\ If turnstile tool tips are switched on, the complete sequent text is \ displayed as toop tip when the mouse stays above a sequent symbol in the \ proof tree display. Similar for command tool tips and proof commands.\n\ \n\ Long proof commands are truncated with \226\128\166 in the display. The \ length at which truncation happens can be set in the configuration dialog. \ Any truncated proof command is displayed in full length as tool tip if the \ mouse stays long enough above it (and if command tool tips are enabled).\n\ \n"); (*************************************************************************) (***************************** Existentials ******************************) (*************************************************************************) (Heading, "Existential variables"); (Default, "\n\ \n"); bold_proof_tree; (Default, " keeps track of existential variables, whether they \ have been instantiated and whether they depend on some other, \ not (yet) instantiated existential. \ It uses different colors for proved branches that contain non-instantiated \ existential variables and branches that only depend on some not instantiated \ existential. Displays with sequents \ or proof commands (in tool-tips and in additional windows) list those \ existential variables that are currently not (yet) instantiated.\n\ \n\ The menu item "); (Italic, "Existentials"); (Default, " opens the dialog for existential variables, which contains \ a table with all existential variables of the current proof and their \ dependencies. \ For each existential variable, the table contains a "); (Italic, "Mark"); (Default, " button, which marks the proof command that introduced \ this variable "); (Background !existential_create_gdk_color, "(with yellow background, by default)"); (Default, " and, if present, the proof command that instantiated \ this variable "); (Background !existential_instantiate_gdk_color, "(with orange background, by default)"); (Default, " in the proof-tree display.\n\ \n\ With "); (Bold, "Coq"); (Default, " >= 8.5, existential variables are severely broken in "); bold_proof_tree; (Default, " because "); (Bold, "Coq"); (Default, " does not provide the necessary information, see "); (Bold, "Coq"); (Default, " bug 4504.\n\ \n"); (*************************************************************************) (***************************** Menus *************************************) (*************************************************************************) (Heading, "Menus"); (Default, "\n\n\ The menu button opens the main menu. A right click opens the context menu, \ which contains some additional items. \n\ \n\ The item "); (Italic, "Undo to point"); (Default, ", which is only active over a sequent node in the proof \ tree display, sends an appropriate retract command to "); bold_proof_general; (Default, ".\n\ \n\ The items "); (Italic, "Insert command"); (Default, " and "); (Italic, "Insert subtree"); (Default, " cause "); bold_proof_general; (Default, " to insert, respectively, the selected proof command or all \ proof commands of the selected subtree, at point in the selected buffer.\n\ \n\ The "); (Italic, "Clone"); (Default, " menu item clones the current proof tree in a separate \ proof tree window. This cloned proof tree is not connected with "); bold_proof_general; (Default, " and won't be updated when the proof is changed.\n\ \n\ The "); (Italic, "Show current"); (Default, " and "); (Italic, "Show selected"); (Default, " menu items reposition the proof tree such that the \ current proof goal or, respectively, the selected node is visible.\n\ \n\ The item "); (Italic, "Existentials"); (Default, " opens the dialog for existential variables, see above.\n\ \n\ The "); (Italic, "Configuration"); (Default, " item displays the configuration dialog. Changes in this dialog \ immediately take effect. In this dialog, the "); (Italic, "Save"); (Default, " button stores the current configuration values \ in the file "); (Italic, config_file_location); (Default, ", which overwrites the build-in default configuration \ at start up. The "); (Italic, "Cancel"); (Default, " button closes the dialog and resets the configuration to \ the state before starting the configuration dialog.\n\ \n\ The "); (Italic, "Exit"); (Default, " item terminates "); bold_proof_tree; (Default, " and closes all proof windows. (Closing all windows does "); (Italic, "not"); (Default, " terminate "); bold_proof_tree; (Default, ".)\n\ \n"); (*************************************************************************) (***************************** Customization *****************************) (*************************************************************************) (Heading, "Customization"); (Default, "\n\n\ A major part of the proof visualization task is done by "); bold_proof_general; (Default, ". Therefore, certain aspects can only be configured \ inside "); bold_proof_general; (Default, " in the customization groups "); (Italic, "proof-tree"); (Default, " and "); (Italic, "proof-tree-internals. "); (Default, "For instance, "); bold_proof_tree; (Default, " command line arguments or the regular expressions for \ navigation and cheating commands can be configured there. \ To visit a customization group, type "); (Italic, "M-x customize-group"); (Default, " followed by the name of the customization group inside "); bold_proof_general; ] (** Format {!help_text} and insert it into the given buffer. The style-tags are translated into appropriate {xref lablgtk type GText.tag_property}, which are used to create {xref lablgtk class GText.tag}'s, which in turn are used to insert the help text. *) let fill_help_buffer (buffer : GText.buffer) = let heading_tag = buffer#create_tag [`SCALE `LARGE; `FONT "bold"] in let i_tag = buffer#create_tag [`FONT "italic"] in let bold_tag = buffer#create_tag [`FONT "bold"] in let get_tags = function | Default -> [] | Color gdk_color -> [buffer#create_tag [`FOREGROUND_GDK gdk_color]] | Background gdk_color -> [buffer#create_tag [`BACKGROUND_GDK gdk_color]] | Italic -> [i_tag] | Bold -> [bold_tag] | Heading -> [heading_tag] in List.iter (fun (tag_sym, text) -> buffer#insert ~tags:(get_tags tag_sym) text) help_text (** Flag for option [-help]. *) let start_help_dialog = ref false (** Create and display a new help window. This function creates a new {xref lablgtk class GWindow.dialog} that contains the formatted help text inside a {xref lablgtk class GText.view}. *) let show_help_window () = let help_win = GWindow.dialog ~no_separator:true ~title:"Prooftree Help" ~resizable:true () in let close_fun _ = help_win#destroy (); if !start_help_dialog then exit 0 in help_win#add_button_stock `CLOSE `CLOSE; let _help_title = GMisc.label ~markup:"Prooftree Help" ~selectable:true ~xpad:10 ~ypad:10 ~packing:help_win#vbox#pack () in let help_scrolling = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:(help_win#vbox#pack ~expand:true) () in let help_view = GText.view ~border_width:2 ~editable:false ~cursor_visible:false ~wrap_mode:`WORD ~packing:help_scrolling#add () in fill_help_buffer help_view#buffer; ignore(help_win#connect#destroy ~callback:close_fun); ignore(help_win#connect#response ~callback:close_fun); help_win#set_default_size ~width:400 ~height:300; (* help_win#set_default_size ~width:800 ~height:800; *) help_win#show () prooftree-0.13/input.mli0000644000175000017500000000237213032677177014053 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: input.mli,v 1.12 2016/01/23 12:57:14 tews Exp $ *) (** Reading commands from nonblocking stdin *) (* for documentation, see input.ml *) (** Take the necessary actions when the configuration record changed. *) val configuration_updated : unit -> unit (** Initialize this module and setup the GTK main loop callback for [stdin]. Puts [stdin] into non-blocking mode. *) val setup_input : unit -> unit prooftree-0.13/proof_tree.mli0000644000175000017500000001326713032677177015065 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: proof_tree.mli,v 1.18 2016/01/23 12:57:15 tews Exp $ *) (** Internal representation of proof trees with undo info *) (** Process a current-goals command from Proof General, updating the proof-tree display in the right way. If the [layer_flag] is set, new root goals for independent proof trees are added in a new layer to the display. In this case there must be no open goal. If no proof display for [proof_name] is currently in progress, this function assumes that a new proof has just been started. Then a new proof display is created or a previous display is emptied and reused. If [layer_flag] is set, the [current_sequent] and the additional sequents (from [additional_ids]) form all root nodes of independent proof trees. If [layer_flag] is false, the following cases are distinguished, using {!current_proof_tree}: {ol {- The old current branch has been finished (possibly with a cheating command such as [admit]) and the proof assistant has switched to the next open goal. This case applies when the new current goal [current_sequent_id] is in the hash of known sequents and differs from the old current sequent.} {- A proof command has been applied to the current sequent, yielding a new current sequent and possibly some additional subgoals. This case applies when the new current sequent [current_sequent_id] is not in the hash of known sequents. As a special exception, this case does also apply when the new current sequent equals the old current sequent and is therefore found in the hash of known sequents (this happens if the user applied a non-failing command, that didn't change the goal, auch as [auto] in some cases.) } } @param state state for undo @param proof_name name of the proof @param proof_command command issued to the prover @param cheated_flag is true if the command is a cheating one @param layer_flag is true if the command adds a new layer of proof goals @param current_sequent_id ID of current sequent @param current_sequent_text the current sequent itself @param additional_ids ID's of the additionally open goals @param uninstantiated existential variables @param inst_deps instantiated existential variables with dependencies *) val process_current_goals : int -> string -> string -> bool -> bool -> string -> string -> string list -> string list -> (string * string list) list -> unit (** Process an [update-sequent] command. This function is a wrapper around {!update_sequent_element}, which looks up the right sequent object and produces appropriate errors, if something goes wrong. @param state state for undo @param proof_name name of proof @param sequent_id ID of sequent to update @param sequent_text new sequent text *) val update_sequent : int -> string -> string -> string -> unit (** Switch to a different open goal. @param state state for undo @param proof_name name of proof @param new_current_id id of new current goal *) val switch_to : int -> string -> string -> unit (** Finish the current branch. Keep current proof, even if this was the last open branch, in case some existential gets instantiated or some sequent updated. @param state state for undo @param proof_name name of the proof @param proof_command last command @param cheated_flag is true if the command is a cheating one @param uninstantiated existential variables @param inst_deps instantiated existential variables with dependencies *) val process_branch_finished : int -> string -> string -> bool -> string list -> (string * string list) list -> unit (** Display a "Complete" message and retire the current proof. @param state state for undo @param proof_name name of the completed proof *) val process_proof_complete : int -> string -> unit (** Undo all changes to reach state [state]. That is, all changes with a strictly greater state number are undone. Proof trees started later than [state] will be deleted. Those finished earlier than [state] remain untouched. All proof trees will be identical to the point in time before the first action with a state strictly greater than [state] has been processed. *) val undo : int -> unit (** Close the proof window for [proof_name]. @param proof_name name of the proof *) val quit_proof : string -> unit (** For efficiency in proof replay the proof tree display and the sequent area are not redrawn after every change. Changes are only recorded in the internal data structures. This function cases a redisplay of those items. *) val finish_drawing : unit -> unit (** Take the necessary actions when the configuration record changed. Calls the {!Proof_window.proof_window.configuration_updated} method on all live proof windows. *) val configuration_updated : unit -> unit prooftree-0.13/gtk_ext.ml0000644000175000017500000001142413032677177014206 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: gtk_ext.ml,v 1.19 2016/01/23 12:57:14 tews Exp $ *) (** Some misc LablGtk extensions *) (** An extension of {xref lablgtk class GDraw.drawable} with a few convinience methods. *) class better_drawable ?colormap w pc = object inherit GDraw.drawable ?colormap w (** Link a writable Pango context for easy access. *) val pango_context = (pc : GPango.context_rw) (** Return a writable Pango context. *) method pango_context = pango_context (** Return the current foreground color of the graphics context of this drawable. *) method get_foreground = (Gdk.GC.get_values gc).Gdk.GC.foreground (** Return the current background color of the graphics context of this drawable. *) method get_background = (Gdk.GC.get_values gc).Gdk.GC.background end (** Convinience wrapper around {xref lablgtk val GWindow.message_dialog}. [run_message_dialog message message_type] displays a modal message dialog of [message_type] with message [message] and one OK button. The dialog is destroyed when the OK button is pressed. [message_type] must be one of [`INFO], [`WARNING], [`QUESTION] and [`ERROR ]. *) let run_message_dialog message message_type = let warn = GWindow.message_dialog ~message ~message_type ~buttons:GWindow.Buttons.ok () in ignore(warn#run()); warn#destroy() (** Another convenience wrapper around {xref lablgtk val GWindow.message_dialog}. [error_message_dialog message] displays a modal error message dialog (of type [`ERROR]) with message [message] and one OK button. The application is terminated with exit status 1 after the error has been acknowledged. *) let error_message_dialog message = run_message_dialog message `ERROR; exit 1 (** Scroll the given adjustment [direction] number of pages into the direction idicated by the sign of [direction]. This function is used for scrolling with keys. *) let scroll_adjustment (a : GData.adjustment) direction = let new_val = a#value +. float_of_int(direction) *. a#step_increment in let new_val = if new_val < 0.0 then 0.0 else new_val in let max = max 0.0 (a#upper -. a#page_size) in let new_val = if new_val > max then max else new_val in a#set_value new_val (** [inside_adj_range adjustment x] checks if [x] is inside the visible range of the adjustment [adjustment]. *) let inside_adj_range adjustment x = let page_l = adjustment#value in let page_u = page_l +. adjustment#page_size in page_l <= x && x <= page_u (** [range_inside_adj_range adjustment xl xh] checks if the range from [xl] to [xh] is inside the visible range of the adjustment [adjustment]. Does only produce correct results if [xl <= xh]. *) let range_inside_adj_range adjustment xl xh = let page_l = adjustment#value in let page_u = page_l +. adjustment#page_size in page_l <= xl && xh <= page_u (** Round a 16-bit color value to 8 bit. *) let round_color_2_digits co = min ((co + 128) / 256) 0xff (** [pango_markup_color s color] adds Pango markup for using color [color] arouns [s]. *) let pango_markup_color s color = Printf.sprintf "%s" (round_color_2_digits (Gdk.Color.red color)) (round_color_2_digits (Gdk.Color.green color)) (round_color_2_digits (Gdk.Color.blue color)) s (** [pango_markup_bold_color s color] adds Pango markup for using a bold font in color [color] arouns [s]. *) let pango_markup_bold_color s color = Printf.sprintf "%s" (round_color_2_digits (Gdk.Color.red color)) (round_color_2_digits (Gdk.Color.green color)) (round_color_2_digits (Gdk.Color.blue color)) s (* XXX why is this necessary?? *) (** Reallocate a Gdk color. This is necessary because some operations copy only the RGB values of a color, leaving the internal color field uninitialized. *) let realloc_color c = GDraw.color (`RGB((Gdk.Color.red c), (Gdk.Color.green c),(Gdk.Color.blue c))) prooftree-0.13/version.txt0000644000175000017500000000000513032677177014426 0ustar tewstews0.13 prooftree-0.13/prooftree.man.html0000644000175000017500000002766013032677177015665 0ustar tewstews Man page of PROOFTREE

PROOFTREE

Section: User Manuals (1)
Updated: August 2011
Index
 

NAME

prooftree - proof-tree display for Proof General  

SYNOPSIS

prooftree [Options...]  

DESCRIPTION

Prooftree visualizes proof trees during proof development with Proof General. Currently it only works for Coq, though adding support for other proof assistants should be relatively easy.

To start a proof-tree display, hit the Prooftree icon in the Proof General tool-bar or select the menu entry Proof-General -> Start/Stop Prooftree or type C-c C-d (which runs proof-tree-external-display-toggle). Inside a proof, this will immediately start a proof-tree display for the current proof. Outside a proof, Proof General remembers to start the proof-tree display for the next proof.

Under normal circumstances Prooftree is started by Proof General as an Emacs subprocess. The user interacts with Prooftree only through the graphical user interface. A substantial part of the proof-tree visualization task is done by Proof General. Therefore not only the Prooftree command line arguments but also other aspects can only be configured inside Proof General, see Proof General Customization below.  

OPTIONS

-help
Print synopsis and exit.
-config
Open the configuration dialog on startup (if you want to change the configuration without starting Proof General).
-geometry spec
Sets the X geometry of the main window. spec is a standard X geometry string in the form xposxypos[+xoff[+yoff]].
-tee file
Write all input to file (usually for debugging purposes).
-debug
Provide more details on errors.
-help-dialog
Open the help dialog on startup. Mainly useful for proofreading the help text.
 

MAIN PROOF DISPLAY

Prooftree opens one window for each proof that it is requested to display. This window contains the proof-tree graph and a small display for sequents and proof commands.  

Colors

The branches in the proof-tree graph are colored according to their state. Prooftree distinguishes between the following states.
current (blue by default)
The current branch is the branch from the root of the proof tree to the current goal.
unproven (default foreground color)
A branch is unproven if it contains open proof goals.
proved incomplete (cyan by default)
An incompletely proved branch has its proof finished, but some of the existential variables that have been introduced in this branch are not (yet) instantiated.
proved partially (dark green by default)
In a partially proved branch all existential variables of the branch itself are instantiated, but some of those instantiations contain existential variables that are not (yet) instantiated.
proved complete (green by default)
A branch is proved complete if all its existential variables are instantiated with terms that themselves do not contain any existential variables.
cheated (red by default)
A cheated branch contains a cheating proof command, such as admit

The colors as well as many other Prooftree parameters can be changed in the Prooftree Configuration Dialog (see below).  

Navigation

When the proof tree grows large one can navigate by a variety of means. In addition to scroll bars and the usual keys one can move the proof tree by dragging with mouse button 1 pressed. By default, dragging moves the viewport (i.e., the proof tree underneath moves in the opposite direction). After setting a negative value for Drag acceleration in the Prooftree Configuration Dialog, dragging will move the proof tree instead (i.e, the proof tree moves in the same direction as the mouse).  

Sequent Display

The sequent display below the proof tree normally shows the ancestor sequent of the current goal. With a single left mouse click one can display any goal or proof command in the sequent display. A single click outside the proof tree will switch back to default behavior. The initial size of the sequent display can be set in the Prooftree Configuration Dialog. A value of 0 hides the sequent display.  

Tool Tips

Abbreviated proof commands and sequents are shown in full as tool tips when the mouse pointer rests over them. Both, the tool tips for abbreviated proof commands and for sequents can be independently switched off in the Prooftree Configuration Dialog. The length at which proof commands are abbreviated can be configured as well.  

Additional Displays

A double click or a shift-click displays any goal or proof command in an additional window. These additional windows are automatically updated, for instance, if an existential variable is instantiated. For additional sequent displays one can browse the instantiation history of the sequent using the forward and backward buttons. These additional windows can be detached from the proof tree. A detached display is neither automatically updated nor automatically deleted.  

Existential Variables

Prooftree keeps track of existential variables, whether they have been instantiated and whether they depend on some other, not (yet) instantiated existential. It uses different colors for proved branches that contain non-instantiated existential variables and branches that only depend on some not instantiated existential. The list of currently not (yet) instantiated existential variables is appended to proof commands and sequents in tool-tips and the other displays.

The Existential Variable Dialog displays a table with all existential variables of the current proof and their dependencies. Each line of the table contains a button that marks the proof command that introduced this variable (with yellow background, by default) and, if present, the proof command that instantiated this variable (with orange background, by default).  

Main Menu

The Menu button displays the main menu. The Clone item clones the current proof tree in an additional window. This additional window continues to display a snapshot of the cloned proof tree, no matter what happens with the original proof.

The Show current and Show selected items move the viewport of the proof tree such that the current proof goal, or, respectively, the selected node will be visible (if they exist).

The Exit item terminates Prooftree and closes all proof-tree displays.

The remaining three items display, respectively, the Prooftree Configuration Dialog, and the Help and About windows.  

Context Menu

A right click displays the Context Menu, which contains additional items.

The item Undo to point is active over sequent nodes in the proof tree. There, it sends an retract or undo request to Proof General that retracts the scripting buffer up to that sequent.

The items Insert command and Insert subproof are active over proof commands. They sent, respectively, the selected proof command or all proof commands in the selected subtree, to Proof General, which inserts them at point.  

CONFIGURATION

 

Prooftree Configuration Dialog

The Save button stores the current configuration (as marshaled OCaml record) in ~/.prooftree, which will overwrite the built-in default configuration for the following Prooftree runs. The Revert button loads and applies the saved configuration. The Cancel and OK buttons close the dialog, but Cancel additionally resets the configuration to the state before the start of the dialog. To avoid opening partial file names, the Log Proof General input check box is deactivated when typing the log file name.  

Proof General Customization

The location of the Prooftree executable and the command line arguments are in the customization group proof-tree. Prover specific points, such as the regular expressions for navigation and cheating commands are in the customization group proof-tree-internals. To visit a customization group, type M-x customize-group followed by the name of the customization group inside Proof General.  

LIMITATIONS

For Coq >= 8.5, existential variables in Prooftree are severely broken because Coq does not provide the necessary information, see Coq bug 4504.

In Coq, proofs must be started with command Proof, which is the recommended practice anyway (see Coq problem report 2776).

In additional sequent displays, the information about existential variables is only shown for the latest version of the sequent and not for older versions in the instantiation history. The current communication protocol between Proof General and Prooftree does not permit more.  

PREREQUISITES

This version of Prooftree requires Coq 8.4beta or better and Proof General 4.3pre130327 or better.  

FILES

~/.prooftree
Saved Prooftree configuration. Is loaded at application start-up for overwriting the built-in default configuration. Must contain a marshaled OCaml configuration record.
 

SEE ALSO

The Prooftree web page, http://askra.de/software/prooftree/

The Proof General Adapting Manual
contains information about adapting Prooftree for a new proof assistant (see http://proofgeneral.inf.ed.ac.uk/adaptingman-latest.html).
 

CREDITS

Prooftree has been inspired by the proof tree display of PVS.  

AUTHOR

Hendrik Tews <prooftree at askra.de>

 

Index

NAME
SYNOPSIS
DESCRIPTION
OPTIONS
MAIN PROOF DISPLAY
Colors
Navigation
Sequent Display
Tool Tips
Additional Displays
Existential Variables
Main Menu
Context Menu
CONFIGURATION
Prooftree Configuration Dialog
Proof General Customization
LIMITATIONS
PREREQUISITES
FILES
SEE ALSO
CREDITS
AUTHOR
This document was created by man2html, using the manual pages.
Time: 10:35:43 GMT, January 03, 2017 prooftree-0.13/tree_layers.ml0000644000175000017500000003644013032677177015064 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2013 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: tree_layers.ml,v 1.6 2016/01/23 12:57:15 tews Exp $ *) (** Organize several layers of proof trees *) open Util open Configuration open Draw_tree open Ext_dialog (** Container for several independent proof trees in one horizontal layer. *) class tree_layer tree_list = object (self) (***************************************************************************) (***************************************************************************) (** {2 State and accessors} *) (***************************************************************************) (***************************************************************************) (** The list of proof trees in this horizontal layer. *) val tree_list = (tree_list : proof_tree_element list) (** The width of this layer. Lazily computed in {!update_size_info}. *) val mutable width = None (** The height of this layer. Lazily computed in {!update_size_info}. *) val mutable height = None (** Upward pointer to the {!tree_layer_stack} that contains this layer. Needed position information. Must be set after initialization. *) val mutable layer_stack = (None : tree_layer abstract_tree_container option) (** Register the {!tree_layer_stack} that contains this layer. *) method register_layer_stack ls = assert (layer_stack = None); layer_stack <- Some ls (********** inside tree_layer class *) (** The initializer ensures all proof trees have their upward pointer set. *) initializer assert (tree_list <> []); List.iter (fun r -> r#register_tree_layer (self :> proof_tree_element abstract_tree_container)) tree_list (***************************************************************************) (***************************************************************************) (** {2 Size and position} *) (***************************************************************************) (***************************************************************************) (** Recompute {!attribute: width} and {!attribute: height} *) method private update_size_info = let w = match tree_list with | [] -> assert false | [r] -> r#subtree_width | first :: rest -> List.fold_left (fun width r -> width + !current_config.proof_tree_sep + r#subtree_width) first#subtree_width rest in let h = List.fold_left (fun height r -> max height r#subtree_height) 0 tree_list in width <- Some w; height <- Some h (********** inside tree_layer class *) (** Compute the left and top offset of this layer relative to the upper-left corner of the complete display. *) method left_top_offset = match layer_stack with | None -> assert false | Some ls -> let (ls_left, ls_top) = ls#left_top_offset in let (me_left, me_top) = ls#child_offsets (self :> tree_layer) in (ls_left + me_left, ls_top + me_top) (** Compute the x and y offset of one child relative to the upper left corner of this layer. *) method child_offsets root = let root_left = ref None in (try ignore( List.fold_left (fun left oroot -> if root = oroot then begin root_left := Some left; raise Exit end else left + !current_config.proof_tree_sep + oroot#subtree_width) 0 tree_list) with Exit -> () ); match !root_left with | None -> assert false | Some left -> (left, 0) (********** inside tree_layer class *) (** Width of this layer. Recompute if necessary. *) method width = if width = None then self#update_size_info; match width with | Some w -> w | None -> assert false (** Height of this layer. Recompute if necessary. *) method height = if height = None then self#update_size_info; match height with | Some h -> h | None -> assert false (** Clear the cached size information for this layer. *) method private clear_self_size_cache = width <- None; height <- None (** Invalidate the size information here and in those objects containing this layer. *) method clear_size_cache = self#clear_self_size_cache; match layer_stack with | None -> assert false | Some sco -> sco#clear_size_cache (********** inside tree_layer class *) (** Draw the content of this layer relative to the specified left and top coordinate. *) method draw left top = ignore( List.fold_left (fun left r -> r#draw_tree_root left top; left + !current_config.proof_tree_sep + r#subtree_width) left tree_list) (** Find the proof tree node at coordinates [(bx, by)] or return [None]. *) method find_node_for_point_in_layer left top bx by = let rec iter left = function | [] -> None | r :: rest -> if left <= bx && bx <= left + r#subtree_width then r#find_node_for_point_root left top bx by else let left = left + !current_config.proof_tree_sep + r#subtree_width in if left <= bx then iter left rest else None in iter left tree_list (********** inside tree_layer class *) (***************************************************************************) (***************************************************************************) (** {2 Misc} *) (***************************************************************************) (***************************************************************************) (** Give a hint if the proof-tree window containing this layer should survive an undo before the start of the proof. *) method survive_undo_before_start_hint = match tree_list with | [] -> assert false | first :: _ -> first#children <> [] (** Return the first proof goal. Needed for selecting the initial goal after proof completion. *) method get_first_root = match tree_list with | [] -> assert false | first :: _ -> Some first (** Disconnect this layer from Proof General. *) method disconnect = List.iter (fun root -> root#disconnect_proof) tree_list (** Process an updated configuration. *) method configuration_updated = self#clear_self_size_cache; List.iter (fun root -> root#configuration_updated) tree_list (********** inside tree_layer class *) (** Update the information about existential variables in sequent displays belonging to nodes of this layer. *) method update_sequent_existentials_info = List.iter (fun root -> root#update_existentials_info) tree_list (** Find a node satisfying the predicate or return [None]. *) method find_node p = let res = ref None in let rec iter node = if p node then begin res := Some node; raise Exit end else List.iter iter node#children in (try List.iter iter tree_list with Exit -> () ); !res (********** inside tree_layer class *) (** Initialize the given existential variable dialog with all existentials occurring in nodes of this layer. *) method init_ext_dialog (ext : existential_variable_window) = ext#fill_table_lines tree_list (** Clone this layer. *) method clone_layer new_pc new_seq ex_hash old_selected cloned_selected = let cloned_trees = List.map (clone_proof_tree new_pc new_seq ex_hash old_selected cloned_selected) tree_list in new tree_layer cloned_trees end (** Container for several layers of proof trees. *) class tree_layer_stack = object (self) (***************************************************************************) (***************************************************************************) (** {2 State and accessors} *) (***************************************************************************) (***************************************************************************) (** The layers in this stack. *) val mutable layers = ([] : tree_layer list) (** The width of this layer. Lazily computed in {!update_size_info}. *) val mutable width = None (** The height of this layer. Lazily computed in {!update_size_info}. *) val mutable height = None (** Add a new layer at the bottom. Return a suitable [n], such that {!del_layer}[ n] will delete this added layer. *) method add_layer l = layers <- layers @ [l]; l#register_layer_stack (self :> tree_layer abstract_tree_container); self#clear_size_cache; List.length layers - 1 (** Keep only the first [n] layers, deleting the following ones. *) method del_layer n = layers <- firstn n layers (********** inside tree_layer_stack class *) (** Prepare this layer stack for reuse. *) method clear_for_reuse = layers <- [] (** Set the layers for this stack. *) method set_layers ls = layers <- ls; List.iter (fun l -> l#register_layer_stack (self :> tree_layer abstract_tree_container)) ls; self#clear_size_cache (** Return the number of layers. *) method count_layers = List.length layers (***************************************************************************) (***************************************************************************) (** {2 Size and position} *) (***************************************************************************) (***************************************************************************) (** Recompute {!attribute: width} and {!attribute: height} *) method private update_size_info = let w = List.fold_left (fun width l -> max width l#width) 0 layers in let h = match layers with | [] -> 0 | [l] -> l#height | first :: rest -> List.fold_left (fun height l -> height + !current_config.layer_sep + l#height) first#height rest in width <- Some w; height <- Some h (********** inside tree_layer_stack class *) (** Compute the left and top offset of this layer relative to the upper-left corner of the complete display, which is trivial. *) method left_top_offset = (0, 0) (** Compute the indentation of the given layer. *) method private layer_indent l = (self#width - l#width) / 2 (** Compute the x and y offset of one child relative to the upper left corner of this layer *) method child_offsets layer = let layer_top = ref None in (try ignore( List.fold_left (fun top olayer -> if layer = olayer then begin layer_top := Some (self#layer_indent layer, top); raise Exit end else top + !current_config.layer_sep + olayer#height) 0 layers) with Exit -> () ); match !layer_top with | None -> assert false | Some (left, top) -> (left, top) (** Invalidate the size information. *) method clear_size_cache = width <- None; height <- None (********** inside tree_layer_stack class *) (** Width of this layer. Recompute if necessary. *) method width = if width = None then self#update_size_info; match width with | Some w -> w | None -> assert false (** Height of this layer. Recompute if necessary. *) method height = if height = None then self#update_size_info; match height with | Some h -> h | None -> assert false (** Draw the content of this stack of layers relative to the specified left and top coordinate. *) method draw left top = ignore( List.fold_left (fun top l -> l#draw (left + self#layer_indent l) top; top + !current_config.layer_sep + l#height) top layers) (********** inside tree_layer_stack class *) (** Find the proof tree node at coordinates [(bx, by)] or return [None]. *) method find_node_for_point_in_layer_stack left top bx by = let rec iter top = function | [] -> None | l :: rest -> let left = left + (self#layer_indent l) in if top <= by && by <= top + l#height && left <= bx && bx <= left + l#width then l#find_node_for_point_in_layer left top bx by else let top = top + !current_config.layer_sep + l#height in if top <= by then iter top rest else None in iter top layers (***************************************************************************) (***************************************************************************) (** {2 Misc} *) (***************************************************************************) (***************************************************************************) (** Get the root node of the first layer. Needed for selecting the initial goal after proof completion. *) method get_root_node = match layers with | [] -> None | first :: _ -> first#get_first_root (********** inside tree_layer_stack class *) (** Give a hint if the proof-tree window with this stack should survive an undo before the start of the proof. *) method survive_undo_before_start_hint = match layers with | [] -> false | first :: _ -> first#survive_undo_before_start_hint (** Disconnect from Proof General. *) method disconnect = List.iter (fun l -> l#disconnect) layers (** Process an updated configuration. *) method configuration_updated = self#clear_size_cache; List.iter (fun l -> l#configuration_updated) layers (** Update the information about existential variables in sequent displays belonging to nodes of this stack of layers. *) method update_sequent_existentials_info = List.iter (fun l -> l#update_sequent_existentials_info) layers (** Find a node satisfying the predicate or return [None]. *) method find_node p = let res = ref None in (try List.iter (fun l -> match l#find_node p with | None -> () | Some n -> res := Some n; raise Exit ) layers with Exit -> () ); !res (********** inside tree_layer_stack class *) (** Initialize the given existential variable dialog with all existentials occurring in nodes of this layer. *) method init_ext_dialog ext = List.iter (fun l -> l#init_ext_dialog ext) layers (** Clone this stack of layers. *) method clone_layers new_pc new_seq old_selected cloned_selected = let ex_hash = Hashtbl.create 251 in List.map (fun l -> l#clone_layer new_pc new_seq ex_hash old_selected cloned_selected) layers end prooftree-0.13/coq.ml0000644000175000017500000001207413032677177013325 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: coq.ml,v 1.5 2016/01/23 12:57:13 tews Exp $ *) (** Coq specific code *) open Gtk_ext (***************************************************************************** *****************************************************************************) (** {3 Coq existential info parser} *) (***************************************************************************** *****************************************************************************) (* (dependent evars:) * (dependent evars: ?35 open, ?36 using ?42 ?41 , ?42 open,) * (dependent evars: ?35 open, ?36 using ?42 ?41 , ?42 using ,) *) (** This function parses one evar uid without the question mark. *) let coq_parse_evar_without_question scan_buf = Scanf.bscanf scan_buf " %[A-Za-z0-9] " (fun evar -> evar) (** This function parses the dependency list that follows ``using'', looking like [ ?42 ?41 ,] [ ,] When the final comma is encountered the now completely parsed evar group is appended to the accumulated results and {!coq_parse_next_evar_info} is called as continuation. *) let rec coq_parse_evar_dependency scan_buf uninst inst evar deps = Scanf.bscanf scan_buf " %c " (function | ',' -> coq_parse_next_evar_info scan_buf uninst ((evar, List.rev deps) :: inst) () | '?' -> let dep = coq_parse_evar_without_question scan_buf in coq_parse_evar_dependency scan_buf uninst inst evar (dep :: deps) | c -> raise (Scanf.Scan_failure (Printf.sprintf ("expected an evar (starting with '?') or ',' " ^^ "for the end of the dependency list; but found '%c'") c)) ) (** This function parses one evar group, looking like [?35 open,] [?36 using ?42 ?41 ,] [?42 using ,] When finished {!coq_parse_next_evar_info} is invoked on the updated accumulated results. *) and coq_parse_one_evar_info scan_buf uninst inst = let evar = coq_parse_evar_without_question scan_buf in Scanf.bscanf scan_buf " %[^, ]" (function | "open" -> Scanf.bscanf scan_buf ", " (coq_parse_next_evar_info scan_buf (evar :: uninst) inst) () | "using" -> coq_parse_evar_dependency scan_buf uninst inst evar [] | x -> raise (Scanf.Scan_failure (Printf.sprintf "expected \"open\" or \"using\" but found \"%s\"" x)) ) (** This function decides whether to continue parsing with reading the next evar group or whether the end of evar information has been reached. In the latter case the accumulated results are returned. *) and coq_parse_next_evar_info scan_buf uninst inst () = Scanf.bscanf scan_buf "%c" (function | '?' -> coq_parse_one_evar_info scan_buf uninst inst | ')' -> (List.rev uninst, List.rev inst) | c -> raise (Scanf.Scan_failure (Printf.sprintf ("expected an evar (starting with '?') or " ^^ "the end of the evar info (a ')'); but found '%c'") c)) ) (** Parse the information display for existential variables of Coq. This information can look like one of the folling lines: [(dependent evars:)] [(dependent evars: ?35 open, ?36 using ?42 ?41 , ?42 open,) ] [(dependent evars: ?35 open, ?36 using ?42 ?41 , ?42 using ,)] This function returns a tuple, where the first element is the list of open, uninstantiated existential variables. The second element is a list of pairs, where each pair contains an instantiated existential variable and the list of variables that are used in its instantiation. If parsing dies with an exception, a suitable error dialog is displayed. *) let coq_parse_existential_info ex_string = let scan_buf = Scanf.Scanning.from_string ex_string in try Scanf.bscanf scan_buf "(dependent evars: " (coq_parse_next_evar_info scan_buf [] []) () with | Scanf.Scan_failure msg -> error_message_dialog (Printf.sprintf ("Coq existential variable info parsing error!\n" ^^ "The parser died on the input\n %s\n" ^^ "with an exception Scan_failure with message\n%s") ex_string msg) | End_of_file -> error_message_dialog (Printf.sprintf ("Coq existential variable info parsing error!\n" ^^ "The parser died on the input\n %s\n" ^^ "with an End_of_file exception.") ex_string) | _ -> assert false prooftree-0.13/COPYING0000644000175000017500000010451313032677177013244 0ustar tewstews GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program 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 3 of the License, or (at your option) any later version. This program 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 this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . prooftree-0.13/test/0000755000175000017500000000000013032677177013164 5ustar tewstewsprooftree-0.13/test/cycle.v0000644000175000017500000000041313032677177014450 0ustar tewstews Lemma a : forall(P1 P2 P3 P4 : Prop), P1 -> P2 -> P3 -> P4 -> P1 /\ P2 /\ P3 /\ P4. Proof. intros P1 P2 P3 P4 H H0 H1 H2. repeat split. all : swap 1 2. all : cycle 2. all : revgoals. auto. auto. auto. auto. Qed. prooftree-0.13/test/giveup.v0000644000175000017500000000016613032677177014655 0ustar tewstews Lemma a : forall(P Q : Prop), P -> Q -> P /\ Q. Proof. intros P Q H H0. split. give_up. eexact H0. Qed. prooftree-0.13/test/evar_2.v0000644000175000017500000000031513032677177014530 0ustar tewstews Lemma a : exists(n : nat), n = n. Proof. eexists. reflexivity. Grab Existential Variables. eexact 2. Qed. Lemma b : exists(n : nat), n = n. Proof. eexists. reflexivity. Unshelve. eexact 2. Qed. prooftree-0.13/proof_window.ml0000644000175000017500000015162113032677177015261 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: proof_window.ml,v 1.67 2016/01/23 12:57:15 tews Exp $ *) (** Creation, display and drawing of the main proof-tree window *) (* open Util *) open Gtk_ext open Configuration open Emacs_commands open Draw_tree open Tree_layers open Node_window open Help_window open About_window open Ext_dialog (** Callback for higher-level modules when the user deletes a proof window. During start-up the reference is changed to {!Proof_tree.quit_proof}. *) let delete_proof_tree_callback = ref (fun (_ : string) -> ()) (** Contains proof window clones. See also [Proof_tree.original_proof_trees]. *) let cloned_proof_windows = ref [] (** Class for managing the main proof-tree window. Contains methods for all callbacks and the necessary state. The widget tree the binding to singals must be done outside. Arguments are - top_window {xref lablgtk class GWindow.window} of the top-level widget - drawing_h_adjustment {xref lablgtk class GData.adjustment} of the horizontal scroll bar of the drawing area - drawing_v_adjustment {xref lablgtk class GData.adjustment} of the vertical scroll bar of the drawing area - drawing_area {xref lablgtk class GMisc.drawing_area} for the proof tree - drawable {!Gtk_ext.better_drawable} for the actual drawing operations - labeled_sequent_frame {xref lablgtk class GBin.frame} labelled frame of the sequent area - sequent_window {xref lablgtk class GText.view} of the sequent area - sequent_v_adjustment {xref lablgtk class GData.adjustment} of the vertical scroll bar of the sequent area - message_label {xref lablgtk class GMisc.label} for messages in the bottom line - context_menu {xref lablgtk class GMenu.menu} of the context menu - proof_name the name of the proof this display is showing *) class proof_window (top_window : GWindow.window) drawing_h_adjustment drawing_v_adjustment (drawing_area : GMisc.drawing_area) (drawable : better_drawable) labeled_sequent_frame sequent_window sequent_v_adjustment (message_label : GMisc.label) context_menu proof_name = object (self) (*************************************************************************** * * Internal state and setters/accessors * ***************************************************************************) (** x-offset of the bounding box of the complete proof tree layer stack. This is only non-zero when the width of the complete layer stack is smaller than the width of the drawing area. *) val mutable top_left = 0 (** y-offset of the bounding box of the top layer. Constantly 0. *) val top_top = 0 (** [true] if the sequent area should always show the last line. This is set to [true] when a sequent is shown and to false when a proof command is shown. *) val mutable sequent_window_scroll_to_bottom = false (** The stack of layers of proof trees *) val layer_stack = new tree_layer_stack (** The current node of the proof tree, if there is one *) val mutable current_node = None (** Cache holding the relative bounding box of the current node. If not [None], it holds the tuple [(x_low, x_high, y_low, y_high)] relative to the top-left corner (i.e., ({!top_left}, {!top_top})) of the bounding box of the complete proof tree. *) val mutable current_node_offset_cache = None (** Set to [true] when we still have to reposition the drawing area to make the current node visible. This is needed because of the asynchronous nature of GTK, which does not immediately resize the drawing area when I request it. Therefore the positioning code has to wait until the drawing area has changed its size and all needed scrollbars have been added. *) val mutable position_to_current_node = true (** List of position hints, containing lists of proof tree nodes. If possible, the current node will positioned such that some hint nodes are also visible. If the list is longer than one, hints are tried one after each other. *) val mutable position_hints = [] (** Holds the selected node, if there is one. *) val mutable selected_node = None (** List of all external non-orphaned node windows that belong to nodes in the current proof tree. This list is stored only for optimization. *) val mutable node_windows = [] (** The management object for the dialog for existential variables, if present. *) val mutable existential_window = None (** When we are asked to destroy this proof-tree window (because of an undo or because Proof General sent a quit-proof command) then the destruction of the top-level GTK window will emit a destroy signal that we interpret as a user destroy button click. Further, the deletion of this proof from the various list with proof_tree structures, might cause a second call of the {!delete_proof_window} method. This flag is used to avoid this double or triple killing. *) val mutable destroy_in_progress = false (** True when this is a clone. *) val mutable is_clone = false (** A proof is disconnected if it is not the current proof that is currently updated by Proof General. Used for the context menu. *) val mutable disconnected = false (** The stack of layers, containing all proof trees belonging to this proof. *) method layer_stack = layer_stack (** Return the selected node or [None] if there is none. *) method get_selected_node = selected_node (** Delete the external node window from {!node_windows}. *) method delete_node_window win = node_windows <- List.filter (fun owin -> owin <> win) node_windows (** Setter for {!is_clone}. *) method set_clone_flag = is_clone <- true (** Setter for {!position_hints}. *) method set_position_hints hints = position_hints <- (hints : proof_tree_element list list) (** Clear {!position_hints}. *) method clear_position_hints = position_hints <- [] (*************************************************************************** * * Messages * ***************************************************************************) (** Display text in the message label. *) method message text = message_label#set_label text (*************************************************************************** * * Sequent window * ***************************************************************************) (** Make the last line visible in the sequent area, if {!sequent_window_scroll_to_bottom} is [true]. This is the callback for the changed signal of the vertical adjustment of the scrollbar of the sequent area (emitted when the sequent area changes its size but not when the scrollbar is moved). *) method sequent_area_changed () = if sequent_window_scroll_to_bottom then let a = sequent_v_adjustment in a#set_value (max a#lower (a#upper -. a#page_size)) (** [update_sequent_area label content scroll_to_bottom] updates the sequent area to show [content] with label [label] on the frame. It further sets {!sequent_window_scroll_to_bottom} to [scroll_to_bottom]. *) method private update_sequent_area label content scroll_to_bottom = labeled_sequent_frame#set_label (Some label); sequent_window#buffer#set_text content; sequent_window_scroll_to_bottom <- scroll_to_bottom (** Clear the sequent area. *) method private clear_sequent_area = self#update_sequent_area "no sequent" "" false (** Refresh the sequent area. If there is a selected node, show it. Otherwise, if there is a current sequent node that has a parent sequent, then show the parent sequent. Otherwise clear the sequent area. *) method refresh_sequent_area = match selected_node with | Some node -> let (frame_text, scroll_to_bottom) = match node#node_kind with | Turnstile -> ("Selected sequent", true) | Proof_command -> ("Selected command", false) in self#update_sequent_area frame_text node#displayed_text scroll_to_bottom | None -> match current_node with | None -> self#clear_sequent_area | Some node -> if node#node_kind = Turnstile then match node#parent with | None -> self#clear_sequent_area | Some p -> match p#parent with | None -> self#clear_sequent_area | Some p -> self#update_sequent_area "Previous sequent" p#displayed_text true else self#clear_sequent_area (*************************************************************************** * * Current node * ***************************************************************************) (** Set the current node. *) method set_current_node n = current_node_offset_cache <- None; current_node <- Some (n : proof_tree_element) (** Clear the current node. *) method clear_current_node = current_node_offset_cache <- None; current_node <- None; (*************************************************************************** * * Unclassified methods * ***************************************************************************) (** Tell whether this proof-tree window should stay alive when the user retracted to a point before the start of the proof. If the window shows more than just the root sequent, it will stay alive. *) method survive_undo_before_start = layer_stack#survive_undo_before_start_hint (** Disconnect the proof tree. Clears all current node and current branch indications. *) method disconnect_proof = disconnected <- true; layer_stack#disconnect (** Reflect changes in the current configuration. *) method configuration_updated = sequent_window#misc#modify_font !sequent_font_desc; drawable#set_line_attributes ~width:(!current_config.turnstile_line_width) (); layer_stack#configuration_updated; self#expand_drawing_area; ignore(self#position_tree); GtkBase.Widget.queue_draw top_window#as_widget; self#configuration_updated_ext_dialog (** Clear this window and the existential variable dialog, if there is one, for reuse when the proof it displays is started again. Deletes and destroys all non-sticky external node windows. *) method clear_for_reuse = disconnected <- false; layer_stack#clear_for_reuse; current_node <- None; current_node_offset_cache <- None; selected_node <- None; self#refresh_sequent_area; List.iter (fun w -> w#delete_attached_node_window) node_windows; assert(node_windows = []); self#clear_existential_dialog_for_reuse (** Update the existentials info in external sequent displays. *) method update_sequent_existentials_info = layer_stack#update_sequent_existentials_info (** Find the first node in the proof tree satisfying the predicate using depth-first search. *) method find_node p = layer_stack#find_node p (*************************************************************************** * * Position to nodes and points * ***************************************************************************) (** Make node visible. *) method private clamp_to_node node = let (x_l, x_u, y_l, y_u) = node#bounding_box top_left top_top in drawing_h_adjustment#clamp_page ~lower:x_l ~upper:x_u; drawing_v_adjustment#clamp_page ~lower:y_l ~upper:y_u (** Move the drawing area to show point [(x,y)] as centre point. *) method private centre_point x y = let x_size = drawing_h_adjustment#page_size in let adj_x_l = drawing_h_adjustment#lower in let adj_x_u = drawing_h_adjustment#upper in let x = x -. x_size /. 2.0 in let x = if x +. x_size > adj_x_u then adj_x_u -. x_size else x in drawing_h_adjustment#set_value (max adj_x_l x); let y_size = drawing_v_adjustment#page_size in let adj_y_l = drawing_v_adjustment#lower in let adj_y_u = drawing_v_adjustment#upper in let y = y -. y_size /. 2.0 in let y = if y +. y_size > adj_y_u then adj_y_u -. y_size else y in drawing_v_adjustment#set_value (max adj_y_l y) (** Show the given node in the centre of the drawing area. *) method private centre_node node = let (x_l, x_u, y_l, y_u) = node#bounding_box top_left top_top in self#centre_point ((x_l +. x_u) /. 2.0) ((y_l +. y_u) /. 2.0) (** Test if the given node is (partially) visible. *) method private is_partially_visible node = let (node_x_l, node_x_u, node_y_l, node_y_u) = node#bounding_box top_left top_top in let in_x = inside_adj_range drawing_h_adjustment in let in_y = inside_adj_range drawing_v_adjustment in ((in_x node_x_l) || (in_x node_x_u)) && ((in_y node_y_l) || (in_y node_y_u)) (** Make the given node visible in a user friendly way. *) method show_node node = if self#is_partially_visible node then self#clamp_to_node node else self#centre_node node (** Make the two given nodes visible in a user friendly way. If both nodes do not fit together in the drawing area, then only the second node is shown. *) method show_both_nodes n1 n2 = let (x1_l, x1_u, y1_l, y1_u) = n1#bounding_box top_left top_top in let (x2_l, x2_u, y2_l, y2_u) = n2#bounding_box top_left top_top in let x_l = min x1_l x2_l in let x_u = max x1_u x2_u in let y_l = min y1_l y2_l in let y_u = max y1_u y2_u in (* * Printf.fprintf (debugc()) * "SBN n1 x %.0f-%.0f y %.0f-%.0f " * "n2 x %.0f-%.0f y %.0f-%.0f bb x %.0f-%.0f y %.0f-%.0f\n%!" * x1_l x1_u y1_l y1_u * x2_l x2_u y2_l y2_u * x_l x_u y_l y_u; *) if x_u -. x_l <= drawing_h_adjustment#page_size && y_u -. y_l <= drawing_v_adjustment#page_size then (* both n1 and n2 fit on the page *) if self#is_partially_visible n1 || self#is_partially_visible n2 then begin self#clamp_to_node n1; self#clamp_to_node n2 end else self#centre_point ((x_l +. x_u) /. 2.0) ((y_l +. y_u) /. 2.0) else self#show_node n2 (*************************************************************************** * * Key events * ***************************************************************************) (** Delete and destroy this proof-tree window, including all its non-sticky external node windows and the existential variable dialog. Delete this window from {!cloned_proof_windows}. Other data structures in higher-level modules are not touched. The destruction process might cause destroy signals which will cause this method to be called again. The flag {!destroy_in_progress} is used to protect against such cases. *) method delete_proof_window = if destroy_in_progress = false then begin destroy_in_progress <- true; List.iter (fun w -> w#delete_attached_node_window) node_windows; self#destroy_existential_dialog; let self = (self :> proof_window) in cloned_proof_windows := List.fold_left (fun res w -> if w = self then res else w :: res) [] !cloned_proof_windows; top_window#destroy() end (** Callback for the "Dismiss" button and the destroy signal (emitted, for instance, when the window manager kills this window). Delete and destroy this window as for {!delete_proof_window} and delete it from all data structures in the module {!Proof_tree}. *) method user_delete_proof_window () = if destroy_in_progress = false then begin if is_clone = false then !delete_proof_tree_callback proof_name; self#delete_proof_window end (** Callback for key events. Call the appropriate action for each key. *) method key_pressed_callback ev = match GdkEvent.Key.keyval ev with | ks when (ks = GdkKeysyms._Q || ks = GdkKeysyms._q) && (List.mem `CONTROL (GdkEvent.Key.state ev)) -> exit 0 | ks when (ks = GdkKeysyms._Q || ks = GdkKeysyms._q) -> self#user_delete_proof_window (); true | ks when ks = GdkKeysyms._Left -> scroll_adjustment drawing_h_adjustment (-1); true | ks when ks = GdkKeysyms._Right -> scroll_adjustment drawing_h_adjustment 1; true | ks when ks = GdkKeysyms._Up -> scroll_adjustment drawing_v_adjustment (-1); true | ks when ks = GdkKeysyms._Down -> scroll_adjustment drawing_v_adjustment 1; true | ks when (ks = GdkKeysyms._E || ks = GdkKeysyms._e) -> self#show_existential_window (); true (* * | ks when (ks = GdkKeysyms._C or ks = GdkKeysyms._c) -> * show_config_window (); true *) | _ -> false (*************************************************************************** * * Window for existential variables * ***************************************************************************) (** Clear {!existential_window}. *) method existential_clear () = existential_window <- None (** Show a dialog for existential variables. If there is currently none, a new one is created and initialized. *) method show_existential_window () = match existential_window with | Some w -> w#present | None -> let ext = make_ext_dialog (self :> proof_window) proof_name in layer_stack#init_ext_dialog ext; ext#finish_table_init; existential_window <- Some ext (** Destroy the existential variables dialog, if one is present. *) method private destroy_existential_dialog = match existential_window with | None -> () | Some w -> w#destroy (); existential_window <- None (** Prepare the existential variable dialog for reuse, if there is one. *) method private clear_existential_dialog_for_reuse = match existential_window with | None -> () | Some w -> w#clear_for_reuse (** Schedule some existentials to be added to the existential variable dialog, if there is one. *) method ext_dialog_add new_ext = match existential_window with | Some w -> w#change_and_add new_ext | None -> () (** Schedule some existentials to be removed from the existential variable dialog, if there is one. *) method ext_dialog_undo remove_ext = match existential_window with | Some w -> w#change_and_delete remove_ext | None -> () (** Process all pending requests for the existential variable dialog, if there is one. *) method update_ext_dialog = match existential_window with | Some w -> w#update_ext_dialog | None -> () (** Ask the existential variable dialog to reflect changes in the current configuration. *) method private configuration_updated_ext_dialog = match existential_window with | Some w -> w#configuration_updated | None -> () (*************************************************************************** * * Redraw / expose events * ***************************************************************************) (** Return the relative bounding box of the current node, see {!current_node_offset_cache}. If there nothing in the cache, try to fill it. Return [None] if there is no current node. *) method private get_current_offset = match current_node_offset_cache with | Some _ as res -> res | None -> match current_node with | None -> None | Some node -> let res = Some node#bounding_box_offsets in current_node_offset_cache <- res; res (** Erase the complete drawing area. *) method private erase = (* Printf.fprintf (debugc()) "ERASE\n%!"; *) let (x,y) = drawable#size in let gc = save_gc drawable in let bg = top_window#misc#style#bg `PRELIGHT in (* let bg = drawable#get_background in *) (* drawable#set_foreground (`NAME("gray85")); *) drawable#set_foreground (`COLOR bg); drawable#polygon ~filled:true [(0,0); (x,0); (x,y); (0,y)]; restore_gc drawable gc (** Try to change the scrollbars of the drawing area such that the current node becomes visible in the bottom part. Do nothing if {!position_to_current_node} is [false]. Making the current node visible might be impossible, because the resize request for the drawing area might not have been processed yet. In this case {!position_to_current_node} stays true and this method is called again at some later stage. *) method private try_adjustment = if position_to_current_node = true then match self#get_current_offset with | None -> position_to_current_node <- false | Some((x_l_off, x_u_off, y_l_off, y_u_off)) -> let x_page_size = int_of_float drawing_h_adjustment#page_size in let y_page_size = int_of_float drawing_v_adjustment#page_size in let x_l_f = float_of_int(top_left + x_l_off) in let x_u_f = float_of_int(top_left + x_u_off) in let y_l_f = float_of_int(top_top + y_l_off) in let y_u_i = top_top + y_u_off in let y_u_f = float_of_int y_u_i in (* * Printf.fprintf (debugc()) * "TRY ADJUSTMENT x %.1f-%.1f y %.1f-%.1f\n%!" * x_l_f x_u_f y_l_f y_u_f; *) let success = ref true in (* The following code might immediately trigger * expose events, which will call try_adjustment again. To avoid * entering this function a second time before leaving it, I * temporarily switch position_to_current_node off. *) position_to_current_node <- false; if x_page_size >= (x_u_off - x_l_off) && y_page_size >= (y_u_off - y_l_off) then begin (* current node fits into the viewport, be sophisticated *) let req_width = layer_stack#width in let req_height = layer_stack#height in if (float_of_int req_width) > drawing_h_adjustment#upper || (float_of_int req_height) > drawing_v_adjustment#upper then begin (* The resize request for the drawing area has not * been processed yet. It might happen that this resize * request causes the addition of some scrollbars. In * this case the viewport gets smaller and the * current node would possible (partially) hidden. * Therefore we mimic an adjustment error. Note that * in this case also clamp_page would not give a proper * adjustment. *) success := false; (* Printf.fprintf (debugc()) "clever forced error %!" *) end else begin let y_val = max drawing_v_adjustment#lower (float_of_int (y_u_i - y_page_size)) in drawing_v_adjustment#set_value y_val; (* make now the _h_adjustment, first try if one of the * hint nodes can be made visible as well *) if List.exists (fun hint_nodes -> let (off_l, off_u) = List.fold_left (fun (off_l, off_u) hint_node -> let (h_x_l_off, h_x_u_off, _, _) = hint_node#bounding_box_offsets in (min off_l h_x_l_off, max off_u h_x_u_off)) (x_l_off, x_u_off) hint_nodes in if x_page_size >= (off_u - off_l) then begin (* the hints fit *) drawing_h_adjustment#clamp_page ~lower:(float_of_int (top_left + off_l)) ~upper:(float_of_int (top_top + off_u)); true end else (* the hints don't fit *) false ) position_hints then () else drawing_h_adjustment#clamp_page ~lower:x_l_f ~upper:x_u_f; (* * Printf.fprintf (debugc()) "clever y_u_i %d up %d y_val %d %!" * y_u_i * (int_of_float drawing_v_adjustment#upper) * (int_of_float y_val); *) end end else begin (* very small viewport, use dump strategy *) (* Printf.fprintf (debugc()) "dump clamp %!"; *) drawing_h_adjustment#clamp_page ~lower:x_l_f ~upper:x_u_f; drawing_v_adjustment#clamp_page ~lower:y_l_f ~upper:y_u_f; end; if !success && range_inside_adj_range drawing_h_adjustment x_l_f x_u_f && range_inside_adj_range drawing_v_adjustment y_l_f y_u_f then begin (* Printf.fprintf (debugc()) "SUCCESSFUL\n%!"; *) () (* Do nothing: leave position_to_current_node disabled *) end else begin (* Printf.fprintf (debugc()) "UNSUCCESSFUL %b\n%!" !success; *) (* Schedule the adjustment again, hope that we are more * successful next time. *) position_to_current_node <- true; end; (* * (let a = drawing_h_adjustment in * Printf.fprintf (debugc()) * ("TA HADJ low %.1f val %.1f " ^^ * "up %.1f size %.1f step %.1f page %.1f\n%!") * a#lower a#value a#upper a#page_size * a#step_increment a#page_increment); * (let a = drawing_v_adjustment in * Printf.fprintf (debugc()) * ("TA VADJ low %.1f val %.1f " ^^ * "up %.1f size %.1f step %.1f page %.1f\n%!") * a#lower a#value a#upper a#page_size * a#step_increment a#page_increment); *) () (** Request the drawing are to change its size to the size of the current proof tree. *) method private expand_drawing_area = let new_width = layer_stack#width in let new_height = layer_stack#height in (* * Printf.fprintf (debugc()) "DRAWING AREA SIZE REQUEST %d x %d\n%!" * new_width new_height; *) (* * if new_width > current_width || new_height > current_height then * drawing_area#misc#set_size_request * ~width:(max current_width new_width) * ~height:(max current_height new_height) (); *) drawing_area#misc#set_size_request ~width:new_width ~height:new_height (); (** Sets the position of the proof tree in the drawing area by computing [top_left]. Returns true if the position changed. In that case the complete drawing area must be redrawn. *) method private position_tree = let old_top_left = top_left in let (width, _) = drawable#size in top_left <- max 0 ((width - layer_stack#width) / 2); top_left <> old_top_left (** Handle expose events. Try to move to the current node, erase and redraw the complete drawing area. *) method private redraw = (* * (let a = drawing_v_adjustment in * Printf.fprintf (debugc()) * "RD %s VADJ low %f val %f up %f size %f step %f page %f\n%!" * (match scheduled_adjustment with | None -> "N" | Some _ -> "S") * a#lower a#value a#upper a#page_size * a#step_increment a#page_increment); *) self#try_adjustment; self#erase; (* Printf.fprintf (debugc()) "REDRAW\n%!"; *) layer_stack#draw top_left top_top (** Schedule an expose event for the drawing area, thereby causing it to get redrawn. *) method invalidate_drawing_area = (* Printf.fprintf (debugc()) "INVALIDATE\n%!"; *) GtkBase.Widget.queue_draw drawing_area#as_widget (** Method for updating the display after the proof tree has changed. Adjusts the tree position in the drawing area, schedules a complete redraw and make the current node (if any) visible. *) method refresh_and_position = (* Printf.fprintf (debugc()) "REFRESH & POSITION\n%!"; *) position_to_current_node <- true; self#expand_drawing_area; ignore(self#position_tree); self#try_adjustment; self#invalidate_drawing_area; (* Printf.fprintf (debugc()) "REFRESH & POSITION END\n%!"; *) () (** Position the current node in the bottom part of the drawing area. *) method reposition_current_node () = position_to_current_node <- true; self#try_adjustment (** Make the current node visible in a user friendly way. *) method show_current_node () = match current_node with | None -> () | Some current -> if self#is_partially_visible current then self#show_node current else self#reposition_current_node () (** Make the selected node visible in a user friendly way. *) method show_selected_node () = match selected_node with | None -> () | Some selected -> self#show_node selected (** Callback for the size_allocate signal of the drawing area. Position the proof tree in the viewport of the drawing area and redraw. *) method draw_scroll_size_allocate_callback (_size : Gtk.rectangle) = (* * Printf.fprintf (debugc()) "SCROLLING SIZE ALLOC SIGNAL size %d x %d\n%!" * (int_of_float (drawing_h_adjustment#upper +. 0.5)) * (int_of_float (drawing_v_adjustment#upper +. 0.5)); *) let need_redraw = self#position_tree in (* * (let a = drawing_v_adjustment in * Printf.fprintf (debugc()) * "SA %s VADJ low %f val %f up %f size %f step %f page %f\n%!" * (match scheduled_adjustment with | None -> "N" | Some _ -> "S") * a#lower a#value a#upper a#page_size * a#step_increment a#page_increment); *) self#try_adjustment; if need_redraw then self#invalidate_drawing_area (* * method draw_area_size_allocate_callback (_size : Gtk.rectangle) = * Printf.fprintf (debugc()) "AREA SIZE ALLOC SIGNAL size %d x %d\n%!" * (int_of_float (drawing_h_adjustment#upper +. 0.5)) * (int_of_float (drawing_v_adjustment#upper +. 0.5)); *) (* * method draw_area_configure_callback configure_event = * Printf.fprintf (debugc()) * "AREA CONFIGURE SIGNAL area size %d x %d scroll size %d x %d\n%!" * (GdkEvent.Configure.width configure_event) * (GdkEvent.Configure.height configure_event) * (int_of_float (drawing_h_adjustment#upper +. 0.5)) * (int_of_float (drawing_v_adjustment#upper +. 0.5)); * false *) (** Callback for exposure events. Redraw the complete tree. *) method expose_callback (_ev : GdkEvent.Expose.t) = (* * let r = GdkEvent.Expose.area ev in * Printf.fprintf (debugc()) "EXPOSE count %d %d x %d at %d x %d\n%!" * (GdkEvent.Expose.count ev) * (Gdk.Rectangle.width r) (Gdk.Rectangle.height r) * (Gdk.Rectangle.x r) (Gdk.Rectangle.y r); *) (* * (let a = drawing_v_adjustment in * Printf.fprintf (debugc()) * "EX VADJ low %f val %f up %f size %f step %f page %f\n%!" * a#lower a#value a#upper a#page_size * a#step_increment a#page_increment); *) (* * (let a = drawing_h_adjustment in * Printf.fprintf (debugc()) * "HADJ low %f val %f up %f size %f step %f page %f\n" * a#lower a#value a#upper a#page_size a#step_increment a#page_increment); * (let a = drawing_v_adjustment in * Printf.fprintf (debugc()) * "VADJ low %f val %f up %f size %f step %f page %f\n%!" * a#lower a#value a#upper a#page_size a#step_increment a#page_increment); *) self#redraw; (* prerr_endline "END EXPOSE EVENT"; *) false (*************************************************************************** * * numbers for external node windows * ***************************************************************************) (** Counter for external node windows. *) val mutable last_node_number = 0 (** Return the number for the next external node window. *) method private next_node_number = last_node_number <- last_node_number + 1; last_node_number (*************************************************************************** * * Button events * ***************************************************************************) (** The dragging feature has the problem that it changes the viewport to the drawing area, which itself generates pointer motion events for the drawing area. The approach is therefore to remember the mouse position at the start of the dragging (i.e., the button press) in coordinates relative to the complete X window. X position of the mouse at the last button press relative to [top_window]. *) val mutable last_button_press_top_x = 0 (** Y position of the mouse at the last button press relative to [top_window]. *) val mutable last_button_press_top_y = 0 (** Value of the vertical scrollbar at the last button press. *) val mutable last_button_press_v_adjustment_value = 0.0 (** Value of the horizontal scrollbar at the last button press. *) val mutable last_button_press_h_adjustment_value = 0.0 (** Fill {!last_button_press_top_x}, {!last_button_press_top_y}, {!last_button_press_v_adjustment_value} and {!last_button_press_h_adjustment_value} in case dragging follows. *) method private remember_for_dragging = let (x, y) = Gdk.Window.get_pointer_location top_window#misc#window in (* * Printf.fprintf (debugc()) "Button press %d x %d\n%!" * (fst new_poi_loc) (snd new_poi_loc); *) last_button_press_top_x <- x; last_button_press_top_y <- y; last_button_press_v_adjustment_value <- drawing_v_adjustment#value; last_button_press_h_adjustment_value <- drawing_h_adjustment#value; (** We have different and incompatible actions for single and double clicks and for dragging. Because single click events do always occur before double clicks and dragging events, we have to undo the changes that were done for the single click. A double click is of course always preceeded by two single clicks. Remember the selected node state before the last but one mouse press. This state needs to get reestablished when we detect a double click. *) val mutable old_old_selected_node = None (** Remember the selected node state before the last mouse press. This state needs to get reestablished on dragging events. *) val mutable old_selected_node = None (** Remember if we have already restored the selected node state since the last button press. *) val mutable restored_selected_node = false (** Reset the selected node state to state [node_opt] and update drawing and sequent area. *) method set_selected_node node_opt = (match selected_node with | None -> () | Some node -> node#selected false); selected_node <- node_opt; (match node_opt with | None -> () | Some node -> node#selected true); self#invalidate_drawing_area; self#refresh_sequent_area (** Make the root node the selected node or clear the selected node if there is no root node *) method select_root_node = self#set_selected_node (layer_stack#get_root_node) (** Save the selected node state on a button press and clear {!restored_selected_node}. *) method private save_selected_node_state = old_old_selected_node <- old_selected_node; old_selected_node <- selected_node; restored_selected_node <- false (** Restore the selected node state when we detect mouse dragging for the first time. Sets {!restored_selected_node}. *) method private single_restore_selected_node = self#set_selected_node old_selected_node; restored_selected_node <- true (** Restore the selected node state after we detected a double click. *) method private double_restore_selected_node = self#set_selected_node old_old_selected_node; restored_selected_node <- true (** [locate_button_node x y found notfound] tries to locate a proof tree element on position [(x, y)]. If there is one [found] is called with this element. If there is nothing [notfound] is called. *) method private locate_button_node : 'a . int -> int -> (#proof_tree_element -> 'a) -> (unit -> 'a) -> 'a = fun x y node_click_fun outside_click_fun -> match layer_stack#find_node_for_point_in_layer_stack top_left top_top x y with | None -> outside_click_fun () | Some node -> node_click_fun node (** Display an external node window for the argument node. *) method private external_node_window (node : proof_tree_element) = let n = string_of_int(self#next_node_number) in let win = make_node_window (self :> proof_window) proof_name node n in node_windows <- win :: node_windows; self#invalidate_drawing_area (** Method to handle button one press events. Receives as arguments the coordinates, a flag for the shift modifier and a flag to indicate a double click. *) method private button_1_press x y shifted double = self#remember_for_dragging; if (not double) && (not shifted) then self#save_selected_node_state; if double && (not shifted) then self#double_restore_selected_node; if double || shifted then self#locate_button_node x y self#external_node_window (fun () -> ()) else self#locate_button_node x y (fun node -> self#set_selected_node (Some node)) (fun () -> self#set_selected_node None) (* val mutable last_button_press_time = 0l *) (** Generic call back for all button press events. *) method button_press ev = let x = int_of_float(GdkEvent.Button.x ev +. 0.5) in let y = int_of_float(GdkEvent.Button.y ev +. 0.5) in let button = GdkEvent.Button.button ev in let shifted = Gdk.Convert.test_modifier `SHIFT (GdkEvent.Button.state ev) in let double = match GdkEvent.get_type ev with | `BUTTON_PRESS -> false | `TWO_BUTTON_PRESS -> true | `THREE_BUTTON_PRESS -> false | `BUTTON_RELEASE -> false in (* * let state = B.state ev in * let mod_list = Gdk.Convert.modifier state in * let _ = Gdk.Convert.test_modifier `SHIFT state in *) (* * let time_diff = * Int32.sub (GdkEvent.Button.time ev) last_button_press_time * in * last_button_press_time <- GdkEvent.Button.time ev; *) (* * (let h = drawing_h_adjustment in * let v = drawing_v_adjustment in * Printf.fprintf (debugc()) * "%s Button %s%d at %d x %d | x: %1.f - %.1f y: %.1f - %.1f\n%!" * (match GdkEvent.get_type ev with * | `BUTTON_PRESS -> "single" * | `TWO_BUTTON_PRESS -> "double" * | `THREE_BUTTON_PRESS -> "triple" * | `BUTTON_RELEASE -> "release") * (if shifted then "shift " else "") * button x y * h#value (h#value +. h#page_size) * v#value (v#value +. v#page_size)); *) (match button with | 1 -> self#button_1_press x y shifted double | 3 -> self#context_menu x y button (GdkEvent.Button.time ev) | _ -> ()); true (*************************************************************************** * * Pointer motion events * ***************************************************************************) (** Action for a pointer motion event that is part of dragging. Moves the viewport to the drawing area relative to the mouse position when dragging started. *) method pointer_motion (_ev : GdkEvent.Motion.t) = let (x, y) = Gdk.Window.get_pointer_location top_window#misc#window in let new_h_value = last_button_press_h_adjustment_value +. !current_config.button_1_drag_acceleration *. (float_of_int (x - last_button_press_top_x)) in let new_v_value = last_button_press_v_adjustment_value +. !current_config.button_1_drag_acceleration *. (float_of_int (y - last_button_press_top_y)) in (* * let hint = GdkEvent.Motion.is_hint _ev in * Printf.fprintf (debugc()) * "PM %d %d%s\n%!" x y (if hint then " H" else ""); *) if not restored_selected_node then self#single_restore_selected_node; drawing_h_adjustment#set_value (min new_h_value (drawing_h_adjustment#upper -. drawing_h_adjustment#page_size)); drawing_v_adjustment#set_value (min new_v_value (drawing_v_adjustment#upper -. drawing_v_adjustment#page_size)); (* * last_button_1_x <- x; * last_button_1_y <- y; *) true (** General callback for all pointer motion events. *) method pointer_general_motion (ev : GdkEvent.Motion.t) = if Gdk.Convert.test_modifier `BUTTON1 (GdkEvent.Motion.state ev) then self#pointer_motion ev else false (*************************************************************************** * * menu actions * ***************************************************************************) (** Field to store the undo state number. This number is determined when the context menu is posted and is needed in the callback for the undo menu entry. *) val mutable context_menu_undo_state = None (** Field to store the proof command under the mouse when the context menu is posted. This node is needed for sending proof commands and proof scripts. To avoid a memory leak, this field is cleared with an idle action, see {!context_menu_deactivated}. *) val mutable context_menu_node = None (** Callback for the undo menu entry. *) method undo_to_point () = match context_menu_undo_state with | None -> assert false | Some state -> emacs_callback_undo state (** Callback for inserting one proof command. *) method insert_proof_command () = match context_menu_node with | None -> assert false | Some node -> emacs_send_proof_script node#content (** Callback for inserting all proof commands of a subtree. *) method insert_subproof () = let buf = Buffer.create 4095 in let rec collect node indent = Buffer.add_string buf (String.make indent ' '); Buffer.add_string buf node#content; Buffer.add_char buf '\n'; let sequents = node#children in ignore( List.fold_left (fun indent sequent -> match sequent#children with | [pc] -> collect pc indent; indent - 2 | [] -> indent - 2 (* happens for the current sequent *) | _ -> assert false) (indent + (2 * List.length sequents) - 2) sequents) in match context_menu_node with | None -> assert false | Some node -> collect node 0; emacs_send_proof_script (Buffer.contents buf) (** Post the context menu. Depending on where the mouse button is pressed, certain menu entries as disabled. The undo state is stored in {!context_menu_undo_state} for use in the callback for the undo entry. *) method context_menu x y button time = self#locate_button_node x y (fun node -> context_menu_node <- Some node; let undo_state = if disconnected then None else match node#node_kind with | Proof_command -> None | Turnstile -> match node#children with | first :: _ -> Some first#undo_state | _ -> None in context_menu_undo_state <- undo_state; (List.nth context_menu#children 0)#misc#set_sensitive (undo_state <> None); (List.nth context_menu#children 1)#misc#set_sensitive (node#node_kind = Proof_command); (List.nth context_menu#children 2)#misc#set_sensitive (node#node_kind = Proof_command); context_menu#popup ~button ~time; ) (fun () -> List.iter (fun n -> (List.nth context_menu#children n)#misc#set_sensitive false) [0; 1; 2]; context_menu#popup ~button ~time ) (** Callback for the deactivated signal of the context menu. Unfortunately, this signal is processed before the callback for the selected menu item is processed. Therefore, the {!context_menu_node} cannot be cleared directly but only in an idle action. *) method context_menu_deactivated () = ignore(GMain.Idle.add (fun () -> context_menu_node <- None; false)) (*************************************************************************** * * tooltips * ***************************************************************************) (** Callback for the query tooltip event. Display a tool-tip if there is a sequent node or an abbreviated proof command node. *) method drawable_tooltip ~x ~y ~kbd:(_kbd : bool) (tooltip : Gtk.tooltip) = (* Printf.fprintf (debugc()) "TTS x %d y %d\n%!" x y; *) self#locate_button_node x y (fun node -> match node#node_kind with | Turnstile -> if !current_config.display_turnstile_tooltips then begin let contents = GMisc.label ~text:node#displayed_text () in GtkBase.Tooltip.set_custom tooltip contents#as_widget; true end else false | Proof_command -> if !current_config.display_command_tooltips && node#content_shortened then begin let contents = GMisc.label ~text:node#displayed_text () in GtkBase.Tooltip.set_custom tooltip contents#as_widget; true end else false ) (fun () -> false) (*************************************************************************** * * Cloning * ***************************************************************************) (** Callback for the clone menu item. Creates and displays a clone window. *) method clone (owin : proof_window) = owin#set_clone_flag; let old_selected = match current_node with | Some _ -> current_node | None -> selected_node in let cloned_selected = ref None in let cloned_layers = layer_stack#clone_layers (owin#new_proof_command 0) (owin#new_turnstile 0) old_selected cloned_selected in owin#layer_stack#set_layers cloned_layers; owin#set_selected_node !cloned_selected; owin#refresh_and_position; cloned_proof_windows := owin :: !cloned_proof_windows (*************************************************************************** * * Proof element creation * ***************************************************************************) (** Create a new turnstile node for sequents. *) method new_turnstile undo_state sequent_id sequent_text_option = new turnstile drawable undo_state sequent_id sequent_text_option (** Create a new proof command node. *) method new_proof_command undo_state command inst_existentials new_existentials = new proof_command drawable undo_state command command (inst_existentials : existential_variable list) (new_existentials : existential_variable list) end (***************************************************************************** * * proof window creation * *****************************************************************************) (** Create a new proof tree window. Creates the widget hierarchy, the menu, initializes the management object and registers all callbacks. *) let rec make_proof_window name geometry_string = let top_window = GWindow.window () in top_window#set_default_size ~width:!current_config.default_width_proof_tree_window ~height:!current_config.default_height_proof_tree_window; (* top_v_box for the pane and the button hbox *) let top_v_box = GPack.vbox ~packing:top_window#add () in (* top_paned for the drawing area and the sequent *) let top_paned = GPack.paned `VERTICAL ~packing:(top_v_box#pack ~expand:true) () in let drawing_scrolling = GBin.scrolled_window (* ~border_width:1 *) ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:(top_paned#pack1 ~resize:true ~shrink:false) () in let drawing_h_adjustment = drawing_scrolling#hadjustment in let drawing_v_adjustment = drawing_scrolling#vadjustment in let drawing_area = GMisc.drawing_area ~packing:drawing_scrolling#add_with_viewport () in let _ = drawing_area#misc#realize () in let drawable = new better_drawable drawing_area#misc#window drawing_area#misc#create_pango_context in let outer_sequent_frame = GBin.frame ~shadow_type:`IN ~packing:(top_paned#pack2 ~resize:false ~shrink:true) () in let labeled_sequent_frame = GBin.frame ~label:"no sequent" ~shadow_type:`NONE ~packing:outer_sequent_frame#add () in let sequent_scrolling = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:labeled_sequent_frame#add () in (* * let sequent_h_adjustment = sequent_scrolling#hadjustment in *) let sequent_v_adjustment = sequent_scrolling#vadjustment in sequent_scrolling#misc#modify_font !sequent_font_desc; let context = sequent_scrolling#misc#pango_context in let layout = context#create_layout in Pango.Layout.set_text layout "X"; let (_, char_height) = Pango.Layout.get_pixel_size layout in let sequent_window = GText.view ~editable:false ~cursor_visible:false ~height:(char_height * !current_config.internal_sequent_window_lines) ~packing:sequent_scrolling#add () in sequent_window#misc#modify_font !sequent_font_desc; (* bottom button line with the message in the middle *) let button_box_align = GBin.alignment ~padding:(1,1,3,3) (* (top, bottom, left, right)*) ~packing:(top_v_box#pack) () in let button_h_box = GPack.hbox ~packing:button_box_align#add () in let dismiss_button = GButton.button ~stock:`CLOSE ~packing:button_h_box#pack () in let message_label = GMisc.label ~selectable:true ~ellipsize:`END ~packing:(button_h_box#pack ~expand:true ~fill:true) () in message_label#set_use_markup true; let menu_button = GButton.button ~label:"Menu" ~packing:(button_h_box#pack) () in let main_menu = GMenu.menu () in let context_menu = GMenu.menu () in let proof_window = new proof_window top_window drawing_h_adjustment drawing_v_adjustment drawing_area drawable labeled_sequent_frame sequent_window sequent_v_adjustment message_label context_menu name in let clone_fun () = let owin = make_proof_window name geometry_string in proof_window#clone owin in let main_menu_entries = [`I("Clone", clone_fun); `I("Show current", proof_window#reposition_current_node); `I("Show selected", proof_window#show_selected_node); `I("Existentials", proof_window#show_existential_window); `I("Configuration", show_config_window); `I("Help", show_help_window); `I("About", show_about_window); `I("Exit", (fun _ -> exit 0)); ] in let context_menu_entries = [`I("Undo to point", proof_window#undo_to_point); `I("Insert command", proof_window#insert_proof_command); `I("Insert subproof", proof_window#insert_subproof); `S ] @ main_menu_entries in GToolbox.build_menu main_menu ~entries:main_menu_entries; GToolbox.build_menu context_menu ~entries:context_menu_entries; ignore(context_menu#connect#deactivate ~callback:(proof_window#context_menu_deactivated)); top_window#set_title (name ^ " proof tree"); drawable#set_line_attributes ~width:(!current_config.turnstile_line_width) (); drawing_area#misc#set_has_tooltip true; ignore(drawing_area#misc#connect#query_tooltip ~callback:proof_window#drawable_tooltip); ignore(drawing_scrolling#misc#connect#size_allocate ~callback:proof_window#draw_scroll_size_allocate_callback); (* * ignore(drawing_area#misc#connect#size_allocate * ~callback:proof_window#draw_area_size_allocate_callback); *) (* * ignore(drawing_area#event#connect#configure * ~callback:proof_window#draw_area_configure_callback); *) ignore(top_window#connect#destroy ~callback:proof_window#user_delete_proof_window); (* the delete event yields a destroy signal if not handled *) (* ignore(top_window#event#connect#delete ~callback:proof_window#delete_proof_window); *) (* * ignore(drawing_area#misc#set_can_focus true); * ignore(drawing_area#event#connect#key_press * proof_window#key_pressed_callback); *) ignore(top_window#event#connect#key_press ~callback:proof_window#key_pressed_callback); ignore(drawing_area#event#connect#expose ~callback:proof_window#expose_callback); (* ignore(drawing_area#misc#connect#size_allocate ~callback:resize); *) (* events to receive: * - all button presses, * - pointer motion when button 1 is pressed * - reduced number of pointer motion events *) ignore(drawing_area#event#add [`BUTTON_PRESS; `BUTTON1_MOTION; `POINTER_MOTION_HINT]); ignore(drawing_area#event#connect#button_press ~callback:proof_window#button_press); ignore(drawing_area#event#connect#motion_notify ~callback:proof_window#pointer_general_motion); ignore(sequent_v_adjustment#connect#changed ~callback:proof_window#sequent_area_changed); ignore(dismiss_button#connect#clicked ~callback:proof_window#user_delete_proof_window); ignore(menu_button#connect#clicked ~callback:(fun () -> main_menu#popup ~button:0 ~time:(GtkMain.Main.get_current_event_time ()))); top_window#show (); if geometry_string <> "" then ignore(top_window#parse_geometry geometry_string); if !current_config.internal_sequent_window_lines = 0 then top_paned#set_position (top_paned#max_position); proof_window prooftree-0.13/proof_tree.ml0000644000175000017500000010475513032677177014717 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: proof_tree.ml,v 1.54 2016/01/23 12:57:14 tews Exp $ *) (** Internal representation of proof trees with undo info This module processes the proof-tree display commands that are read from standard input. It keeps a state record (of type {!proof_tree}) for all proof trees currently displayed. *) open Util open Gtk_ext open Configuration open Draw_tree open Tree_layers open Proof_window open Emacs_commands (** Internal exception for state mismatches. This exception is raised when the internal state of one proof tree in this module is inconsistent with the proof-tree display command that has been read. In a correct setup (with the right Proof General version) such an error indicates a bug in either prooftree or in the Proof General preprocessing code. This exception can also be raised if prooftree is used with a wrong version of Proof General or if somebody manipulates the internal data structures of Proof General. *) exception Proof_tree_error of string type proof_tree = { window : proof_window; (** The window displaying this tree. *) proof_name : string; (** The name of the proof *) mutable pa_start_state : int; (** Internal proof assistant state number where this proof starts. Used to detect bulk undos. *) mutable pa_end_state : int; (** Internal proof assistant state number where this proof finishes, or [-1] if this proof is not finished yet. Used to speed up undo processing. *) mutable cheated : bool; (** [true] if a cheating command has been used somewhere in the proof. *) sequent_hash : (string, turnstile) Hashtbl.t; (** Hash table mapping all currently known sequents of this proof tree to {!class: Draw_tree.turnstile} objects. Used to detect new sequents and to update sequents. *) mutable current_sequent_id : string option; (** The ID of the current sequent, if there is one. Needed to distinguish the peculiar case, where a non-failing proof command (such as [auto]) does not change the proof state. *) mutable current_sequent : proof_tree_element option; (** The object of the current sequent, if there is one. Used for coloring branches. There is no current sequent, if a branch has been finished without switching to a new goal. *) mutable open_goals_count : int; (** Counter for the total number of open goals, including the current sequent. *) existential_hash : (string, existential_variable) Hashtbl.t; (** Mapping containing all existential variables in the proof tree. Needed to establish the dependency links in instantiated existentials. *) mutable need_redraw : bool; (** [true] if the tree display needs a redraw. Used to delay redrawing. *) mutable sequent_area_needs_refresh : bool; (** [true] if the sequent area needs to be refreshed. Used to delay sequent area refreshs. *) mutable undo_actions : (int * (unit -> unit) list) list; (** List of undo actions for this proof tree. Each element has the form [(state, action_list)], where [action_list] is the list of undo actions that must be performed if the user retracts to a state equal or lesser than [state]. *) } (** State record for displayed proof trees. The code maintains the following invariants. {ul {- Each displayed proof tree is in precisely one the lists {!original_proof_trees} or {!Proof_window.cloned_proof_windows}.} {- {!proof_tree.current_sequent_id} = [None] iff {!proof_tree.current_sequent} = [None]} } *) (** Add an undo action to the current state [pa_state] of the proof [pt]. This action is performed if the user retracts to a state equal or lesser than [pa_state]. *) let add_undo_action pt pa_state undo_fun = match pt.undo_actions with | [] -> pt.undo_actions <- [(pa_state, [undo_fun])] | (prev_pa_state, prev_undos) :: undo_tail -> assert(pa_state >= prev_pa_state); if pa_state = prev_pa_state then pt.undo_actions <- (prev_pa_state, undo_fun :: prev_undos) :: undo_tail else pt.undo_actions <- (pa_state, [undo_fun]) :: pt.undo_actions (** Contains all non-cloned proof trees managed in this module. Cloned proof trees are in {!Proof_window.cloned_proof_windows}. *) let original_proof_trees = ref [] (** Take the necessary actions when the configuration record changed. Calls the {!Proof_window.proof_window.configuration_updated} method on all live proof windows. *) let configuration_updated () = List.iter (fun pt -> pt.window#configuration_updated) !original_proof_trees; List.iter (fun ptw -> ptw#configuration_updated) !cloned_proof_windows (** Mark the given existential as instantiated and link it with its dependencies. *) let instantiate_existential ex_hash ex dependency_names = assert(ex.dependencies = []); ex.status <- Partially_instantiated; ex.dependencies <- List.map (Hashtbl.find ex_hash) dependency_names (** Reset the given list of existential variables to not being instantiated. *) let undo_instantiate_existentials exl = List.iter (fun ex -> ex.status <- Uninstantiated; ex.dependencies <- []; ) exl (** Create a new existential variable and add it to the hash of existentials. The newly created existential is returned. *) let make_new_existential ex_hash ex_name = let ex = {existential_name = ex_name; status = Uninstantiated; existential_mark = false; dependencies = []; } in Hashtbl.add ex_hash ex_name ex; ex (** Walk over all existential variables and update their instantiation status. More precisely, for evars that are instantiated (i.e., have a status of [Partially_instantiated] or [Fully_instantiated], see {!Draw_tree.existential_status}) the complete tree of dependencies is scanned and then their status is set appropriately. *) let update_existential_status ex_hash = let visited_hash = Hashtbl.create 251 in let rec collect ex = if Hashtbl.mem visited_hash ex.existential_name then () else begin if ex.status <> Uninstantiated then begin List.iter collect ex.dependencies; ex.status <- if (List.for_all (fun dep -> dep.status = Fully_instantiated) ex.dependencies) then Fully_instantiated else Partially_instantiated end; Hashtbl.add visited_hash ex.existential_name () end in Hashtbl.iter (fun _ ext -> collect ext) ex_hash (** Update the hash of existential variables and the existentials themselves. First the list of uninstantiated existentials and the one of instantiated existentials are scanned for new existentials. Note that new existentials can even be found in the dependencies of instantiated existentials, if some complex strategy creates and instantiates several existentials. Newly created existentials are registered in the hash of existential variables. Finally the state of those existentials that got instantiated is updated. This function returns the list of newly instantiated existentials and the list of new existentials. *) let update_existentials ex_hash uninst_ex inst_ex_deps = let test_and_create_ex_list exl accu = List.fold_left (fun res ex_name -> if Hashtbl.mem ex_hash ex_name then res else (make_new_existential ex_hash ex_name) :: res ) accu exl in let new_ex = test_and_create_ex_list uninst_ex [] in let new_ex = List.fold_left (fun res (ex_name, deps) -> (* Complex stategies might create and instantiate several * existentials. It may therefore happen that some * instantiated existential and even some of its dependencies * are actually new. *) test_and_create_ex_list (ex_name :: deps) res ) new_ex inst_ex_deps in let ex_got_instatiated = List.fold_left (fun res (ex_name, deps) -> let ex = Hashtbl.find ex_hash ex_name in if ex.status = Uninstantiated then begin instantiate_existential ex_hash ex deps; ex :: res end else res ) [] inst_ex_deps in (* XXX use a coq specific comparison function for sorting *) (ex_got_instatiated, List.sort compare new_ex) (** Local convenience function for changing the current node. Sets the current node in the proof-tree window and schedules an update for the sequent area if there is no selected node. *) let set_current_node_wrapper pt sequent = (match sequent with | Some s -> pt.window#set_current_node s; | None -> pt.window#clear_current_node; ); if pt.window#get_selected_node = None then pt.sequent_area_needs_refresh <- true (** Local convenience function for marking the current sequent. *) let mark_current_sequent_maybe = function | Some cs -> cs#mark_current | None -> () (** Holds the state for the currently active proof window, if any. Mainly used for {!finish_drawing} to delay redrawing. *) let current_proof_tree = ref None (** Closes the proof tree [pt] by leaving the current branch open. Additionally clear {!current_proof_tree}. *) let stop_proof_tree pt pa_state = (* Don't keep undo actions. Because of insertions, undo state * numbers might get out of sync with retired proof trees. Undo into * the middle of a proof is therefore impossible. *) pt.undo_actions <- []; pt.pa_end_state <- pa_state; pt.window#disconnect_proof; pt.window#clear_current_node; pt.window#refresh_sequent_area; update_existential_status pt.existential_hash; pt.window#refresh_and_position; pt.window#update_ext_dialog; pt.need_redraw <- false; pt.sequent_area_needs_refresh <- false; current_proof_tree := None (** Same as {!stop_proof_tree} but make the current sequent the selected one, if there is no selected sequent. *) let stop_proof_tree_last_selected pt pa_state = (match pt.window#get_selected_node with | None -> (* stop_proof_tree will clear all undo actions * add_undo_action pt pa_state * (fun () -> pt.window#set_selected_node None); *) pt.window#select_root_node | Some _ -> ()); stop_proof_tree pt pa_state (** Result values for [undo_tree] that tell the calling function [undo] what to do with the argument proof tree. *) type proof_tree_undo_result = | PT_undo_delete (** Argument proof tree should be deleted *) | PT_undo_current (** Argument proof tree should be kept as current *) | PT_undo_keep (** Argument proof tree should be kept non-current *) (** Process all undo actions with a state greater than [undo_state]. Return the list of unprocessed undo actions (with state strictly less than [undo_state]). *) let rec fire_undo_actions undo_state = function | [] -> [] | ((state, undos) :: undo_rest) as undo_list -> if state > undo_state then begin List.iter (fun f -> f()) undos; fire_undo_actions undo_state undo_rest end else undo_list (** Perform undo actions in proof tree [pt] to reach state [pa_state]. This means that either {ul {- nothing is done (because [pt] was finished in a state less than [pa_state]),} {- some of the nodes in [pt] are deleted,} {- the complete window belonging to [pt] is deleted, or} {- no node of [pt] is deleted and pt is kept as surviver (because a bulk undo with a state less than the starting state of [pt] was detected.)} } Because of insertions, undo-state numbers might get out of sync with retired proof trees. Therefore, undo into the middle of an retired proof tree is not supported. *) let undo_tree pt pa_state = let pt_is_current = match !current_proof_tree with | Some cpt -> pt == cpt | None -> false in if pa_state < pt.pa_start_state then begin if pt.window#survive_undo_before_start then begin pt.window#message "Retract before start"; if pt_is_current then stop_proof_tree pt (-1) else pt.pa_end_state <- -1; pt.window#clear_position_hints; PT_undo_keep end else begin pt.window#delete_proof_window; PT_undo_delete end end else if pt.pa_end_state >= 0 && pa_state >= pt.pa_end_state then begin assert(pt_is_current = false); PT_undo_keep end else (* pt.pa_start_state <= pa_state < pt.pa_end_state *) if pt_is_current then begin pt.undo_actions <- fire_undo_actions pa_state pt.undo_actions; mark_current_sequent_maybe pt.current_sequent; set_current_node_wrapper pt pt.current_sequent; pt.window#message (Printf.sprintf "Retract to %d" pa_state); pt.need_redraw <- true; pt.window#clear_position_hints; PT_undo_current end else begin if pt.window#survive_undo_before_start then begin pt.window#message "Retract before start"; pt.pa_end_state <- -1; pt.window#clear_position_hints; PT_undo_keep end else begin pt.window#delete_proof_window; PT_undo_delete end end (** Perform undo to state [pa_state] in all non-cloned proof trees ({!original_proof_trees}). As result some of the proof windows might get deleted, some proof trees might get changed, and some might be kept as surviver. {!current_proof_tree} might be cleared. *) let undo pa_state = let new_current = ref None in original_proof_trees := List.fold_left (fun pts pt -> match undo_tree pt pa_state with | PT_undo_delete -> pts | PT_undo_current -> new_current := Some pt; pt :: pts | PT_undo_keep -> pt :: pts ) [] !original_proof_trees; current_proof_tree := !new_current (** Try to find an old proof window for [proof_name]. *) let get_surviver proof_name = try Some( List.find (fun pt -> pt.proof_name = proof_name) !original_proof_trees ) with | Not_found -> None (** Create a new proof-tree state (containing an empty proof tree window) for [proof_name] with starting state [state]. *) let create_new_proof_tree proof_name state = { window = make_proof_window proof_name !geometry_string; proof_name = proof_name; pa_start_state = state; pa_end_state = -1; cheated = false; sequent_hash = Hashtbl.create 503; current_sequent_id = None; current_sequent = None; open_goals_count = 0; existential_hash = Hashtbl.create 251; need_redraw = true; sequent_area_needs_refresh = true; undo_actions = []; } (** Initialize a surviver proof-tree state (and window) for reuse with the initial sequent [current_sequent] and start state [state]. *) let reinit_surviver pt state = pt.window#clear_for_reuse; Hashtbl.clear pt.sequent_hash; Hashtbl.clear pt.existential_hash; pt.pa_start_state <- state; pt.pa_end_state <- -1; pt.cheated <- false; pt.current_sequent_id <- None; pt.current_sequent <- None; pt.open_goals_count <- 0; pt.need_redraw <- true; pt.sequent_area_needs_refresh <- true; pt.undo_actions <- []; pt.window#message "" (** Start a new proof [proof_name] which is initially empty, that is contains no proof tree layers. If a surviver proof tree is found it is reused. Otherwise a new proof-tree state and window is created. *) let start_new_proof state proof_name = let pt = match get_surviver proof_name with | None -> let pt = create_new_proof_tree proof_name state in original_proof_trees := pt :: !original_proof_trees; pt | Some pt -> reinit_surviver pt state; pt in current_proof_tree := Some pt; pt (** Create a new layer in the proof tree display with the current sequent and all additional sequents as root goals. There must be no open subgoal. The information about existential variables is processed, but there must be no new and no newly instantiated existential variables. If this is the first layer in the display, a warning is displayed, if there are more than 1 root nodes. *) let create_new_layer pt state current_sequent_id current_sequent_text additional_ids uninstantiated_existentials instantiated_ex_deps = assert(List.for_all (fun id -> Hashtbl.mem pt.sequent_hash id = false) (current_sequent_id :: additional_ids)); assert(pt.open_goals_count = 0); let (ex_got_instantiated, new_existentials) = update_existentials pt.existential_hash uninstantiated_existentials instantiated_ex_deps in (* schedule an existential status update when this assert goes away *) assert (ex_got_instantiated = [] && new_existentials = []); let first_sw = pt.window#new_turnstile state current_sequent_id (Some current_sequent_text) in Hashtbl.add pt.sequent_hash current_sequent_id first_sw; let first_sw = (first_sw :> proof_tree_element) in let other_sw = List.fold_right (fun id res -> let sw = pt.window#new_turnstile state id None in Hashtbl.add pt.sequent_hash id sw; (sw :> proof_tree_element) :: res) additional_ids [] in let all_roots = first_sw :: other_sw in let layer = new tree_layer all_roots in let layer_undo_pos = pt.window#layer_stack#add_layer layer in pt.current_sequent_id <- Some current_sequent_id; pt.current_sequent <- Some first_sw; pt.open_goals_count <- List.length all_roots; first_sw#mark_current; set_current_node_wrapper pt (Some first_sw); pt.window#clear_position_hints; let layer_count = pt.window#layer_stack#count_layers in let message = if layer_count = 1 then "Initial sequent" else Printf.sprintf "Layer %d with %d goals" layer_count pt.open_goals_count in pt.window#message message; let unhash_sequent_ids = current_sequent_id :: additional_ids in let undo () = List.iter (fun s -> s#delete_non_sticky_external_windows) all_roots; List.iter (fun id -> Hashtbl.remove pt.sequent_hash id) unhash_sequent_ids; List.iter (fun sw -> if sw#is_selected then pt.window#set_selected_node None) all_roots; pt.window#layer_stack#del_layer layer_undo_pos; pt.current_sequent_id <- None; pt.current_sequent <- None; pt.open_goals_count <- 0; in add_undo_action pt state undo; pt.need_redraw <- true; pt.sequent_area_needs_refresh <- true; if layer_count = 1 && pt.open_goals_count > 1 then run_message_dialog "More than one initial goal. \n\ You need to start proofs with \n\ the \"Proof\" command!" `WARNING (** Add a new proof command with the new current sequent [current_sequent] and the additionally spawned subgoals. The additionally spawned subgoals are computed from [additional_ids] which must contain the ID's of all new subgoals (except for [current_sequent_id]). Old, currently unfinished subgoals in [additional_ids] are filtered out with the help of [pt.sequent_hash]. Except for the [current_sequent], the newly created subgoals contain no sequent text yet. This is expected to arrive soon with an [update-sequent] command. [cheated_flag] is asserted to be false, because the code assumes that a cheating command solves the current subgoal. *) let add_new_goal pt state proof_command cheated_flag current_sequent_id current_sequent_text additional_ids uninstantiated_existentials instantiated_ex_deps = assert(cheated_flag = false); let (ex_got_instantiated, new_existentials) = update_existentials pt.existential_hash uninstantiated_existentials instantiated_ex_deps in (* Update the existentials early, to have correct info in the * current sequent. *) if ex_got_instantiated <> [] then update_existential_status pt.existential_hash; let parent = match pt.current_sequent with | Some s -> s | None -> assert false in let pc = pt.window#new_proof_command state proof_command ex_got_instantiated new_existentials in let pc = (pc :> proof_tree_element) in set_children parent [pc]; let sw = pt.window#new_turnstile state current_sequent_id (Some current_sequent_text) in Hashtbl.add pt.sequent_hash current_sequent_id sw; let sw = (sw :> proof_tree_element) in let new_goal_ids_rev = list_filter_rev (fun id -> not (Hashtbl.mem pt.sequent_hash id)) additional_ids in let new_goals = List.fold_left (fun res id -> let sw = pt.window#new_turnstile state id None in Hashtbl.add pt.sequent_hash id sw; let sw = (sw :> proof_tree_element) in sw :: res) [] new_goal_ids_rev in let position_hints = match new_goals with | [] -> [[pc]] | [snd] -> [[snd; pc]; [snd]; [pc]] | snd :: rest -> let last = list_last rest in [[last; pc]; [snd; pc]; [snd]; [pc]] in let all_subgoals = sw :: new_goals in set_children pc all_subgoals; let unhash_sequent_ids = current_sequent_id :: new_goal_ids_rev in let old_current_sequent_id = pt.current_sequent_id in let old_current_sequent = parent in let old_open_goals_count = pt.open_goals_count in pt.current_sequent_id <- Some current_sequent_id; pt.current_sequent <- Some sw; pt.open_goals_count <- pt.open_goals_count + List.length new_goals; sw#mark_current; set_current_node_wrapper pt (Some sw); pt.window#set_position_hints position_hints; (* The uninstantiated existentials are displayed together with the * sequent. Therefore, if some existential got instantiated we have * to update all those sequent displays. *) if ex_got_instantiated <> [] then begin pt.window#update_sequent_existentials_info; pt.sequent_area_needs_refresh <- true; end; let message = match List.length new_goals with | 0 -> Printf.sprintf "%d open goal%s (no new)" pt.open_goals_count (if pt.open_goals_count > 1 then "s" else "") | n -> Printf.sprintf "%d open goal%s (%d new)" pt.open_goals_count (if pt.open_goals_count > 1 then "s" else "") n in pt.window#message message; pt.window#ext_dialog_add new_existentials; let undo () = pc#delete_non_sticky_external_windows; List.iter (fun s -> s#delete_non_sticky_external_windows) all_subgoals; clear_children old_current_sequent; old_current_sequent#mark_current; List.iter (fun id -> Hashtbl.remove pt.sequent_hash id) unhash_sequent_ids; List.iter (fun sw -> if sw#is_selected then pt.window#set_selected_node None) all_subgoals; if pc#is_selected then pt.window#set_selected_node None; pt.current_sequent_id <- old_current_sequent_id; pt.current_sequent <- Some old_current_sequent; pt.open_goals_count <- old_open_goals_count; List.iter (fun ex -> Hashtbl.remove pt.existential_hash ex.existential_name) new_existentials; if ex_got_instantiated <> [] then begin undo_instantiate_existentials ex_got_instantiated; update_existential_status pt.existential_hash; pt.window#update_sequent_existentials_info; pt.sequent_area_needs_refresh <- true; end; pt.window#ext_dialog_undo new_existentials; in add_undo_action pt state undo; pt.need_redraw <- true (** Add [proof_command] as final command, which solved the current goal, to the current branch. If [cheated_flag] is set, the branch is marked as cheated. This function only finishes the current branch, moving to the next open subgoal (if necessary) is done by {!internal_switch_to}. *) let finish_branch pt state proof_command cheated_flag uninstantiated_existentials instantiated_ex_deps = let (ex_got_instantiated, new_existentials) = update_existentials pt.existential_hash uninstantiated_existentials instantiated_ex_deps in let parent = match pt.current_sequent with | Some s -> s | None -> assert false in let pc = pt.window#new_proof_command state proof_command ex_got_instantiated new_existentials in let pc = (pc :> proof_tree_element) in parent#unmark_current; set_children parent [pc]; if cheated_flag then pc#mark_cheated else pc#mark_proved; let old_cheated = pt.cheated in let old_current_sequent = parent in let old_current_sequent_id = pt.current_sequent_id in let old_open_goals_count = pt.open_goals_count in let undo () = pc#delete_non_sticky_external_windows; clear_children old_current_sequent; old_current_sequent#unmark_proved_or_cheated; pt.current_sequent <- Some old_current_sequent; pt.current_sequent_id <- old_current_sequent_id; pt.open_goals_count <- old_open_goals_count; pt.cheated <- old_cheated; List.iter (fun ex -> Hashtbl.remove pt.existential_hash ex.existential_name) new_existentials; if ex_got_instantiated <> [] then begin undo_instantiate_existentials ex_got_instantiated; update_existential_status pt.existential_hash; pt.window#update_sequent_existentials_info; pt.sequent_area_needs_refresh <- true; end; pt.window#ext_dialog_undo new_existentials; in add_undo_action pt state undo; if cheated_flag then pt.cheated <- true; pt.open_goals_count <- pt.open_goals_count - 1; pt.current_sequent <- None; pt.current_sequent_id <- None; pt.window#clear_position_hints; set_current_node_wrapper pt None; if ex_got_instantiated <> [] then begin update_existential_status pt.existential_hash; pt.window#update_sequent_existentials_info; pt.sequent_area_needs_refresh <- true; end; pt.window#ext_dialog_add new_existentials; pt.need_redraw <- true (** Switch to [new_current_sequent_id], that is, mark this sequent as the current one. *) let internal_switch_to pt state new_current_sequent_id = assert(pt.current_sequent = None && pt.current_sequent_id = None); let new_current_sequent = Hashtbl.find pt.sequent_hash new_current_sequent_id in let new_current_sequent = (new_current_sequent :> proof_tree_element) in let undo () = new_current_sequent#unmark_current; pt.current_sequent_id <- None; pt.current_sequent <- None; in new_current_sequent#mark_current; set_current_node_wrapper pt (Some new_current_sequent); pt.current_sequent_id <- Some new_current_sequent_id; pt.current_sequent <- Some new_current_sequent; pt.window#clear_position_hints; add_undo_action pt state undo; pt.need_redraw <- true (** Finish the current branch with [proof_command] and switch to [current_sequent] as next current sequent. *) let finish_branch_and_switch_to pt state proof_command cheated_flag current_sequent_id additional_ids uninstantiated_existentials instantiated_ex_deps = assert(not (List.mem current_sequent_id additional_ids)); finish_branch pt state proof_command cheated_flag uninstantiated_existentials instantiated_ex_deps; internal_switch_to pt state current_sequent_id; let message = Printf.sprintf "%s (%d goal%s remaining)" (if cheated_flag then pango_markup_bold_color "Branch aborted" !cheated_gdk_color else pango_markup_bold_color "Branch finished" !proved_complete_gdk_color) pt.open_goals_count (if pt.open_goals_count > 1 then "s" else "") in pt.window#message message (* See mli for doc *) let process_current_goals state proof_name proof_command cheated_flag layer_flag current_sequent_id current_sequent_text additional_ids uninstatiated_existentials instantiated_ex_deps = (match !current_proof_tree with | Some pt -> if pt.proof_name <> proof_name then stop_proof_tree_last_selected pt state | None -> ()); let layer_flag = layer_flag || !current_proof_tree = None in let pt = match !current_proof_tree with | None -> start_new_proof state proof_name | Some pt -> assert ((iff (pt.current_sequent = None) (pt.current_sequent_id = None)) && (iff layer_flag (pt.current_sequent = None))); pt in if layer_flag then begin assert (cheated_flag = false); create_new_layer pt state current_sequent_id current_sequent_text additional_ids uninstatiated_existentials instantiated_ex_deps end else if pt.current_sequent_id <> (Some current_sequent_id) && Hashtbl.mem pt.sequent_hash current_sequent_id then finish_branch_and_switch_to pt state proof_command cheated_flag current_sequent_id additional_ids uninstatiated_existentials instantiated_ex_deps else add_new_goal pt state proof_command cheated_flag current_sequent_id current_sequent_text additional_ids uninstatiated_existentials instantiated_ex_deps (** Udate the sequent text for some sequent text and set an appropriate undo action. *) let update_sequent_element pt state sw sequent_text = sw#update_sequent sequent_text; if sw#is_selected then pt.sequent_area_needs_refresh <- true; let undo () = sw#undo_update_sequent; if sw#is_selected then pt.sequent_area_needs_refresh <- true in add_undo_action pt state undo (* See mli for doc *) let update_sequent state proof_name sequent_id sequent_text = match !current_proof_tree with | None -> raise (Proof_tree_error "Update sequent without current proof tree") | Some pt -> if pt.proof_name <> proof_name then raise (Proof_tree_error "Update sequent on other non-current proof"); try update_sequent_element pt state (Hashtbl.find pt.sequent_hash sequent_id) sequent_text with | Not_found -> raise (Proof_tree_error "Update unknown sequent") (** Leave current branch as is to prepare for switching to a different goal. *) let leave_branch pt state = assert (pt.current_sequent <> None && pt.current_sequent_id <> None); let last_node = match pt.current_sequent with | Some s -> s | None -> assert false in last_node#unmark_current; let old_current_sequent = last_node in let old_current_sequent_id = pt.current_sequent_id in let undo () = pt.current_sequent <- Some old_current_sequent; pt.current_sequent_id <- old_current_sequent_id; in add_undo_action pt state undo; pt.current_sequent <- None; pt.current_sequent_id <- None; set_current_node_wrapper pt None; pt.need_redraw <- true (* See mli for doc *) let switch_to state proof_name new_current_sequent_id = match !current_proof_tree with | None -> raise (Proof_tree_error "Switch to sequent without current proof tree") | Some pt -> if pt.proof_name <> proof_name then raise (Proof_tree_error "Switch to sequent on other proof"); match pt.current_sequent_id with | Some old_id -> assert (pt.current_sequent <> None); (* Coq generates a lot switch-to commands if you use bullets * and braces. Some of them don't actually change the current goal. *) if old_id <> new_current_sequent_id then begin leave_branch pt state; internal_switch_to pt state new_current_sequent_id; let message = Printf.sprintf "Branch changed (%d goal%s remaining)" pt.open_goals_count (if pt.open_goals_count > 1 then "s" else "") in pt.window#message message end | None -> assert (pt.current_sequent = None); internal_switch_to pt state new_current_sequent_id; let message = Printf.sprintf "%d open goal%s" pt.open_goals_count (if pt.open_goals_count > 1 then "s" else "") in pt.window#message message (* See mli for doc *) let process_branch_finished state proof_name proof_command cheated_flag uninstatiated_existentials instantiated_ex_deps = match !current_proof_tree with | None -> raise (Proof_tree_error "branch-finished without current proof tree") | Some pt -> if pt.proof_name <> proof_name then raise (Proof_tree_error "Branch finish in other proof"); assert (pt.current_sequent <> None && pt.current_sequent_id <> None); finish_branch pt state proof_command cheated_flag uninstatiated_existentials instantiated_ex_deps; let message = if pt.open_goals_count = 0 then begin let all_ex_inst = Hashtbl.fold (fun _ ex res -> res && ex.status <> Uninstantiated) pt.existential_hash true in let message_text = (if pt.cheated then "False proof finished" else "Proof finished") ^ (if all_ex_inst then "" else " (incomplete)") in let color = if pt.cheated then !cheated_gdk_color else if all_ex_inst then !proved_complete_gdk_color else !proved_incomplete_gdk_color in pango_markup_bold_color message_text color end else Printf.sprintf "%s (%d goal%s remaining)" (if cheated_flag then pango_markup_bold_color "Branch aborted" !cheated_gdk_color else pango_markup_bold_color "Branch finished" !proved_complete_gdk_color) pt.open_goals_count (if pt.open_goals_count > 1 then "s" else "") in pt.window#message message (* See mli for doc *) let process_proof_complete state proof_name = match !current_proof_tree with | None -> raise (Proof_tree_error "proof-complete without current proof tree") | Some pt -> if pt.proof_name <> proof_name then raise (Proof_tree_error "Completed other non-current proof"); let message = if pt.cheated then pango_markup_bold_color "False proof completed" !cheated_gdk_color else pango_markup_bold_color "Proof completed" !proved_complete_gdk_color in pt.window#message message; stop_proof_tree_last_selected pt state (** Delete the proof tree structure with the given name from the lists of live and not-cloned proof tree structures. This function is used for {!Proof_window.delete_proof_tree_callback}. *) let clear_proof_tree_lists proof_name = let proof_tree_list_fold_fun pts pt = if pt.proof_name = proof_name then begin pt.window#delete_proof_window; pts end else pt :: pts in original_proof_trees := List.fold_left proof_tree_list_fold_fun [] !original_proof_trees let quit_proof proof_name = (match !current_proof_tree with | None -> () | Some pt -> if pt.proof_name = proof_name then begin current_proof_tree := None; emacs_callback_stop_display (); end ); clear_proof_tree_lists proof_name let _ = delete_proof_tree_callback := quit_proof let finish_drawing () = match !current_proof_tree with | None -> () | Some pt -> if pt.sequent_area_needs_refresh then pt.window#refresh_sequent_area; if pt.need_redraw then begin pt.window#refresh_and_position; pt.window#update_ext_dialog; end; pt.sequent_area_needs_refresh <- false; pt.need_redraw <- false prooftree-0.13/INSTALL0000644000175000017500000000373113032677177013242 0ustar tewstews============================================================================ PREREQUISITES ============================================================================ Make sure you have Proof General >= 4.3pre130327 and Coq 8.4beta or better. For installation instructions see http://proofgeneral.inf.ed.ac.uk/devel and http://coq.inria.fr/coq-84 If you want to install Prooftree from sources you need OCaml with the Gtk bindings from the LablGtk2 library installed. The configure script checks if ocamlopt.opt -I +lablgtk2 lablgtk.cmxa gtkInit.cmx runs without errors. For Debian, installing the packages ocaml-nox and liblablgtk2-ocaml-dev suffice (but the package ocaml-native-compilers is strongly recommended for binary compilation). ============================================================================ INSTALLATION ============================================================================ 1. Configure with ./configure optionally supply -prefix or -bindir to set the installation directories. 2. Compile with make all 3. Acquire the necessary rights and install with make install ============================================================================ EMACS CONFIGURATION ============================================================================ Before you can enjoy prooftree you have to configure Emacs to find prooftree and use the right versions of Proof General and Coq. Of course you have to disable any other setting that select a particular Proof General or Coq version. 1. Prooftree is controlled by Proof General as a subprocess of Emacs. You therefore have to make sure Emacs loads the right version of Proof General. Put (load-file "/generic/proof-site.el") in your .emacs, where is the installation directory of your version of Proof General. ============================================================================ Local Variables: mode: indented-text fill-column: 75 End: prooftree-0.13/configure0000755000175000017500000001015513032677177014116 0ustar tewstews#!/bin/sh ############################################################################## # # Configuration script for prooftree # # Hendrik Tews Copyright (C) 2011 - 2016 # # This file is part of "prooftree". # # "prooftree" 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 3 of the # License, or (at your option) any later version. # # "prooftree" 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 in file COPYING in this or one of the parent # directories for more details. # # You should have received a copy of the GNU General Public License # along with "prooftree". If not, see . # # $Id: configure,v 1.7 2016/01/23 12:57:13 tews Exp $ # ############################################################################## root=/usr/local bindir=$root/bin mandir=$root/share/man native= ocamldep= ocamlc= prooftree= ocamldoc= lablgtkdir= force_byte="false" usage (){ echo "Usage:" echo "./configure [OPTION]..." echo echo "Recognized options are:" echo " --prefix installation prefix [/usr/local]" echo " --bindir user executables [PREFIX/bin]" echo " --mandir man pages [PREFIX/share/man]" } while : ; do case "$1" in "") break;; -help|--help) usage; exit 2;; -prefix|--prefix) bindir=$2/bin mandir=$2/share/man shift;; -bindir|--bindir) bindir=$2 shift;; -mandir|--mandir) mandir=$2 shift;; -test-byte) force_byte="true";; *) echo "Unknown option \"$1\"." 1>&2; usage; exit 2;; esac shift done # check for ocamlc ocbv=$(ocamlc -version) if [ $? -ne 0 ] ; then echo compiler ocamlc not found. echo Please install ocaml and/or adjust \$PATH exit 1 else echo ocamlc version $ocbv found. fi # check for ocamlopt.opt ocvo=$(ocamlopt.opt -version) if [ $? -eq 0 ] ; then echo ocamlopt.opt version $ocvo found. Native compilation enabled. native=true else echo ocamlopt.opt not found. Native compilation disabled. native=false fi if [ $force_byte = "true" ] ; then native=false fi if [ $native = "true" ] ; then ocamldep=ocamldep.opt ocamlc=ocamlopt.opt prooftree=prooftree.opt ocamldoc=ocamldoc.opt else ocamldep=ocamldep ocamlc=ocamlc prooftree=prooftree.byte ocamldoc=ocamldoc fi # check ocamldep ocdepv=$($ocamldep -version) if [ $? -ne 0 ] ; then echo $ocamlc exists but $ocamldep not. echo Please check your ocaml installation! exit 1 fi # check ocamldoc ocdocv=$($ocamldoc -version) if [ $? -ne 0 ] ; then echo $ocamlc exists but $ocamldoc not. echo Please check your ocaml installation! exit 1 fi # check for lablgtk check_lablgtk () { echo test $ocamlc -I $1 if [ $native = "true" ] ; then $ocamlc -o /dev/null -I $1 lablgtk.cmxa gtkInit.cmx else $ocamlc -o /dev/null -I $1 lablgtk.cma gtkInit.cmo fi } if check_lablgtk "+lablgtk2" ; then lablgtkdir="+lablgtk2" elif ocamlfind query lablgtk2 > /dev/null ; then lablgtkdir=$(ocamlfind query lablgtk2) if check_lablgtk $lablgtkdir ; then true else lablgtkdir="" fi fi if [ $lablgtkdir = "" ] ; then echo library LablGtk not found. Please install package liblablgtk2-ocaml-dev. exit 1 fi # Summary of the configuration echo echo " Configuration summary:" echo " binaries will be copied to $bindir" echo " man pages will be copied to $mandir" if [ $native = "true" ] ; then echo " native-code compilation enabled with $ocamlc" else echo " native-code compilation disabled with $ocamlc" fi echo " LablGtk2 at $lablgtkdir" # Make the Makefile sed -e "s|@BINDIR@|$bindir|" \ -e "s|@MANDIR@|$mandir|" \ -e "s|@PROOFTREE@|$prooftree|" \ -e "s|@OCAMLC@|$ocamlc|" \ -e "s|@OCAMLDEP@|$ocamldep|" \ -e "s|@OCAMLDOC@|$ocamldoc|" \ -e "s|@LABLGTKDIR@|$lablgtkdir|" \ Makefile.in > Makefile prooftree-0.13/.gitignore0000644000175000017500000000020213032677177014167 0ustar tewstews*~ *.cmi *.cmo *.cmx *.o Makefile Makefile.deps dump.odoc-dump prooftree prooftree.man.html prooftree.man.txt version.ml TAGS doc prooftree-0.13/version.mli0000644000175000017500000000207013032677177014374 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: version.mli,v 1.6 2016/01/23 12:57:15 tews Exp $ *) (** Version number. The implementation of this module is generated automatically from version.txt *) (** Prooftree version number *) val version : string prooftree-0.13/node_window.ml0000644000175000017500000002400213032677177015051 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: node_window.ml,v 1.21 2016/01/23 12:57:14 tews Exp $ *) (** Creation, display and drawing of the extra node windows *) open Util open Configuration open Draw_tree (** State class for external node windows. Objects of this class represent external windows for proof commands and sequents internally. They contain all the necessary state and methods for these windows. The creation of the window and the object as well signal connection happens outside in {!make_node_window}. *) class node_window proof_window node top_window text_window detach_button (version_label : GMisc.label option) sequent_history window_number proof_name = object (self) (** Flag whether this window is orphaned. An orphaned window has no connection to the proof tree anymore. *) val mutable orphaned = false (** Link to the proof window. Used to keep {!Proof_window.proof_window.node_windows} up to date and to redraw the tree when a node window is deleted. This link gets deleted when this node window becomes orphaned. *) val mutable proof_window = Some proof_window (** Link to the proof-tree element. Used to keep {!Draw_tree.proof_tree_element.external_windows} up to date. This link is deleted when this node becomes orphaned. *) val mutable node = Some node (** Local copy of the sequent text history. Used for the feature that sticky node windows don't change their display and history. For proof commands, this holds always just the current proof command. *) val mutable sequent_history = sequent_history (** The element of the sequent history that is currently on display. This counts forwards, starting with 0. 0 means the current version. For proof-command windows, this is always 0, to always select the only element of the history list. *) val mutable sequent_history_pos = 0 (** Number of this node window. Used to correlate node windows with the proof-tree display. *) method window_number = window_number (** Make this node window orphaned. A orphaned node window is not connected with the proof tree any more. Its Sticky button is disabled. *) method private orphan_node_window = if not orphaned then begin (match node with | Some node -> node#delete_external_window (self :> external_node_window); top_window#set_title ((match node#node_kind with | Turnstile -> "Orphaned sequent of " | Proof_command -> "Orphaned tactic of " ) ^ proof_name) | None -> assert false ); (match proof_window with | Some proof_window -> proof_window#delete_node_window self; proof_window#invalidate_drawing_area; | None -> assert false ); detach_button#misc#set_sensitive false; node <- None; proof_window <- None; orphaned <- true; end (** Delete and destroy this node window. *) method delete_node_window () = self#orphan_node_window; top_window#destroy() (** Key event callback for deleting and destroying this node window. Returns [true] to indicate that the key has been processed. *) method private delete_node_window_event _ = self#delete_node_window (); true (** Delete this node window if it is not detached. Needs to be called when the corresponding element in the proof-tree display is deleted. *) method delete_attached_node_window = if not detach_button#active then self#delete_node_window () else self#orphan_node_window (** Callback for key events. Deals only with 'Q' and 'q'. *) method key_pressed_callback ev = match GdkEvent.Key.keyval ev with | ks when (ks = GdkKeysyms._Q || ks = GdkKeysyms._q) -> self#delete_node_window_event ev | _ -> false (** Reconfigure and redraw the node window. Needs to be called when the configuration has been changed. Actually only the font of the buffer text is changed. *) method configuration_updated = text_window#misc#modify_font !sequent_font_desc; GtkBase.Widget.queue_draw top_window#as_widget (** Display the element from {!sequent_history} that {!sequent_history_pos} denotes. Update the history label. *) method private display_content = text_window#buffer#set_text (match sequent_history with | [] -> "waiting for sequent text" | _ -> List.nth sequent_history sequent_history_pos); (match version_label with | None -> () | Some label -> let sequent_history_len = List.length sequent_history in label#set_label (Printf.sprintf "version %d of %d versions" (sequent_history_len - sequent_history_pos) sequent_history_len) ) (** Update the content in the text buffer of this node window. The argument tells how much the history length grew (greater zero) or shrunk (lesser zero). *) method update_content new_history = if not detach_button#active then begin if sequent_history_pos > 0 then begin let old_length = List.length sequent_history in let new_length = List.length new_history in sequent_history_pos <- max 0 (new_length - (old_length - sequent_history_pos)) end; sequent_history <- new_history; self#display_content end (** Callback for the sequent-history-backwards button. *) method history_back_click () = sequent_history_pos <- min (List.length sequent_history - 1) (sequent_history_pos + 1); self#display_content (** Callback for the sequent-history-forwards button. *) method history_for_click () = sequent_history_pos <- max 0 (sequent_history_pos - 1); self#display_content (** Callback for *) method detach_button_toggle () = if not detach_button#active then match node with | None -> assert false | Some sn -> self#update_content sn#sequent_text_history end (** Create and initialize a new external node window. Composes the GTK window, fills the initial content, creates the contolling object and connects hooks and signals. *) let make_node_window proof_window proof_name node window_number = let top_window = GWindow.window () in let top_v_box = GPack.vbox ~packing:top_window#add () in let scrolling = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:(top_v_box#pack ~expand:true) () in let text_win = GText.view ~editable:false ~cursor_visible:false ~packing:scrolling#add () in text_win#misc#modify_font !sequent_font_desc; let context = text_win#misc#pango_context in let metrics = context#get_metrics() in let char_width = GPango.to_pixels(metrics#approx_char_width) in let layout = context#create_layout in Pango.Layout.set_text layout "X"; let (_, char_height) = Pango.Layout.get_pixel_size layout in let lines = min (Util.number_of_lines node#displayed_text) !current_config.node_window_max_lines in (* * text_win#misc#set_size_request * ~width:(char_width * 60) ~height:(char_height * lines) (); *) (* text_win#misc#set_size_chars ~width:60 ~height:lines (); *) top_window#set_default_size ~width:(char_width * 80) ~height:(char_height * (lines + 2)); let button_h_box = GPack.hbox ~spacing:5 ~packing:top_v_box#pack () in let dismiss_button = GButton.button ~stock:`CLOSE ~packing:(button_h_box#pack ~from:`END) () in let detach_button = (* XXX find stock item *) GButton.toggle_button ~label:"Detach" ~packing:button_h_box#pack () in let sequent_history = node#sequent_text_history in let (version_back_button, version_label, version_for_button) = match node#node_kind with | Proof_command -> (None, None, None) | Turnstile -> let version_back_button = GButton.button ~stock:`GO_BACK ~packing:button_h_box#pack () in let sequent_history_len = List.length sequent_history in let version_label = GMisc.label ~text:(Printf.sprintf "version %d of %d versions" sequent_history_len sequent_history_len) ~packing:button_h_box#pack () in let version_for_button = GButton.button ~stock:`GO_FORWARD ~packing:button_h_box#pack () in (Some version_back_button, Some version_label, Some version_for_button) in let node_window = new node_window proof_window node top_window text_win detach_button version_label sequent_history window_number proof_name in node#register_external_window (node_window :> external_node_window); let title_start = match node#node_kind with | Proof_command -> "Tactic " | Turnstile -> "Sequent " in top_window#set_title (title_start ^ window_number ^ " of " ^ proof_name); ignore(top_window#event#connect#key_press ~callback:node_window#key_pressed_callback); text_win#buffer#set_text node#displayed_text; ignore(detach_button#connect#toggled ~callback:node_window#detach_button_toggle); (match node#node_kind with | Proof_command -> () | Turnstile -> ignore((access_option version_back_button)#connect#clicked ~callback:node_window#history_back_click); ignore((access_option version_for_button)#connect#clicked ~callback:node_window#history_for_click); ); ignore(top_window#connect#destroy ~callback:node_window#delete_node_window); ignore(dismiss_button#connect#clicked ~callback:node_window#delete_node_window); top_window#show (); node_window prooftree-0.13/ChangeLog0000644000175000017500000005314113032677177013763 0ustar tewstews2017-01-03 Hendrik Tews * prepare changes.html for release 2017-01-02 Hendrik Tews * compile with -safe-string 2017-01-02 Hendrik Tews * update doc 2016-12-28 Hendrik Tews * gitignore and some debugging code in comments 2016-01-23 Hendrik Tews * update copyright 2016-01-22 Hendrik Tews * add tests for cycle/swap/revgoals, Grab Existentials/Unshelve, giveup 2016-01-21 Hendrik Tews * update evar parsing for 8.5 2016-01-18 Hendrik Tews * disable implicit optional argument elimination warning 48 2016-01-18 Hendrik Tews * fix deprecated or 2016-01-17 Hendrik Tews * fix 4.02 compilation problem 2016-01-16 Hendrik Tews * crash fix ?? 2013-08-11 Hendrik Tews * rename delete_non_sticky_node_window 2013-08-10 Hendrik Tews * let the cancel button reset the configuration 2013-08-10 Hendrik Tews * display a warning for config file version errors 2013-08-10 Hendrik Tews * catch input log file opening errors 2013-08-08 Hendrik Tews * close old PG log file, before changing it 2013-08-08 Hendrik Tews * update doc 2013-08-08 Hendrik Tews * config window without apply 2013-08-05 Hendrik Tews * use stock items for most buttons 2013-08-04 Hendrik Tews * describe prooftree notification messages and other doc fixes 2013-08-03 Hendrik Tews * show selected menu entry 2013-08-03 Hendrik Tews * update INSTALL, README; add compatibility file 2013-08-03 Hendrik Tews * update man page 2013-08-02 Hendrik Tews * quit prooftree when closing -config or -help-dialog windows * update help window text 2013-08-01 Hendrik Tews * add history list in external sequent windows 2013-07-23 Hendrik Tews * fix wrong existential info in external node windows 2013-07-18 Hendrik Tews * fix title of orphaned node windows * don't update content of sticky node windows 2013-05-17 Hendrik Tews * release version 0.12 on 2013-05-17 13:39:12 UTC 2013-05-17 Hendrik Tews * prepare changes.html for release 2013-05-17 Hendrik Tews * prepare changes.html for release 2013-03-28 Hendrik Tews * copyright 2013 2013-03-27 Hendrik Tews * change required Proof General version to 4.3pre130327 2013-03-11 Hendrik Tews * another clone regression 2013-01-30 Hendrik Tews * fix clone regression 2013-01-30 Hendrik Tews * after release changes 2013-01-21 Hendrik Tews * release version 0.11 on 2013-01-21 16:43:11 UTC 2013-01-21 Hendrik Tews * prepare changes.html for release 2013-01-21 Hendrik Tews * misc changes towards release 2013-01-21 Hendrik Tews * implement proof script insertion 2013-01-20 Hendrik Tews * implement undo * have a separate context menu * add headings in help window 2013-01-18 Hendrik Tews * add scrollbar to evar table * add keybindings to evar window * add default number of lines of evar window to config record, but stay at config file version 04 2013-01-17 Hendrik Tews * fix embarrassing evar positioning bug 2013-01-17 Hendrik Tews * try ocamlfind in configure for lablgtk2 * fix ocamldoc warnings 2013-01-17 Hendrik Tews * write ocamldoc comments 2013-01-17 Hendrik Tews * delete newlines in short proof commands 2013-01-17 Hendrik Tews * center layers 2013-01-17 Hendrik Tews * warning for more than one initial goal 2013-01-17 Hendrik Tews * integrate new config values in configuration dialog 2013-01-17 Hendrik Tews * support Grab Existential Variables * display several layers with several proof trees each * protocol change, but stay at version 3 * new config file version 04 2013-01-15 Hendrik Tews * differentiate proof complete message according to extistential status 2013-01-15 Hendrik Tews * doc fixes 2013-01-14 Hendrik Tews * fix paragraphs in help window 2013-01-14 Hendrik Tews * support for bullets and braces * protocol change to version 3 - change proof-finished into branch-finished and adapt its meaning * introduce proof-tree states without current sequent and permit navigation commands without current sequent 2013-01-03 Hendrik Tews * fix surviver reuse bug introduced yesterday 2013-01-02 Hendrik Tews * improve positioning: make parents and new siblings visible 2013-01-02 Hendrik Tews * fix assertion when undo states are incorrect because of insertions 2012-09-12 Hendrik Tews * die with a sensible message in case Proof is missing * polish man page and add limitations section 2012-08-08 Hendrik Tews * fix clone deletes primary window problem 2012-07-11 Hendrik Tews * fix an embarrassing control flow bug in input.ml 2012-05-14 Hendrik Tews * release version 0.10 on 2012-05-14 21:11:13 UTC 2012-05-14 Hendrik Tews * prepare changes.html for release 2012-05-14 Hendrik Tews * more debian packaging fixes 2012-05-14 Hendrik Tews * prepare release * adjust debian stuff 2012-05-14 Hendrik Tews * use odoc_xref tags for doc links into other libraries 2012-03-11 Hendrik Tews * fix assertion in callback 2012-03-08 Hendrik Tews * internal documentation complete 2012-03-07 Hendrik Tews * lots of internal documentation 2012-03-06 Hendrik Tews * ignore overridden methods warning as long as we support 3.11 * check-doc makefile goal * add minimal support for HOL Light * add and fix some doc comments 2012-01-29 Hendrik Tews * unescaped string end-of-line warning 2012-01-11 Hendrik Tews * structured copyright * doc-base entry 2012-01-11 Hendrik Tews * try watch again 2012-01-11 Hendrik Tews * try watch again 2012-01-11 Hendrik Tews * try out-of-date-standards-version 2012-01-11 Hendrik Tews * try lintian possible-documentation, Debian-watch-file-is-missing, out-of-date-standards-version 2012-01-11 Hendrik Tews * prepare debian/changelog for next release 2012-01-04 Hendrik Tews * release version 0.9 on 2012-01-04 20:39:05 UTC 2012-01-04 Hendrik Tews * prepare changes.html for release 2012-01-04 Hendrik Tews * fix debian/changelog 2012-01-04 Hendrik Tews * fix case where some existential is instantiated with the last proof command * protocol change to version 2 - rename proof-complete into proof-finished and add existential info - add proof-complete message 2012-01-03 Hendrik Tews * release version 0.8 on 2012-01-03 10:11:10 UTC 2012-01-03 Hendrik Tews * prepare changes.html for release 2012-01-02 Hendrik Tews * separate INSTALL * make-release update 2012-01-02 Hendrik Tews * update README, changes, man page 2012-01-02 Hendrik Tews * clean up copyright * packaging in make-release 2012-01-02 Hendrik Tews * DESTDIR * copyright 2012 * add make-release * add debian subdir 2012-01-02 Hendrik Tews * protocol change: configure message required as first message * set protocol version to 1 * simplify Elisp communication primitives 2012-01-01 Hendrik Tews * delete proof-full-annotation-internal (as Dave wished) (elisp only) * fix strange start problem 2011-12-31 Hendrik Tews * protocol change: first fixed length line tells length of second line with command 2011-12-25 Hendrik Tews * put coq specific code into coq.ml 2011-12-21 Hendrik Tews * new option -help-dialog * update builtin help man page 2011-12-21 Hendrik Tews * handle display quit and prooftree process termination 2011-12-20 Hendrik Tews * delete other_open_goals field from internal state 2011-12-20 Hendrik Tews * fix quit problem (which makes another quit problem more obvious) * improve evar printing 2011-12-19 Hendrik Tews * elisp only: - proof-tree-configured for protecting menu and entry function - send undo when leaving buffer - fix proof-tree start without a proof shell - simplify/clear unused code - fix initialization problem - put update-goal into callback - don't use numbers as flags any more - clear state when proof is finished/quit - fix bug introduced earlier today - use Show Goal, flush coq-sequent-id-assoc - prooftree updates now inaccessible sequents! - improve starting prooftree in the middle of a proof - assert-until-point no longer called inside the process filter - improve error handling when prooftree cannot be found 2011-12-16 Hendrik Tews * some elisp-only changes - call delayed proof-tree handler only conditionally - simplify proof-tree-current-proof, flush its undo history - new prover option proof-tree-find-begin-of-unfinished-proof for finding the starting point of a theorem - specify proof-tree-get-proof-info as function without arguments - flush unused cmd argument from proof-tree-urgent-action 2011-12-09 Hendrik Tews * set proof-tree background to GTK prelight default * adjust default colors 2011-12-09 Hendrik Tews * put detailed existential status into the existential record, which is updated lazily before every redraw * proof tree uses color for partial instantiation 2011-12-09 Hendrik Tews * using column in evar window * new color for partially instantiated evar's * new config file version 03 * use colors in evar window * update configuration in evar window 2011-12-08 Hendrik Tews * fix -w Ae warnings * use an existential hash in the proof-tree record and link dependencies for instantiated existentials 2011-12-08 Hendrik Tews * more documentation * move to coq trunk - protocol change: current-goals gets the complete evar info as string, which is parsed inside prooftree - added coq specific evar info parser * new option -config 2011-12-06 Hendrik Tews * abandon coq patches, work with coq trunk now (elisp only) Many thanks to Arnaud Spiwack for his dependent evar patch! * use match-string-no-properties instead of buffer-substring-no-properties (elisp only) 2011-11-01 Hendrik Tews * release version 0.7 on 2011-11-01 13:23:57 UTC 2011-11-01 Hendrik Tews * prepare changes.html for release 2011-11-01 Hendrik Tews * notebook for configuration 2011-11-01 Hendrik Tews * help text / man page for existential dialog 2011-11-01 Hendrik Tews * fix state-number simplification from 2011-09-27 2011-11-01 Hendrik Tews * fix clone existentials bug 2011-10-28 Hendrik Tews * existential variable window/dialog * fix rounding bug with width and subtree_width 2011-10-24 Hendrik Tews * some more doc strings 2011-10-22 Hendrik Tews * use a different color for proved branches with non-instantiated existential variables * some more doc strings 2011-10-20 Hendrik Tews * manage uninstantiated existential variables * change coq patch to print the uninstantiated existentials * change communication protocol to send the list of open existentials to prooftree * change Proof General to extract and send uninstantiated existentials * proof-tree nodes have now a list of existential variables, which is changed in place, when they get instantiated * change sequent and proof-command displays to list open existentials * update these displays as necessary 2011-10-07 Hendrik Tews * fix full-annotation problem (elisp only) 2011-10-04 Hendrik Tews * move recent-changes marker in sync with website 2011-10-04 Hendrik Tews * release version 0.6 on 2011-10-04 10:26:05 UTC 2011-10-04 Hendrik Tews * make-bundle fix 2011-10-04 Hendrik Tews * prepare changes.html for release 2011-09-27 Hendrik Tews * simplify state numbers 2011-09-23 Hendrik Tews * fix bug of not properly deleted proof tree windows and structures 2011-09-15 Hendrik Tews * fix a current node position bug * some more doc strings 2011-08-12 Hendrik Tews * fix to delete external node windows when retracting * improve handling of orphaned node windows 2011-08-11 Hendrik Tews * release version 0.5 on 2011-08-11 13:53:56 UTC 2011-08-11 Hendrik Tews * prepare changes.html for release 2011-08-11 Hendrik Tews * small fix 2011-08-11 Hendrik Tews * changes towards release 2011-08-11 Hendrik Tews * man page 2011-08-10 Hendrik Tews * treat common config file errors 2011-08-10 Hendrik Tews * sequent tooltips and more tool tip config 2011-08-10 Hendrik Tews * change default colors * show current menu item * improve help 2011-08-10 Hendrik Tews * improve makefile and configure 2011-08-06 Hendrik Tews * tooltips with complete proof command 2011-08-04 Hendrik Tews * external node window height configurable 2011-08-04 Hendrik Tews * initial size of sequent window configurable 2011-08-01 Hendrik Tews * improve save button 2011-08-01 Hendrik Tews * save/restore buttons in configuration dialog 2011-07-31 Hendrik Tews * change colors in configuration record into RGB triplets 2011-07-30 Hendrik Tews * apply and ok in configuration window 2011-07-29 Hendrik Tews * honor default size in configuration record 2011-07-29 Hendrik Tews * honor tooltips in configuration record 2011-07-29 Hendrik Tews * honor colors in configuration record 2011-07-28 Hendrik Tews * honor fonts in configuration record 2011-07-28 Hendrik Tews * configuration dialog layout finished, no effects yet 2011-07-23 Hendrik Tews * help and exit menu items 2011-07-21 Hendrik Tews * add menu with about dialog 2011-07-20 Hendrik Tews * fix different line length problem 2011-07-18 Hendrik Tews * invert dragging direction 2011-07-13 Hendrik Tews * move proof tree by dragging with mouse 1 2011-07-12 Hendrik Tews * internal documentation of main, input 2011-07-10 Hendrik Tews * display external node windows on double click or shift click 2011-07-08 Hendrik Tews * improve current node positioning 2011-07-06 Hendrik Tews * fix resize behaviour of node windows * add message label with some status information 2011-06-14 Hendrik Tews * release version 0.4 on 2011-06-14 11:26:01 UTC 2011-06-14 Hendrik Tews * prepare changes.html for release 2011-06-08 Hendrik Tews * another release fix 2011-06-08 Hendrik Tews * small release fix 2011-06-08 Hendrik Tews * prepare changes.html for release 2011-06-08 Hendrik Tews * update coq version number in README's 2011-05-30 Hendrik Tews * color cheated commands/branches in red 2011-05-30 Hendrik Tews * clone button 2011-05-28 Hendrik Tews * update existentials in external windows 2011-05-27 Hendrik Tews * external node windows on mouse button 2 * window titles 2011-05-26 Hendrik Tews * prooftree toolbar and menu entry (emacs lisp only) 2011-05-26 Hendrik Tews * start prooftree in the middle of a proof (just emacs-lisp changes) * kill proof tree window from emacs * let windows survive bulk undo's and change their state accordingly 2011-05-12 Hendrik Tews * clear sequent window when undoing the selected proof command 2011-04-21 Hendrik Tews * release version 0.3 on 2011-04-21 14:43:35 UTC 2011-04-21 Hendrik Tews * make-bundle fix 2011-04-21 Hendrik Tews * prepare changes.html for release 2011-04-21 Hendrik Tews * new protocol command switch-to * Coq's Focus/Unfocus work 2011-04-20 Hendrik Tews * release version 0.2 on 2011-04-20 20:36:37 UTC 2011-04-20 Hendrik Tews * another make-bundle fix 2011-04-20 Hendrik Tews * prepare changes.html for release 2011-04-20 Hendrik Tews * make-bundle fix 2011-04-20 Hendrik Tews * prepare changes.html for release 2011-04-20 Hendrik Tews * existential variables are now updated (which required only Emacs lisp changes) * fix a number of cases when the sequent window showed invalid or non-existing sequent text 2011-04-18 Hendrik Tews * release version 0.1 2011-04-18 Hendrik Tews * undo release * makefile fix 2011-04-18 Hendrik Tews * minor 2011-04-18 Hendrik Tews * make-bundle changes 2011-04-18 Hendrik Tews * small improvements 2011-04-18 Hendrik Tews * various README's, make-bundle 2011-04-18 Hendrik Tews * GPL 3 2011-04-18 Hendrik Tews * configure 2011-04-15 Hendrik Tews * fix bug with new subgoals and their order 2011-04-15 Hendrik Tews * scroll sequent window to bottom 2011-04-15 Hendrik Tews * redesign communication protocol (send complete states now) * fix idle proof command problem 2011-04-13 Hendrik Tews * privatized non-public methods * some module interface restrictions 2011-04-13 Hendrik Tews * license 2011-04-13 Hendrik Tews * truncate long proof commands 2011-04-12 Hendrik Tews * fix undo for unaffected proofs 2011-04-12 Hendrik Tews * states and proper undo * proper proof finish 2011-04-06 Hendrik Tews * mouse button 1 * current/selected node drawing * use of sequent window 2011-04-05 Hendrik Tews * parsing input, first version of communication protocol * reposition to current node * colors prooftree-0.13/prooftree.10000644000175000017500000003273613032677177014307 0ustar tewstews.\" groff -man -Tascii prooftree.1 .\" .TH PROOFTREE 1 "August 2011" PROOFTREE "User Manuals" .SH NAME prooftree \- proof-tree display for Proof General .SH SYNOPSIS .B prooftree \fR[\fIOptions...\fR] .SH DESCRIPTION .\" ============= paragraph general purpose =================================== .B Prooftree visualizes proof trees during proof development with .B Proof General\fR. Currently it only works for \fBCoq\fR, though adding support for other proof assistants should be relatively easy. .\" ========================================================================== .P To start a proof-tree display, hit the .B Prooftree icon in the .B Proof General tool-bar or select the menu entry .I Proof-General -> .I Start/Stop Prooftree or type .I C-c C-d (which runs .I proof-tree-external-display-toggle\fR). Inside a proof, this will immediately start a proof-tree display for the current proof. Outside a proof, .B Proof General remembers to start the proof-tree display for the next proof. .\" ========================================================================== .P Under normal circumstances .B Prooftree is started by .B Proof General as an .B Emacs subprocess. The user interacts with .B Prooftree only through the graphical user interface. A substantial part of the proof-tree visualization task is done by .B Proof General\fR. Therefore not only the .B Prooftree command line arguments but also other aspects can only be configured inside .B Proof General\fR, see .B Proof General Customization below. .\" .\" ========================================================================== .\" ================ Options ================================================= .\" ========================================================================== .\" .SH OPTIONS .\" ======================================= -help ============================ .IP "-help" Print synopsis and exit. .\" ======================================= -config ========================== .IP "-config" Open the configuration dialog on startup (if you want to change the configuration without starting .B Proof General\fR). .\" ======================================= -geometry ======================== .IP "-geometry \fIspec\fR" Sets the X geometry of the main window. .I spec is a standard X geometry string in the form \fIxpos\fRx\fIypos\fR[+\fIxoff\fR[+\fIyoff\fR]]. .\" ======================================= -tee ============================= .IP "-tee \fIfile\fR" Write all input to .I file (usually for debugging purposes). .\" ======================================= -debug =========================== .IP "-debug" Provide more details on errors. .\" ======================================= -help-dialog ===================== .IP "-help-dialog" Open the help dialog on startup. Mainly useful for proofreading the help text. .\" .\" ========================================================================== .\" ================ Main Window ============================================= .\" ========================================================================== .\" .SH MAIN PROOF DISPLAY .B Prooftree opens one window for each proof that it is requested to display. This window contains the proof-tree graph and a small display for sequents and proof commands. .\" ========================================================================== .SS Colors The branches in the proof-tree graph are colored according to their state. .B Prooftree distinguishes between the following states. .IP "current (blue by default)" The current branch is the branch from the root of the proof tree to the current goal. .IP "unproven (default foreground color)" A branch is unproven if it contains open proof goals. .IP "proved incomplete (cyan by default)" An incompletely proved branch has its proof finished, but some of the existential variables that have been introduced in this branch are not (yet) instantiated. .IP "proved partially (dark green by default)" In a partially proved branch all existential variables of the branch itself are instantiated, but some of those instantiations contain existential variables that are not (yet) instantiated. .IP "proved complete (green by default)" A branch is proved complete if all its existential variables are instantiated with terms that themselves do not contain any existential variables. .IP "cheated (red by default)" A cheated branch contains a cheating proof command, such as .I admit\f. .P The colors as well as many other .B Prooftree parameters can be changed in the .B Prooftree Configuration Dialog (see below). .\" ========================================================================== .SS Navigation When the proof tree grows large one can navigate by a variety of means. In addition to scroll bars and the usual keys one can move the proof tree by dragging with mouse button 1 pressed. By default, dragging moves the viewport (i.e., the proof tree underneath moves in the opposite direction). After setting a negative value for .I Drag acceleration in the .B Prooftree Configuration Dialog\fR, dragging will move the proof tree instead (i.e, the proof tree moves in the same direction as the mouse). .\" ========================================================================== .SS Sequent Display The sequent display below the proof tree normally shows the ancestor sequent of the current goal. With a single left mouse click one can display any goal or proof command in the sequent display. A single click outside the proof tree will switch back to default behavior. The initial size of the sequent display can be set in the .B Prooftree Configuration Dialog\fR. A value of 0 hides the sequent display. .\" ========================================================================== .SS Tool Tips Abbreviated proof commands and sequents are shown in full as tool tips when the mouse pointer rests over them. Both, the tool tips for abbreviated proof commands and for sequents can be independently switched off in the .B Prooftree Configuration Dialog\fR. The length at which proof commands are abbreviated can be configured as well. .\" ========================================================================== .SS Additional Displays A double click or a shift-click displays any goal or proof command in an additional window. These additional windows are automatically updated, for instance, if an existential variable is instantiated. For additional sequent displays one can browse the instantiation history of the sequent using the forward and backward buttons. These additional windows can be .I detached from the proof tree. A detached display is neither automatically updated nor automatically deleted. .\" ========================================================================== .SS Existential Variables .B Prooftree keeps track of existential variables, whether they have been instantiated and whether they depend on some other, not (yet) instantiated existential. It uses different colors for proved branches that contain non-instantiated existential variables and branches that only depend on some not instantiated existential. The list of currently not (yet) instantiated existential variables is appended to proof commands and sequents in tool-tips and the other displays. .\" ========================================================================== .P The .B Existential Variable Dialog displays a table with all existential variables of the current proof and their dependencies. Each line of the table contains a button that marks the proof command that introduced this variable (with yellow background, by default) and, if present, the proof command that instantiated this variable (with orange background, by default). .\" ========================================================================== .SS Main Menu The .I Menu button displays the main menu. The .I Clone item clones the current proof tree in an additional window. This additional window continues to display a snapshot of the cloned proof tree, no matter what happens with the original proof. .\" ========================================================================== .P The .I Show current and .I Show selected items move the viewport of the proof tree such that the current proof goal, or, respectively, the selected node will be visible (if they exist). .\" ========================================================================== .P The .I Exit item terminates .B Prooftree and closes all proof-tree displays. .\" ========================================================================== .P The remaining three items display, respectively, the .B Prooftree Configuration Dialog\fR, and the .B Help and .B About windows. .\" ========================================================================== .SS Context Menu A right click displays the .I Context Menu\fR, which contains additional items. .\" ========================================================================== .P The item .I Undo to point is active over sequent nodes in the proof tree. There, it sends an retract or undo request to Proof General that retracts the scripting buffer up to that sequent. .\" ========================================================================== .P The items .I Insert command and .I Insert subproof are active over proof commands. They sent, respectively, the selected proof command or all proof commands in the selected subtree, to Proof General, which inserts them at point. .\" .\" ========================================================================== .\" ================ Configuration =========================================== .\" ========================================================================== .\" .SH CONFIGURATION .SS Prooftree Configuration Dialog The .I Save button stores the current configuration (as marshaled .B OCaml record) in .I ~/.prooftree\fR, which will overwrite the built-in default configuration for the following .B Prooftree runs. The .I Revert button loads and applies the saved configuration. The .I Cancel and .I OK buttons close the dialog, but .I Cancel additionally resets the configuration to the state before the start of the dialog. To avoid opening partial file names, the .I Log Proof General input check box is deactivated when typing the log file name. .\" ========================================================================== .SS Proof General Customization The location of the .B Prooftree executable and the command line arguments are in the customization group .I proof-tree\fR. Prover specific points, such as the regular expressions for navigation and cheating commands are in the customization group .I proof-tree-internals\fR. To visit a customization group, type .I M-x customize-group followed by the name of the customization group inside .B Proof General\fR. .\" .\" ========================================================================== .\" ================ Limitations ============================================= .\" ========================================================================== .\" .SH LIMITATIONS For .B Coq >= 8.5, existential variables in .B Prooftree are severely broken because .B Coq does not provide the necessary information, see .B Coq bug 4504. .\" ========================================================================== .P In .B Coq\fR, proofs must be started with command .I Proof\fR, which is the recommended practice anyway (see Coq problem report 2776). .\" ========================================================================== .P In additional sequent displays, the information about existential variables is only shown for the latest version of the sequent and not for older versions in the instantiation history. The current communication protocol between .B Proof General and .B Prooftree does not permit more. .\" .\" ========================================================================== .\" ================ Prerequisites =========================================== .\" ========================================================================== .\" .SH PREREQUISITES This version of .B Prooftree requires .B Coq 8.4beta or better and .B Proof General 4.3pre130327 or better. .\" .\" ========================================================================== .\" ================ Files =================================================== .\" ========================================================================== .\" .SH FILES .IP "~/.prooftree" Saved .B Prooftree configuration. Is loaded at application start-up for overwriting the built-in default configuration. Must contain a marshaled .B OCaml configuration record. .\" .\" ========================================================================== .\" ================ SEE ALSO ================================================ .\" ========================================================================== .\" .SH SEE ALSO .TP The \fBProoftree\fR web page, \fIhttp://askra.de/software/prooftree/\fR .TP The \fBProof General Adapting Manual\fR contains information about adapting .B Prooftree for a new proof assistant (see .I http://proofgeneral.inf.ed.ac.uk/adaptingman-latest.html\fR). .\" .\" ========================================================================== .\" ================ Credits ================================================= .\" ========================================================================== .\" .SH CREDITS .B Prooftree has been inspired by the proof tree display of .B PVS\fR. .\" .\" ========================================================================== .\" ================ Author ================================================== .\" ========================================================================== .\" .SH AUTHOR Hendrik Tews prooftree-0.13/main.ml0000644000175000017500000001001113032677177013454 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: main.ml,v 1.23 2016/01/23 12:57:14 tews Exp $ *) (* (setq proof-tree-arguments '("-tee" "/tmp/tews/ptlog")) (setq proof-tree-program "/home/tews/bin/teeprooftree") *) (* let _ = Configuration.tee_input_file := Some "/tmp/tews/proof-tree-input" *) (** Main --- Argument parsing and program start *) open Util open Gtk_ext open Configuration open Help_window open Input (**/**) module U = Unix (**/**) (** Master hook to be called when the configuration has been updated. Reconfigures the complete program to reflect the changes in the current configuration. This function is stored into {!Configuration.configuration_updated_callback}. *) let configuration_updated () = Proof_tree.configuration_updated (); Input.configuration_updated () let _ = configuration_updated_callback := configuration_updated (** Argument list for [Arg.parse] *) let arguments = Arg.align [ ("-config", Arg.Set start_config_dialog, " display the configuration dialog on startup"); ("-geometry", Arg.Set_string Configuration.geometry_string, " X geometry"); ("-help-dialog", Arg.Set start_help_dialog, " display the help dialog on startup"); ("-tee", Arg.String (fun s -> current_config := {!current_config with copy_input = true; copy_input_file = s} ), "file save input in file"); ("-debug", Arg.Unit (fun () -> current_config := {!current_config with debug_mode = true} ), " print more details on errors"); ] (** Function for anonymous arguments. Terminates the program with exit status 1. *) let anon_fun s = Printf.eprintf "unrecognized argument %s\n" s; exit 1 (** Main function without exception handling. Performs the following actions: - parses command line arguments - registers {!Input.parse_input_callback_ex} as callback for [stdin] in the GTK main loop - print a hello world message to [stdout] - start the GTK main loop *) let main () = try_load_config_file (); Arg.parse arguments anon_fun "prooftree"; (try setup_input(); with | Log_input_file_error msg -> run_message_dialog (Printf.sprintf "Prooftree startup error: Opening the input logging file \ failed with:\n %s\nDisabeling input logging." msg) `WARNING; update_configuration_record {!current_config with copy_input = false}; setup_input() ); Printf.printf ("Prooftree version %s awaiting input on stdin.\n" ^^ "Entering LablGTK main loop ...\n\n%!") Version.version; if !start_config_dialog then Configuration.show_config_window (); if !start_help_dialog then show_help_window (); GMain.Main.main () (** Real main function, which is just an exception handling wrapper around [main]. *) let main_ex () = try Printexc.record_backtrace true; main() with | e -> let backtrace = Printexc.get_backtrace() in prerr_string "\nFatal error: escaping exception "; prerr_endline (Printexc.to_string e); (match e with | U.Unix_error(error, _func, _info) -> Printf.eprintf "%s\n" (U.error_message error) | _ -> () ); prerr_endline ""; prerr_string backtrace; prerr_endline ""; exit 2 let _ = main_ex() prooftree-0.13/input.ml0000644000175000017500000011235313032677177013703 0ustar tewstews(* * prooftree --- proof tree display for Proof General * * Copyright (C) 2011 - 2016 Hendrik Tews * * This file is part of "prooftree". * * "prooftree" 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 3 of the * License, or (at your option) any later version. * * "prooftree" 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 in file COPYING in this or one of the parent * directories for more details. * * You should have received a copy of the GNU General Public License * along with "prooftree". If not, see . * * $Id: input.ml,v 1.43 2016/01/23 12:57:14 tews Exp $ *) (** Reading commands from nonblocking stdin *) (***************************************************************************** *****************************************************************************) (** {2 Communition Protocol with Proof General} The communication protocol with Proof General is mostly one-way: Proof General sends display messages to Prooftree and Prooftree never requests information for the proof-tree display from Proof General. Prooftree sends a notification to Proof General when the proof-tree window is closed. It also sends proof commands to Proof General on request of the user. The communication protocol between Proof General and Prooftree is split into two parts: The display messages, which are sent from Proof General to Prooftree and the notification messages, which are sent from Prooftree to Proof General. {3 Display Messages} The protocol for the display messages is designed such that Prooftree always knows in advance how many bytes it has to read until the end of a message. All display messages consist of {ul {- a first line of exactly 16 bytes (including the new line) of the form "second line 157\n", where the number is the length of the second line (including its final newline).} {- a second line containing the display command and the length of the additional data sections, if the command has data sections.} {- the data sections (if any), where the last character of each data sections is a newline.} } All data is UTF-8 encoded. Some data sections have a prover specific format. Currently, [prooftree] only supports Coq. In the following list of commands, ``%d'' stands for a positive integer and %s for a string which contains no white space. ``\{cheated | not-cheated\}'' denotes the alternative of either ``cheated'' or ``not-cheated''. An integer following the keyword state is a state number. An integer following some xxx-bytes denotes the number of bytes of the next section, including the final newline of that section. A ``[ \ ]'' at the end of a line denotes line continuation without newline. Prooftree understands the following display commands in the following format. The first 16-byte line that preceeds every display-command line is ommitted in the following list. {ul {- {v configure for "PA" and protocol version NN v} Configure Prooftree for proof assistant PA and communication protocol version NN. If proof assistant PA or version NN is not supported, Prooftree displays an error message and exits. The name PA might contain arbitrary characters but no quotation mark ( '"' ). There must always be exectly one configure message, which must be the first message. } {- {v current-goals state %d current-sequent %s \ {cheated | not-cheated} {new-layer | current-layer} proof-name-bytes %d \ command-bytes %d sequent-text-bytes %d additional-id-bytes %d \ existential-bytes %d\n\ \n\ \n\ \n\ \n\ \n v} The [current-goals] command tells [prooftree] about a new proof state with a new set of open goals. This corresponds to either of the following cases: {ol {- The initial proof state of a newly started proof} {- A proof command has been applied to the old current sequent, yielding a new current sequent and possibly additional new open subgoals} {- The old current goal has been solved (by some proof command) and the new current sequent is one of the previously spawned subgoals} {- A new set of proof-tree root goal nodes is associated with the current proof. This happens for instance, when Coq transformes open existential variables into proof goals with the command [Grab Existential Variables].} } For case 1 or case 4 [new-layer] must be given. Otherwise, [current-layer] must be specified and [prooftree] decides with the help of its internal state whether case 2 or 3 applies. For the second and the third case, the set of open goals does not need to represent the total set of all open subgoals, but it must contain all newly spawned subgoals. The state number in the [current-goals] command is for undo. It is interpreted as the state that has been reached after processing the current command. [current-sequent %s] denotes the ID of the current sequent. The cheated flag tells [prooftree] whether the new proof state was obtained by a cheating command such as [admit] or [sorry]. The data sections are : {ol {- Full name of the proof} {- The proof command that yielded this proof state} {- Text of the current sequent} {- ID's of additionally open sequents (as space separated list of strings)} {- Prover specific information about existential variables.} } The second data section is ignored for initial proof states. The text of newly created additional goals other then the current goal is expected to arrive separately with an [update-sequent] command. } {- {v update-sequent state %d sequent %s proof-name-bytes %d \ sequent-text-bytes %d\n\ \n\ \n v} The update sequent command updates the text of some known sequent. Such updates are necessary for newly spawned subgoals. But also when existential variables get instantiated. The state number is for undo and the sequent ID denotes the sequent to update. The data sections are: {ol {- Full name of the proof} {- new sequent text} } } {- {v switch-goal state %d sequent %s proof-name-bytes %d\n \n v} Switch goal tells [proftree] that the current goal has changed without changing or solving the old current goal. The state number is for undo and the only data section is: {ol {- Full name of the proof} } } {- {v branch-finished state %d {cheated | not-cheated} \ proof-name-bytes %d command-bytes %d existential-bytes %d\n\ \n\ \n\ \n v} [branch-finished] tells [prooftree] the last proof command that closed the current branch. If there are still open subgoals, the proof will hopefully continue with one of them, which is not yet known. The cheated flag tells [prooftree] whether the new proof state was obtained by a cheating command such as [admit] or [sorry]. The data sections are : {ol {- Full name of the proof} {- The last proof command} {- Prover specific information about existential variables.} } } {- {v proof-complete state %d proof-name-bytes %d\n\ \n v} [proof-complete] tells Prooftree that the current proof has been completed and will further not be updated. The only data section is: {ol {- Full name of the proof} } } {- {v undo-to state %d\n v} The state number here is not for undo, it is the undo-state. Undo tells [prooftree] to change the display to the state before the first command with a state strictly greater than [undo-state] has been processed. } {- {v quit-proof proof-name-bytes %d\n\ \n v} Quit closes the window for the indicated proof. Cloned windows are not closed. The only data section is: {ol {- Full name of the proof whoose window should be delected} } } } {3 Notification Messages} The notification messages are sent from Prooftree to Proof General as a consequence of certain user interactions. There are 3 different notification messages: for stopping the proof-tree display, for undo and for sending proof scripts. All notification messages are preceeded with a newline and the string [emacs exec:], followed by a space, for easy recognition in Proof General. The remaining part of the messages have the following format. {ul {- {v stop-displaying v} Prooftree sends this message to Proof General when the user closed the proof-tree display of a proof currently under development. Proof General then stops sending display commands for that proof. } {- {v undo %d v} Prooftree sends the undo message, when the user selected an undo for a certain sequent from the context menu. The integer is the undo state number of the proof command child node of the selected sequent. } {- {v insert-proof-script %d\n