prooftree-0.12/ 0000755 0002026 0000144 00000000000 12145426047 012344 5 ustar tews users prooftree-0.12/input.mli 0000644 0002026 0000144 00000002372 12124774370 014214 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.11 2013/03/28 08:02:00 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.12/about_window.ml 0000644 0002026 0000144 00000005021 12124774370 015377 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.6 2013/03/28 08:02:00 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.12/changes.html 0000644 0002026 0000144 00000007667 12145425006 014654 0 ustar tews users
List of changes for Prooftree
List of Changes for Prooftree
- 2013-05-17: Prooftree 0.12 released
-
- 2013-01-21: Prooftree 0.11 released
-
- incompatible protocol change: requires Proof General >= 4.3pre130327
- support for bullets, braces and Grab Existential
Variables of Coq 8.4
- New context menu items for retraction (undo), inserting proof
commands and proof scripts from subproofs
- several bug fixes and other small improvements
- 2012-05-14: Prooftree 0.10 released
-
- bug fixes and internal changes
- 2012-01-04: Prooftree 0.9 released
-
- fix case when some existential variables is instantiated by
the last proof command
- 2012-01-03: Prooftree 0.8 released
-
- Works now with standard versions of Coq (>= 8.4beta)
and Proof General (current development version)
- Update all sequents when existential variables get
instantiated
- Display dependencies of existential variables
- various internal improvements
- 2011-11-01
-
- Improved support for existential variables
- Dialog for marking introduction and instantiation points of
existential variables
- Use a different color for branches that are proved but have
non-instantiated existential variables
- display not instantiated existential variables in tool-tips,
sequent and proof command displays
- several bug fixes
- 2011-10-04
-
- in sync with Proof General version 4.1
- several bug fixes
- 2011-08-11
-
- User interface changes
- extra sequent and proof command windows on double click
and shift click
- move proof tree by dragging with mouse button 1
- main menu with new help, about, exit items
- progress message between Dismiss and
Menu button
- new Configuration dialog and support for user specific
configurations
- tool tips show proof commands and sequents
-
man page added
- several fixes and small changes
- 2011-06-14
-
- support starting prooftree in the middle of a proof
- display extra windows with the complete sequent text or the
complete proof command on mouse button 2
- the clone button yields a frozen copy of the proof tree
- branches that are finished by a cheating tactic (such as
admit or sorry) are colored in red
- keep proof tree windows when retracting in a big step to a
point before the proof
- 2011-04-21
-
- Show, Focus and Unfocus work.
- 2011-04-20
-
- Update existential variables when they are instantiated (as
far as possible)
- fix sequent window showing outdated text
- 2011-04-18
-
last changed on
17 May 2013
by Hendrik
prooftree-0.12/util.ml 0000644 0002026 0000144 00000021450 12124774371 013660 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.22 2013/03/28 08:02:01 tews Exp $
*)
(** Misc utility functions *)
(****************************************************************************)
(** {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 = String.copy s in
for i = 0 to String.length r - 1 do
if r.[i] = c1 then r.[i] <- c2
done;
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 rec iter s i s_len res j res_len len hangover =
if len = 0
then begin
assert(j = res_len);
res
end
else if i < s_len
then
let s_i_len = utf8_sequence_length s i in
if j + s_i_len <= res_len
then begin
res.[j] <- s.[i];
for k = 1 to s_i_len - 1 do
res.[j + k] <- s.[i + k]
done;
iter s (i + s_i_len) s_len
res (j + s_i_len) res_len
(len - 1) (hangover + s_i_len - 1)
end
else
let n_res_len = res_len + hangover + s_i_len - 1 in
let n_res = String.create n_res_len in
String.blit res 0 n_res 0 j;
iter s i s_len n_res j n_res_len len (1 - s_i_len)
else
raise (Invalid_argument "utf8_string_sub")
in
iter s 0 (String.length s)
(String.create len) 0 len
len 0
(****************************************************************************)
(** {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.12/prooftree.1 0000644 0002026 0000144 00000030635 12124565371 014443 0 ustar tews users .\" 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
deleted when the main proof-tree window disappears, unless their
.I Sticky
button is pressed.
.\" ==========================================================================
.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
item moves the viewport to the proof tree such that the current
proof goal (if there is any) will be visible.
.\" ==========================================================================
.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. Then 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
Changes in the configuration dialog take only effect when
the
.I Apply
or
.I OK
button is pressed. 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 Restore
button loads and applies the saved configuration.
.\" ==========================================================================
.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\fR,
proofs must be started with command
.I Proof\fR,
which is the recommended practice anyway (see Coq problem report
2776).
.\"
.\" ==========================================================================
.\" ================ 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.12/coq.ml 0000644 0002026 0000144 00000012066 12124774370 013467 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.3 2013/03/28 08:02:00 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 " %[0-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.12/node_window.ml 0000644 0002026 0000144 00000015262 12124774370 015222 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.15 2013/03/28 08:02:00 tews Exp $
*)
(** Creation, display and drawing of the extra node windows *)
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
sticky_button 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
(** Number of this node window. Used to correlate node windows with
the proof-tree display.
*)
method window_number = window_number
(** Set the content in the text buffer of this node window *)
method update_content new_content =
text_window#buffer#set_text new_content
(** 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
);
sticky_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 sticky. Needs to be called
when the corresponding element in the proof-tree display is
deleted.
*)
method delete_non_sticky_node_window =
if not sticky_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 or 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
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 ~packing:top_v_box#pack () in
let dismiss_button =
GButton.button ~label:"Dismiss" ~packing:button_h_box#pack ()
in
let sticky_button =
GButton.toggle_button ~label:"Sticky"
~packing:(button_h_box#pack ~from:`END) ()
in
let node_window =
new node_window proof_window node top_window text_win
sticky_button 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(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.12/INSTALL 0000644 0002026 0000144 00000003731 12124565371 013402 0 ustar tews users ============================================================================
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.12/ext_dialog.ml 0000644 0002026 0000144 00000054265 12124774370 015033 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.15 2013/03/28 08:02:00 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 or ks = GdkKeysyms._q)
&& (List.mem `CONTROL (GdkEvent.Key.state ev))
->
exit 0
| ks when (ks = GdkKeysyms._Q or 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
~label:"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.12/main.ml 0000644 0002026 0000144 00000007435 12124774370 013635 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.19 2013/03/28 08:02:00 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 *)
(**/**)
module U = Unix
(**/**)
open Configuration
open Help_window
open Input
(** 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
(** Flag for option [-config]. *)
let start_config_dialog = ref false
(** Flag for option [-help]. *)
let start_help_dialog = ref false
(** 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";
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.12/proof_tree.ml 0000644 0002026 0000144 00000104603 12124774370 015050 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.51 2013/03/28 08:02:00 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
assert (ex_got_instantiated = [] && new_existentials = []);
let first_sw =
pt.window#new_turnstile state current_sequent_id 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 "waiting for sequent text" 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
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 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 "waiting for sequent text" 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;
if ex_got_instantiated <> [] then begin
undo_instantiate_existentials ex_got_instantiated;
pt.window#update_sequent_existentials_info;
pt.sequent_area_needs_refresh <- true;
end;
List.iter (fun ex -> Hashtbl.remove pt.existential_hash ex.existential_name)
new_existentials;
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;
if ex_got_instantiated <> [] then begin
undo_instantiate_existentials ex_got_instantiated;
pt.window#update_sequent_existentials_info;
pt.sequent_area_needs_refresh <- true;
end;
List.iter (fun ex -> Hashtbl.remove pt.existential_hash ex.existential_name)
new_existentials;
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
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
(** Update the sequent text for some sequent. This function is used
for both, setting the new sequent text as well as reseting to the
old sequent text in the undo action.
*)
let change_sequent_text pt sequent text () =
sequent#update_sequent text;
if sequent#is_selected then
pt.sequent_area_needs_refresh <- true
(** Udate the sequent text for some sequent text and set an
appropriate undo action.
*)
let update_sequent_element pt state sw sequent_text =
let old_sequent_text = sw#content in
change_sequent_text pt sw sequent_text ();
add_undo_action pt state (change_sequent_text pt sw old_sequent_text)
(* 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
update_existential_status pt.existential_hash;
pt.window#refresh_and_position;
pt.window#update_ext_dialog;
end;
pt.sequent_area_needs_refresh <- false;
pt.need_redraw <- false
prooftree-0.12/gtk_ext.ml 0000644 0002026 0000144 00000011424 12124774370 014347 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.18 2013/03/28 08:02:00 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.12/version.txt 0000644 0002026 0000144 00000000005 12077270062 014563 0 ustar tews users 0.12
prooftree-0.12/emacs_commands.ml 0000644 0002026 0000144 00000003711 12124774370 015653 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.5 2013/03/28 08:02:00 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.12/README 0000644 0002026 0000144 00000004240 12124774370 013226 0 ustar tews users ============================================================================
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 for Debian Squeeze and wheezy for
i386 and amd64 are available on the Prooftree website.
============================================================================
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 - 2013 Hendrik Tews
============================================================================
Local Variables:
mode: indented-text
fill-column: 75
End:
prooftree-0.12/help_window.ml 0000644 0002026 0000144 00000025560 12124774370 015227 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.17 2013/03/28 08:02:00 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
[(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");
(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");
(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 deleted when the main proof-tree \
window disappears, unless their ");
(Italic, "Sticky");
(Default, " button is pressed.\n\
\n\
");
(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");
(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");
(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, " menu item repositions the proof tree such that the \
current proof goal 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. Changing values \
there does only take effect after the ");
(Italic, "Apply");
(Default, " or ");
(Italic, "OK");
(Default, " button has been pressed. 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.\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");
(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
(** 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
help_win#add_button "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:(fun () -> help_win#destroy()));
ignore(help_win#connect#response ~callback:(fun _ -> help_win#destroy()));
help_win#set_default_size ~width:400 ~height:300;
(* help_win#set_default_size ~width:800 ~height:800; *)
help_win#show ()
prooftree-0.12/configuration.ml 0000644 0002026 0000144 00000173511 12124774370 015557 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.39 2013/03/28 08:02:00 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_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 =
current_config := c;
update_font_and_color ();
!configuration_updated_callback ()
(** Reference for the argument of the [-geometry] option. *)
let geometry_string = ref ""
(*****************************************************************************
*****************************************************************************)
(** {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 header = String.create header_len in
let ic = open_in_bin file_name in
really_input ic header 0 header_len;
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 is updated. Used during start-up.
*)
let try_load_config_file () =
let copt =
try
Some(read_config_file config_file_location)
with
| _ -> None
in
match copt with
| None -> ()
| Some c -> update_configuration 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
- top_window {xref lablgtk class GWindow.window}
of the top-level widget
- line_width_spinner {xref lablgtk class GEdit.spin_button}
for line width
- turnstile_size_spinner {xref lablgtk class GEdit.spin_button}
for turnstile size
- line_sep_spinner {xref lablgtk class GEdit.spin_button}
for line gap
- proof_tree_sep_spinner {xref lablgtk class GEdit.spin_button}
for proof tree sep
- subtree_sep_spinner {xref lablgtk class GEdit.spin_button}
for node padding
- command_length_spinner {xref lablgtk class GEdit.spin_button}
for command length
- level_dist_spinner {xref lablgtk class GEdit.spin_button}
for vertical distance
- layer_sep_spinner {xref lablgtk class GEdit.spin_button}
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_spinner {xref lablgtk class GEdit.spin_button}
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_spinner {xref lablgtk class GEdit.spin_button}
for default window size width
- default_size_height_spinner {xref lablgtk class GEdit.spin_button}
for default window size height
- internal_seq_lines_spinner {xref lablgtk class GEdit.spin_button}
for lines in the internal sequent window
- external_node_lines_spinner {xref lablgtk class GEdit.spin_button}
for lines in external node windows
- ext_table_lines_spinner {xref lablgtk class GEdit.spin_button}
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_label {xref lablgtk class GMisc.label}
of the log-file label
- tee_file_name_entry {xref lablgtk class GEdit.entry}
of the log-file text entry
- tee_file_name_button {xref lablgtk class GButton.button}
of the log-file button that
starts the file selection dialog
- 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
top_window
line_width_spinner
turnstile_size_spinner
line_sep_spinner
proof_tree_sep_spinner
subtree_sep_spinner
command_length_spinner
level_dist_spinner
layer_sep_spinner
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_spinner
doc_tooltip_check_box
turnstile_tooltip_check_box
command_tooltip_check_box
default_size_width_spinner default_size_height_spinner
internal_seq_lines_spinner
external_node_lines_spinner
ext_table_lines_spinner
debug_check_box
tee_file_box_check_box
tee_file_name_label tee_file_name_entry tee_file_name_button
tooltip_misc_objects
=
object (self)
(** {xref lablgtk class GData.adjustment} of the line-width spin button. *)
val line_width_adjustment = line_width_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the turnstile-size spin
button.
*)
val turnstile_size_adjustment = turnstile_size_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the line-gap spin button. *)
val line_sep_adjustment = line_sep_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the proof_tree_sep spin
button.
*)
val proof_tree_sep_adjustment = proof_tree_sep_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the node-padding spin
button.
*)
val subtree_sep_adjustment = subtree_sep_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the command-length spin
button.
*)
val command_length_adjustment = command_length_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the vertical-distance
spin button.
*)
val level_dist_adjustment = level_dist_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the layer_sep spin
button.
*)
val layer_sep_adjustment = layer_sep_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the drag-acceleration
spin button.
*)
val drag_accel_adjustment = drag_accel_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the
default-window-size-width spin button.
*)
val default_size_width_adjustment = default_size_width_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the
default-window-size-height spin button.
*)
val default_size_height_adjustment = default_size_height_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the spin button for the
number of lines in the internal sequent window.
*)
val internal_seq_lines_adjustment = internal_seq_lines_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the spin button for the
number of lines in external node windows.
*)
val external_node_lines_adjustment = external_node_lines_spinner#adjustment
(** {xref lablgtk class GData.adjustment} of the spin button for the
default number of lines in the existential variable table.
*)
val ext_table_lines_adjustment = ext_table_lines_spinner#adjustment
(** 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 =
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;
()
(** Change spinners and buttons to show the compile-time default
configuration.
*)
method reset_to_default () =
self#set_configuration default_configuration
(** Switch the help/documentation tool-tips on or off, according to
the state of the help-tool-tips check box.
*)
method toggle_tooltips () =
let flag = doc_tooltip_check_box#active in
List.iter (fun misc -> misc#set_has_tooltip flag) tooltip_misc_objects;
()
(** Change the visibility of the tee-file elements, according to the
state of the log-input check box.
*)
method tee_file_toggle () =
let flag = tee_file_box_check_box#active in
tee_file_name_label#misc#set_sensitive flag;
tee_file_name_entry#misc#set_sensitive flag;
tee_file_name_button#misc#set_sensitive flag;
()
(** 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.
*)
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 "Select" `SELECT;
file_chooser#add_button "Cancel" `CANCEL;
ignore(file_chooser#set_current_folder
(Filename.dirname tee_file_name_entry#text));
(match file_chooser#run() with
| `SELECT ->
(match file_chooser#filename with
| None -> ()
| Some file -> tee_file_name_entry#set_text file
)
| `CANCEL
| `DELETE_EVENT -> ()
);
file_chooser#destroy();
()
(** 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
(** Action for the Apply button: Extract a configuration record and
update the current configuration.
*)
method apply () =
update_configuration (self#extract_configuration)
(** 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 () =
let do_save = ref true in
if self#extract_configuration <> !current_config
then begin
let proceed_dialog = GWindow.message_dialog
~message:"The save operation writes the current configuration \
record to disk. However, the current configuration \
record differs from what the configuration dialog now \
shows (because there are changes that have not been \
applied). Proceed anyway?"
~message_type:`QUESTION
~buttons:GWindow.Buttons.yes_no ()
in
(match proceed_dialog#run () with
| `YES -> ()
| `NO
| `DELETE_EVENT -> do_save := false
);
proceed_dialog#destroy ()
end;
if !do_save
then
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#set_configuration c;
update_configuration 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()
(** Action of the OK button. *)
method ok () =
self#apply ();
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 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
adjustment_set_pos_int line_width_spinner#adjustment;
line_width_spinner#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
adjustment_set_pos_int turnstile_size_spinner#adjustment;
turnstile_size_spinner#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
adjustment_set_pos_int ~lower:0.0 line_sep_spinner#adjustment;
line_sep_spinner#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
adjustment_set_pos_int ~lower:0.0 proof_tree_sep_spinner#adjustment;
proof_tree_sep_spinner#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
adjustment_set_pos_int ~lower:0.0 subtree_sep_spinner#adjustment;
subtree_sep_spinner#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
adjustment_set_pos_int command_length_spinner#adjustment;
command_length_spinner#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
adjustment_set_pos_int level_dist_spinner#adjustment;
level_dist_spinner#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
adjustment_set_pos_int layer_sep_spinner#adjustment;
layer_sep_spinner#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
drag_accel_spinner#adjustment#set_bounds
~lower:(-99.0) ~upper:99.0
~step_incr:0.01 ~page_incr:1.0 ();
drag_accel_spinner#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
default_size_width_spinner#adjustment#set_bounds
~lower:(-9999.0) ~upper:9999.0
~step_incr:1.0 ~page_incr:100.0 ();
default_size_width_spinner#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
default_size_height_spinner#adjustment#set_bounds
~lower:(-9999.0) ~upper:9999.0
~step_incr:1.0 ~page_incr:100.0 ();
default_size_height_spinner#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
adjustment_set_pos_int ~lower:0.0 internal_seq_lines_spinner#adjustment;
internal_seq_lines_spinner#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
adjustment_set_pos_int external_node_lines_spinner#adjustment;
external_node_lines_spinner#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
adjustment_set_pos_int ext_table_lines_spinner#adjustment;
ext_table_lines_spinner#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:"Log-file selection dialog"
~packing:(debug_frame_table#attach ~left:3 ~top:2) () 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
~label:"Set defaults" ~packing:button_box#pack () in
let apply_button = GButton.button
~label:"Apply" ~packing:button_box#pack () in
let cancel_button = GButton.button
~label:"Cancel" ~packing:button_box#pack () in
let ok_button = GButton.button
~label:"OK" ~packing:button_box#pack () in
let restore_button = GButton.button
~label:"Restore" ~packing:(button_box#pack ~from:`END) () in
let save_button = GButton.button
~label:"Save" ~packing:(button_box#pack ~from:`END) () in
let config_window =
new config_window top_window
line_width_spinner
turnstile_size_spinner
line_sep_spinner
proof_tree_sep_spinner
subtree_sep_spinner
command_length_spinner
level_dist_spinner
layer_sep_spinner
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_spinner
doc_tooltip_check_box
turnstile_tooltip_check_box
command_tooltip_check_box
default_size_width_spinner default_size_height_spinner
internal_seq_lines_spinner
external_node_lines_spinner
ext_table_lines_spinner
debug_check_box
tee_file_box_check_box
tee_file_name_label tee_file_name_entry tee_file_name_button
[ 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 ();
config_window#tee_file_toggle();
ignore(doc_tooltip_check_box#connect#toggled
~callback:config_window#toggle_tooltips);
ignore(tee_file_box_check_box#connect#toggled
~callback:config_window#tee_file_toggle);
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(apply_button#connect#clicked ~callback:config_window#apply);
ignore(cancel_button#connect#clicked ~callback:config_window#destroy);
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.12/version.mli 0000644 0002026 0000144 00000002070 12124774371 014536 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.5 2013/03/28 08:02:01 tews Exp $
*)
(** Version number. The implementation of this module is generated
automatically from version.txt *)
(** Prooftree version number *)
val version : string
prooftree-0.12/ChangeLog 0000644 0002026 0000144 00000045605 12145425006 014122 0 ustar tews users 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.12/Makefile.in 0000644 0002026 0000144 00000011436 12124774370 014420 0 ustar tews users ##
## prooftree --- proof tree display for Proof General
##
## Copyright (C) 2011 - 2013 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.26 2013/03/28 08:02:00 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:=-w Aem -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)
prooftree-0.12/COPYING 0000644 0002026 0000144 00000104513 11552763075 013411 0 ustar tews users 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.12/proof_tree.mli 0000644 0002026 0000144 00000013267 12124774371 015227 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.17 2013/03/28 08:02:01 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.12/tree_layers.ml 0000644 0002026 0000144 00000034411 12117335567 015224 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2013 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.4 2013/03/11 11:09:43 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
(** 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
(** 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)
(** 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
(** 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
(***************************************************************************)
(***************************************************************************)
(** {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
(** 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
(** 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
(** 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
(** 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
(** 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)
(** 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
(** 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
(** 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.12/input.ml 0000644 0002026 0000144 00000105374 12124774370 014051 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.37 2013/03/28 08:02:00 tews Exp $
*)
(** Reading commands from nonblocking stdin *)
(*****************************************************************************
*****************************************************************************)
(** {2 Communition Protocol with Proof General}
The communication protocol with Proof General is almost one-way
only: Proof General sends display messages to Prooftree and
Prooftree never requests anything from Proof General. Only when
the proof-tree window of the current proof is closed, Prooftree
notifies Proof General. The communication protocol is designed
such that Prooftree always knows in advance how many bytes it has
to read until the end of a display 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}
}
}
}
*)
(** Version number of the communication protocol described and
implemented by this module.
*)
let protocol_version = 3
(** {2 General remarks}
This module reads display commands from a pipe. It may therefore happen
that the input buffer depletes in the middle of a command. In this
case we have to return control to the GTK main loop, which will
call this module again, if the operating system decides that it is
time to make more input available. The input channel is therefore
turned into non-blocking mode, which means that reading raises an
exception instead of blocking when currently no more input is
available. As a consequence, the parsing engine in this module
must be prepared to get interrupted whenever it tries to read from
the input channel.
The state of the parser is stored in the variable
{!Input.current_parser}, which holds the function to be called when
more input becomes available. It must always be set before new
input is read from the input channel. Typically, there are
partially filled buffers and index variables in the closure of
[current_parser].
*)
(*****************************************************************************
*****************************************************************************)
open Configuration
open Util
open Gtk_ext
(**/**)
module U = Unix
(**/**)
(** {2 Module Documentation}
{3 General parsing utilities and parser state}
*)
(** Exception raised if [prooftree] encounters an unknown or malformed command.
The first argument is a description of the error. If the error was caused
by an exception, the second argument carries this exception and the
execption backtrace until the point where [Protocol_error] was raised.
*)
exception Protocol_error of string * (exn * string) option
(** Parsing function for the info string of existential variables.
This function is proof assistant specific and must therefore be
set when the configure message is received in
{!configure_prooftree}. The default value here is a valid parser
that can be used for proof assistants that have no existential
variables.
*)
let parse_existential_info =
ref(fun _ -> ([], []) : string -> (string list * (string * string list) list))
(** Forward pointer to {!message_start}. Initialized in
{!setup_input}. The forward pointer is needed, because various
functions that must be defined before [message_start] must set
{!current_parser} to [message_start].
*)
let message_start_parser = ref (fun () -> ())
(** Parsing function to be called when the next input arrives. Typically
the closure of this function contains the parsing state, such as
partially filled buffers.
*)
let current_parser = ref (fun () -> ())
(** Output channel for saving a backup copy of all material from the input.
Set by option [-tee], mainly used for debugging.
*)
let input_backup_oc = ref None
(** Filename {!input_backup_oc} is referring to. Needed in order to
decide whether {!input_backup_oc} must be changed when the current
configuration changed.
*)
let input_backup_filename = ref None
(** Set {!Input.input_backup_oc} according to the current configuration.
*)
let setup_input_backup_channel () =
if !current_config.copy_input &&
!input_backup_filename = Some !current_config.copy_input_file
then ()
else if !current_config.copy_input = false &&
!input_backup_filename = None
then ()
else if !current_config.copy_input
then begin
input_backup_oc := Some(open_out !current_config.copy_input_file);
input_backup_filename := Some !current_config.copy_input_file;
end else begin
input_backup_oc := None;
input_backup_filename := None;
end
(** Input function for reading from the input channel. To make the
input backup feature work (see option [-tee]) input must always be
read with this function. Arguments are the same as for {xref
stdlib val Pervasives.input}, [local_input buf start len] reads at
most [len] bytes from [stdin] into buffer [buf], starting at
position [start]. Any material read is immediately written to
{!Input.input_backup_oc}. Before calling this function,
{!Input.current_parser} must be set to the parsing continuation
function. This will be used in case parsing is interrupted now,
because no more input is currently available, and control is given
back to the GTK main loop. When more input becomes available the
GTK main loop calls this module again and the main parsing loop in
{!Input.parse_input} continues parsing with the function stored in
[current_parser].
@raise Sys_blocked_io when no more input is available currently
*)
let local_input buf start len =
let read_len = input stdin buf start len in
(match !input_backup_oc with
| None -> ()
| Some oc ->
output oc buf start read_len;
flush oc
);
if read_len = 0 then
raise (Protocol_error("Connection closed", None));
read_len
(** [get_string_cont s i len cont ()]
fills buffer [s] and continue parsing with [cont]. This
is a utility function for {!Input.get_string}. [get_string_cont s i
len cont ()] reads [len - i] bytes from the input channel and
stores them in [s] at position [i]. When finished it calles
[cont]. This function sets {!Input.current_parser} to itself
to continue reading later if not enough input is available now.
@raise Sys_blocked_io when not enough input is available currently
*)
let rec get_string_cont s i len continuation_fn () =
(* Printf.fprintf (debugc()) "GS cont %d - %d enter\n%!" i len; *)
current_parser := (get_string_cont s i len continuation_fn);
let n = local_input s i (len - i) in
(*
* Printf.fprintf (debugc()) "GS read %d bytes: %s\n%!"
* n (String.sub s i n);
*)
let i = i + n in
if i = len
then begin
(* Printf.fprintf (debugc()) "GS %d yields %s\n%!" len s; *)
continuation_fn s
end
else get_string_cont s i len continuation_fn ()
(** Main input function for strings. [get_string len cont] creates a
new string of length [len] and fills it from [stdin], saving a
copy to {!input_backup_oc}, and calls [cont new_string] as
continuation when finished. This function properly deals with
parsing interrupts (by setting {!Input.current_parser}
internally).
@raise Sys_blocked_io when not enough input is available currently
*)
let get_string len continuation_fn =
(* Printf.fprintf (debugc()) "GS %d enter\n%!" len; *)
let s = String.create len in
get_string_cont s 0 len continuation_fn ()
(******************************************************************************
******************************************************************************
* configure for "PA" and protocol version NN
*)
(** {3 Configure command parser} *)
(** [true] if the configure message has been received. *)
let configure_message_received = ref false
(** Raise an error if no configure message has been received yet. *)
let check_if_configured () =
if not !configure_message_received then
raise (Protocol_error ("Configure message missing", None))
(** Process the configure message. Raise an error if the proof
assistant or the communication protocol version is not supported.
This function is the place were a new proof assistant must be
added.
*)
let configure_prooftree proof_assistant pg_protocol_version =
if !configure_message_received then
raise (Protocol_error ("Received a second configure message", None));
(match proof_assistant with
| "Coq" ->
parse_existential_info := Coq.coq_parse_existential_info
| "HOL Light" -> ()
| _ ->
raise (Protocol_error ("Unknown proof assistant " ^ proof_assistant,
None))
);
if protocol_version <> pg_protocol_version then
raise (Protocol_error
((Printf.sprintf
("Communication protocol mismatch.\n"
^^ "Proof General uses version %02d\n"
^^ "but this version of Prooftree supports version %02d")
pg_protocol_version protocol_version),
None));
configure_message_received := true
(** Parse the configure message and process it. *)
let parse_configure com_buf =
Scanf.bscanf com_buf
" for \"%s@\" and protocol version %d" configure_prooftree
(******************************************************************************
******************************************************************************
* 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
*)
(** {3 Current-goals command parser} *)
(** Finish parsing of the [current-goals] command and call
{!Proof_tree.process_current_goals} to display the new proof
state. The arguments are the unprocessed strings read from the
input channel in this order:
@param state state number from the first line of the command
@param current_sequent_id ID of the current sequent from the first
line of the command
@param cheated_string either "cheated" or "not-cheated" from the
first line of the command
@param layer_string either "new-layer" of "current-layer" from the
first line of the command
@param proof_name name of the current proof
@param proof_command text of the last proof command (or garbage if
this is the first state of the proof)
@param current_sequent_text text of the current sequent
@param additional_ids_string ID's of all currently open goals
@param existentials_string prover specific information about
existentials
*)
let parse_current_goals_finish state current_sequent_id cheated_string
layer_string proof_name proof_command current_sequent_text
additional_ids_string existentials_string =
(* Printf.fprintf (debugc()) "PCGF\n%!"; *)
let cheated_flag = match cheated_string with
| "not-cheated" -> false
| "cheated" -> true
| _ ->
raise(Protocol_error
("Parse error in current-goals command. " ^
"Expected \"cheated\" or \"not-cheated\" as 6th word.",
None))
in
let layer_flag = match layer_string with
| "new-layer" -> true
| "current-layer" -> false
| _ ->
raise(Protocol_error
("Parse error in current-goals command. " ^
"Expected \"new-layer\" or \"current-layer\" as 7th word.",
None))
in
let proof_name = chop_final_newlines proof_name in
let proof_command = chop_final_newlines proof_command in
let current_sequent_text = chop_final_newlines current_sequent_text in
let additional_ids_string = chop_final_newlines additional_ids_string in
let additional_ids = string_split ' ' additional_ids_string in
let existentials_string = chop_final_newlines existentials_string in
let (ex_uninst, ex_inst) = !parse_existential_info existentials_string in
Proof_tree.process_current_goals state proof_name proof_command cheated_flag
layer_flag current_sequent_id current_sequent_text additional_ids
ex_uninst ex_inst;
current_parser := !message_start_parser
(** Start parsing of the [current-goals] command. Extracts elements and
string length' from the [Scanf] parsing buffer argument and reads
all the necessary strings from the input channel. When reading finished
{!Input.parse_current_goals_finish} is called.
*)
let parse_current_goals com_buf =
check_if_configured ();
Scanf.bscanf com_buf
(" state %d current-sequent %s %s %s proof-name-bytes %d "
^^ "command-bytes %d sequent-text-bytes %d "
^^ "additional-id-bytes %d existential-bytes %d")
(fun state current_sequent_id cheated_string layer_string
proof_name_bytes command_bytes sequent_text_bytes additional_id_bytes
existential_bytes ->
get_string proof_name_bytes
(fun proof_name ->
get_string command_bytes
(fun proof_command ->
get_string sequent_text_bytes
(fun current_sequent_text ->
get_string additional_id_bytes
(fun additional_ids_string ->
get_string existential_bytes
(fun existentials_string ->
parse_current_goals_finish state current_sequent_id
cheated_string layer_string
proof_name proof_command current_sequent_text
additional_ids_string existentials_string))))))
(******************************************************************************
* update-sequent state %d sequent %s proof-name-bytes %d \
* sequent-text-bytes %d\n\
* \n
* \n
*)
(** {3 Update-sequent command parser} *)
(** Finish parsing of the [update-sequent] command and call
{!Proof_tree.update_sequent} to update the sequent. The
arguments are as follows:
@param state state number
@param sequent_id ID of sequent to update
@param proof_name full proof name (as raw data section string)
@param sequent_text new sequent text (as raw data section string)
*)
let parse_update_sequent_finish state sequent_id proof_name sequent_text =
let proof_name = chop_final_newlines proof_name in
let sequent_text = chop_final_newlines sequent_text in
Proof_tree.update_sequent state proof_name sequent_id sequent_text;
current_parser := !message_start_parser
(** Parse and process a [update-sequent] command. Extracts the state and
the data section length' from the first command line in the [Scanf]
parsing buffer argument, reads the data sections and finally call
{!Input.parse_update_sequent_finish}.
*)
let parse_update_sequent com_buf =
check_if_configured ();
Scanf.bscanf com_buf
" state %d sequent %s proof-name-bytes %d sequent-text-bytes %d"
(fun state sequent_id proof_name_bytes sequent_text_bytes ->
get_string proof_name_bytes
(fun proof_name ->
get_string sequent_text_bytes
(fun sequent_text ->
parse_update_sequent_finish state sequent_id
proof_name sequent_text)))
(******************************************************************************
* switch-goal state %d sequent %s proof-name-bytes %d\n
* \n
*)
(** {3 Switch-goal command parser} *)
(** Finish parsing of the [switch-goal] command and process it with
{!Proof_tree.switch_to}. The arguments are as follows:
@param state state number
@param new_current_id ID of new current goal
@param proof_name full proof name (as raw data section string)
*)
let parse_switch_goal_finish state new_current_id proof_name =
let proof_name = chop_final_newlines proof_name in
Proof_tree.switch_to state proof_name new_current_id;
current_parser := !message_start_parser
(** Parse and process a [switch-goal] command. Extracts the state, the
new current sequent and the data section length from the first
command line in the [Scanf] parsing buffer argument, reads the
data section and finally calls {!Input.parse_switch_goal_finish}.
*)
let parse_switch_goal com_buf =
check_if_configured ();
Scanf.bscanf com_buf
" state %d sequent %s proof-name-bytes %d"
(fun state new_current_id proof_name_bytes ->
get_string proof_name_bytes
(fun proof_name ->
parse_switch_goal_finish state new_current_id proof_name))
(******************************************************************************
* branch-finished state %d {cheated|not-cheated} \
* proof-name-bytes %d command-bytes %d existential-bytes %d\n\
* \n\
* \n\
* \n
*)
(** {3 Branch-finished command parser} *)
(** Finish parsing of the [branch-finished] command and process it
with {!Proof_tree.process_branch_finished}. The arguments are
@param state state number
@param cheated_string either "cheated" or "not-cheated"
@param proof_name full proof name (as raw data section string)
@param proof_command last proof command (as raw data section string)
@param existentials_string prover specific data about existentials
*)
let parse_branch_finished_finish
state cheated_string proof_name proof_command existentials_string =
let cheated_flag = match cheated_string with
| "not-cheated" -> false
| "cheated" -> true
| _ ->
raise(Protocol_error
("Parse error in branch-finished command. " ^
"Expected \"cheated\" or \"not-cheated\" as 4th word.",
None))
in
let proof_name = chop_final_newlines proof_name in
let proof_command = chop_final_newlines proof_command in
let existentials_string = chop_final_newlines existentials_string in
let (ex_uninst, ex_inst) = !parse_existential_info existentials_string in
Proof_tree.process_branch_finished
state proof_name proof_command cheated_flag ex_uninst ex_inst;
current_parser := !message_start_parser
(** Parse and process a [proof-finished] command. Extracts the
necessary information from the first command line in the [Scanf]
parsing buffer argument, reads the data section and finally calls
{!Input.parse_branch_finished_finish}.
*)
let parse_branch_finished com_buf =
check_if_configured ();
Scanf.bscanf com_buf
" state %d %s proof-name-bytes %d command-bytes %d existential-bytes %d"
(fun state cheated_string proof_name_bytes
command_bytes existential_bytes ->
get_string proof_name_bytes
(fun proof_name ->
get_string command_bytes
(fun proof_command ->
get_string existential_bytes
(fun existentials_string ->
parse_branch_finished_finish
state cheated_string proof_name
proof_command existentials_string))))
(******************************************************************************
* proof-complete state %d proof-name-bytes %d\n\
* \n
*)
(** {3 Proof-complete command parser} *)
(** Parse and process a [proof-complete] command. Extracts information
from the command and process it with
{!Proof_tree.process_proof_complete}.
*)
let parse_proof_complete com_buf =
check_if_configured ();
Scanf.bscanf com_buf " state %d proof-name-bytes %d"
(fun state proof_name_bytes ->
get_string proof_name_bytes
(fun proof_name ->
let proof_name = chop_final_newlines proof_name in
Proof_tree.process_proof_complete state proof_name;
current_parser := !message_start_parser))
(******************************************************************************
* undo-to state %d\n
*)
(** {3 Undo-to command parser} *)
(** Parse an [undo-to] command and call {!Proof_tree.undo} to process it.
*)
let do_undo com_buf =
check_if_configured ();
Scanf.bscanf com_buf " state %d" Proof_tree.undo
(*****************************************************************************
*
* quit-proof proof-name-bytes %d\n\
* \n
*)
(** {3 Quit-proof command parser} *)
(** Finish parsing a [quit-proof] command and process it with
{!Proof_tree.quit_proof}. The argument is
@param proof_name full proof name (as raw data section string)
*)
let parse_quit_proof_finish proof_name =
let proof_name = chop_final_newlines proof_name in
Proof_tree.quit_proof proof_name;
current_parser := !message_start_parser
(** Parse and process a [quit-proof] command. Extracts the
data-section length from the first line in the [Scanf] parsing
buffer, reads the data section and finally calls
{!Input.parse_quit_proof_finish}.
*)
let parse_quit_proof com_buf =
check_if_configured ();
Scanf.bscanf com_buf " proof-name-bytes %d"
(fun proof_name_bytes ->
get_string proof_name_bytes parse_quit_proof_finish)
(*****************************************************************************
*
* general parsing
*
*****************************************************************************)
(** {3 General command parser} *)
(** Parse and process a command. Argument [command] holds the complete
second line of the display command. This function only builds a scanning
buffer from [command] and switches to the different command
parsers, depending on the first word in [command].
@raise Sys_blocked_io if parsing gets interrupted
*)
let parse_command command =
(* Printf.fprintf (debugc()) "PC %s\n%!" command; *)
let com_buf = Scanf.Scanning.from_string command in
Scanf.bscanf com_buf "%s "
(function
| "configure" -> parse_configure com_buf
| "current-goals" -> parse_current_goals com_buf
| "update-sequent" -> parse_update_sequent com_buf
| "switch-goal" -> parse_switch_goal com_buf
| "branch-finished" -> parse_branch_finished com_buf
| "proof-complete" -> parse_proof_complete com_buf
| "undo-to" -> do_undo com_buf
| "quit-proof" -> parse_quit_proof com_buf
| _ ->
raise (Protocol_error ("Parse error on input \"" ^ command ^ "\"",
None))
);
current_parser := !message_start_parser;
()
(** [read_second_line first_line] extracts the length of the second
line from [first_line], reads the second line and switches to
{!parse_command} to process the complete display command.
@raise Sys_blocked_io if parsing gets interrupted
*)
let read_second_line first_line =
Scanf.sscanf first_line "second line %3d\n"
(fun second_line_len ->
(* Printf.fprintf (debugc()) "second line cont %d\n%!" second_line_len; *)
get_string second_line_len parse_command)
(** Read the first, fixed-length line of a display command and switch
to {!read_second_line} to process the complete display command.
This function is the entry point into the display-command parser.
All command parsing functions set {!Input.current_parser} to
[read_command_line] when they are finished with their work. This
way, this function is called again to parse the next command by
the main parsing loop in {!Input.parse_input}.
@raise Sys_blocked_io if parsing gets interrupted
@raise Protocol_error for parsing and protocol errors
*)
let message_start () =
(* every message starts with a line "second line %03d"
* where the number gives the bytes in the next line
*)
(* Printf.fprintf (debugc()) "message start\n%!"; *)
try
get_string 16 read_second_line
with
| Scanf.Scan_failure _
| Failure _
| End_of_file as e
->
let bt = Printexc.get_backtrace() in
raise (Protocol_error ("Parse error", Some(e, bt)))
(** {3 Main parsing loop, GTK callback and initialization} *)
(** Main parsing loop. Calls the function in {!Input.current_parser}
in an infinite loop until input depletes and parsing is
interrupted. If parsing is interrupted this function calls
{!Proof_tree.finish_drawing} to schedule a redisplay of the proof
tree if necessary.
All parsing functions raise [Sys_blocked_io] if no more input is
available. This exception is caught here.
This function always returns [true] to tell the GTK main loop to
keep calling this module.
@raise Protocol_error for parsing and protocol errors
*)
let parse_input () =
try
(* Printf.fprintf (debugc()) "PI first\n%!"; *)
while true do
(* Printf.fprintf (debugc()) "PI next\n%!"; *)
!current_parser ()
done;
true
with
| Sys_blocked_io ->
(* Printf.fprintf (debugc()) "PI finished\n%!"; *)
Proof_tree.finish_drawing ();
true
(** Input callback without exception handling. The argument comes from
the GTK main loop and indicates the condition on the watched
channel. Because I only registered a callback for the [`IN] (i.e.,
input available) condition, I only deal with the case where the
argument is [[`IN]]. For all other arguments
{!Input.Protocol_error} is thrown, because I either don't expect
them or I don't know what they mean.
*)
let parse_input_callback = function
| [`IN] -> parse_input ()
| clist ->
raise (Protocol_error
("Strange callback condition " ^
(String.concat " "
(List.map (function
| `IN -> "IN"
| `OUT -> "OUT"
| `PRI -> "PRI"
| `ERR -> "ERR"
| `HUP -> "HUP"
| `NVAL -> "NVAL")
clist)),
None))
(** Internal counter of fatal error conditions of the command
processing. If a fatal error occurs, it is normally displayed in a
popup message. Special circumstances might cause a fatal error to
repeately occur. Then this counter causes prooftree to terminate
at some state instead of generating an infinite number of popup
messages.
*)
let error_counter = ref 0
(** Callback for the GTK main loop when input is available on [stdin].
This is just an exception wrapper around
{!Input.parse_input_callback}. In case of an escaping exception a
popup message is displayed and the same message is printed on
[stderr]. For {!Input.Protocol_error} and [End_of_input] the
message only contains a backtrace if [debug_mode] in the current
configuration (see {!Configuration.t} and
{!Configuration.current_config}) is true. For other exceptions the
message does always contain the backtrace.
*)
let parse_input_callback_ex clist =
try
parse_input_callback clist
with
| e ->
incr error_counter;
if !error_counter > 20 then exit 2;
let backtrace = Printexc.get_backtrace() in
let buf = Buffer.create 4095 in
let print_backtrace = ref !current_config.debug_mode in
let prev_exception = ref None in
(match e with
| Protocol_error(err, prev_e) ->
Printf.bprintf buf "Protocol error!\n%s\nClosing connection." err;
prev_exception := prev_e
| _ ->
Buffer.add_string buf
"Internal error: Escaping exception in parse_input";
print_backtrace := true;
);
if !print_backtrace then begin
Buffer.add_char buf '\n';
Buffer.add_string buf (Printexc.to_string e);
(match e with
| U.Unix_error(error, _func, _info) ->
Buffer.add_string buf (U.error_message error);
Buffer.add_string buf "\n"
| _ -> ()
);
Buffer.add_char buf '\n';
Buffer.add_string buf backtrace;
(match !prev_exception with
| None -> ()
| Some(e, bt) ->
Buffer.add_string buf "Caused by ";
Buffer.add_string buf (Printexc.to_string e);
Buffer.add_char buf '\n';
Buffer.add_string buf bt
);
end;
prerr_endline (Buffer.contents buf);
error_message_dialog (Buffer.contents buf)
(*****************************************************************************
*
* Initialization
*
*****************************************************************************)
(** Take the necessary actions when the configuration record changed.
*)
let configuration_updated = setup_input_backup_channel
(** Initialize this module and setup the GTK main loop callback for
[stdin]. Puts [stdin] into non-blocking mode.
*)
let setup_input () =
U.set_nonblock U.stdin;
message_start_parser := message_start;
current_parser := message_start;
setup_input_backup_channel();
ignore(GMain.Io.add_watch
~cond:[ `IN ]
~callback:parse_input_callback_ex
(GMain.Io.channel_of_descr U.stdin))
prooftree-0.12/draw_tree.ml 0000644 0002026 0000144 00000161111 12124774370 014655 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.48 2013/03/28 08:02:00 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
(** Set the content in the text buffer of this node window *)
method update_content : string -> 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_non_sticky_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
(** 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
(** 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)
(***************************************************************************)
(***************************************************************************)
(** {2 Accessors / Setters} *)
(***************************************************************************)
(***************************************************************************)
(** 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
(** 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
(***************************************************************************)
(***************************************************************************)
(** {2 Children Iterators} *)
(***************************************************************************)
(***************************************************************************)
(** 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} *)
(***************************************************************************)
(***************************************************************************)
(** 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
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;
(* 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;
*)
(** 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} *)
(***************************************************************************)
(***************************************************************************)
(** 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)
(** 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))
(** 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)
(** 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)
(** 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)
(** 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} *)
(***************************************************************************)
(***************************************************************************)
(** 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
(** 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 -> ()
(** 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
)
(** 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
)
(** 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} *)
(***************************************************************************)
(***************************************************************************)
(** Return the displayed sequent text for turnstile 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
(** Delete all non-sticky external node windows of this node.
*)
method delete_non_sticky_external_windows =
List.iter (fun w -> w#delete_non_sticky_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 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 =
(if external_windows <> [] && existential_variables <> []
then
let new_text = self#displayed_text in
List.iter (fun ew -> ew#update_content new_text) external_windows
);
List.iter (fun c -> c#update_existentials_info) children
(** 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 =
object (self)
inherit proof_tree_element drawable undo_state sequent_id [] [] as super
(** The pure sequent text. *)
val mutable sequent_text = (sequent_text : string)
(** 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
(** Update the sequent text. *)
method update_sequent new_text =
sequent_text <- new_text;
let new_text = self#displayed_text in
List.iter
(fun ew -> ew#update_content new_text)
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
(** 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
)
(** 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
initializer
self#set_node_size;
(*
* Printf.fprintf (debugc()) "INIT %s width %d height %d\n%!"
* self#debug_name width height;
*)
self#update_subtree_size;
()
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
(** 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
(** 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
(** 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
(** 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 ();
(** 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;
(* 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 ->
(new_seq node#id node#content : 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.12/.cvsignore 0000644 0002026 0000144 00000000162 11725422750 014343 0 ustar tews users *.cmi
*.cmo
*.cmx
Makefile
Makefile.deps
dump.odoc-dump
prooftree
prooftree.man.html
prooftree.man.txt
version.ml
prooftree-0.12/configure 0000755 0002026 0000144 00000010155 12124774370 014257 0 ustar tews users #!/bin/sh
##############################################################################
#
# Configuration script for prooftree
#
# Hendrik Tews Copyright (C) 2011 - 2013
#
# 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.6 2013/03/28 08:02:00 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.12/proof_window.ml 0000644 0002026 0000144 00000151214 12124774371 015421 0 ustar tews users (*
* prooftree --- proof tree display for Proof General
*
* Copyright (C) 2011 - 2013 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.61 2013/03/28 08:02:01 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 if 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_non_sticky_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_non_sticky_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 or ks = GdkKeysyms._q)
&& (List.mem `CONTROL (GdkEvent.Key.state ev))
->
exit 0
| ks when (ks = GdkKeysyms._Q or 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 or 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 ()
(** 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 =
new turnstile drawable undo_state sequent_id sequent_text
(** 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 ~label:"Dismiss" ~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("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