From: no author Date: Mon, 7 Oct 2002 16:25:56 +0000 (+0000) Subject: This commit was manufactured by cvs2svn to create tag 'initial'. X-Git-Tag: initial X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=dcc5749e8534ee245bc89e73f4fb6ca1b99c5fa6;p=helm.git This commit was manufactured by cvs2svn to create tag 'initial'. --- diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.i386.rpm b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.i386.rpm new file mode 100644 index 000000000..e759a668b Binary files /dev/null and b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.i386.rpm differ diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.spec b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.spec new file mode 100644 index 000000000..63b197d82 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.spec @@ -0,0 +1,25 @@ +Summary: GtkMathView : the binding for lablgtk of the GtkMathView widget +Name: lablgtk-20000829_gtkmathview +Version: 0.1.0 +Release: 1 +Copyright: LGPL +Group: Development/Libraries +Requires: lablgtk_20000829 gtkmathview +Source: www.cs.unibo.it:/~lpadovan/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0.tar.gz +%description +GtkMathView is the binding for lablgtk of the GtkMathView widget. + +%prep +%setup + +%build +make +make opt + +%install +make install + +%files +%doc COPYING + +/usr/lib/ocaml/lablgtk/mathview diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.src.rpm b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.src.rpm new file mode 100644 index 000000000..3377d3cd5 Binary files /dev/null and b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0-1.src.rpm differ diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0.tar.gz b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0.tar.gz new file mode 100644 index 000000000..73f44b364 Binary files /dev/null and b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0.tar.gz differ diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/.depend b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/.depend new file mode 100644 index 000000000..600449bb8 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/.depend @@ -0,0 +1,4 @@ +gMathView.cmo: gtkMathView.cmo gtk_mathview.cmo +gMathView.cmx: gtkMathView.cmx gtk_mathview.cmx +gtkMathView.cmo: gtk_mathview.cmo +gtkMathView.cmx: gtk_mathview.cmx diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/COPYING b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/COPYING new file mode 100644 index 000000000..20b480a10 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/COPYING @@ -0,0 +1,11 @@ +This library is made available under the LGPL. +You should have got a copy of the LGPL with Objective Caml. +The LGPL applies to all the files in this directory, but not in +subdirectories. + +For the test subdirectory, there is no specific licensing policy, +but you may freely take inspiration from the code, and copy parts of +it in your application. + +Author: + Claudio Sacerdoti Coen diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/Makefile b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/Makefile new file mode 100644 index 000000000..1195de528 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/Makefile @@ -0,0 +1,98 @@ +# Makefile for lablgtk_mathview. + +LABLGTKDIR = /usr/local/lib/ocaml/lablgtk +MLFLAGS += -I $(LABLGTKDIR) + +TARGETS = ml_gtk_mathview.o lablgtkmathview.cma + +all: $(TARGETS) + +opt: lablgtkmathviewopt + +configure: + @rm -f config.make + @$(MAKE) --no-print-directory -f configure.mk + +depend: + @rm -f .depend + @$(MAKE) --no-print-directory -f configure.mk .depend + +.depend config.make: + @$(MAKE) --no-print-directory -f configure.mk + +COMPILER = $(CAMLC) $(MLFLAGS) -w s -labels -c +LINKER = $(CAMLC) $(MLFLAGS) +COMPOPT = $(CAMLOPT) $(MLFLAGS) -w s -labels -c +LINKOPT = $(CAMLOPT) $(MLFLAGS) + +include config.make + +INSTALLDIR = $(LIBDIR)/lablgtk/mathview + +MLLIBS = lablgtkmathview.cma +CLIBS = +MLLINK = unix.cma str.cma + +ifdef DEBUG +CFLAGS = -g $(GTKCFLAGS) +MLLINK += -cclib -lcamlrund +MLFLAGS += -g +else +CFLAGS = -O -DGTK_NO_CHECK_CASTS -DGTK_DISABLE_COMPAT_H $(GTKCFLAGS) +endif + +THFLAGS = -thread +THLINK = unix.cma threads.cma + +ifdef USE_CC +CCOMPILER = $(CC) -c -I$(LIBDIR) $(CFLAGS) +else +CCOMPILER = ocamlc -c -ccopt "$(CFLAGS)" +endif + +# Rules +.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .o .var .h .opt .def +.c.o: + $(CCOMPILER) $< +.ml.cmo: + $(COMPILER) $< +.mli.cmi: + $(COMPILER) $< +.ml.cmx: + $(COMPOPT) $< +.var.h: + ./var2def < $< > $@ +.var.c: + ./var2conv < $< > $@ + +# Targets +COBJS = ml_gtk_mathview.o +MLOBJS = gtk_mathview.cmo gtkMathView.cmo gMathView.cmo +ALLOBJS = $(MLOBJS) + +lablgtkmathviewopt: $(CLIBS) $(MLLIBS:.cma=.cmxa) + +install: + if test -d $(INSTALLDIR); then : ; else mkdir -p $(INSTALLDIR); fi + cp $(ALLOBJS:.cmo=.cmi) $(INSTALLDIR) + if test -f *.mli ; then cp *.mli $(INSTALLDIR) ; fi + cp $(ALLOBJS:.cmo=.ml) $(INSTALLDIR) + cp $(MLLIBS) $(INSTALLDIR) + cp $(COBJS) $(INSTALLDIR) + if test ! -z "$(CLIBS)" ; then cp $(CLIBS) $(INSTALLDIR) ; fi + if test -f lablgtkmathview.cmxa; then \ + cp $(MLLIBS:.cma=.cmxa) $(MLLIBS:.cma=.a) \ + $(INSTALLDIR); fi + +lablgtkmathview.cma: $(MLOBJS) + $(LINKER) -a -custom -o $@ $(MLOBJS) $(GTKLIBS) $(GTKMATHVIEWLIBS) +lablgtkmathview.cmxa: $(MLOBJS:.cmo=.cmx) + $(LINKOPT) -a -o $@ $(MLOBJS:.cmo=.cmx) $(GTKLIBS) $(GTKMATHVIEWLIBS) + +ml_gtk.o: $(LABLGTKDIR)/gtk_tags.c $(LABLGTKDIR)/gtk_tags.h \ + $(LABLGTKDIR)/ml_gtk.h $(LABLGTKDIR)/ml_gdk.h $(LABLGTKDIR)/wrappers.h + +clean: + rm -f *.cm* *.o *.a *_tags.[ch] $(TARGETS) + +include .depend diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/config.make b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/config.make new file mode 100644 index 000000000..d50ffb585 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/config.make @@ -0,0 +1,15 @@ +CAMLC=ocamlc +CAMLOPT=ocamlopt +USE_GL= +USE_GNOME= +USE_CC= +DEBUG= +CC=cc +RANLIB=ranlib +LIBDIR=/usr/lib/ocaml +BINDIR=/usr/bin +INSTALLDIR=/usr/lib/ocaml/lablgtk/mathview +GTKCFLAGS=-I/usr/lib/glib/include -I/usr/X11R6/include -I/usr/lib/ocaml/lablgtk +GTKLIBS=-ccopt -L/usr/lib -ccopt -L/usr/X11R6/lib -cclib -lgtk -cclib -lgdk -ccopt -rdynamic -cclib -lgmodule -cclib -lglib -cclib -ldl -cclib -lXi -cclib -lXext -cclib -lX11 -cclib -lm +GTKMATHVIEWLIBS=-ccopt -L/usr/local/lib/gtkmathview -cclib -lgtkmathview +GNOMELIBS= diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/configure.mk b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/configure.mk new file mode 100644 index 000000000..73cfc3d35 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/configure.mk @@ -0,0 +1,53 @@ +# makefile for configuring lablGTK_mathview + +# Default compilers +CAMLC = ocamlc +CAMLOPT = ocamlopt + +# Default installation directories +BINDIR = `$(GETBINDIR)` +INSTALLDIR = $(LIBDIR)/lablgtk/mathview + +# Autoconf +GETLIBDIR = ocamlc -v | grep "^Standard" | sed 's/^.*: *//' +LIBDIR = `$(GETLIBDIR)` +GETBINDIR = $(GETLIBDIR) | sed -e 's|/lib/[^/]*$$|/bin|' -e 's|/lib$$|/bin|' +GETRANLIB = which ranlib 2>/dev/null | sed -e 's|.*/ranlib$$|!|' -e 's/^[^!]*$$/:/' -e 's/!/ranlib/' + +ifdef USE_GNOME +GTKGETCFLAGS = gtk-config --cflags`" -I"`gnome-config --includedir +GNOMELIBS = `gnome-config --libs gtkxmhtml` +else +GTKGETCFLAGS = gtk-config --cflags +endif + +GTKGETLIBS = gtk-config --libs + +configure: .depend config.make + +.depend: + ocamldep *.ml *.mli > .depend + +config.make: + @echo CAMLC=$(CAMLC) > config.make + @echo CAMLOPT=$(CAMLOPT) >> config.make + @echo USE_GL=$(USE_GL) >> config.make + @echo USE_GNOME=$(USE_GNOME) >> config.make + @echo USE_CC=$(USE_CC) >> config.make + @echo DEBUG=$(DEBUG) >> config.make + @echo CC=$(CC) >> config.make + @echo RANLIB=`$(GETRANLIB)` >> config.make + @echo LIBDIR=$(LIBDIR) >> config.make + @echo BINDIR=`$(GETBINDIR)` >> config.make + @echo INSTALLDIR=$(INSTALLDIR) >> config.make + @echo GTKCFLAGS=`$(GTKGETCFLAGS)` -I/usr/lib/ocaml/lablgtk >> config.make + @echo GTKLIBS=`$(GTKGETLIBS)` | \ + sed -e 's/-l/-cclib &/g' -e 's/-[LRWr][^ ]*/-ccopt &/g' \ + >> config.make + # + echo GTKMATHVIEWLIBS="-ccopt -L/usr/local/lib/gtkmathview -cclib -lgtkmathview " >> config.make + # + @echo GNOMELIBS=$(GNOMELIBS) | \ + sed -e 's/-l/-cclib &/g' -e 's/-[LRWr][^ ]*/-ccopt &/g' \ + >> config.make + cat config.make diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gMathView.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gMathView.ml new file mode 100644 index 000000000..b79c81244 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gMathView.ml @@ -0,0 +1,50 @@ +open Gaux +open Gtk +open Gtk_mathview +open GtkBase +open GtkMathView +open GObj + +exception ErrorLoadingFile of string;; + +class math_view_signals obj = object + inherit GContainer.container_signals obj + method jump = GtkSignal.connect ~sgn:MathView.Signals.jump obj ~after + method clicked = GtkSignal.connect ~sgn:MathView.Signals.clicked obj ~after +end + +class math_view obj = object + inherit GContainer.container (obj : Gtk_mathview.math_view obj) + method connect = new math_view_signals obj + method load ~filename = + if not (MathView.load obj ~filename) then raise (ErrorLoadingFile filename) + method get_selection = MathView.get_selection obj + method unload = MathView.unload obj + method dump = MathView.dump obj + method get_width = MathView.get_width obj + method get_height = MathView.get_height obj + method set_adjustments = + fun adj1 adj2 -> + MathView.set_adjustments obj (GData.as_adjustment adj1) + (GData.as_adjustment adj2) + method get_hadjustment = new GData.adjustment (MathView.get_hadjustment obj) + method get_vadjustment = new GData.adjustment (MathView.get_vadjustment obj) + method get_buffer = MathView.get_buffer obj + method get_frame = new GBin.frame (MathView.get_frame obj) + method set_font_size = MathView.set_font_size obj + (*method get_top = MathView.get_top obj + method set_top = MathView.set_top obj*) +end + +let math_view ?adjustmenth ?adjustmentv ?border_width ?width ?height + ?packing ?show () += + let w = + MathView.create + ?adjustmenth:(may_map ~f:GData.as_adjustment adjustmenth) + ?adjustmentv:(may_map ~f:GData.as_adjustment adjustmentv) + () + in + Container.set w ?border_width ?width ?height; + pack_return (new math_view w) ~packing ~show +;; diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gtkMathView.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gtkMathView.ml new file mode 100644 index 000000000..9ed42b8b7 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gtkMathView.ml @@ -0,0 +1,61 @@ +open Gtk +open Gtk_mathview +open Tags +open GtkBase +open Gpointer + +module MathView = struct + let cast w : math_view obj = Object.try_cast w "GtkMathView" + external create : Gtk.adjustment optobj -> Gtk.adjustment optobj -> + math_view obj = "ml_gtk_math_view_new" + let create ~adjustmenth ~adjustmentv () = + create (optboxed adjustmenth) (optboxed adjustmentv) + external load : [>`math_view] obj -> filename:string -> bool = + "ml_gtk_math_view_load" + external get_selection : [>`math_view] obj -> string option = + "ml_gtk_math_view_get_selection" + external unload : [>`math_view] obj -> unit = + "ml_gtk_math_view_unload" + external dump : [>`math_view] obj -> unit = + "ml_gtk_math_view_dump" + external get_width : [>`math_view] obj -> int = + "ml_gtk_math_view_get_width" + external get_height : [>`math_view] obj -> int = + "ml_gtk_math_view_get_height" + external set_adjustments : [>`math_view] obj -> Gtk.adjustment obj -> Gtk.adjustment obj -> unit = + "ml_gtk_math_view_set_adjustments" + external get_hadjustment : [>`math_view] obj -> Gtk.adjustment obj = + "ml_gtk_math_view_get_hadjustment" + external get_vadjustment : [>`math_view] obj -> Gtk.adjustment obj = + "ml_gtk_math_view_get_vadjustment" + external get_buffer : [>`math_view] obj -> Gdk.pixmap = + "ml_gtk_math_view_get_buffer" + external get_frame : [>`math_view] obj -> [`frame] obj = + "ml_gtk_math_view_get_frame" + external set_font_size : [>`math_view] obj -> int -> unit = + "ml_gtk_math_view_set_font_size" + (*external get_top : [>`math_view] obj -> (int * int) = + "ml_gtk_math_view_get_top" + external set_top : [>`math_view] obj -> int -> int -> unit = + "ml_gtk_math_view_set_top"*) + + module Signals = struct + open GtkSignal + + let jump : ([>`math_view],_) t = + let marshal_jump f _ = + function + [GtkArgv.STRING (Some str)] -> f str + | _ -> invalid_arg "GtkMathView.MathView.Signals.marshal_jump" + in + { name = "jump"; marshaller = marshal_jump } + + let clicked : ([>`math_view],_) t = + let marshal_clicked f _ = + function + [] -> f () + | _ -> invalid_arg "GtkMathView.MathView.Signals.marshal_clicked" + in + { name = "clicked"; marshaller = marshal_clicked } + end +end diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gtk_mathview.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gtk_mathview.ml new file mode 100644 index 000000000..745a1ba82 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/gtk_mathview.ml @@ -0,0 +1 @@ +type math_view = [`widget|`container|`bin|`eventbox|`math_view] diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/ml_gtk_mathview.c b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/ml_gtk_mathview.c new file mode 100644 index 000000000..b16f68e50 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/ml_gtk_mathview.c @@ -0,0 +1,55 @@ +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +#include +#include +#include +#include +#include + +/* : Next row should be put in a .h of lablgtk. */ +#define GtkAdjustment_val(val) check_cast(GTK_ADJUSTMENT,val) + +#define GtkMathView_val(val) check_cast(GTK_MATH_VIEW,val) +ML_2 (gtk_math_view_new,GtkAdjustment_val, GtkAdjustment_val,Val_GtkWidget_sink) +ML_2 (gtk_math_view_load, GtkMathView_val, String_val, Val_bool) +ML_1 (gtk_math_view_unload, GtkMathView_val, Unit) +ML_1 (gtk_math_view_dump, GtkMathView_val, Unit) +ML_1 (gtk_math_view_get_width, GtkMathView_val, Val_int) +ML_1 (gtk_math_view_get_height, GtkMathView_val, Val_int) +//ML_3 (gtk_math_view_set_top, GtkMathView_val, Int_val, Int_val, Unit) +ML_3 (gtk_math_view_set_adjustments, GtkMathView_val, GtkAdjustment_val, GtkAdjustment_val, Unit) +ML_1 (gtk_math_view_get_hadjustment, GtkMathView_val, Val_GtkWidget) +ML_1 (gtk_math_view_get_vadjustment, GtkMathView_val, Val_GtkWidget) +ML_1 (gtk_math_view_get_buffer, GtkMathView_val, Val_GdkPixmap) +ML_1 (gtk_math_view_get_frame, GtkMathView_val, Val_GtkWidget) +ML_2 (gtk_math_view_set_font_size, GtkMathView_val, Int_val, Unit) + +/* +value ml_gtk_math_view_get_top (value arg1) +{ + CAMLparam1(arg1); + CAMLlocal1 (result); + int x, y; + gtk_math_view_get_top(GtkMathView_val (arg1), &x, &y); + result = alloc(2, 0); + Store_field(result, 0, Val_int(x)); + Store_field(result, 0, Val_int(y)); + CAMLreturn (result); +} +*/ + +value ml_gtk_math_view_get_selection (value arg1) +{ + const char *stringa; + stringa = gtk_math_view_get_selection (GtkMathView_val (arg1)); + return Val_option (stringa, Val_string); +} diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/Makefile b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/Makefile new file mode 100644 index 000000000..cc5bd50f5 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/Makefile @@ -0,0 +1,36 @@ +LABLGTK_DIR = ../../lablgtk-20000829 +LABLGTK_MATHVIEW_DIR = .. +OCAMLC = ocamlc -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) -I mlmathview +OCAMLOPT = ocamlopt -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) -I mlmathview + +all: test +opt: test.opt + +test: test.cmo + $(OCAMLC) -custom -o test lablgtk.cma gtkInit.cmo \ + $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cma \ + test.cmo \ + -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ + -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ + -L/usr/local/lib/gtkmathview -lgtkmathview \ + $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" + +test.opt: test.cmx + $(OCAMLOPT) -o test.opt lablgtk.cmxa gtkInit.cmx \ + $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cmxa \ + test.cmx \ + -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ + -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ + -L/usr/local/lib/gtkmathview -lgtkmathview \ + $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" + +.SUFFIXES: .ml .mli .cmo .cmi .cmx +.ml.cmo: + $(OCAMLC) -c $< +.mli.cmi: + $(OCAMLC) -c $< +.ml.cmx: + $(OCAMLOPT) -c $< + +clean: + rm -f *.cm[iox] *.o test test.opt diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/test.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/test.ml new file mode 100644 index 000000000..e914f4d6b --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/test.ml @@ -0,0 +1,141 @@ +(******************************************************************************) +(* Claudio Sacerdoti Coen *) +(* 25/09/2000 *) +(* *) +(* This is a simple test for the OCaml (LablGtk indeed) binding of the *) +(* MathView widget *) +(******************************************************************************) + +(* Callbacks *) +let jump s = + print_string ("jump: " ^ s ^ "\n") ; + flush stdout +;; + +let clicked () = + print_string "clicked: IT WORKS\n" ; + flush stdout +;; + +let load mathview () = + mathview#load "test.xml" ; + print_string "load: SEEMS TO WORK\n" ; + flush stdout +;; + +exception Ok;; +let get_selection mathview () = + let selection = + match mathview#get_selection with + None -> "NO SELECTION" + | Some s -> s + in + print_string ("get_selection: " ^ selection ^ "\n") ; + flush stdout +;; + +let unload mathview () = + mathview#unload ; + print_string "unload: SEEMS TO WORK\n" ; + flush stdout +;; + +let dump mathview () = + mathview#dump ; + print_string "dump: SEEMS TO WORK\n" ; + flush stdout +;; + +let get_width mathview () = + print_string ("get_width: " ^ string_of_int (mathview#get_width) ^ "\n") ; + flush stdout +;; + +let get_height mathview () = + print_string ("get_height: " ^ string_of_int (mathview#get_height) ^ "\n") ; + flush stdout +;; + +let set_adjustments mathview () = + let adj1 = GData.adjustment () in + let adj2 = GData.adjustment () in + mathview#set_adjustments adj1 adj2 ; + adj1#set_value ((adj1#lower +. adj1#upper) /. 2.0) ; + adj2#set_value ((adj2#lower +. adj2#upper) /. 2.0) ; + print_string "set_adjustments: SEEM TO WORK\n" ; + flush stdout +;; + +let get_hadjustment mathview () = + let adj = mathview#get_hadjustment in + adj#set_value ((adj#lower +. adj#upper) /. 2.0) ; + print_string "get_hadjustment: SEEM TO WORK\n" ; + flush stdout +;; + +let get_vadjustment mathview () = + let adj = mathview#get_vadjustment in + adj#set_value ((adj#lower +. adj#upper) /. 2.0) ; + print_string "get_vadjustment: SEEM TO WORK\n" ; + flush stdout +;; + +let get_buffer mathview () = + let buffer = mathview#get_buffer in + Gdk.Draw.rectangle buffer (Gdk.GC.create buffer) ~x:0 ~y:0 + ~width:50 ~height:50 ~filled:true () ; + print_string "get_buffer: SEEMS TO WORK (hint: force the widget redrawing)\n"; + flush stdout +;; + +let get_frame mathview () = + let frame = mathview#get_frame in + frame#set_shadow_type `NONE ; + print_string "get_frame: SEEMS TO WORK\n" ; + flush stdout +;; + +let set_font_size mathview () = + mathview#set_font_size 24 ; + print_string "set_font_size: FONT IS NOW 24\n" ; + flush stdout +;; + +(* Widget creation *) +let main_window = GWindow.window ~title:"GtkMathView test" () in +let vbox = GPack.vbox ~packing:main_window#add () in +let sw = GBin.scrolled_window ~width:50 ~height:50 ~packing:vbox#pack () in +(*let mathview = GMathView.math_view ~packing:sw#add_with_viewport ~width:50 ~height:50 () in*) +let mathview = GMathView.math_view ~packing:sw#add ~width:50 ~height:50 () in +let hbox = GPack.hbox ~packing:vbox#pack () in +let button_load = GButton.button ~label:"load" ~packing:hbox#pack () in +let button_get_selection = GButton.button ~label:"get_selection" ~packing:hbox#pack () in +let button_unload = GButton.button ~label:"unload" ~packing:hbox#pack () in +let button_dump = GButton.button ~label:"dump" ~packing:hbox#pack () in +let button_get_width = GButton.button ~label:"get_width" ~packing:hbox#pack () in +let button_get_height = GButton.button ~label:"get_height" ~packing:hbox#pack () in +let button_set_adjustments = GButton.button ~label:"set_adjustments" ~packing:hbox#pack () in +let button_get_hadjustment = GButton.button ~label:"get_hadjustment" ~packing:hbox#pack () in +let button_get_vadjustment = GButton.button ~label:"get_vadjustment" ~packing:hbox#pack () in +let button_get_buffer = GButton.button ~label:"get_buffer" ~packing:hbox#pack () in +let button_get_frame = GButton.button ~label:"get_frame" ~packing:hbox#pack () in +let button_set_font_size = GButton.button ~label:"set_font_size" ~packing:hbox#pack () in +(* Signals connection *) +ignore(button_load#connect#clicked (load mathview)) ; +ignore(button_get_selection#connect#clicked (get_selection mathview)) ; +ignore(button_unload#connect#clicked (unload mathview)) ; +ignore(button_dump#connect#clicked (dump mathview)) ; +ignore(button_get_width#connect#clicked (get_width mathview)) ; +ignore(button_get_height#connect#clicked (get_height mathview)) ; +ignore(button_set_adjustments#connect#clicked (set_adjustments mathview)) ; +ignore(button_get_hadjustment#connect#clicked (get_hadjustment mathview)) ; +ignore(button_get_vadjustment#connect#clicked (get_vadjustment mathview)) ; +ignore(button_get_buffer#connect#clicked (get_buffer mathview)) ; +ignore(button_get_frame#connect#clicked (get_frame mathview)) ; +ignore(button_set_font_size#connect#clicked (set_font_size mathview)) ; +ignore(mathview#connect#jump jump) ; +ignore(mathview#connect#clicked clicked) ; +(* Main Loop *) +main_window#show () ; +GMain.Main.main () +;; diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/test.xml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/test.xml new file mode 100644 index 000000000..b0f8c1563 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20000829_gtkmathview-0.1.0/test/test.xml @@ -0,0 +1,123 @@ + + + ∫ + ⁡ + + + + a + ⁢ + x + + + + b + + + + x + 2 + + + + + p + ⁢ + x + + + + q + + + + d + x + = + + + a2 + ⁢ + + ln + ⁡ + + ( + + x2 + + + + p + ⁢ + x + + + + q + + ) + + + + + + + + + + 2 + ⁢ + b + + - + + a + ⁢ + p + + + + + + 4 + ⁢ + q + + - + + p + 2 + + + + + ⁢ + + arctg + ⁡ + + + + 2 + ⁢ + x + + + + p + + + + + 4 + ⁢ + q + + - + + p + 2 + + + + + + + + + c + + diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/.cvsignore b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/.cvsignore new file mode 100644 index 000000000..cd9e25037 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/.cvsignore @@ -0,0 +1 @@ +*.cmi *.cmo *.cmx *.cma *.cmxa config.make diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/.depend b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/.depend new file mode 100644 index 000000000..600449bb8 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/.depend @@ -0,0 +1,4 @@ +gMathView.cmo: gtkMathView.cmo gtk_mathview.cmo +gMathView.cmx: gtkMathView.cmx gtk_mathview.cmx +gtkMathView.cmo: gtk_mathview.cmo +gtkMathView.cmx: gtk_mathview.cmx diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/COPYING b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/COPYING new file mode 100644 index 000000000..20b480a10 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/COPYING @@ -0,0 +1,11 @@ +This library is made available under the LGPL. +You should have got a copy of the LGPL with Objective Caml. +The LGPL applies to all the files in this directory, but not in +subdirectories. + +For the test subdirectory, there is no specific licensing policy, +but you may freely take inspiration from the code, and copy parts of +it in your application. + +Author: + Claudio Sacerdoti Coen diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/Makefile b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/Makefile new file mode 100644 index 000000000..b8adbb47b --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/Makefile @@ -0,0 +1,109 @@ +# Makefile for lablgtk_mathview. + +LABLGTKDIR = /usr/lib/ocaml/lablgtk +MINIDOMDIR = ./minidom +TESTDIR = ./test +MLFLAGS += -I $(LABLGTKDIR) -I $(MINIDOMDIR) + +TARGETS = ml_gtk_mathview.o lablgtkmathview.cma + +all: Minidom $(TARGETS) + +opt: Minidom.opt lablgtkmathviewopt + +Minidom: + cd $(MINIDOMDIR); make + +Minidom.opt: + cd $(MINIDOMDIR); make opt + +configure: + @rm -f config.make + @$(MAKE) --no-print-directory -f configure.mk + +depend: + @rm -f .depend + @$(MAKE) --no-print-directory -f configure.mk .depend + +.depend config.make: + @$(MAKE) --no-print-directory -f configure.mk + +COMPILER = $(CAMLC) $(MLFLAGS) -w s -labels -c +LINKER = $(CAMLC) $(MLFLAGS) +COMPOPT = $(CAMLOPT) $(MLFLAGS) -w s -labels -c +LINKOPT = $(CAMLOPT) $(MLFLAGS) + +include config.make + +INSTALLDIR = $(LIBDIR)/lablgtk/mathview + +MLLIBS = lablgtkmathview.cma +CLIBS = +MLLINK = unix.cma str.cma + +ifdef DEBUG +CFLAGS = -g $(GTKCFLAGS) +MLLINK += -cclib -lcamlrund +MLFLAGS += -g +else +CFLAGS = -O -DGTK_NO_CHECK_CASTS -DGTK_DISABLE_COMPAT_H $(GTKCFLAGS) +endif +CFLAGS += $(MINIDOMCFLAGS) $(GTKMATHVIEWCFLAGS) + +THFLAGS = -thread +THLINK = unix.cma threads.cma + +ifdef USE_CC +CCOMPILER = $(CC) -c -I$(LIBDIR) $(CFLAGS) +else +CCOMPILER = ocamlc -c -ccopt "$(CFLAGS)" +endif + +# Rules +.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .o .var .h .opt .def +.c.o: + $(CCOMPILER) $< +.ml.cmo: + $(COMPILER) $< +.mli.cmi: + $(COMPILER) $< +.ml.cmx: + $(COMPOPT) $< +.var.h: + ./var2def < $< > $@ +.var.c: + ./var2conv < $< > $@ + +# Targets +COBJS = ml_gtk_mathview.o +MLOBJS = gtk_mathview.cmo gtkMathView.cmo gMathView.cmo +ALLOBJS = $(MLOBJS) + +lablgtkmathviewopt: $(CLIBS) $(MLLIBS:.cma=.cmxa) + +install: + if test -d $(INSTALLDIR); then : ; else mkdir -p $(INSTALLDIR); fi + cp $(ALLOBJS:.cmo=.cmi) $(INSTALLDIR) + if test -f *.mli ; then cp *.mli $(INSTALLDIR) ; fi + cp $(ALLOBJS:.cmo=.ml) $(INSTALLDIR) + cp $(MLLIBS) $(INSTALLDIR) + cp $(COBJS) $(INSTALLDIR) + if test ! -z "$(CLIBS)" ; then cp $(CLIBS) $(INSTALLDIR) ; fi + if test -f lablgtkmathview.cmxa; then \ + cp $(MLLIBS:.cma=.cmxa) $(MLLIBS:.cma=.a) \ + $(INSTALLDIR); fi + +lablgtkmathview.cma: $(MLOBJS) + $(LINKER) -a -custom -o $@ $(MLOBJS) $(GTKLIBS) -cclib "$(GTKMATHVIEWLIBS)" -cclib "$(MINIDOMLIBS)" +lablgtkmathview.cmxa: $(MLOBJS:.cmo=.cmx) + $(LINKOPT) -a -o $@ $(MLOBJS:.cmo=.cmx) $(GTKLIBS) -cclib "$(GTKMATHVIEWLIBS)" -cclib "$(MINIDOMLIBS)" + +ml_gtk.o: $(LABLGTKDIR)/gtk_tags.c $(LABLGTKDIR)/gtk_tags.h \ + $(LABLGTKDIR)/ml_gtk.h $(LABLGTKDIR)/ml_gdk.h $(LABLGTKDIR)/wrappers.h + +clean: + rm -f *.cm* *.o *.a *_tags.[ch] $(TARGETS) + cd $(MINIDOMDIR); make clean + cd $(TESTDIR); make clean + +include .depend diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/configure.mk b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/configure.mk new file mode 100644 index 000000000..8982371ee --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/configure.mk @@ -0,0 +1,59 @@ +# makefile for configuring lablGTK_mathview + +# Default compilers +CAMLC = ocamlc +CAMLOPT = ocamlopt + +# Default installation directories +BINDIR = `$(GETBINDIR)` +INSTALLDIR = $(LIBDIR)/lablgtk/mathview + +# Autoconf +GETLIBDIR = ocamlc -v | grep "^Standard" | sed 's/^.*: *//' +LIBDIR = `$(GETLIBDIR)` +GETBINDIR = $(GETLIBDIR) | sed -e 's|/lib/[^/]*$$|/bin|' -e 's|/lib$$|/bin|' +GETRANLIB = which ranlib 2>/dev/null | sed -e 's|.*/ranlib$$|!|' -e 's/^[^!]*$$/:/' -e 's/!/ranlib/' + +ifdef USE_GNOME +GTKGETCFLAGS = gtk-config --cflags`" -I"`gnome-config --includedir +GNOMELIBS = `gnome-config --libs gtkxmhtml` +else +GTKGETCFLAGS = gtk-config --cflags +endif + +GTKGETLIBS = gtk-config --libs + +configure: .depend config.make + +.depend: + ocamldep *.ml *.mli > .depend + +config.make: + @echo CAMLC=$(CAMLC) > config.make + @echo CAMLOPT=$(CAMLOPT) >> config.make + @echo USE_GL=$(USE_GL) >> config.make + @echo USE_GNOME=$(USE_GNOME) >> config.make + @echo USE_CC=$(USE_CC) >> config.make + @echo DEBUG=$(DEBUG) >> config.make + @echo CC=$(CC) >> config.make + @echo RANLIB=`$(GETRANLIB)` >> config.make + @echo LIBDIR=$(LIBDIR) >> config.make + @echo BINDIR=`$(GETBINDIR)` >> config.make + @echo INSTALLDIR=$(INSTALLDIR) >> config.make +# Luca: was +# @echo GTKCFLAGS=`$(GTKGETCFLAGS)` -I/usr/lib/ocaml/lablgtk >> config.make +# Luca: now + @echo GTKCFLAGS=`$(GTKGETCFLAGS)` -I$(LIBDIR)/lablgtk >> config.make + @echo GTKLIBS=`$(GTKGETLIBS)` | \ + sed -e 's/-l/-cclib &/g' -e 's/-[LRWr][^ ]*/-ccopt &/g' \ + >> config.make +# Luca: GtkMathView configuration + @echo GTKMATHVIEWCFLAGS=`gtkmathview-config --cflags` >> config.make + @echo MINIDOMCFLAGS=`minidom-config --cflags` >> config.make + @echo GTKMATHVIEWLIBS=`gtkmathview-config --libs` >> config.make + @echo MINIDOMLIBS=`minidom-config --libs` >> config.make +# Luca: end of GtkMathView configuration + @echo GNOMELIBS=$(GNOMELIBS) | \ + sed -e 's/-l/-cclib &/g' -e 's/-[LRWr][^ ]*/-ccopt &/g' \ + >> config.make + cat config.make diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gMathView.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gMathView.ml new file mode 100644 index 000000000..e897ccfdb --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gMathView.ml @@ -0,0 +1,80 @@ +open Gaux +open Gtk +open Gtk_mathview +open GtkBase +open GtkMathView +open GObj + +exception ErrorLoadingFile of string;; +exception ErrorWritingFile of string;; +exception NoSelection;; + +class math_view_signals obj = object + inherit GContainer.container_signals obj + method clicked = GtkSignal.connect ~sgn:MathView.Signals.clicked obj ~after + method jump = GtkSignal.connect ~sgn:MathView.Signals.jump obj ~after + method selection_changed = + GtkSignal.connect ~sgn:MathView.Signals.selection_changed obj ~after +end + +class math_view obj = object + inherit GContainer.container (obj : Gtk_mathview.math_view obj) + method connect = new math_view_signals obj + method load ~filename = + if not (MathView.load obj ~filename) then raise (ErrorLoadingFile filename) + method unload = MathView.unload obj + method get_selection = MathView.get_selection obj + method set_selection (node : Ominidom.o_mDOMNode option) = MathView.set_selection obj node + method get_width = MathView.get_width obj + method get_height = MathView.get_height obj + method get_top = MathView.get_top obj + method set_top = MathView.set_top obj + method set_adjustments = + fun adj1 adj2 -> + MathView.set_adjustments obj (GData.as_adjustment adj1) + (GData.as_adjustment adj2) + method get_hadjustment = new GData.adjustment (MathView.get_hadjustment obj) + method get_vadjustment = new GData.adjustment (MathView.get_vadjustment obj) + method get_buffer = MathView.get_buffer obj + method get_frame = new GBin.frame (MathView.get_frame obj) + method set_font_size = MathView.set_font_size obj + method get_font_size = MathView.get_font_size obj + method set_anti_aliasing = MathView.set_anti_aliasing obj + method get_anti_aliasing = MathView.get_anti_aliasing obj + method set_kerning = MathView.set_kerning obj + method get_kerning = MathView.get_kerning obj + method set_log_verbosity = MathView.set_log_verbosity obj + method get_log_verbosity = MathView.get_log_verbosity obj + method export_to_postscript + ?(width = 595) ?(height = 822) ?(x_margin = 72) ?(y_margin = 72) + ?(disable_colors = false) ~filename () = + let result = MathView.export_to_postscript obj + ~width ~height ~x_margin ~y_margin ~disable_colors ~filename + in + if not result then raise (ErrorWritingFile filename) + method get_font_manager_type = MathView.get_font_manager_type obj + method set_font_manager_type ~fm_type = MathView.set_font_manager_type obj ~fm_type +end + +let math_view ?adjustmenth ?adjustmentv ?font_size ?font_manager ?border_width + ?width ?height ?packing ?show () = + let w = + MathView.create + ?adjustmenth:(may_map ~f:GData.as_adjustment adjustmenth) + ?adjustmentv:(may_map ~f:GData.as_adjustment adjustmentv) + () + in + Container.set w ?border_width ?width ?height; + let mathview = pack_return (new math_view w) ~packing ~show in + begin + match font_size with + | Some size -> mathview#set_font_size size + | None -> () + end; + begin + match font_manager with + | Some manager -> mathview#set_font_manager_type ~fm_type:manager + | None -> () + end; + mathview +;; diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gtkMathView.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gtkMathView.ml new file mode 100644 index 000000000..4c893fab4 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gtkMathView.ml @@ -0,0 +1,118 @@ +open Gtk +open Gtk_mathview +open Tags +open GtkBase +open Gpointer + +external mDOMNode_of_boxed_option : + Gpointer.boxed option -> Minidom.mDOMNode = + "ml_gtk_math_view_mDOMNode_of_bodex_option" + +external mDOMNode_option_of_boxed_option : + Gpointer.boxed option -> Minidom.mDOMNode option = + "ml_gtk_math_view_mDOMNode_option_of_bodex_option" + +let o_mDOMNode_of_mDOMNode node = new Ominidom.o_mDOMNode node + +let o_mDOMNode_option_of_mDOMNode_option = + function + | Some x -> Some (o_mDOMNode_of_mDOMNode x) + | None -> None + +let mDOMNode_option_of_o_mDOMNode_option = + function + | Some x -> Some (x#get_dom_node) + | None -> None + +module MathView = struct + exception NoSelection + + let cast w : math_view obj = Object.try_cast w "GtkMathView" + external create : Gtk.adjustment optobj -> Gtk.adjustment optobj -> + math_view obj = "ml_gtk_math_view_new" + let create ~adjustmenth ~adjustmentv () = + create (optboxed adjustmenth) (optboxed adjustmentv) + external load : [>`math_view] obj -> filename:string -> bool = + "ml_gtk_math_view_load" + external unload : [>`math_view] obj -> unit = + "ml_gtk_math_view_unload" + external raw_get_selection : [>`math_view] obj -> Minidom.mDOMNode option = + "ml_gtk_math_view_get_selection" + let get_selection obj = + o_mDOMNode_option_of_mDOMNode_option (raw_get_selection obj) + external raw_set_selection : [>`math_view] obj -> Minidom.mDOMNode option -> unit= + "ml_gtk_math_view_set_selection" + let set_selection obj node = + raw_set_selection obj (mDOMNode_option_of_o_mDOMNode_option node) + external get_width : [>`math_view] obj -> int = + "ml_gtk_math_view_get_width" + external get_height : [>`math_view] obj -> int = + "ml_gtk_math_view_get_height" + external get_top : [>`math_view] obj -> (int * int) = + "ml_gtk_math_view_get_top" + external set_top : [>`math_view] obj -> int -> int -> unit = + "ml_gtk_math_view_set_top" + external set_adjustments : [>`math_view] obj -> Gtk.adjustment obj -> Gtk.adjustment obj -> unit = + "ml_gtk_math_view_set_adjustments" + external get_hadjustment : [>`math_view] obj -> Gtk.adjustment obj = + "ml_gtk_math_view_get_hadjustment" + external get_vadjustment : [>`math_view] obj -> Gtk.adjustment obj = + "ml_gtk_math_view_get_vadjustment" + external get_buffer : [>`math_view] obj -> Gdk.pixmap = + "ml_gtk_math_view_get_buffer" + external get_frame : [>`math_view] obj -> [`frame] obj = + "ml_gtk_math_view_get_frame" + external set_font_size : [>`math_view] obj -> int -> unit = + "ml_gtk_math_view_set_font_size" + external get_font_size : [>`math_view] obj -> int = + "ml_gtk_math_view_get_font_size" + external set_anti_aliasing : [>`math_view] obj -> bool -> unit = + "ml_gtk_math_view_set_anti_aliasing" + external get_anti_aliasing : [>`math_view] obj -> bool = + "ml_gtk_math_view_get_anti_aliasing" + external set_kerning : [>`math_view] obj -> bool -> unit = + "ml_gtk_math_view_set_kerning" + external get_kerning : [>`math_view] obj -> bool = + "ml_gtk_math_view_get_kerning" + external set_log_verbosity : [>`math_view] obj -> int -> unit = + "ml_gtk_math_view_set_log_verbosity" + external get_log_verbosity : [>`math_view] obj -> int = + "ml_gtk_math_view_get_log_verbosity" + external export_to_postscript : + [>`math_view] obj -> width:int -> height:int -> x_margin:int -> y_margin:int -> disable_colors:bool -> filename:string -> bool = + "ml_gtk_math_view_export_to_postscript_bytecode" "ml_gtk_math_view_export_to_postscript_native" + external get_font_manager_type : [>`math_view] obj -> + [`font_manager_gtk | `font_manager_t1] = + "ml_gtk_math_view_get_font_manager_type" + external set_font_manager_type : [>`math_view] obj -> + fm_type:[`font_manager_gtk | `font_manager_t1] -> unit = + "ml_gtk_math_view_set_font_manager_type" + + module Signals = struct + open GtkSignal + + let clicked : ([>`math_view],_) t = + let marshal_clicked f _ = + function + [GtkArgv.POINTER node] -> f (o_mDOMNode_of_mDOMNode (mDOMNode_of_boxed_option node)) + | _ -> invalid_arg "GtkMathView.MathView.Signals.marshal_clicked" + in + { name = "clicked"; marshaller = marshal_clicked } + + let jump : ([>`math_view],_) t = + let marshal_jump f _ = + function + [GtkArgv.POINTER node] -> f (o_mDOMNode_of_mDOMNode (mDOMNode_of_boxed_option node)) + | _ -> invalid_arg "GtkMathView.MathView.Signals.marshal_jump" + in + { name = "jump"; marshaller = marshal_jump } + + let selection_changed : ([>`math_view],_) t = + let marshal_selection_changed f _ = + function + [GtkArgv.POINTER node] -> f (o_mDOMNode_option_of_mDOMNode_option (mDOMNode_option_of_boxed_option node)) + | _ -> invalid_arg "GtkMathView.MathView.Signals.marshal_selection_changed" + in + { name = "selection_changed"; marshaller = marshal_selection_changed } + end +end diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gtk_mathview.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gtk_mathview.ml new file mode 100644 index 000000000..745a1ba82 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/gtk_mathview.ml @@ -0,0 +1 @@ +type math_view = [`widget|`container|`bin|`eventbox|`math_view] diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/.cvsignore b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/.cvsignore new file mode 100644 index 000000000..84bdd8eff --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/.cvsignore @@ -0,0 +1 @@ +*.cmi *.cmo *.cmx test test.opt diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/Makefile b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/Makefile new file mode 100644 index 000000000..6fe73af6a --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/Makefile @@ -0,0 +1,51 @@ +LIBDIR = /usr/lib/ocaml +INSTALLDIR = $(LIBDIR)/minidom +OBJECTS = minidom.cmi minidom.cmo ml_minidom.o ominidom.cmi ominidom.cmo +OBJECTS_OPT = minidom.cmx ominidom.cmx +INST = minidom.o ominidom.o ml_minidom.h minidom.mli + +all: $(OBJECTS) test + +opt: $(OBJECTS_OPT) test.opt + +ml_minidom.o: ml_minidom.c + gcc -c -I/usr/lib/ocaml/caml/ `glib-config --cflags` `minidom-config --cflags` $< + +minidom.cmi: minidom.mli + ocamlc -c $< + +minidom.cmo: minidom.ml minidom.cmi + ocamlc -c $< + +minidom.cmx: minidom.ml minidom.cmi + ocamlopt -c $< + +ominidom.cmi: ominidom.mli + ocamlc -c $< + +ominidom.cmo: ominidom.ml + ocamlc -c $< + +ominidom.cmx: ominidom.ml + ocamlopt -c $< + +test.cmo: test.ml minidom.cmo + ocamlc -c test.ml + +test.cmx: test.ml minidom.cmx + ocamlopt -c test.ml + +test: test.cmo minidom.cmo ml_minidom.o + ocamlc -custom -o test minidom.cmo test.cmo ml_minidom.o \ + -cclib "`glib-config --libs` `minidom-config --libs`" + +test.opt: test.cmx minidom.cmx ml_minidom.o + ocamlopt -o test.opt minidom.cmx test.cmx ml_minidom.o \ + -cclib "`glib-config --libs` `minidom-config --libs`" + +install: + if test -d $(INSTALLDIR); then : ; else mkdir -p $(INSTALLDIR); fi + cp $(OBJECTS) $(OBJECTS_OPT) $(INST) $(INSTALLDIR) + +clean: + rm -f *.o *.cm? test test.opt diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/minidom.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/minidom.ml new file mode 100644 index 000000000..31e677b3f --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/minidom.ml @@ -0,0 +1,61 @@ + +type mDOMString +type mDOMDoc +type mDOMNode +type mDOMAttr +type mDOMEntity + +external string_of_mDOMString : mDOMString -> string = "ml_string_of_mDOMString" +external mDOMString_of_string : string -> mDOMString = "ml_mDOMString_of_string" +external mDOMString_eq : string -> string -> bool = "ml_mDOMString_eq" + +external doc_load : string -> mDOMDoc = "ml_doc_load" +external doc_unload : mDOMDoc -> unit = "ml_doc_unload" + +external doc_new : mDOMString -> mDOMDoc = "ml_doc_new" +external doc_get_root_node : mDOMDoc -> mDOMNode = "ml_doc_get_root_node" + +external doc_add_entity : mDOMDoc -> mDOMString -> mDOMString -> mDOMEntity = "ml_doc_add_entity" +external doc_get_entity : mDOMDoc -> mDOMString -> mDOMEntity option = "ml_doc_get_entity" +external doc_get_predefined_entity : mDOMDoc -> mDOMString -> mDOMEntity option = "ml_doc_get_predefined_entity" +external entity_get_content : mDOMEntity -> mDOMString = "ml_entity_get_content" + +external node_is_text : mDOMNode -> bool = "ml_node_is_text" +external node_is_element : mDOMNode -> bool = "ml_node_is_element" +external node_is_blank : mDOMNode -> bool = "ml_node_is_blank" +external node_is_entity_ref : mDOMNode -> bool = "ml_node_is_entity_ref" +external node_get_type : mDOMNode -> int = "ml_node_get_type" +external node_get_name : mDOMNode -> mDOMString option = "ml_node_get_name" +external node_get_ns_uri : mDOMNode -> mDOMString option = "ml_node_get_ns_uri" +external node_get_attribute : mDOMNode -> mDOMString -> mDOMString option = "ml_node_get_attribute" +external node_get_attribute_ns : mDOMNode -> mDOMString -> mDOMString -> mDOMString option = "ml_node_get_attribute_ns" +external node_get_content : mDOMNode -> mDOMString option = "ml_node_get_content" +external node_get_parent : mDOMNode -> mDOMNode option = "ml_node_get_parent" +external node_get_prev_sibling : mDOMNode -> mDOMNode option = "ml_node_get_prev_sibling" +external node_get_next_sibling : mDOMNode -> mDOMNode option = "ml_node_get_next_sibling" +external node_get_first_child : mDOMNode -> mDOMNode option = "ml_node_get_first_child" +external node_get_first_attribute : mDOMNode -> mDOMAttr option = "ml_node_get_first_attribute" +external node_is_first : mDOMNode -> bool = "ml_node_is_first" +external node_is_last : mDOMNode -> bool = "ml_node_is_last" + +external attr_get_name : mDOMAttr -> mDOMString option = "ml_attr_get_name" +external attr_get_ns_uri : mDOMAttr -> mDOMString option = "ml_attr_get_ns_uri" +external attr_get_value : mDOMAttr -> mDOMString option = "ml_attr_get_value" +external attr_get_prev_sibling : mDOMAttr -> mDOMAttr option = "ml_attr_get_prev_sibling" +external attr_get_next_sibling : mDOMAttr -> mDOMAttr option = "ml_attr_get_next_sibling" +external attr_get_parent : mDOMAttr -> mDOMNode option = "ml_attr_get_parent" + +let rec node_list_of_node_first = + function None -> [] + | Some node -> node :: (node_list_of_node_first (node_get_next_sibling node)) + +let rec attr_list_of_attr_first = + function None -> [] + | Some attr -> attr :: (attr_list_of_attr_first (attr_get_next_sibling attr)) + +let node_get_children node = + (node_list_of_node_first (node_get_first_child node)) + +let node_get_attributes node = + (attr_list_of_attr_first (node_get_first_attribute node)) + diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/minidom.mli b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/minidom.mli new file mode 100644 index 000000000..0b655955b --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/minidom.mli @@ -0,0 +1,50 @@ + +type mDOMString +type mDOMDoc +type mDOMNode +type mDOMAttr +type mDOMEntity + +external string_of_mDOMString : mDOMString -> string = "ml_string_of_mDOMString" +external mDOMString_of_string : string -> mDOMString = "ml_mDOMString_of_string" +external mDOMString_eq : string -> string -> bool = "ml_mDOMString_eq" + +external doc_load : string -> mDOMDoc = "ml_doc_load" +external doc_unload : mDOMDoc -> unit = "ml_doc_unload" + +external doc_new : mDOMString -> mDOMDoc = "ml_doc_new" +external doc_get_root_node : mDOMDoc -> mDOMNode = "ml_doc_get_root_node" + +external doc_add_entity : doc:mDOMDoc -> name:mDOMString -> content:mDOMString -> mDOMEntity = "ml_doc_add_entity" +external doc_get_entity : doc:mDOMDoc -> name:mDOMString -> mDOMEntity option = "ml_doc_get_entity" +external doc_get_predefined_entity : doc:mDOMDoc -> name:mDOMString -> mDOMEntity option = "ml_doc_get_predefined_entity" +external entity_get_content : mDOMEntity -> mDOMString = "ml_entity_get_content" + +external node_is_text : mDOMNode -> bool = "ml_node_is_text" +external node_is_element : mDOMNode -> bool = "ml_node_is_element" +external node_is_blank : mDOMNode -> bool = "ml_node_is_blank" +external node_is_entity_ref : mDOMNode -> bool = "ml_node_is_entity_ref" +external node_get_type : mDOMNode -> int = "ml_node_get_type" +external node_get_name : mDOMNode -> mDOMString option = "ml_node_get_name" +external node_get_ns_uri : mDOMNode -> mDOMString option = "ml_node_get_ns_uri" +external node_get_attribute : node:mDOMNode -> name:mDOMString -> mDOMString option = "ml_node_get_attribute" +external node_get_attribute_ns : node:mDOMNode -> name:mDOMString -> ns_uri:mDOMString -> mDOMString option = "ml_node_get_attribute_ns" +external node_get_content : mDOMNode -> mDOMString option = "ml_node_get_content" +external node_get_parent : mDOMNode -> mDOMNode option = "ml_node_get_parent" +external node_get_prev_sibling : mDOMNode -> mDOMNode option = "ml_node_get_prev_sibling" +external node_get_next_sibling : mDOMNode -> mDOMNode option = "ml_node_get_next_sibling" +external node_get_first_child : mDOMNode -> mDOMNode option = "ml_node_get_first_child" +external node_get_first_attribute : mDOMNode -> mDOMAttr option = "ml_node_get_first_attribute" +external node_is_first : mDOMNode -> bool = "ml_node_is_first" +external node_is_last : mDOMNode -> bool = "ml_node_is_last" + +external attr_get_name : mDOMAttr -> mDOMString option = "ml_attr_get_name" +external attr_get_ns_uri : mDOMAttr -> mDOMString option = "ml_attr_get_ns_uri" +external attr_get_value : mDOMAttr -> mDOMString option = "ml_attr_get_value" +external attr_get_prev_sibling : mDOMAttr -> mDOMAttr option = "ml_attr_get_prev_sibling" +external attr_get_next_sibling : mDOMAttr -> mDOMAttr option = "ml_attr_get_next_sibling" +external attr_get_parent : mDOMAttr -> mDOMNode option = "ml_attr_get_parent" + +val node_get_children : mDOMNode -> mDOMNode list +val node_get_attributes : mDOMNode -> mDOMAttr list + diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ml_minidom.c b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ml_minidom.c new file mode 100644 index 000000000..10626143c --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ml_minidom.c @@ -0,0 +1,288 @@ + +#include +#include +#include + +#include "minidom.h" + +#define Val_ptr(p) ((value) (p)) +#define Val_option(p,f) ((p != NULL) ? ml_some(f(p)) : Val_unit) +#define Val_mDOMString(s) (copy_string((char*) (s))) +#define mDOMString_val(v) ((mDOMStringRef) String_val(v)) + +static value +ml_some(value v) +{ + CAMLparam1(v); + value ret = alloc_small(1,0); + Field(ret,0) = v; + CAMLreturn(ret); +} + +value +ml_string_of_mDOMString(value s) +{ + CAMLparam1(s); + CAMLreturn(s); +} + +value +ml_mDOMString_of_string(value s) +{ + CAMLparam1(s); + CAMLreturn(s); +} + +value +ml_doc_load(value file_name) +{ + mDOMDocRef doc_ref; + + CAMLparam1(file_name); + + doc_ref = mdom_load(String_val(file_name), FALSE, NULL); + if (doc_ref == NULL) failwith("minidom: could not load document"); + + CAMLreturn((value) doc_ref); +} + +value +ml_doc_unload(value doc) +{ + CAMLparam1(doc); + + mdom_unload((mDOMDocRef) doc); + + CAMLreturn(Val_unit); +} + +value +ml_doc_new(value s) +{ + mDOMDocRef doc_ref; + + CAMLparam1(s); + + doc_ref = mdom_doc_new(mDOMString_val(s)); + if (doc_ref == NULL) failwith("minidom: could not create new document"); + + CAMLreturn((value) doc_ref); +} + + +value +ml_doc_get_root_node(value doc) +{ + mDOMNodeRef root; + + CAMLparam1(doc); + root = mdom_doc_get_root_node((mDOMDocRef) doc); + if (root == NULL) failwith("minidom: document has no root node!"); + + CAMLreturn((value) root); +} + +value +ml_doc_add_entity(value doc, value name, value content) +{ + mDOMEntityRef ent; + + CAMLparam3(doc, name, content); + ent = mdom_doc_add_entity((mDOMDocRef) doc, mDOMString_val(name), mDOMString_val(content)); + if (ent == NULL) failwith("minidom: could not add entity"); + + CAMLreturn((value) ent); +} + +value +ml_doc_get_entity(value doc, value name) +{ + mDOMEntityRef ent; + + CAMLparam2(doc, name); + ent = mdom_doc_get_entity((mDOMDocRef) doc, mDOMString_val(name)); + + CAMLreturn(Val_option(ent, Val_ptr)); +} + +value +ml_doc_get_predefined_entity(value name) +{ + mDOMEntityRef ent; + + CAMLparam1(name); + ent = mdom_get_predefined_entity(mDOMString_val(name)); + + CAMLreturn(Val_option(ent, Val_ptr)); +} + +value +ml_entity_get_content(value ent) +{ + CAMLparam1(ent); + CAMLreturn(Val_mDOMString(mdom_entity_get_content((mDOMEntityRef) ent))); +} + +value +ml_node_is_text(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_bool(mdom_node_is_text((mDOMNodeRef) node))); +} + +value +ml_node_is_element(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_bool(mdom_node_is_element((mDOMNodeRef) node))); +} + +value +ml_node_is_blank(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_bool(mdom_node_is_blank((mDOMNodeRef) node))); +} + +value +ml_node_is_entity_ref(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_bool(mdom_node_is_entity_ref((mDOMNodeRef) node))); +} + +value +ml_node_get_type(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_int(mdom_node_get_type((mDOMNodeRef) node))); +} + +value +ml_node_get_name(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_name((mDOMNodeRef) node), Val_mDOMString)); +} + +value +ml_node_get_content(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_content((mDOMNodeRef) node), Val_mDOMString)); +} + +value +ml_node_get_ns_uri(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_ns_uri((mDOMNodeRef) node), Val_mDOMString)); +} + +value +ml_node_get_attribute(value node, value name) +{ + CAMLparam2(node,name); + CAMLreturn(Val_option(mdom_node_get_attribute((mDOMNodeRef) node, String_val(name)), Val_mDOMString)); +} + +value +ml_node_get_attribute_ns(value node, value name, value ns_uri) +{ + CAMLparam2(node,name); + CAMLreturn(Val_option(mdom_node_get_attribute_ns((mDOMNodeRef) node, + String_val(name), + String_val(ns_uri)), Val_mDOMString)); +} + +value +ml_node_get_parent(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_parent((mDOMNodeRef) node), Val_ptr)); +} + +value +ml_node_get_prev_sibling(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_prev_sibling((mDOMNodeRef) node), Val_ptr)); +} + +value +ml_node_get_next_sibling(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_next_sibling((mDOMNodeRef) node), Val_ptr)); +} + +value +ml_node_get_first_child(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_first_child((mDOMNodeRef) node), Val_ptr)); +} + +value +ml_node_get_first_attribute(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_option(mdom_node_get_first_attribute((mDOMNodeRef) node), Val_ptr)); +} + +value +ml_node_is_first(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_bool(mdom_node_is_first((mDOMNodeRef) node))); +} + +value +ml_node_is_last(value node) +{ + CAMLparam1(node); + CAMLreturn(Val_bool(mdom_node_is_last((mDOMNodeRef) node))); +} + +value +ml_attr_get_name(value attr) +{ + CAMLparam1(attr); + CAMLreturn(Val_option(mdom_attr_get_name((mDOMAttrRef) attr), Val_mDOMString)); +} + +value +ml_attr_get_ns_uri(value attr) +{ + CAMLparam1(attr); + CAMLreturn(Val_option(mdom_attr_get_ns_uri((mDOMAttrRef) attr), Val_mDOMString)); +} + +value +ml_attr_get_value(value attr) +{ + CAMLparam1(attr); + CAMLreturn(Val_option(mdom_attr_get_value((mDOMAttrRef) attr), Val_mDOMString)); +} + +value +ml_attr_get_prev_sibling(value attr) +{ + CAMLparam1(attr); + CAMLreturn(Val_option(mdom_attr_get_prev_sibling((mDOMAttrRef) attr), Val_ptr)); +} + +value +ml_attr_get_next_sibling(value attr) +{ + CAMLparam1(attr); + CAMLreturn(Val_option(mdom_attr_get_next_sibling((mDOMAttrRef) attr), Val_ptr)); +} + +value +ml_attr_get_parent(value attr) +{ + CAMLparam1(attr); + CAMLreturn(Val_option(mdom_attr_get_parent((mDOMAttrRef) attr), Val_ptr)); +} + diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ml_minidom.h b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ml_minidom.h new file mode 100644 index 000000000..d22479964 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ml_minidom.h @@ -0,0 +1,18 @@ + +#ifndef ml_minidom_h +#define ml_minidom_h + +#define Val_ptr(p) ((value) (p)) +#ifndef Val_option +#define Val_option(p,f) ((p != NULL) ? ml_some(f(p)) : Val_unit) +#endif /* Val_option */ +#define Val_mDOMString(s) (copy_string((char*) (s))) +#define mDOMString_val(v) ((mDOMStringRef) String_val(v)) +#define mDOMNode_val(v) ((mDOMNodeRef) v) + +#define mDOMNode_option_mDOMNodeRef(p) (((p) != NULL) ? ml_some((value) (p)) : Val_unit) +#define mDOMNodeRef_mDOMNode_option(v) ((v == Val_unit) ? NULL : (mDOMNodeRef)Field((v),0)) +#define Val_mDOMNodeRef(p) (mDOMNode_option_mDOMNodeRef(p)) +#define mDOMNodeRef_val(v) (mDOMNodeRef_mDOMNode_option(v)) + +#endif /* ml_minidom_h */ diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ominidom.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ominidom.ml new file mode 100644 index 000000000..85ad2e4ed --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ominidom.ml @@ -0,0 +1,156 @@ + +exception Node_has_no_parent;; +exception Node_has_no_sibling of string;; +exception Node_has_no_children;; +exception Node_has_no_attributes;; +exception Attribute_has_no_sibling of string;; +exception Attribute_has_no_parent;; +exception Undefined_entity;; + +let option_to_exception v e = + match v with + Some x -> x + | None -> raise e +;; + +class o_mDOMString (str: Minidom.mDOMString) = + object + method get_dom_string = str + method get_string = Minidom.string_of_mDOMString str + end;; + +let o_mDOMString_of_string str = + new o_mDOMString (Minidom.mDOMString_of_string str) + +class o_mDOMEntity (ent : Minidom.mDOMEntity) = + object + method get_dom_entity = ent + method get_content = + new o_mDOMString (Minidom.entity_get_content ent) + end +;; + +class o_mDOMDoc (doc : Minidom.mDOMDoc) = + object + method get_dom_doc = doc + + method get_root_node = + new o_mDOMNode (Minidom.doc_get_root_node doc) + method add_entity (name : o_mDOMString) (value : o_mDOMString) = + new o_mDOMEntity + (Minidom.doc_add_entity doc + (name#get_dom_string) (value#get_dom_string) + ) + method get_entity (name : o_mDOMString) = + match Minidom.doc_get_entity doc (name#get_dom_string) with + | Some x -> new o_mDOMEntity x + | None -> raise Undefined_entity + method get_predefined_entity (name : o_mDOMString) = + match Minidom.doc_get_predefined_entity doc (name#get_dom_string) with + | Some x -> new o_mDOMEntity x + | None -> raise Undefined_entity + end +and o_mDOMNode (node : Minidom.mDOMNode) = + object + method get_dom_node = node + + method is_text = Minidom.node_is_text node + method is_element = Minidom.node_is_element node + method is_blank = Minidom.node_is_blank node + method is_entity_ref = Minidom.node_is_entity_ref node + + method get_type = Minidom.node_get_type node + method get_name = + match Minidom.node_get_name node with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_ns_uri = + match Minidom.node_get_ns_uri node with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_attribute (name : o_mDOMString) = + match Minidom.node_get_attribute node (name#get_dom_string) with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_attribute_ns (name : o_mDOMString) (uri : o_mDOMString) = + match + Minidom.node_get_attribute_ns node + (name#get_dom_string) (uri#get_dom_string) + with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_content = + match Minidom.node_get_content node with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_parent = + new o_mDOMNode + (option_to_exception (Minidom.node_get_parent node) Node_has_no_parent) + method get_prev_sibling = + new o_mDOMNode + (option_to_exception + (Minidom.node_get_prev_sibling node) + (Node_has_no_sibling "left") + ) + method get_next_sibling = + new o_mDOMNode + (option_to_exception + (Minidom.node_get_next_sibling node) + (Node_has_no_sibling "right") + ) + method get_first_child = + new o_mDOMNode + (option_to_exception + (Minidom.node_get_first_child node) + (Node_has_no_children) + ) + method get_first_attribute = + new o_mDOMAttr + (option_to_exception + (Minidom.node_get_first_attribute node) + (Node_has_no_attributes) + ) + method is_first = Minidom.node_is_first node + method is_last = Minidom.node_is_last node + + method get_children = + List.map (function x -> new o_mDOMNode x) (Minidom.node_get_children node) + method get_attributes = List.map + (function x -> new o_mDOMAttr x) (Minidom.node_get_attributes node) + end +and o_mDOMAttr (attr : Minidom.mDOMAttr) = + object + method get_dom_attr = attr + + method get_name = + match Minidom.attr_get_name attr with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_ns_uri = + match Minidom.attr_get_ns_uri attr with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_value = + match Minidom.attr_get_value attr with + | Some x -> Some (new o_mDOMString x) + | None -> None + method get_prev_sibling = + new o_mDOMAttr + (option_to_exception + (Minidom.attr_get_prev_sibling attr) + (Attribute_has_no_sibling "left") + ) + method get_next_sibling = + new o_mDOMAttr + (option_to_exception + (Minidom.attr_get_next_sibling attr) + (Attribute_has_no_sibling "right") + ) + method get_parent = + new o_mDOMNode + (option_to_exception + (Minidom.attr_get_parent attr) Attribute_has_no_parent + ) + end +;; + diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ominidom.mli b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ominidom.mli new file mode 100644 index 000000000..24329544d --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/ominidom.mli @@ -0,0 +1,64 @@ +exception Node_has_no_parent +exception Node_has_no_sibling of string +exception Node_has_no_children +exception Node_has_no_attributes +exception Attribute_has_no_sibling of string +exception Attribute_has_no_parent +exception Undefined_entity + +class o_mDOMString : Minidom.mDOMString -> + object + method get_dom_string : Minidom.mDOMString + method get_string : string + end + +val o_mDOMString_of_string : string -> o_mDOMString + +class o_mDOMEntity : Minidom.mDOMEntity -> + object + method get_content : o_mDOMString + method get_dom_entity : Minidom.mDOMEntity + end + +class o_mDOMDoc : Minidom.mDOMDoc -> + object + method add_entity : o_mDOMString -> o_mDOMString -> o_mDOMEntity + method get_dom_doc : Minidom.mDOMDoc + method get_entity : o_mDOMString -> o_mDOMEntity + method get_predefined_entity : o_mDOMString -> o_mDOMEntity + method get_root_node : o_mDOMNode + end +and o_mDOMNode : Minidom.mDOMNode -> + object + method get_attribute : o_mDOMString -> o_mDOMString option + method get_attribute_ns : + o_mDOMString -> o_mDOMString -> o_mDOMString option + method get_attributes : o_mDOMAttr list + method get_children : o_mDOMNode list + method get_content : o_mDOMString option + method get_dom_node : Minidom.mDOMNode + method get_first_attribute : o_mDOMAttr + method get_first_child : o_mDOMNode + method get_name : o_mDOMString option + method get_next_sibling : o_mDOMNode + method get_ns_uri : o_mDOMString option + method get_parent : o_mDOMNode + method get_prev_sibling : o_mDOMNode + method get_type : int + method is_blank : bool + method is_element : bool + method is_entity_ref : bool + method is_first : bool + method is_last : bool + method is_text : bool + end +and o_mDOMAttr : Minidom.mDOMAttr -> + object + method get_dom_attr : Minidom.mDOMAttr + method get_name : o_mDOMString option + method get_next_sibling : o_mDOMAttr + method get_ns_uri : o_mDOMString option + method get_parent : o_mDOMNode + method get_prev_sibling : o_mDOMAttr + method get_value : o_mDOMString option + end diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/test.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/test.ml new file mode 100644 index 000000000..3c7a092e9 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/test.ml @@ -0,0 +1,84 @@ + +let doc = Minidom.doc_load "test.xml" + +let root = Minidom.doc_get_root_node doc + +let check_attribute_ns attr = + Printf.printf "\n\n"; + let ns_uri = Minidom.attr_get_ns_uri attr + and attr_name = Minidom.attr_get_name attr + and attr_value = Minidom.attr_get_value attr + and parent = Minidom.attr_get_parent attr + in + match parent,ns_uri,attr_name,attr_value with + Some parent_node,Some uri,Some attribute_name,Some attribute_value -> + let attr_value = Minidom.node_get_attribute_ns parent_node attribute_name uri + in begin + match attr_value with + Some attr1 -> + Printf.printf "found the attribute with ns %s (was %s)\n" + (Minidom.string_of_mDOMString attr1) (Minidom.string_of_mDOMString attribute_value) + | None -> + Printf.printf "attribute not found (uri was %s)!!!!\n" (Minidom.string_of_mDOMString uri) + end + | _ -> + Printf.printf "parent_node == NULL || uri == NULL || attribute_name == NULL || attribute_value == NULL\n" +;; + +let print_attribute attr = + check_attribute_ns attr; + let ns_uri = Minidom.attr_get_ns_uri attr + in + begin + match ns_uri with + Some uri -> Printf.printf " %s:" (Minidom.string_of_mDOMString uri); + | None -> () + end; + match ((Minidom.attr_get_name attr), (Minidom.attr_get_value attr)) with + (Some attr_name, Some attr_value) -> + Printf.printf " %s=\"%s\"" (Minidom.string_of_mDOMString attr_name) (Minidom.string_of_mDOMString attr_value) + | (Some attr_name, _) -> + Printf.printf " ??? attribute %s has no value !!!" (Minidom.string_of_mDOMString attr_name) + | (_,_) -> + Printf.printf " ??? very strange attribute !!!" +;; + +let rec print_node n node = + if Minidom.node_is_blank node then () + else if Minidom.node_is_element node then begin + match Minidom.node_get_name node with + Some node_name -> + begin + let children = Minidom.node_get_children node + and attributes = Minidom.node_get_attributes node + and ns_uri = Minidom.node_get_ns_uri node + and is_first,is_last = (Minidom.node_is_first node), (Minidom.node_is_last node) + in + for i = 1 to n do print_char ' ' done; + Printf.printf "<"; + begin + match ns_uri with + Some uri -> Printf.printf "%s:" (Minidom.string_of_mDOMString uri) + | None -> () + end; + Printf.printf "%s" (Minidom.string_of_mDOMString node_name); + List.iter print_attribute attributes; + Printf.printf ">\n"; + List.iter (print_node (n + 2)) children; + for i = 1 to n do print_char ' ' done; + Printf.printf "\n" (Minidom.string_of_mDOMString node_name) + end + | None -> Printf.printf "??? this node has no name !!!\n" + end else if Minidom.node_is_text node then begin + match Minidom.node_get_content node with + Some node_content -> + for i = 1 to n do print_char ' ' done; + Printf.printf "%s\n" (Minidom.string_of_mDOMString node_content) + | None -> Printf.printf "??? this node has no content !!!\n" + end else begin + Printf.printf "don't know how to manage a node with type %d\n" (Minidom.node_get_type node) + end +;; + +print_node 0 root;; + diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/test.xml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/test.xml new file mode 100644 index 000000000..83d2eef68 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/minidom/test.xml @@ -0,0 +1,505 @@ + + + + + + + + DEFINITION and_ind() OF TYPE + + + + + + + + __ + + + + + + + + ( + + + + + Π + A + : + + Prop + + + + + + + . + + + + + Π + B + : + + Prop + + + + + + + . + + + + + Π + P + : + + Prop + + + + + + + . + + + + + Π + f + : + + ( + A + → + + ( + B + → + P + ) + + ) + + + + + + + . + + Π + a + : + + ( + and + + _ + + A + + _ + + B + ) + + . + P + + + + + + + + + + + + + + + + + + + + + + + + + + + + :> + + Prop + + + + + + + + ) + + + + + + + + cast + + prod + + A + + + Prop + + + + + prod + + B + + + Prop + + + + + prod + + P + + + Prop + + + + + prod + + f + + + arrow + A + + arrow + B + P + + + + + + prod + + a + + + app + and + A + B + + + + P + + + + + + + Prop + + + + + + + + + + + AS + + + + + + + + __ + + + + + + + λ + A + : + + Prop + + + + + + + . + + + + + λ + B + : + + Prop + + + + + + + . + + + + + λ + P + : + + Prop + + + + + + + . + + + + + λ + f + : + + ( + A + → + + ( + B + → + P + ) + + ) + + + + + + + . + + + + + λ + a + : + + ( + and + + _ + + A + + _ + + B + ) + + + + + + + . + + < + P + > + CASES + + _ + + a + + _ + + OF + + ( + conj + + _ + + $1 + + _ + + $2 + ) + + ⇒ + + ( + f + + _ + + $1 + + _ + + $2 + ) + + + _ + + END + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + A + + + Prop + + + + + + B + + + Prop + + + + + + P + + + Prop + + + + + + f + + + arrow + A + + arrow + B + P + + + + + + + a + + + app + and + A + B + + + + + mutcase + P + a + + app + conj + $1 + $2 + + + app + f + $1 + $2 + + + + + + + + + + + + + + diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/ml_gtk_mathview.c b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/ml_gtk_mathview.c new file mode 100644 index 000000000..3c86f0057 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/ml_gtk_mathview.c @@ -0,0 +1,159 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +#include +#include +#include +#include +#include + +#include +#include "minidom/ml_minidom.h" + +/* : Next row should be put in a .h of lablgtk. */ +#define GtkAdjustment_val(val) check_cast(GTK_ADJUSTMENT,val) + +#define GtkMathView_val(val) check_cast(GTK_MATH_VIEW,val) + +#define FontManagerId_val(val) Int_val(val) +#define Val_FontManagerId(val) Val_int(val) + +FontManagerId +font_manager_id_of_value(value v) +{ + if (v == hash_variant("font_manager_gtk")) return FONT_MANAGER_GTK; + else if (v == hash_variant("font_manager_t1")) return FONT_MANAGER_T1; + else assert(0); +} + +value +value_of_font_manager_id(FontManagerId id) +{ + switch (id) { + case FONT_MANAGER_GTK: + return hash_variant("font_manager_gtk"); + case FONT_MANAGER_T1: + return hash_variant("font_manager_t1"); + default: + assert(0); + break; + } +} + +ML_2 (gtk_math_view_new,GtkAdjustment_val, GtkAdjustment_val, Val_GtkWidget_sink) +ML_2 (gtk_math_view_load, GtkMathView_val, String_val, Val_bool) +ML_1 (gtk_math_view_unload, GtkMathView_val, Unit) +/*ML_1 (gtk_math_view_dump, GtkMathView_val, Unit)*/ +ML_1 (gtk_math_view_get_selection, GtkMathView_val, Val_mDOMNodeRef) +ML_2 (gtk_math_view_set_selection, GtkMathView_val, mDOMNodeRef_val, Unit) +ML_1 (gtk_math_view_get_width, GtkMathView_val, Val_int) +ML_1 (gtk_math_view_get_height, GtkMathView_val, Val_int) +ML_3 (gtk_math_view_set_top, GtkMathView_val, Int_val, Int_val, Unit) +ML_3 (gtk_math_view_set_adjustments, GtkMathView_val, GtkAdjustment_val, GtkAdjustment_val, Unit) +ML_1 (gtk_math_view_get_hadjustment, GtkMathView_val, Val_GtkWidget) +ML_1 (gtk_math_view_get_vadjustment, GtkMathView_val, Val_GtkWidget) +ML_1 (gtk_math_view_get_buffer, GtkMathView_val, Val_GdkPixmap) +ML_1 (gtk_math_view_get_frame, GtkMathView_val, Val_GtkWidget) +ML_2 (gtk_math_view_set_font_size, GtkMathView_val, Int_val, Unit) +ML_1 (gtk_math_view_get_font_size, GtkMathView_val, Val_int) +ML_2 (gtk_math_view_set_anti_aliasing, GtkMathView_val, Bool_val, Unit) +ML_1 (gtk_math_view_get_anti_aliasing, GtkMathView_val, Val_bool) +ML_2 (gtk_math_view_set_kerning, GtkMathView_val, Bool_val, Unit) +ML_1 (gtk_math_view_get_kerning, GtkMathView_val, Val_bool) +ML_2 (gtk_math_view_set_log_verbosity, GtkMathView_val, Int_val, Unit) +ML_1 (gtk_math_view_get_log_verbosity, GtkMathView_val, Val_int) +ML_2 (gtk_math_view_set_font_manager_type, GtkMathView_val, font_manager_id_of_value, Unit) +ML_1 (gtk_math_view_get_font_manager_type, GtkMathView_val, value_of_font_manager_id) + +value +ml_gtk_math_view_export_to_postscript_native(value arg1, + value w, value h, value x0, value y0, value disable_colors, value arg2) +{ + CAMLparam5(arg1,w,h,x0,y0); + CAMLxparam2(disable_colors, arg2); + + char *filename; + FILE *fd; + int res; + filename = String_val (arg2); + if ((fd = fopen(filename, "w"))) { + gtk_math_view_export_to_postscript(GtkMathView_val (arg1), + Int_val(w), Int_val(h), Int_val(x0), Int_val(y0), Bool_val(disable_colors), fd); + fclose (fd); + res = 1; + } else { + fprintf(stderr, "Error opening file %s for writing\n", filename); + res = 0; + } + CAMLreturn (Val_bool(res)); +} + +value ml_gtk_math_view_export_to_postscript_bytecode (value* arg, int argn) +{ + return ml_gtk_math_view_export_to_postscript_native(arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6]); +} + +value ml_gtk_math_view_get_top (value arg1) +{ + CAMLparam1(arg1); + CAMLlocal1 (result); + int x, y; + gtk_math_view_get_top(GtkMathView_val (arg1), &x, &y); + result = alloc(2, 0); + Store_field(result, 0, Val_int(x)); + Store_field(result, 0, Val_int(y)); + CAMLreturn (result); +} + + +value ml_gtk_math_view_mDOMNode_of_bodex_option (value arg1) +{ + CAMLparam1(arg1); + + mDOMNodeRef nr; + CAMLlocal1 (tmp); + CAMLlocal1 (optval); + CAMLlocal1 (res); + + if (arg1==Val_int(0)) { + assert(0); + } else { + tmp = Field(arg1, 0); + nr = (mDOMNodeRef) Field(tmp, 1); + } + optval = Val_mDOMNodeRef(nr); + if (optval==Val_int(0)) { + assert(0); + } else { + res = Field(optval, 0); + } + + CAMLreturn(res); +} + +value ml_gtk_math_view_mDOMNode_option_of_bodex_option (value arg1) +{ + CAMLparam1(arg1); + + mDOMNodeRef nr; + CAMLlocal1 (tmp); + + if (arg1==Val_int(0)) { + nr=NULL; + } else { + tmp = Field(arg1, 0); + nr = (mDOMNodeRef) Field(tmp, 1); + } + + CAMLreturn(Val_mDOMNodeRef(nr)); +} diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/.cvsignore b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/.cvsignore new file mode 100644 index 000000000..1968614b7 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/.cvsignore @@ -0,0 +1 @@ +*.cmo *.cmi *.cmx t1lib.log test test.opt test.ps test.o diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/Makefile b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/Makefile new file mode 100644 index 000000000..d631d239f --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/Makefile @@ -0,0 +1,45 @@ +LABLGTK_DIR = /usr/lib/ocaml/lablgtk +LABLGTK_MATHVIEW_DIR = .. +MINIDOM_DIR = ../minidom +OCAMLC = ocamlc -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) \ + -I $(MINIDOM_DIR) -I mlmathview +OCAMLOPT = ocamlopt -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) \ + -I $(MINIDOM_DIR) -I mlmathview + +all: test +opt: test.opt + +test: test.cmo + $(OCAMLC) -custom -o test lablgtk.cma gtkInit.cmo \ + $(MINIDOM_DIR)/minidom.cmo \ + $(MINIDOM_DIR)/ominidom.cmo \ + $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cma \ + -cclib "$(MINIDOM_DIR)/ml_minidom.o" \ + test.cmo \ + -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ + -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ + -L/usr/local/lib/gtkmathview -lgtkmathview \ + $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" + +test.opt: test.cmx + $(OCAMLOPT) -o test.opt lablgtk.cmxa gtkInit.cmx \ + $(MINIDOM_DIR)/minidom.cmx \ + $(MINIDOM_DIR)/ominidom.cmx \ + $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cmxa \ + -cclib "$(MINIDOM_DIR)/ml_minidom.o" \ + test.cmx \ + -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ + -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ + -L/usr/local/lib/gtkmathview -lgtkmathview \ + $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" + +.SUFFIXES: .ml .mli .cmo .cmi .cmx +.ml.cmo: + $(OCAMLC) -c $< +.mli.cmi: + $(OCAMLC) -c $< +.ml.cmx: + $(OCAMLOPT) -c $< + +clean: + rm -f *.cm[iox] *.o test test.opt t1lib.log test.ps diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/t1.config b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/t1.config new file mode 100644 index 000000000..afb669e95 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/t1.config @@ -0,0 +1,3 @@ +ENCODING=. +AFM=/usr/share/texmf/fonts/afm/ +TYPE1=/usr/share/texmf/fonts/type1/bluesky/cm/:/usr/X11R6/lib/X11/fonts/Type1/:. diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/test.ml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/test.ml new file mode 100644 index 000000000..dd66d3885 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/test.ml @@ -0,0 +1,297 @@ +(******************************************************************************) +(* Claudio Sacerdoti Coen *) +(* 25/09/2000 *) +(* *) +(* This is a simple test for the OCaml (LablGtk indeed) binding of the *) +(* MathView widget *) +(******************************************************************************) + +(* Callbacks *) +let jump (node : Ominidom.o_mDOMNode) = + let module O = Ominidom in + print_string ("jump: " ^ + (match node#get_attribute (O.o_mDOMString_of_string "href") with + | Some x -> x#get_string + | None -> "NO HREF FOR THIS NODE" + ) ^ "\n"); + flush stdout +;; + +let selection_changed mathview (node : Ominidom.o_mDOMNode option) = + let module O = Ominidom in + print_string ("selection_changed: " ^ + (match node with + None -> "selection_changed on nothing" + | Some node -> + match node#get_name with + | Some x -> x#get_string + | None -> "on element without name" + ) ^ "\n"); + mathview#set_selection node; + flush stdout +;; + + +let clicked (node : Ominidom.o_mDOMNode) = + let module O = Ominidom in + print_string ("clicked: " ^ + (match node#get_name with + | Some x -> x#get_string + | None -> "no name" + ) ^ "\n"); + flush stdout +;; + + +let activate_t1 mathview () = + mathview#set_font_manager_type `font_manager_t1; + print_string "WIDGET SET WITH T1 FONTS\n" ; + flush stdout +;; + +let activate_gtk mathview () = + mathview#set_font_manager_type `font_manager_gtk; + print_string "WIDGET SET WITH GTK FONTS\n" ; + flush stdout +;; + +let get_font_manager_type mathview () = + print_string "CURRENT FONT MANAGER TYPE: "; + begin + match mathview#get_font_manager_type with + | `font_manager_t1 -> print_string "T1" + | `font_manager_gtk -> print_string "GTK" + end; + print_newline(); + flush stdout +;; + +let load mathview () = + mathview#load "test.xml" ; + print_string "load: SEEMS TO WORK\n" ; + flush stdout +;; + +let get_selection mathview () = + let module O = Ominidom in + let selection = + match mathview#get_selection with + | Some node -> + begin + match node#get_name with + | Some name -> name#get_string + | None -> "element with no name!" + end + | None -> "no selection!" + in + print_string ("get_selection: " ^ selection ^ "\n") ; + flush stdout +;; + +let set_selection mathview () = + let module O = Ominidom in + begin + match mathview#get_selection with + | Some node -> + begin + try + let parent_node = node#get_parent in + mathview#set_selection (Some parent_node); + print_string "set selection: SEEMS TO WORK\n" + with + _ -> print_string "EXCEPTION: no parent\n" + end + | None -> + mathview#set_selection None; + print_string "no selection\n" + end ; + flush stdout +;; + +let unload mathview () = + mathview#unload ; + print_string "unload: SEEMS TO WORK\n" ; + flush stdout +;; + +let get_width mathview () = + print_string ("get_width: " ^ string_of_int (mathview#get_width) ^ "\n") ; + flush stdout +;; + +let get_height mathview () = + print_string ("get_height: " ^ string_of_int (mathview#get_height) ^ "\n") ; + flush stdout +;; + +let get_top mathview () = + let (x,y) = mathview#get_top in + print_string ("get_top: ("^ string_of_int x ^ "," ^ string_of_int y ^ ")\n") ; + flush stdout +;; + +let set_top mathview () = + mathview#set_top 0 0; + print_string "set_top: SEEM TO WORK\n" ; + flush stdout +;; + +let set_adjustments mathview () = + let adj1 = GData.adjustment () in + let adj2 = GData.adjustment () in + mathview#set_adjustments adj1 adj2 ; + adj1#set_value ((adj1#lower +. adj1#upper) /. 2.0) ; + adj2#set_value ((adj2#lower +. adj2#upper) /. 2.0) ; + print_string "set_adjustments: SEEM TO WORK\n" ; + flush stdout +;; + +let get_hadjustment mathview () = + let adj = mathview#get_hadjustment in + adj#set_value ((adj#lower +. adj#upper) /. 2.0) ; + print_string "get_hadjustment: SEEM TO WORK\n" ; + flush stdout +;; + +let get_vadjustment mathview () = + let adj = mathview#get_vadjustment in + adj#set_value ((adj#lower +. adj#upper) /. 2.0) ; + print_string "get_vadjustment: SEEM TO WORK\n" ; + flush stdout +;; + +let get_buffer mathview () = + let buffer = mathview#get_buffer in + Gdk.Draw.rectangle buffer (Gdk.GC.create buffer) ~x:0 ~y:0 + ~width:50 ~height:50 ~filled:true () ; + print_string "get_buffer: SEEMS TO WORK (hint: force the widget redrawing)\n"; + flush stdout +;; + +let get_frame mathview () = + let frame = mathview#get_frame in + frame#set_shadow_type `NONE ; + print_string "get_frame: SEEMS TO WORK\n" ; + flush stdout +;; + +let set_font_size mathview () = + mathview#set_font_size 24 ; + print_string "set_font_size: FONT IS NOW 24\n" ; + flush stdout +;; + +let get_font_size mathview () = + print_string ("get_font_size: " ^ string_of_int (mathview#get_font_size) ^ "\n") ; + flush stdout +;; + +let set_anti_aliasing mathview () = + mathview#set_anti_aliasing true ; + print_string "set_anti_aliasing: ON\n" ; + flush stdout +;; + +let get_anti_aliasing mathview () = + print_string ("get_anti_aliasing: " ^ + (match mathview#get_anti_aliasing with true -> "ON" | false -> "OFF") ^ + "\n") ; + flush stdout +;; + +let set_kerning mathview () = + mathview#set_kerning true ; + print_string "set_kerning: ON\n" ; + flush stdout +;; + +let get_kerning mathview () = + print_string ("get_kerning: " ^ + (match mathview#get_kerning with true -> "ON" | false -> "OFF") ^ + "\n") ; + flush stdout +;; + +let set_log_verbosity mathview () = + mathview#set_log_verbosity 3 ; + print_string "set_log_verbosity: NOW IS 3\n" ; + flush stdout +;; + +let get_log_verbosity mathview () = + print_string ("get_log_verbosity: " ^ + string_of_int mathview#get_log_verbosity ^ + "\n") ; + flush stdout +;; + +let export_to_postscript (mathview : GMathView.math_view) () = + mathview#export_to_postscript ~filename:"test.ps" (); + print_string "expor_to_postscript: SEEMS TO WORK (hint: look at test.ps)\n"; + flush stdout +;; + +(* Widget creation *) +let main_window = GWindow.window ~title:"GtkMathView test" () in +let vbox = GPack.vbox ~packing:main_window#add () in +let sw = GBin.scrolled_window ~width:50 ~height:50 ~packing:vbox#pack () in +let mathview= GMathView.math_view ~packing:sw#add ~width:50 ~height:50 () in +let table = GPack.table ~rows:6 ~columns:5 ~packing:vbox#pack () in +let button_gtk=GButton.button ~label:"activate Gtk fonts" ~packing:(table#attach ~left:0 ~top:0) () in +let button_load = GButton.button ~label:"load" ~packing:(table#attach ~left:1 ~top:0) () in +let button_unload = GButton.button ~label:"unload" ~packing:(table#attach ~left:2 ~top:0) () in +let button_get_selection = GButton.button ~label:"get_selection" ~packing:(table#attach ~left:3 ~top:0) () in +let button_set_selection = GButton.button ~label:"set_selection" ~packing:(table#attach ~left:4 ~top:0) () in +let button_get_width = GButton.button ~label:"get_width" ~packing:(table#attach ~left:0 ~top:1) () in +let button_get_height = GButton.button ~label:"get_height" ~packing:(table#attach ~left:1 ~top:1) () in +let button_get_top = GButton.button ~label:"get_top" ~packing:(table#attach ~left:2 ~top:1) () in +let button_set_top = GButton.button ~label:"set_top" ~packing:(table#attach ~left:3 ~top:1) () in +let button_set_adjustments = GButton.button ~label:"set_adjustments" ~packing:(table#attach ~left:4 ~top:1) () in +let button_get_hadjustment = GButton.button ~label:"get_hadjustment" ~packing:(table#attach ~left:0 ~top:2) () in +let button_get_vadjustment = GButton.button ~label:"get_vadjustment" ~packing:(table#attach ~left:1 ~top:2) () in +let button_get_buffer = GButton.button ~label:"get_buffer" ~packing:(table#attach ~left:2 ~top:2) () in +let button_get_frame = GButton.button ~label:"get_frame" ~packing:(table#attach ~left:3 ~top:2) () in +let button_set_font_size = GButton.button ~label:"set_font_size" ~packing:(table#attach ~left:4 ~top:2) () in +let button_get_font_size = GButton.button ~label:"get_font_size" ~packing:(table#attach ~left:0 ~top:3) () in +let button_set_anti_aliasing = GButton.button ~label:"set_anti_aliasing" ~packing:(table#attach ~left:1 ~top:3) () in +let button_get_anti_aliasing = GButton.button ~label:"get_anti_aliasing" ~packing:(table#attach ~left:2 ~top:3) () in +let button_set_kerning = GButton.button ~label:"set_kerning" ~packing:(table#attach ~left:3 ~top:3) () in +let button_get_kerning = GButton.button ~label:"get_kerning" ~packing:(table#attach ~left:4 ~top:3) () in +let button_set_log_verbosity = GButton.button ~label:"set_log_verbosity" ~packing:(table#attach ~left:0 ~top:4) () in +let button_get_log_verbosity = GButton.button ~label:"get_log_verbosity" ~packing:(table#attach ~left:1 ~top:4) () in +let button_export_to_postscript = GButton.button ~label:"export_to_postscript" ~packing:(table#attach ~left:2 ~top:4) () in +let button_t1 = GButton.button ~label:"activate T1 fonts" ~packing:(table#attach ~left:3 ~top:4) () in +let button_get_font_manager_type = GButton.button ~label:"get_font_manager" ~packing:(table#attach ~left:4 ~top:4) () in +(* Signals connection *) +ignore(button_gtk#connect#clicked (activate_gtk mathview)) ; +ignore(button_load#connect#clicked (load mathview)) ; +ignore(button_unload#connect#clicked (unload mathview)) ; +ignore(button_get_selection#connect#clicked (get_selection mathview)) ; +ignore(button_set_selection#connect#clicked (set_selection mathview)) ; +ignore(button_get_width#connect#clicked (get_width mathview)) ; +ignore(button_get_height#connect#clicked (get_height mathview)) ; +ignore(button_get_top#connect#clicked (get_top mathview)) ; +ignore(button_set_top#connect#clicked (set_top mathview)) ; +ignore(button_set_adjustments#connect#clicked (set_adjustments mathview)) ; +ignore(button_get_hadjustment#connect#clicked (get_hadjustment mathview)) ; +ignore(button_get_vadjustment#connect#clicked (get_vadjustment mathview)) ; +ignore(button_get_buffer#connect#clicked (get_buffer mathview)) ; +ignore(button_get_frame#connect#clicked (get_frame mathview)) ; +ignore(button_set_font_size#connect#clicked (set_font_size mathview)) ; +ignore(button_get_font_size#connect#clicked (get_font_size mathview)) ; +ignore(button_set_anti_aliasing#connect#clicked (set_anti_aliasing mathview)) ; +ignore(button_get_anti_aliasing#connect#clicked (get_anti_aliasing mathview)) ; +ignore(button_set_kerning#connect#clicked (set_kerning mathview)) ; +ignore(button_get_kerning#connect#clicked (get_kerning mathview)) ; +ignore(button_set_log_verbosity#connect#clicked (set_log_verbosity mathview)) ; +ignore(button_get_log_verbosity#connect#clicked (get_log_verbosity mathview)) ; +ignore(button_export_to_postscript#connect#clicked (export_to_postscript mathview)) ; +ignore(button_t1#connect#clicked (activate_t1 mathview)) ; +ignore(button_get_font_manager_type#connect#clicked (get_font_manager_type mathview)) ; +ignore(mathview#connect#jump jump) ; +ignore(mathview#connect#clicked clicked) ; +ignore(mathview#connect#selection_changed (selection_changed mathview)) ; +(* Main Loop *) +main_window#show () ; +GMain.Main.main () +;; diff --git a/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/test.xml b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/test.xml new file mode 100644 index 000000000..b0f8c1563 --- /dev/null +++ b/helm/DEVEL/lablgtk_gtkmathview/lablgtk-20001129_gtkmathview-0.2.2/test/test.xml @@ -0,0 +1,123 @@ + + + ∫ + ⁡ + + + + a + ⁢ + x + + + + b + + + + x + 2 + + + + + p + ⁢ + x + + + + q + + + + d + x + = + + + a2 + ⁢ + + ln + ⁡ + + ( + + x2 + + + + p + ⁢ + x + + + + q + + ) + + + + + + + + + + 2 + ⁢ + b + + - + + a + ⁢ + p + + + + + + 4 + ⁢ + q + + - + + p + 2 + + + + + ⁢ + + arctg + ⁡ + + + + 2 + ⁢ + x + + + + p + + + + + 4 + ⁢ + q + + - + + p + 2 + + + + + + + + + c + + diff --git a/helm/cgi/mkindex.pl b/helm/cgi/mkindex.pl new file mode 100755 index 000000000..9bc41ef11 --- /dev/null +++ b/helm/cgi/mkindex.pl @@ -0,0 +1,93 @@ +#!/usr/bin/perl + +# the required file defines: $helm_dir, $helm_url_path, $getheader_url, +# $style_url, $webeq_url, $webeqp_url +require "/local/lib/helm/configuration.pl"; + +$baseuri0 = $dirname = $uri = $ENV{"REQUEST_URI"}; + +$dirname =~ s/$helm_url_path//; +$dirname = $helm_dir.$dirname; + +$baseuri0 =~ s/$helm_url_path//; + +opendir(DIR, $dirname); +@filenames = readdir(DIR); +closedir(DIR); + +$output = ""; +foreach $i (@filenames) { + if ($i eq "..") { + $output .= < Parent Directory +EOT + } elsif ($i !~ /^\./) { + # hidden files excluded + (undef,undef,$mode) = stat("$dirname$i"); + if ($mode &= 16384) { + # directory + $output .= < $i +EOT + } else { + # file + if ($i =~ /\.(con|var|ind)\.xml$/) { + my $i_without_xml = $i; + $i_without_xml =~ s/(.*)\.xml/$1/; + # cic file + my $baseuri = "cic:".$baseuri0; + $output .= < $i MathML HTML WEBEQ WEBEQ PRESENTATION ONLY +EOT + } elsif ($i =~ /\.(con|var|ind)\.ann\.xml$/) { + my $i_without_xml = $i; + my $i_without_ann_and_xml = $i; + $i_without_xml =~ s/(.*)\.xml/$1/; + $i_without_ann_and_xml =~ s/(.*)\.ann\.xml/$1/; + # cic file + my $baseuri = "cic:".$baseuri0; + $output .= < $i MathML HTML WEBEQ WEBEQ PRESENTATION ONLY +EOT + } elsif ($i =~ /\.theory\.xml$/) { + my $i_without_xml = $i; + $i_without_xml =~ s/(.*)\.xml/$1/; + # theory file + my $baseuri = "theory:".$baseuri0; + $output .= < $i MathML HTML +EOT + } else { + # other file + $output .= < $i +EOT + } + } + } +} + +print < + + +Index of $uri + + +
+Index of $uri +
+
+
+$output
+
+
+ + +EOT diff --git a/helm/configuration/local/etc/helm/configuration.dtd b/helm/configuration/local/etc/helm/configuration.dtd new file mode 100644 index 000000000..2a2428d1d --- /dev/null +++ b/helm/configuration/local/etc/helm/configuration.dtd @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/configuration/local/etc/helm/configuration.xml b/helm/configuration/local/etc/helm/configuration.xml new file mode 100644 index 000000000..0a007fc5b --- /dev/null +++ b/helm/configuration/local/etc/helm/configuration.xml @@ -0,0 +1,22 @@ + + + + + /home/pauillac/coq3/sacerdot/HELM/INTERFACE/examples + + /dtd + /home/pauillac/coq3/sacerdot/HELM/INTERFACE/servers.txt + /home/pauillac/coq3/sacerdot/HELM/INTERFACE/urls_of_uris + + index.txt + /tmp + + /home/lpadovan/helm/PARSER/examples + http://localhost/really_very_local/helm/header/getheader.xml + http://localhost/really_very_local/helm/style/ + http://localhost/cgi-bin/helm/webeq.pl + http://localhost/cgi-bin/helm/webeqp.pl + http://localhost/cgi-bin/helm/use_webeqp.pl + ?baseurl=&stylesheet1=rootcontent.xsl&stylesheet2=content_to_html.xsl&xmlfile= + http://localhost:8081/getwithtypes?url= + diff --git a/helm/configuration/local/lib/helm/configuration.pl b/helm/configuration/local/lib/helm/configuration.pl new file mode 100644 index 000000000..deea890a8 --- /dev/null +++ b/helm/configuration/local/lib/helm/configuration.pl @@ -0,0 +1,35 @@ +use XML::Parser; + +# this should be the only fixed constant +$configuration_file = "/home/cadet/sacerdot/local/etc/helm/configuration.xml"; + +$parser = new XML::Parser(Handlers => {Start => \&handle_start, + End => \&handle_end, + Char => \&handle_char}); + + +$parser->parsefile($configuration_file, ErrorContext => 3); + + +sub handle_start +{ + if ($_[1] eq "value-of") { + $$varname .= ${$_[3]}; + } elsif ($_[1] ne "configuration") { + $varname = $_[1]; + } +} + +sub handle_end +{ + if ($_[1] ne "value-of" && $_[1] ne "configuration") { + # Next line for debugging only: + # print "OK: #$_[1]# := #$$varname#\n"; + $varname = undef; + } +} + +sub handle_char +{ + $$varname .= $_[1]; +} diff --git a/helm/dtd/annotations.dtd b/helm/dtd/annotations.dtd new file mode 100644 index 000000000..c7d379983 --- /dev/null +++ b/helm/dtd/annotations.dtd @@ -0,0 +1,29 @@ + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/cic.dtd b/helm/dtd/cic.dtd new file mode 100644 index 000000000..e16b10287 --- /dev/null +++ b/helm/dtd/cic.dtd @@ -0,0 +1,176 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/cicobject.dtd b/helm/dtd/cicobject.dtd new file mode 100644 index 000000000..1d9917b10 --- /dev/null +++ b/helm/dtd/cicobject.dtd @@ -0,0 +1,97 @@ + + + + + + + + + +%mathml; + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isoamsa.ent b/helm/dtd/isoamsa.ent new file mode 100644 index 000000000..5ecf4db21 --- /dev/null +++ b/helm/dtd/isoamsa.ent @@ -0,0 +1,173 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isoamsb.ent b/helm/dtd/isoamsb.ent new file mode 100644 index 000000000..08e646c2b --- /dev/null +++ b/helm/dtd/isoamsb.ent @@ -0,0 +1,146 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isoamsc.ent b/helm/dtd/isoamsc.ent new file mode 100644 index 000000000..cce399cf9 --- /dev/null +++ b/helm/dtd/isoamsc.ent @@ -0,0 +1,49 @@ + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isoamsn.ent b/helm/dtd/isoamsn.ent new file mode 100644 index 000000000..cddeba066 --- /dev/null +++ b/helm/dtd/isoamsn.ent @@ -0,0 +1,117 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isoamso.ent b/helm/dtd/isoamso.ent new file mode 100644 index 000000000..8ac4bdb61 --- /dev/null +++ b/helm/dtd/isoamso.ent @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isoamsr.ent b/helm/dtd/isoamsr.ent new file mode 100644 index 000000000..7fec58255 --- /dev/null +++ b/helm/dtd/isoamsr.ent @@ -0,0 +1,205 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isobox.ent b/helm/dtd/isobox.ent new file mode 100644 index 000000000..630edc559 --- /dev/null +++ b/helm/dtd/isobox.ent @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isocyr1.ent b/helm/dtd/isocyr1.ent new file mode 100644 index 000000000..4bcc9e416 --- /dev/null +++ b/helm/dtd/isocyr1.ent @@ -0,0 +1,94 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isocyr2.ent b/helm/dtd/isocyr2.ent new file mode 100644 index 000000000..67c477b24 --- /dev/null +++ b/helm/dtd/isocyr2.ent @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isodia.ent b/helm/dtd/isodia.ent new file mode 100644 index 000000000..ba6496300 --- /dev/null +++ b/helm/dtd/isodia.ent @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isogrk3.ent b/helm/dtd/isogrk3.ent new file mode 100644 index 000000000..fa0335504 --- /dev/null +++ b/helm/dtd/isogrk3.ent @@ -0,0 +1,70 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isolat1.ent b/helm/dtd/isolat1.ent new file mode 100644 index 000000000..849d360ae --- /dev/null +++ b/helm/dtd/isolat1.ent @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isolat2.ent b/helm/dtd/isolat2.ent new file mode 100644 index 000000000..3049be7f1 --- /dev/null +++ b/helm/dtd/isolat2.ent @@ -0,0 +1,148 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isomfrk.ent b/helm/dtd/isomfrk.ent new file mode 100644 index 000000000..d3d92aaee --- /dev/null +++ b/helm/dtd/isomfrk.ent @@ -0,0 +1,79 @@ + + + +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > diff --git a/helm/dtd/isomopf.ent b/helm/dtd/isomopf.ent new file mode 100644 index 000000000..6b5e01f79 --- /dev/null +++ b/helm/dtd/isomopf.ent @@ -0,0 +1,53 @@ + + + +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > diff --git a/helm/dtd/isomscr.ent b/helm/dtd/isomscr.ent new file mode 100644 index 000000000..75d3bc5df --- /dev/null +++ b/helm/dtd/isomscr.ent @@ -0,0 +1,79 @@ + + + +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > +" > diff --git a/helm/dtd/isonum.ent b/helm/dtd/isonum.ent new file mode 100644 index 000000000..d6d346169 --- /dev/null +++ b/helm/dtd/isonum.ent @@ -0,0 +1,106 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isopub.ent b/helm/dtd/isopub.ent new file mode 100644 index 000000000..5591fc390 --- /dev/null +++ b/helm/dtd/isopub.ent @@ -0,0 +1,111 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/isotech.ent b/helm/dtd/isotech.ent new file mode 100644 index 000000000..8b30af833 --- /dev/null +++ b/helm/dtd/isotech.ent @@ -0,0 +1,183 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +" > + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/mathml2-qname-1.mod b/helm/dtd/mathml2-qname-1.mod new file mode 100644 index 000000000..4dea63a00 --- /dev/null +++ b/helm/dtd/mathml2-qname-1.mod @@ -0,0 +1,268 @@ + + + + + + + + + + + + + + + + + + + + + + + +]]> + + + + +]]> + + + + +]]> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/mathml2.dtd b/helm/dtd/mathml2.dtd new file mode 100644 index 000000000..a9b7bf1ac --- /dev/null +++ b/helm/dtd/mathml2.dtd @@ -0,0 +1,1948 @@ + + + + + + + + + +%mathml-qname.mod;]]> + + +--> + +]]> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +%ent-isoamsa; + + +%ent-isoamsb; + + +%ent-isoamsc; + + +%ent-isoamsn; + + +%ent-isoamso; + + +%ent-isoamsr; + + +%ent-isogrk3; + + +%ent-isomfrk; + + +%ent-isomopf; + + +%ent-isomscr; + + +%ent-isotech; + + + + +%ent-isobox; + + +%ent-isocyr1; + + +%ent-isocyr2; + + +%ent-isodia; + + +%ent-isolat1; + + +%ent-isolat2; + + +%ent-isonum; + + +%ent-isopub; + + + + +%ent-mmlextra; + + + + +%ent-mmlalias; + +]]> + + + + + + diff --git a/helm/dtd/maththeory.dtd b/helm/dtd/maththeory.dtd new file mode 100644 index 000000000..85469b6ce --- /dev/null +++ b/helm/dtd/maththeory.dtd @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/mmlalias.ent b/helm/dtd/mmlalias.ent new file mode 100644 index 000000000..f5901b384 --- /dev/null +++ b/helm/dtd/mmlalias.ent @@ -0,0 +1,529 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/mmlextra.ent b/helm/dtd/mmlextra.ent new file mode 100644 index 000000000..e76de448c --- /dev/null +++ b/helm/dtd/mmlextra.ent @@ -0,0 +1,134 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/dtd/provastruct.theory.xml b/helm/dtd/provastruct.theory.xml new file mode 100644 index 000000000..23c8f7c6d --- /dev/null +++ b/helm/dtd/provastruct.theory.xml @@ -0,0 +1,158 @@ + + + +
+ +
+ + cast + + Prop + + + Type + + + +
+ + cast + + Prop + + + Type + + + + 1: A 0: B + cast + + arrow + A + + arrow + arrow + A + + B + + + B + + + + + Prop + + + + 1: A 0: B + A0 + A + + H + arrow + A + + B + + + app + conj + A + B + A0 + app + axiom + A0 + H + + + + + + cast + + arrow + A + + arrow + arrow + A + + B + + + AB + + + + + Prop + + + +
+
+ + cast + + Set + + + Type + + + + 1: A + cast + + prodA + Prop + + arrow + A + + A + + + + + Prop + + + +
+ 0: A + A0 + Prop + + H + A0 + + H + + + + cast + + prodA + Prop + + arrow + A + + A + + + + + Prop + + + +
+
+ + diff --git a/helm/dtd/theoryobject.dtd b/helm/dtd/theoryobject.dtd new file mode 100644 index 000000000..8ff26cfb2 --- /dev/null +++ b/helm/dtd/theoryobject.dtd @@ -0,0 +1,14 @@ + + + + + + + + + +%cicobj; + + + + diff --git a/helm/header/getheader.xml b/helm/header/getheader.xml new file mode 100644 index 000000000..a0f903f87 --- /dev/null +++ b/helm/header/getheader.xml @@ -0,0 +1,21 @@ + + + + + + + + + String baseURL = request.getParameter("baseurl"); + String styleURL1 = request.getParameter("stylesheet1"); + String styleURL2 = request.getParameter("stylesheet2"); + String xmlURI = request.getParameter("xmluri"); + String annURI = request.getParameter("annuri"); + + baseURL + styleURL1 + styleURL2 + xmlURI + annURI + + diff --git a/helm/header/provaurl b/helm/header/provaurl new file mode 100644 index 000000000..86344dc78 --- /dev/null +++ b/helm/header/provaurl @@ -0,0 +1 @@ +http://phd.cs.unibo.it/helm/PARSER/examples/header/getheader.xml?baseurl=http://cartoonia.cs.unibo.it/helm/PARSER/examples/style/&stylesheet1=content.xsl&stylesheet2=mmlextension.xsl&xmlfile=file:///really_very_local/helm/PARSER/examples/prove/provaIota/bool_ind.con.xml diff --git a/helm/header/provaurl1 b/helm/header/provaurl1 new file mode 100644 index 000000000..d95769884 --- /dev/null +++ b/helm/header/provaurl1 @@ -0,0 +1,2 @@ +http://cartoonia.cs.unibo.it/helm/PARSER/examples/header/getheader.xml?baseurl=http://cartoonia.cs.unibo.it/helm/PARSER/examples/style/&stylesheet1=content.xsl&stylesheet2=content_to_html.xsl&xmlfile=/really_very_local/helm/PARSER/examples/prove/prova/forest_rec.con.xml:wq + diff --git a/helm/header/setheader.xsl b/helm/header/setheader.xsl new file mode 100644 index 000000000..a1ba13199 --- /dev/null +++ b/helm/header/setheader.xsl @@ -0,0 +1,33 @@ + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + type="text/xml" + href="" type="text/xsl" + type="xslt" + + + + + + + + + + + + + diff --git a/helm/http_getter/cadet b/helm/http_getter/cadet new file mode 100755 index 000000000..2b84119fa --- /dev/null +++ b/helm/http_getter/cadet @@ -0,0 +1,9 @@ +#! /bin/sh + +# WARNING!!! No "//" in the middle of the path, nor a "/" at the end!!!! + +# For V6.2 +export HELM_CONFIGURATION_PREFIX=~/HELM/installation + +# For V7 +#export HELM_CONFIGURATION_PREFIX=/home/cadet/sacerdot diff --git a/helm/http_getter/http_getter.pl b/helm/http_getter/http_getter.pl new file mode 100755 index 000000000..1d99e65ce --- /dev/null +++ b/helm/http_getter/http_getter.pl @@ -0,0 +1,329 @@ +#!/usr/bin/perl + +# First of all, let's load HELM configuration +use Env; +my $HELM_CONFIGURATION_PREFIX = $ENV{"HELM_CONFIGURATION_PREFIX"}; +my $HELM_CONFIGURATION_PATH = + $HELM_CONFIGURATION_PREFIX."/local/lib/helm/configuration.pl"; +# next require defines: $helm_dir, $html_link +require $HELM_CONFIGURATION_PATH; + + + +use HTTP::Daemon; +use HTTP::Status; +use HTTP::Request; +use LWP::UserAgent; +use DB_File; + +my $cont = ""; +my $d = new HTTP::Daemon LocalPort => 8081; +tie(%map, 'DB_File', $uris_dbm.".db", O_RDONLY, 0664); +print "Please contact me at: url, ">\n"; +print "helm_dir: $helm_dir\n"; +print "urls_of_uris.db: $uris_dbm.db\n"; +$SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes +while (my $c = $d->accept) { + if (fork() == 0) { + while (my $r = $c->get_request) { + #CSC: mancano i controlli di sicurezza + + $cont = ""; + my $cicuri = $r->url; + $cicuri =~ s/^[^?]*\?url=(.*)/$1/; + print "*".$r->url."\n"; + my $http_method = $r->method; + my $http_path = $r->url->path; + if ($http_method eq 'GET' and $http_path eq "/get") { + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + $filename = $helm_dir.$filename.".xml"; + my $resolved = $map{$cicuri}; + print "$cicuri ==> $resolved ($filename)\n"; + if (stat($filename)) { + print "Using local copy\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + print "Downloading\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file\n"; + mkdirs($filename); + open(FD, ">".$filename); + print FD $cont; + close(FD); + + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } + } elsif ($http_method eq 'GET' and $http_path eq "/annotate") { + my $do_annotate = ($cicuri =~ /\.ann$/); + my $target_to_annotate = $cicuri; + $target_to_annotate =~ s/(.*)\.ann$/$1/ if $do_annotate; + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + my $filename_target = $helm_dir.$filename if $do_annotate; + $filename = $helm_dir.$filename.".xml"; + $filename_target =~ s/(.*)\.ann$/$1.xml/ if $do_annotate; + my $resolved = $map{$cicuri}; + my $resolved_target = $map{$target_to_annotate} if $do_annotate; + if ($do_annotate) { + print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n"; + } else { + print "$cicuri ==> $resolved ($filename)\n"; + } + + # Retrieves the annotation + + if (stat($filename)) { + print "Using local copy for the annotation\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the annotation\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file for the annotation\n"; + mkdirs($filename); + open(FD, ">".$filename); + print FD $cont; + close(FD); + } + my $annotation = $cont; + + # Retrieves the target to annotate + + $cont = ""; + if ($do_annotate) { + if (stat($filename_target)) { + print "Using local copy for the file to annotate\n"; + open(FD, $filename_target); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the file to annotate\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved_target"); + $response = $ua->request($request, \&callback); + + print "Storing file for the file to annotate\n"; + mkdirs($filename_target); + open(FD, ">".$filename_target); + print FD $cont; + close(FD); + } + } + my $target = $cont; + + # Merging the annotation and the target + + $target =~ s/<\?xml [^?]*\?>//sg; + $target =~ s/]*>//sg; + $annotation =~ s/<\?xml [^?]*\?>//sg; + $annotation =~ s/]*>//sg; + my $merged = < + +$target +$annotation + +EOT + + # Answering the client + + my $res = new HTTP::Response; + $res->content($merged); + $c->send_response($res); + } elsif ($http_method eq 'GET' and $http_path eq "/getwithtypes") { + my $mode; + my $do_annotate; + if ($cicuri =~ /\.types$/) { + $do_annotate = 1; + $mode = "types"; + } elsif ($cicuri =~ /\.ann$/) { + $do_annotate = 1; + $mode = "ann"; + } else { + $do_annotate = 0; + } + my $target_to_annotate = $cicuri; + if ($mode eq "types") { + $target_to_annotate =~ s/(.*)\.types$/$1/; + } elsif ($mode eq "ann") { + $target_to_annotate =~ s/(.*)\.ann$/$1/; + } + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + my $filename_target = $helm_dir.$filename if $do_annotate; + $filename = $helm_dir.$filename.".xml"; + if ($mode eq "types") { + $filename_target =~ s/(.*)\.types$/$1.xml/; + } elsif ($mode eq "ann") { + $filename_target =~ s/(.*)\.ann$/$1.xml/; + } + my $resolved = $map{$cicuri}; + my $resolved_target = $map{$target_to_annotate} if $do_annotate; + if ($do_annotate) { + print "GETWITHTYPES!!\n" if ($mode eq "types"); + print "GETWITHANN!!\n" if ($mode eq "ann"); + print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n"; + } else { + print "$cicuri ==> $resolved ($filename)\n"; + } + + # Retrieves the annotation + + if (stat($filename)) { + print "Using local copy for the types\n" if ($mode eq "types"); + print "Using local copy for the ann\n" if ($mode eq "ann"); + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the types\n" if ($mode eq "types"); + print "Downloading the ann\n" if ($mode eq "ann"); + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file for the types\n" if ($mode eq "types"); + print "Storing file for the ann\n" if ($mode eq "ann"); + mkdirs($filename); + open(FD, ">".$filename); + print FD $cont; + close(FD); + } + my $annotation = $cont; + + # Retrieves the target to annotate + + $cont = ""; + my $target; + if ($do_annotate) { + if (stat($filename_target)) { + print "Using local copy for the file to type\n"; + open(FD, $filename_target); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the file to type\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved_target"); + $response = $ua->request($request, \&callback); + + print "Storing file for the file to type\n"; + mkdirs($filename_target); + open(FD, ">".$filename_target); + print FD $cont; + close(FD); + } + $target = $cont; + } else { + $target = $annotation; + $annotation = ""; + } + + # Merging the annotation and the target + + $target =~ s/<\?xml [^?]*\?>//sg; + $target =~ s/]*>//sg; + $annotation =~ s/<\?xml [^?]*\?>//sg; + $annotation =~ s/]*>//sg; + my $element, $endelement; + if ($mode eq "types") { + $element = ""; + $endelement = ""; + } elsif ($mode eq "ann") { + $element = ""; + $endelement = ""; + } + my $merged = < + +$target +$element +$annotation +$endelement + +EOT + + # Answering the client + + my $res = new HTTP::Response; + $res->content($merged); + $c->send_response($res); + } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") { + my $filename = $cicuri; + $filename = $helm_dir."/dtd/".$filename; + print "DTD: $cicuri ==> ($filename)\n"; + if (stat($filename)) { + print "Using local copy\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + die "Could not find DTD!"; + } + } elsif ($http_method eq 'GET' and $http_path eq "/conf") { + my $quoted_html_link = $html_link; + $quoted_html_link =~ s/&/&/g; + $quoted_html_link =~ s//>/g; + $quoted_html_link =~ s/'/'/g; + $quoted_html_link =~ s/"/"/g; + print "Configuration requested, returned #$quoted_html_link#\n"; + $cont = "$quoted_html_link"; + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + print "INVALID REQUEST!!!!!\n"; + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + print "\nCONNECTION CLOSED\n\n"; + exit; + } # fork +} + +#================================ + +sub callback +{ + my ($data) = @_; + $cont .= $data; +} + +# Does not raise errors if could not create dirs/files + +# Too much powerful: creates even /home, /home/users/, ... +sub mkdirs +{ + my ($pathname) = @_; + my @dirs = split /\//,$pathname; + my $tmp; + foreach $dir (@dirs) { + $tmp = ((defined($tmp)) ? $tmp = $tmp."\/".$dir : ""); + mkdir($tmp,0777); + } + rmdir($tmp); +} diff --git a/helm/interface/.depend b/helm/interface/.depend new file mode 100644 index 000000000..a495dfeab --- /dev/null +++ b/helm/interface/.depend @@ -0,0 +1,92 @@ +experiment.cmo: cicCache.cmi cicPp.cmi configuration.cmo getter.cmi \ + uriManager.cmi +experiment.cmx: cicCache.cmx cicPp.cmx configuration.cmx getter.cmx \ + uriManager.cmx +cicCache.cmo: annotationParser.cmo cic.cmo cicParser.cmi cicSubstitution.cmi \ + deannotate.cmo getter.cmi uriManager.cmi cicCache.cmi +cicCache.cmx: annotationParser.cmx cic.cmx cicParser.cmx cicSubstitution.cmx \ + deannotate.cmx getter.cmx uriManager.cmx cicCache.cmi +cicCache.cmi: cic.cmo uriManager.cmi +cicPp.cmo: cic.cmo cicCache.cmi uriManager.cmi cicPp.cmi +cicPp.cmx: cic.cmx cicCache.cmx uriManager.cmx cicPp.cmi +cicPp.cmi: cic.cmo +cicParser.cmo: cicParser2.cmi cicParser3.cmi pxpUriResolver.cmo \ + uriManager.cmi cicParser.cmi +cicParser.cmx: cicParser2.cmx cicParser3.cmx pxpUriResolver.cmx \ + uriManager.cmx cicParser.cmi +cicParser.cmi: cic.cmo uriManager.cmi +cicParser2.cmo: cic.cmo cicParser3.cmi uriManager.cmi cicParser2.cmi +cicParser2.cmx: cic.cmx cicParser3.cmx uriManager.cmx cicParser2.cmi +cicParser2.cmi: cic.cmo cicParser3.cmi +cicParser3.cmo: cic.cmo uriManager.cmi cicParser3.cmi +cicParser3.cmx: cic.cmx uriManager.cmx cicParser3.cmi +cicParser3.cmi: cic.cmo uriManager.cmi +cic.cmo: uriManager.cmi +cic.cmx: uriManager.cmx +getter.cmo: configuration.cmo uriManager.cmi getter.cmi +getter.cmx: configuration.cmx uriManager.cmx getter.cmi +getter.cmi: uriManager.cmi +cicReduction.cmo: cic.cmo cicCache.cmi cicPp.cmi cicSubstitution.cmi \ + uriManager.cmi cicReduction.cmi +cicReduction.cmx: cic.cmx cicCache.cmx cicPp.cmx cicSubstitution.cmx \ + uriManager.cmx cicReduction.cmi +cicReduction.cmi: cic.cmo +cicTypeChecker.cmo: cic.cmo cicCache.cmi cicPp.cmi cicReduction.cmi \ + cicSubstitution.cmi uriManager.cmi cicTypeChecker.cmi +cicTypeChecker.cmx: cic.cmx cicCache.cmx cicPp.cmx cicReduction.cmx \ + cicSubstitution.cmx uriManager.cmx cicTypeChecker.cmi +cicTypeChecker.cmi: uriManager.cmi +reduction.cmo: cic.cmo cicCache.cmi cicPp.cmi cicReduction.cmi \ + cicTypeChecker.cmi configuration.cmo getter.cmi uriManager.cmi +reduction.cmx: cic.cmx cicCache.cmx cicPp.cmx cicReduction.cmx \ + cicTypeChecker.cmx configuration.cmx getter.cmx uriManager.cmx +theoryParser.cmo: pxpUriResolver.cmo theoryParser2.cmo +theoryParser.cmx: pxpUriResolver.cmx theoryParser2.cmx +theoryParser2.cmo: theory.cmo +theoryParser2.cmx: theory.cmx +theoryTypeChecker.cmo: cicCache.cmi cicTypeChecker.cmi theory.cmo \ + theoryCache.cmo uriManager.cmi +theoryTypeChecker.cmx: cicCache.cmx cicTypeChecker.cmx theory.cmx \ + theoryCache.cmx uriManager.cmx +cicCooking.cmo: cic.cmo cicCache.cmi uriManager.cmi cicCooking.cmi +cicCooking.cmx: cic.cmx cicCache.cmx uriManager.cmx cicCooking.cmi +cicCooking.cmi: cic.cmo uriManager.cmi +cicFindParameters.cmo: cic.cmo cic2Xml.cmo cicCache.cmi configuration.cmo \ + uriManager.cmi xml.cmi +cicFindParameters.cmx: cic.cmx cic2Xml.cmx cicCache.cmx configuration.cmx \ + uriManager.cmx xml.cmx +theoryCache.cmo: getter.cmi theoryParser.cmo +theoryCache.cmx: getter.cmx theoryParser.cmx +fix_params.cmo: cicFindParameters.cmo configuration.cmo deannotate.cmo \ + getter.cmi uriManager.cmi +fix_params.cmx: cicFindParameters.cmx configuration.cmx deannotate.cmx \ + getter.cmx uriManager.cmx +cic2Xml.cmo: cic.cmo uriManager.cmi xml.cmi +cic2Xml.cmx: cic.cmx uriManager.cmx xml.cmx +xml.cmo: xml.cmi +xml.cmx: xml.cmi +uriManager.cmo: uriManager.cmi +uriManager.cmx: uriManager.cmi +cicSubstitution.cmo: cic.cmo cicSubstitution.cmi +cicSubstitution.cmx: cic.cmx cicSubstitution.cmi +cicSubstitution.cmi: cic.cmo uriManager.cmi +mmlinterface.cmo: annotation2Xml.cmo cicAnnotationHinter.cmo cicCache.cmi \ + cicTypeChecker.cmi cicXPath.cmo configuration.cmo getter.cmi \ + theoryTypeChecker.cmo uriManager.cmi xml.cmi xsltProcessor.cmo +mmlinterface.cmx: annotation2Xml.cmx cicAnnotationHinter.cmx cicCache.cmx \ + cicTypeChecker.cmx cicXPath.cmx configuration.cmx getter.cmx \ + theoryTypeChecker.cmx uriManager.cmx xml.cmx xsltProcessor.cmx +xsltProcessor.cmo: configuration.cmo uriManager.cmi +xsltProcessor.cmx: configuration.cmx uriManager.cmx +deannotate.cmo: cic.cmo +deannotate.cmx: cic.cmx +cicXPath.cmo: cic.cmo +cicXPath.cmx: cic.cmx +annotationParser.cmo: annotationParser2.cmo pxpUriResolver.cmo +annotationParser.cmx: annotationParser2.cmx pxpUriResolver.cmx +annotationParser2.cmo: cic.cmo +annotationParser2.cmx: cic.cmx +annotation2Xml.cmo: cic.cmo uriManager.cmi xml.cmi +annotation2Xml.cmx: cic.cmx uriManager.cmx xml.cmx +cicAnnotationHinter.cmo: cic.cmo +cicAnnotationHinter.cmx: cic.cmx diff --git a/helm/interface/ISTRUZIONI b/helm/interface/ISTRUZIONI new file mode 100644 index 000000000..fe6c09efc --- /dev/null +++ b/helm/interface/ISTRUZIONI @@ -0,0 +1,22 @@ +============================== +ISTRUZIONI PER CHI USA LA TCSH +============================== + +Lanciare: + + source PER_FARLO_ANDARE_TCSH + +Poi far partire altri due xterm. +Nel primo lanciare: + + make start-xaland3 + +Nel secondo lanciare: + + make start-http-getter + +Se non funziona significa che ce ne e' gia' uno attivo. + +Infini lanciare, dall'ultima shell, + + ./mmlinterface.opt.saved diff --git a/helm/interface/Makefile b/helm/interface/Makefile new file mode 100644 index 000000000..2b892e2d9 --- /dev/null +++ b/helm/interface/Makefile @@ -0,0 +1,180 @@ +LABLGTK_DIR = /usr/lib/ocaml/lablgtk +LABLGTK_MATHVIEW_DIR = /usr/lib/ocaml/lablgtk/mathview +PXP_DIR = /usr/lib/ocaml/site-lib/pxp +NETSTRING_DIR = /usr/lib/ocaml/site-lib/netstring +OCAMLC = ocamlc -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) -I $(PXP_DIR) -I $(NETSTRING_DIR) -I mlmathview +OCAMLOPT = ocamlopt -I $(LABLGTK_DIR) -I $(LABLGTK_MATHVIEW_DIR) -I mlgtk_devel -I $(PXP_DIR) -I $(NETSTRING_DIR) -I mlmathview +OCAMLDEP = ocamldep + +all: experiment reduction fix_params mmlinterface +opt: experiment.opt reduction.opt fix_params.opt mmlinterface.opt + +PXPLIBS = netstring.cma netmappings_iso.cmo netmappings_other.cmo \ + pxp_types.cma \ + pxp_lex_iso88591.cma pxp_lex_utf8.cma pxp_engine.cma \ + pxp_utf8.cmo + +PXPLIBSOPT = netstring.cmxa netmappings_iso.cmx netmappings_other.cmx \ + pxp_types.cmxa \ + pxp_lex_iso88591.cmxa pxp_lex_utf8.cmxa pxp_engine.cmxa \ + pxp_utf8.cmx + + +DEPOBJS = experiment.ml cicCache.ml cicCache.mli cicPp.ml cicPp.mli \ + cicParser.ml cicParser.mli cicParser2.ml cicParser2.mli \ + cicParser3.ml cicParser3.mli cic.ml getter.ml getter.mli \ + gtkInterface.ml cicReduction.ml cicReduction.mli cicTypeChecker.ml \ + cicTypeChecker.mli reduction.ml tgtkInterface.ml theory.ml \ + theoryParser.ml theoryParser2.ml theoryPp.ml theoryTypeChecker.ml \ + cicCooking.ml cicCooking.mli cicFindParameters.ml theoryCache.ml \ + fix_params.ml cic2Xml.ml xml.ml uriManager.ml uriManager.mli \ + cicSubstitution.ml cicSubstitution.mli mml.ml \ + mmlinterface.ml configuration.ml \ + xsltProcessor.ml deannotate.ml cicXPath.ml pxpUriResolver.ml \ + annotationParser.ml annotationParser2.ml annotation2Xml.ml \ + cicAnnotationHinter.ml + +MMLINTERFACEOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \ + pxpUriResolver.cmo \ + cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ + cicSubstitution.cmo annotationParser2.cmo \ + annotationParser.cmo cicCache.cmo cicCooking.cmo cicPp.cmo \ + cicReduction.cmo cicTypeChecker.cmo mml.cmo \ + xml.cmo \ + xsltProcessor.cmo cic2Xml.cmo annotation2Xml.cmo \ + cicXPath.cmo theory.cmo theoryParser2.cmo theoryParser.cmo \ + theoryCache.cmo theoryTypeChecker.cmo \ + cicAnnotationHinter.cmo mmlinterface.cmo + +MMLINTERFACEOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \ + pxpUriResolver.cmx \ + cicParser3.cmx cicParser2.cmx cicParser.cmx \ + deannotate.cmx cicSubstitution.cmx annotationParser2.cmx \ + annotationParser.cmx cicCache.cmx \ + cicCooking.cmx cicPp.cmx cicReduction.cmx \ + cicTypeChecker.cmx mml.cmx \ + xml.cmx xsltProcessor.cmx \ + cic2Xml.cmx annotation2Xml.cmx cicXPath.cmx \ + theory.cmx theoryParser2.cmx theoryParser.cmx \ + theoryCache.cmx theoryTypeChecker.cmx \ + cicAnnotationHinter.cmx mmlinterface.cmx + +FIX_PARAMSOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \ + pxpUriResolver.cmo \ + cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ + cicSubstitution.cmo annotationParser2.cmo \ + annotationParser.cmo cicCache.cmo cicPp.cmo xml.cmo \ + cic2Xml.cmo cicFindParameters.cmo fix_params.cmo + +FIX_PARAMSOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \ + pxpUriResolver.cmx \ + cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \ + cicSubstitution.cmx annotationParser2.cmx \ + annotationParser.cmx cicCache.cmx cicPp.cmx xml.cmx \ + cic2Xml.cmx cicFindParameters.cmx fix_params.cmx + +REDUCTIONOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \ + pxpUriResolver.cmo \ + cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ + cicSubstitution.cmo annotationParser2.cmo annotationParser.cmo \ + cicCache.cmo cicPp.cmo cicCooking.cmo \ + cicReduction.cmo cicTypeChecker.cmo reduction.cmo + +REDUCTIONOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \ + pxpUriResolver.cmx \ + cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \ + cicSubstitution.cmx annotationParser2.cmx \ + annotationParser.cmx cicCache.cmx cicPp.cmx cicCooking.cmx \ + cicReduction.cmx cicTypeChecker.cmx reduction.cmx + +EXPERIMENTOBJS = configuration.cmo uriManager.cmo getter.cmo cic.cmo \ + pxpUriResolver.cmo \ + cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ + cicSubstitution.cmo annotationParser2.cmo \ + annotationParser.cmo cicCache.cmo cicPp.cmo experiment.cmo + +EXPERIMENTOPTOBJS = configuration.cmx uriManager.cmx getter.cmx cic.cmx \ + pxpUriResolver.cmx \ + cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \ + cicSubstitution.cmx annotationParser2.cmx \ + annotationParser.cmx cicCache.cmx cicPp.cmx experiment.cmx + +depend: + $(OCAMLDEP) $(DEPOBJS) > .depend + +mmlinterface: $(MMLINTERFACEOBJS) + $(OCAMLC) -custom -o mmlinterface str.cma unix.cma $(PXPLIBS) dbm.cma \ + lablgtk.cma gtkInit.cmo \ + $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cma \ + $(MMLINTERFACEOBJS) \ + -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ + -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ + -lunix -L/usr/local/lib/gtkmathview -lgtkmathview \ + $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" \ + -cclib -lmldbm -cclib -lndbm + +mmlinterface.opt: $(MMLINTERFACEOPTOBJS) + $(OCAMLOPT) -o mmlinterface.opt str.cmxa $(PXPLIBSOPT) unix.cmxa \ + dbm.cmxa lablgtk.cmxa gtkInit.cmx \ + $(LABLGTK_MATHVIEW_DIR)/lablgtkmathview.cmxa \ + $(MMLINTERFACEOPTOBJS) \ + -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ + -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ + -lunix -L/usr/local/lib/gtkmathview -lgtkmathview \ + $(LABLGTK_MATHVIEW_DIR)/ml_gtk_mathview.o" \ + -cclib -lmldbm -cclib -lndbm + +fix_params: $(FIX_PARAMSOBJS) + $(OCAMLC) -custom -o fix_params str.cma $(PXPLIBS) dbm.cma \ + $(FIX_PARAMSOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm + +fix_params.opt: $(FIX_PARAMSOPTOBJS) + $(OCAMLOPT) -o fix_params.opt str.cmxa $(PXPLIBSOPT) dbm.cmxa \ + $(FIX_PARAMSOPTOBJS) -cclib -lstr -cclib -lmldbm \ + -cclib -lndbm + +reduction: $(REDUCTIONOBJS) + $(OCAMLC) -custom -o reduction str.cma $(PXPLIBS) dbm.cma \ + $(REDUCTIONOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm + +reduction.opt: $(REDUCTIONOPTOBJS) + $(OCAMLOPT) -o reduction.opt str.cmxa $(PXPLIBSOPT) dbm.cmxa \ + $(REDUCTIONOPTOBJS) -cclib -lstr -cclib -lmldbm \ + -cclib -lndbm + +experiment: $(EXPERIMENTOBJS) + $(OCAMLC) -custom -o experiment str.cma $(PXPLIBS) dbm.cma \ + $(EXPERIMENTOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm + +experiment.opt: $(EXPERIMENTOPTOBJS) + $(OCAMLOPT) -o experiment.opt str.cmxa $(PXPLIBSOPT) dbm.cmxa \ + $(EXPERIMENTOPTOBJS) -cclib -lstr -cclib -lmldbm \ + -cclib -lndbm + +.SUFFIXES: .ml .mli .cmo .cmi .cmx +.ml.cmo: + $(OCAMLC) -c $< +.mli.cmi: + $(OCAMLC) -c $< +.ml.cmx: + $(OCAMLOPT) -c $< + +clean: + rm -f *.cm[iox] *.o experiment experiment.opt reduction \ + reduction.opt fix_params fix_params.opt mmlinterface \ + mmlinterface.opt mmlinterface2 mmlinterface2.opt + +start-xaland: + java xaland 12345 12346 examples/style/rootcontent.xsl \ + examples/style/annotatedpres.xsl examples/style/theory_content.xsl \ + examples/style/theory_pres.xsl + +start-xaland3: + java xaland 12347 12348 examples/style/rootcontent.xsl \ + examples/style/annotatedpres.xsl examples/style/theory_content.xsl \ + examples/style/theory_pres.xsl + +start-http-getter: + http_getter/http_getter.pl + +include .depend diff --git a/helm/interface/NON_VA b/helm/interface/NON_VA new file mode 100644 index 000000000..375447103 --- /dev/null +++ b/helm/interface/NON_VA @@ -0,0 +1,29 @@ + + *********************************************************************** + + A T T E N Z I O N E ! ! ! + + Quando si usa fix_params.opt, scrivere + + find /really_very_local/helm/PARSER/examples + + invece di examples + + *********************************************************************** + + PROBLEMA NON FIXATO CON fix_params + + LA SOLUZIONE E' + + + +Correggere: + + examples/coq/SETS/Powerset_facts/Sets_as_an_algebra/setcover_intro.con.xml + +aggiungendo paramMode="POSSIBLE" + +Un esempio che altrimenti non funziona e': + +examples/coq/SETS/Powerset_Classical_facts/Sets_as_an_algebra/Add_covers.con.xml + diff --git a/helm/interface/PER_FARLO_ANDARE b/helm/interface/PER_FARLO_ANDARE new file mode 100644 index 000000000..20fb52a86 --- /dev/null +++ b/helm/interface/PER_FARLO_ANDARE @@ -0,0 +1,2 @@ +export LD_LIBRARY_PATH=.:/really_very_local/helm/proveluca/mml-browser/ +export no_proxy=cs.unibo.it diff --git a/helm/interface/PER_FARLO_ANDARE_TCSH b/helm/interface/PER_FARLO_ANDARE_TCSH new file mode 100644 index 000000000..b527fabea --- /dev/null +++ b/helm/interface/PER_FARLO_ANDARE_TCSH @@ -0,0 +1,4 @@ +setenv PATH "/home/projects/java/jdk1.2.2/bin:$PATH" +setenv CLASSPATH "/really_very_local/helm/java/xalan_1_1/xalan.jar:/really_very_local/helm/java/xalan_1_1/xerces.jar:." +setenv CLASSPATH "/really_very_local/helm/java/saxon-5.3.2/saxon.jar:$CLASSPATH" +setenv LD_LIBRARY_PATH ".:/really_very_local/helm/proveluca/mml-browser/" diff --git a/helm/interface/PER_FARLO_ANDARE_TCSH_D01 b/helm/interface/PER_FARLO_ANDARE_TCSH_D01 new file mode 100644 index 000000000..208f00a0e --- /dev/null +++ b/helm/interface/PER_FARLO_ANDARE_TCSH_D01 @@ -0,0 +1,4 @@ +setenv PATH "/home/projects/java/jdk1.2.2/bin:$PATH" +setenv CLASSPATH "/really_very_local/helm/java/xalan_1_2_D01/xalan.jar:/really_very_local/helm/java/xalan_1_2_D01/xerces.jar:." +setenv CLASSPATH "/really_very_local/helm/java/saxon-5.3.2/saxon.jar:$CLASSPATH" +setenv LD_LIBRARY_PATH ".:/really_very_local/helm/proveluca/mml-browser/" diff --git a/helm/interface/README b/helm/interface/README new file mode 100644 index 000000000..89265ca8a --- /dev/null +++ b/helm/interface/README @@ -0,0 +1,44 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* A tactic to print Coq objects in XML *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 22/11/1999 *) +(******************************************************************************) + +This is the main directory of the coq-like pretty printer for cic terms exported +in xml from Coq. Once compiled four different executables are made: + + experiment a command-line pretty-printer (interpreted) + experiment.opt same as experiment (compiled) + gtkInterface a gtk-based pretty-printer (interpreted) + gtkInterface.opt a gtk-based pretty-printer (compiled) + +To use one of the previous pretty-printer the syntax is + + pretty_printer_name file1 ... filen + +where filei is an xml cic object + +Code files: + + cic.ml the internal definition of cic objects and terms + getter.ml converts uris to filenames retrieving the correspondent file + cache.ml a cache for cic objects (actually a simple hash-table) + cicParser.ml a parser from xml to internal definition: top level + cicParser2.ml a parser from xml to internal definition: objects level + cicParser3.ml a parser from xml to internal definition: terms level + cicPp.ml a pretty-printer for the internal definition of cic objects + experiment.ml a textual interface to cicPp + gtkInterface.ml a gtk interface to cicPp + +Interface files: + cache.mli getter.mli cicPp.mli cicParser.mli cicParser2.mli cicParser3.mli + +Other files: + + Makefile the targets are "all" "opt" "depend" "clean" + .depend dependencies file used by make + examples symbolic link to the root of the exported library diff --git a/helm/interface/TEMPI b/helm/interface/TEMPI new file mode 100644 index 000000000..dc2bc8522 --- /dev/null +++ b/helm/interface/TEMPI @@ -0,0 +1,214 @@ +prima di UriManager.ml: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m50.266s + user 0m44.160s + sys 0m0.700s + +dopo UriManager.ml, ma prima di passare da = a ==: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m51.388s + user 0m45.430s + sys 0m0.530s + +dopo UriManager.ml e popo il passaggio (parziale?) da = a ==: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m50.767s + user 0m44.750s + sys 0m0.510s + +dopo il passaggio alla cache che usa ancora =: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m50.646s + user 0m44.680s + sys 0m0.530s + +dopo il passaggio alla cache con utilizzo di ==: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m50.861s + user 0m45.030s + sys 0m0.500s + +con funzione di hashing costante ;-( + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m51.442s + user 0m45.440s + sys 0m0.530s + +con implementazione isomorfa all'albero delle uri: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m54.081s + user 0m47.590s + sys 0m0.780s + +con implementazione con doppio RB-albero: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m52.504s + user 0m46.120s + sys 0m0.720s + +con implementazione semplice, gestite anche le uri delle var: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m51.850s + user 0m46.060s + sys 0m0.530s + +con implementazione con doppio RB-albero, gestite anche le uri delle var: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m51.495s + user 0m45.660s + sys 0m0.540s + +========================================================= + +con implementazione con doppio RB-albero, gestite anche le uri delle var +e spostata nell'uri-manager is_prefix: + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m50.465s + user 0m45.710s + sys 0m0.590s + +con implementazione semplice (e tutto il resto): + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m49.710s + user 0m43.850s + sys 0m0.500s + +con implementazione banale (e tutto il resto): + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m49.289s + user 0m44.840s + sys 0m0.570s + +con implementazione banale SOLO PARSING ;-) + + [ABCI]* (terza passata, uguale alla seconda): + + real 0m48.395s + user 0m42.830s + sys 0m0.850s + +========================================================= + +con implementazione con doppio RB-albero, gestite anche le uri delle var +e spostata nell'uri-manager is_prefix: + + REAL (prima passata, dopo un sync): + + real 10m58.033s + user 10m37.690s + sys 0m2.570s + +con implementazione semplice (e tutto il resto): + + REAL (prima passata, dopo un sync): + + real 10m31.035s + user 10m9.350s + sys 0m3.230s + +con implementazione banale (e tutto il resto): + + REAL (prima passata, dopo un sync): + + real 11m4.026s + user 10m43.930s + sys 0m3.070s + +================================================= + +con implementazione banale, SOLO PARSING di tutto: + + real 6m54.336s + user 6m13.850s + sys 0m6.580s + +con implementazione banale, anche typechecking di tutto: + + real 20m17.739s + user 19m14.740s + sys 0m8.550s + +con implementazione semplice, anche typechecking di tutto: + + real 19m36.079s + user 18m36.480s + sys 0m7.760s + +con implementazione con doppio RB-albero, anche typechecking di tutto: + + real 17m30.423s + user 16m30.840s + sys 0m6.170s + +*************************************************************************** + APPLICATA EURISTICA +*************************************************************************** + +con implementazione con doppio RB-albero, anche typechecking di tutto +(universita') ????????: + +real 5m37.805s +user 5m1.640s +sys 0m5.010s + +tutto (ma a casa): + +real 7m36.663s +user 6m52.220s +sys 0m5.860s + + +solo REAL: + +real 2m52.860s +user 2m41.050s +sys 0m2.820s + +========================================================================== + +tutto (ma a casa) dopo eliminazione buri: + +real 7m52.773s +user 6m52.110s +sys 0m7.130s + +"solo parsing" di tutto dopo eliminazione buri: + +real 7m8.379s +user 6m15.250s +sys 0m6.700s + +=========================================================================== + +TUTTO ALL'UNIVERSITA' CON EURISTICA MA SENZA UNIVERSI: + +real 5m47.920s +user 5m14.600s +sys 0m5.010s + diff --git a/helm/interface/WGET b/helm/interface/WGET new file mode 100644 index 000000000..f1cca6c37 --- /dev/null +++ b/helm/interface/WGET @@ -0,0 +1,3 @@ +-P directory di destinazione +-q no output (quiet mode) +-c continue retrieving (no uri.1, uri.2, ...) diff --git a/helm/interface/annotation2Xml.ml b/helm/interface/annotation2Xml.ml new file mode 100644 index 000000000..a9fca071a --- /dev/null +++ b/helm/interface/annotation2Xml.ml @@ -0,0 +1,190 @@ +(*CSC codice cut & paste da cicPp e xmlcommand *) + +exception ImpossiblePossible;; +exception NotImplemented;; +exception BinderNotSpecified;; + +let dtdname = "http://localhost:8081/getdtd?url=annotations.dtd";; + +(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *) +let print_term = + let rec aux = + let module C = Cic in + let module X = Xml in + let module U = UriManager in + function + C.ARel (id,ann,_,_) -> + (match !ann with + None -> [<>] + | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) + | C.AVar (id,ann,_) -> + (match !ann with + None -> [<>] + | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) + | C.AMeta (id,ann,_) -> + (match !ann with + None -> [<>] + | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) + | C.ASort (id,ann,_) -> + (match !ann with + None -> [<>] + | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) + | C.AImplicit _ -> raise NotImplemented + | C.AProd (id,ann,_,s,t) -> + [< (match !ann with + None -> [<>] + | Some ann -> + (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) ; + aux s ; + aux t + >] + | C.ACast (id,ann,v,t) -> + [< (match !ann with + None -> [<>] + | Some ann -> + (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) ; + aux v ; + aux t + >] + | C.ALambda (id,ann,_,s,t) -> + [< (match !ann with + None -> [<>] + | Some ann -> + (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) ; + aux s ; + aux t + >] + | C.AAppl (id,ann,li) -> + [< (match !ann with + None -> [<>] + | Some ann -> + (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) ; + List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>] + >] + | C.AConst (id,ann,_,_) -> + (match !ann with + None -> [<>] + | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) + | C.AAbst (id,ann,_) -> raise NotImplemented + | C.AMutInd (id,ann,_,_,_) -> + (match !ann with + None -> [<>] + | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) + | C.AMutConstruct (id,ann,_,_,_,_) -> + (match !ann with + None -> [<>] + | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) + | C.AMutCase (id,ann,_,_,_,ty,te,patterns) -> + [< (match !ann with + None -> [<>] + | Some ann -> + (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) ; + aux ty ; + aux te ; + List.fold_right + (fun x i -> [< aux x ; i>]) + patterns [<>] + >] + | C.AFix (id, ann, _, funs) -> + [< (match !ann with + None -> [<>] + | Some ann -> + (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) ; + List.fold_right + (fun (_,_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>] + >] + | C.ACoFix (id, ann,no,funs) -> + [< (match !ann with + None -> [<>] + | Some ann -> + (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) + ) ; + List.fold_right + (fun (_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>] + >] + in + aux +;; + +let print_mutual_inductive_type (_,_,arity,constructors) = + [< print_term arity ; + List.fold_right + (fun (name,ty,_) i -> [< print_term ty ; i >]) constructors [<>] + >] +;; + +let target_uri_of_annotation_uri uri = + Str.replace_first (Str.regexp "\.ann$") "" (UriManager.string_of_uri uri) +;; + +let pp_annotation obj curi = + let module C = Cic in + let module X = Xml in + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n\n") ; + X.xml_nempty "Annotations" ["of", target_uri_of_annotation_uri curi] + begin + match obj with + C.ADefinition (xid, ann, _, te, ty, _) -> + [< (match !ann with + None -> [<>] + | Some ann -> + X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) + ) ; + print_term te ; + print_term ty + >] + | C.AAxiom (xid, ann, _, ty, _) -> + [< (match !ann with + None -> [<>] + | Some ann -> + X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) + ) ; + print_term ty + >] + | C.AVariable (xid, ann, _, ty) -> + [< (match !ann with + None -> [<>] + | Some ann -> + X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) + ) ; + print_term ty + >] + | C.ACurrentProof (xid, ann, _, conjs, bo, ty) -> + [< (match !ann with + None -> [<>] + | Some ann -> + X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) + ) ; + List.fold_right + (fun (_,t) i -> [< print_term t ; i >]) + conjs [<>] ; + print_term bo ; + print_term ty + >] + | C.AInductiveDefinition (xid, ann, tys, params, paramsno) -> + [< (match !ann with + None -> [<>] + | Some ann -> + X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) + ) ; + List.fold_right + (fun x i -> [< print_mutual_inductive_type x ; i >]) + tys [< >] + >] + end + >] +;; diff --git a/helm/interface/annotationParser.ml b/helm/interface/annotationParser.ml new file mode 100644 index 000000000..3c645fe5d --- /dev/null +++ b/helm/interface/annotationParser.ml @@ -0,0 +1,30 @@ +exception Warnings;; + +class warner = + object + method warn w = + print_endline ("WARNING: " ^ w) ; + (raise Warnings : unit) + end +;; + +exception EmptyUri;; + +let annotate filename ids_to_targets = + let module Y = Pxp_yacc in + try + let d = + let config = {Y.default_config with Y.warner = new warner} in + Y.parse_document_entity config +(*PXP (Y.ExtID (Pxp_types.System filename, + new Pxp_reader.resolve_as_file ~url_of_id ())) +*) (PxpUriResolver.from_file filename) + Y.default_spec + + in + AnnotationParser2.annotate ids_to_targets d#root + with + e -> + print_endline (Pxp_types.string_of_exn e) ; + raise e +;; diff --git a/helm/interface/annotationParser2.ml b/helm/interface/annotationParser2.ml new file mode 100644 index 000000000..5e5042efa --- /dev/null +++ b/helm/interface/annotationParser2.ml @@ -0,0 +1,103 @@ +exception IllFormedXml of int;; + +(* Utility functions that transform a Pxp attribute into something useful *) + +let string_of_attr a = + let module T = Pxp_types in + match a with + T.Value s -> s + | _ -> raise (IllFormedXml 0) +;; + +exception DontKnowWhatToDo;; + +let rec string_of_annotations n = + let module D = Pxp_document in + let module T = Pxp_types in + match n#node_type with + D.T_element s -> + "<" ^ s ^ + List.fold_right + (fun att i -> + match n#attribute att with + T.Value s -> " " ^ att ^ "=\"" ^ s ^ "\"" ^ i + | T.Implied_value -> i + | T.Valuelist l -> " " ^ att ^ "=\"" ^ String.concat " " l ^ "\"" ^ i + ) (n#attribute_names) "" ^ + (match n#sub_nodes with + [] -> "/>" + | l -> + ">" ^ + String.concat "" (List.map string_of_annotations l) ^ + "" + ) + | D.T_data -> n#data + | _ -> raise DontKnowWhatToDo +;; + +let get_annotation n = + String.concat "" (List.map string_of_annotations (n#sub_nodes)) +;; + +let annotate_object ann obj = + let module C = Cic in + let rann = + match obj with + C.ADefinition (_, rann, _, _, _, _) -> rann + | C.AAxiom (_, rann, _, _, _) -> rann + | C.AVariable (_, rann, _, _) -> rann + | C.ACurrentProof (_, rann, _, _, _, _) -> rann + | C.AInductiveDefinition (_, rann, _, _, _) -> rann + in + rann := Some ann +;; + +let annotate_term ann term = + let module C = Cic in + let rann = + match term with + C.ARel (_, rann, _, _) -> rann + | C.AVar (_, rann, _) -> rann + | C.AMeta (_, rann, _) -> rann + | C.ASort (_, rann, _) -> rann + | C.AImplicit (_, rann) -> rann + | C.ACast (_, rann, _, _) -> rann + | C.AProd (_, rann, _, _, _) -> rann + | C.ALambda (_, rann, _, _, _) -> rann + | C.AAppl (_, rann, _) -> rann + | C.AConst (_, rann, _, _) -> rann + | C.AAbst (_, rann, _) -> rann + | C.AMutInd (_, rann, _, _, _) -> rann + | C.AMutConstruct (_, rann, _, _, _, _) -> rann + | C.AMutCase (_, rann, _, _, _, _, _, _) -> rann + | C.AFix (_, rann, _, _) -> rann + | C.ACoFix (_, rann, _, _) -> rann + in + rann := Some ann +;; + +let annotate ids_to_targets n = + let module D = Pxp_document in + let module C = Cic in + let annotate_elem n = + let ntype = n # node_type in + match ntype with + D.T_element "Annotation" -> + let of_uri = string_of_attr (n # attribute "of") in + begin + try + match Hashtbl.find ids_to_targets of_uri with + C.Object o -> annotate_object (get_annotation n) o + | C.Term t -> annotate_term (get_annotation n) t + with + Not_found -> assert false + end + | D.T_element _ | D.T_data -> + raise (IllFormedXml 1) + | _ -> raise DontKnowWhatToDo + in + match n # node_type with + D.T_element "Annotations" -> + List.iter annotate_elem (n # sub_nodes) + | _ -> raise (IllFormedXml 2) +;; diff --git a/helm/interface/cadet b/helm/interface/cadet new file mode 100755 index 000000000..f674925b3 --- /dev/null +++ b/helm/interface/cadet @@ -0,0 +1,13 @@ +#! /bin/sh + +export PATH=/home/cadet/sacerdot/jdk118/bin:$PATH + +export CLASSPATH=/home/cadet/sacerdot/xalan-j_1_2/xalan.jar:/home/cadet/sacerdot/xalan-j_1_2/xerces.jar:. + +#export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xalan.jar +#export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xerces.jar +#export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/saxon-5.3.2/saxon.jar + +# Per (my)Coq 6.3.0 +#export LD_LIBRARY_PATH=/home/lpadovan/helm/usr/lib/:$LD_LIBRARY_PATH +export LD_LIBRARY_PATH=/usr/local/lib/gtkmathview:$LD_LIBRARY_PATH diff --git a/helm/interface/cic.ml b/helm/interface/cic.ml new file mode 100644 index 000000000..dd9192531 --- /dev/null +++ b/helm/interface/cic.ml @@ -0,0 +1,134 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 14/06/2000 *) +(* *) +(* This module defines the internal representation of the objects (variables, *) +(* blocks of (co)inductive definitions and constants) and the terms of cic *) +(* *) +(******************************************************************************) + +(* STUFF TO MANAGE IDENTIFIERS *) +type id = string (* the abstract type of the (annotated) node identifiers *) +type anntarget = + Object of annobj + | Term of annterm + +(* INTERNAL REPRESENTATION OF CIC OBJECTS AND TERMS *) +and sort = + Prop + | Set + | Type +and name = + Name of string + | Anonimous +and term = + Rel of int (* DeBrujin index *) + | Var of UriManager.uri (* uri *) + | Meta of int (* numeric id *) + | Sort of sort (* sort *) + | Implicit (* *) + | Cast of term * term (* value, type *) + | Prod of name * term * term (* binder, source, target *) + | Lambda of name * term * term (* binder, source, target *) + | Appl of term list (* arguments *) + | Const of UriManager.uri * int (* uri, number of cookings*) + | Abst of UriManager.uri (* uri *) + | MutInd of UriManager.uri * int * int (* uri, cookingsno, typeno*) + | MutConstruct of UriManager.uri * int * (* uri, cookingsno, *) + int * int (* typeno, consno *) + (*CSC: serve cookingsno?*) + | MutCase of UriManager.uri * int * (* ind. uri, cookingsno, *) + int * (* ind. typeno, *) + term * term * (* outtype, ind. term *) + term list (* patterns *) + | Fix of int * inductiveFun list (* funno, functions *) + | CoFix of int * coInductiveFun list (* funno, functions *) +and obj = + Definition of string * term * term * (* id, value, type, *) + (int * UriManager.uri list) list (* parameters *) + | Axiom of string * term * + (int * UriManager.uri list) list (* id, type, parameters *) + | Variable of string * term (* name, type *) + | CurrentProof of string * (int * term) list * (* name, conjectures, *) + term * term (* value, type *) + | InductiveDefinition of inductiveType list * (* inductive types, *) + (int * UriManager.uri list) list * int (* parameters, n ind. pars *) +and inductiveType = + string * bool * term * (* typename, inductive, arity *) + constructor list (* constructors *) +and constructor = + string * term * bool list option ref (* id, type, really recursive *) +and inductiveFun = + string * int * term * term (* name, ind. index, type, body *) +and coInductiveFun = + string * term * term (* name, type, body *) + +and annterm = + ARel of id * annotation option ref * + int * string option (* DeBrujin index, binder *) + | AVar of id * annotation option ref * + UriManager.uri (* uri *) + | AMeta of id * annotation option ref * int (* numeric id *) + | ASort of id * annotation option ref * sort (* sort *) + | AImplicit of id * annotation option ref (* *) + | ACast of id * annotation option ref * + annterm * annterm (* value, type *) + | AProd of id * annotation option ref * + name * annterm * annterm (* binder, source, target *) + | ALambda of id * annotation option ref * + name * annterm * annterm (* binder, source, target *) + | AAppl of id * annotation option ref * + annterm list (* arguments *) + | AConst of id * annotation option ref * + UriManager.uri * int (* uri, number of cookings*) + | AAbst of id * annotation option ref * + UriManager.uri (* uri *) + | AMutInd of id * annotation option ref * + UriManager.uri * int * int (* uri, cookingsno, typeno*) + | AMutConstruct of id * annotation option ref * + UriManager.uri * int * (* uri, cookingsno, *) + int * int (* typeno, consno *) + (*CSC: serve cookingsno?*) + | AMutCase of id * annotation option ref * + UriManager.uri * int * (* ind. uri, cookingsno *) + int * (* ind. typeno, *) + annterm * annterm * (* outtype, ind. term *) + annterm list (* patterns *) + | AFix of id * annotation option ref * + int * anninductiveFun list (* funno, functions *) + | ACoFix of id * annotation option ref * + int * anncoInductiveFun list (* funno, functions *) +and annobj = + ADefinition of id * annotation option ref * + string * (* id, *) + annterm * annterm * (* value, type, *) + (int * UriManager.uri list) list exactness (* parameters *) + | AAxiom of id * annotation option ref * + string * annterm * (* id, type *) + (int * UriManager.uri list) list (* parameters *) + | AVariable of id * annotation option ref * + string * annterm (* name, type *) + | ACurrentProof of id * annotation option ref * + string * (int * annterm) list * (* name, conjectures, *) + annterm * annterm (* value, type *) + | AInductiveDefinition of id * + annotation option ref * anninductiveType list * (* inductive types , *) + (int * UriManager.uri list) list * int (* parameters,n ind. pars*) +and anninductiveType = + string * bool * annterm * (* typename, inductive, arity *) + annconstructor list (* constructors *) +and annconstructor = + string * annterm * bool list option ref (* id, type, really recursive *) +and anninductiveFun = + string * int * annterm * annterm (* name, ind. index, type, body *) +and anncoInductiveFun = + string * annterm * annterm (* name, type, body *) +and annotation = + string +and 'a exactness = + Possible of 'a (* an approximation to something *) + | Actual of 'a (* something *) +;; diff --git a/helm/interface/cic2Xml.ml b/helm/interface/cic2Xml.ml new file mode 100644 index 000000000..ff16e2f70 --- /dev/null +++ b/helm/interface/cic2Xml.ml @@ -0,0 +1,217 @@ +(*CSC codice cut & paste da cicPp e xmlcommand *) + +exception ImpossiblePossible;; +exception NotImplemented;; +exception BinderNotSpecified;; + +let dtdname = "http://localhost:8081/getdtd?url=cic.dtd";; + +(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *) +let print_term curi = + let rec aux = + let module C = Cic in + let module X = Xml in + let module U = UriManager in + function + C.ARel (id,_,n,Some b) -> + X.xml_empty "REL" ["value",(string_of_int n);"binder",b;"id",id] + | C.ARel _ -> raise BinderNotSpecified + | C.AVar (id,_,uri) -> + let vdepth = U.depth_of_uri uri + and cdepth = U.depth_of_uri curi in + X.xml_empty "VAR" + ["relUri",(string_of_int (cdepth - vdepth)) ^ "," ^ + (U.name_of_uri uri) ; + "id",id] + | C.AMeta (id,_,n) -> + X.xml_empty "META" ["no",(string_of_int n) ; "id",id] + | C.ASort (id,_,s) -> + let string_of_sort = + function + C.Prop -> "Prop" + | C.Set -> "Set" + | C.Type -> "Type" + in + X.xml_empty "SORT" ["value",(string_of_sort s) ; "id",id] + | C.AImplicit _ -> raise NotImplemented + | C.AProd (id,_,C.Anonimous,s,t) -> + X.xml_nempty "PROD" ["id",id] + [< X.xml_nempty "source" [] (aux s) ; + X.xml_nempty "target" [] (aux t) + >] + | C.AProd (xid,_,C.Name id,s,t) -> + X.xml_nempty "PROD" ["id",xid] + [< X.xml_nempty "source" [] (aux s) ; + X.xml_nempty "target" ["binder",id] (aux t) + >] + | C.ACast (id,_,v,t) -> + X.xml_nempty "CAST" ["id",id] + [< X.xml_nempty "term" [] (aux v) ; + X.xml_nempty "type" [] (aux t) + >] + | C.ALambda (id,_,C.Anonimous,s,t) -> + X.xml_nempty "LAMBDA" ["id",id] + [< X.xml_nempty "source" [] (aux s) ; + X.xml_nempty "target" [] (aux t) + >] + | C.ALambda (xid,_,C.Name id,s,t) -> + X.xml_nempty "LAMBDA" ["id",xid] + [< X.xml_nempty "source" [] (aux s) ; + X.xml_nempty "target" ["binder",id] (aux t) + >] + | C.AAppl (id,_,li) -> + X.xml_nempty "APPLY" ["id",id] + [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>]) + >] + | C.AConst (id,_,uri,_) -> + X.xml_empty "CONST" ["uri", (U.string_of_uri uri) ; "id",id] + | C.AAbst (id,_,uri) -> raise NotImplemented + | C.AMutInd (id,_,uri,_,i) -> + X.xml_empty "MUTIND" + ["uri", (U.string_of_uri uri) ; + "noType",(string_of_int i) ; + "id",id] + | C.AMutConstruct (id,_,uri,_,i,j) -> + X.xml_empty "MUTCONSTRUCT" + ["uri", (U.string_of_uri uri) ; + "noType",(string_of_int i) ; "noConstr",(string_of_int j) ; + "id",id] + | C.AMutCase (id,_,uri,_,typeno,ty,te,patterns) -> + X.xml_nempty "MUTCASE" + ["uriType",(U.string_of_uri uri) ; + "noType", (string_of_int typeno) ; + "id", id] + [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; + X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; + List.fold_right + (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>]) + patterns [<>] + >] + | C.AFix (id, _, no, funs) -> + X.xml_nempty "FIX" ["noFun", (string_of_int no) ; "id",id] + [< List.fold_right + (fun (fi,ai,ti,bi) i -> + [< X.xml_nempty "FixFunction" + ["name", fi; "recIndex", (string_of_int ai)] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] ; + i + >] + ) funs [<>] + >] + | C.ACoFix (id,_,no,funs) -> + X.xml_nempty "COFIX" ["noFun", (string_of_int no) ; "id",id] + [< List.fold_right + (fun (fi,ti,bi) i -> + [< X.xml_nempty "CofixFunction" ["name", fi] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] ; + i + >] + ) funs [<>] + >] + in + aux +;; + +let encode params = + List.fold_right + (fun (n,l) i -> + match l with + [] -> i + | _ -> + string_of_int n ^ ": " ^ + String.concat " " (List.map UriManager.name_of_uri l) ^ + i + ) params "" +;; + +let print_mutual_inductive_type curi (typename,inductive,arity,constructors) = + let module C = Cic in + let module X = Xml in + [< X.xml_nempty "InductiveType" + ["name",typename ; + "inductive",(string_of_bool inductive) + ] + [< X.xml_nempty "arity" [] (print_term curi arity) ; + (List.fold_right + (fun (name,ty,_) i -> + [< X.xml_nempty "Constructor" ["name",name] + (print_term curi ty) ; + i + >]) + constructors + [<>] + ) + >] + >] +;; + +let pp obj curi = + let module C = Cic in + let module X = Xml in + match obj with + C.ADefinition (xid, _, id, te, ty, params) -> + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n\n") ; + X.xml_nempty "Definition" + (["name", id ; "id",xid] @ + match params with + C.Possible _ -> raise ImpossiblePossible + (*CSC params are kept in inverted order in the internal *) + (* representation (the order of application) *) + | C.Actual fv' -> ["params",(encode (List.rev fv'))]) + [< X.xml_nempty "body" [] (print_term curi te) ; + X.xml_nempty "type" [] (print_term curi ty) >] + >] + | C.AAxiom (xid, _, id, ty, params) -> + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n\n") ; + X.xml_nempty "Axiom" + (*CSC params are kept in inverted order in the internal *) + (* representation (the order of application) *) + ["name",id ; "params",(encode (List.rev params)) ; "id",xid] + [< X.xml_nempty "type" [] (print_term curi ty) >] + >] + | C.AVariable (xid, _, name, ty) -> + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n\n") ; + X.xml_nempty "Variable" ["name",name ; "id",xid] + [< X.xml_nempty "type" [] (print_term curi ty) >] + >] + | C.ACurrentProof (xid, _, name, conjs, bo, ty) -> + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n\n"); + X.xml_nempty "CurrentProof" ["name",name ; "id",xid] + [< List.fold_right + (fun (j,t) i -> + [< X.xml_nempty "Conjecture" ["no",(string_of_int j)] + [< print_term curi t >] ; i >]) + conjs [<>] ; + X.xml_nempty "body" [] [< print_term curi bo >] ; + X.xml_nempty "type" [] [< print_term curi ty >] + >] + >] + | C.AInductiveDefinition (xid, _, tys, params, paramsno) -> + let names = + List.map + (fun (typename,_,_,_) -> typename) + tys + in + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n\n") ; + X.xml_nempty "InductiveDefinition" + (*CSC params are kept in inverted order in the internal *) + (* representation (the order of application) *) + ["noParams",string_of_int paramsno ; + "params",(encode (List.rev params)) ; + "id",xid] + [< List.fold_right + (fun x i -> [< print_mutual_inductive_type curi x ; i >]) + tys [< >] + >] + >] +;; diff --git a/helm/interface/cicAnnotationHinter.ml b/helm/interface/cicAnnotationHinter.ml new file mode 100644 index 000000000..21f30a722 --- /dev/null +++ b/helm/interface/cicAnnotationHinter.ml @@ -0,0 +1,337 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 14/06/2000 *) +(* *) +(* *) +(******************************************************************************) + +let deactivate_hints_from annotation_window n = + let annotation_hints = annotation_window#annotation_hints in + for i = n to Array.length annotation_hints - 1 do + annotation_hints.(i)#misc#hide () + done +;; + +(* CSC: orripilante *) +(* the list of the signal ids *) +let sig_ids = ref ([] : GtkSignal.id list);; + +let disconnect_hint annotation_window buttonno = + match !sig_ids with + id::ids -> + annotation_window#annotation_hints.(buttonno)#misc#disconnect id ; + sig_ids := ids + | _ -> assert false +;; + +(* link_hint annotation_window n label hint *) +(* set the label of the nth hint button of annotation_window to label *) +(* and the correspondent hint to hint *) +let link_hint annotation_window buttonno label hint = + let button = annotation_window#annotation_hints.(buttonno) in + sig_ids := + (button#connect#clicked + (fun () -> (annotation_window#annotation : GEdit.text)#insert hint) + ) :: !sig_ids ; + button#misc#show () ; + match button#children with + [labelw] -> (GMisc.label_cast labelw)#set_text label + | _ -> assert false +;; + +exception TooManyHints;; + +let link_hints annotation_window a = + if Array.length a > Array.length annotation_window#annotation_hints then + raise TooManyHints ; + for i = List.length !sig_ids - 1 downto 0 do + disconnect_hint annotation_window i + done ; + Array.iteri + (fun i (label,hint) -> link_hint annotation_window i label hint) a ; + deactivate_hints_from annotation_window (Array.length a) +;; + +let list_mapi f = + let rec aux n = + function + [] -> [] + | he::tl -> (f n he)::(aux (n + 1) tl) + in + aux 0 +;; + +let get_id annterm = + let module C = Cic in + match annterm with + C.ARel (id,_,_,_) -> id + | C.AVar (id,_,_) -> id + | C.AMeta (id,_,_) -> id + | C.ASort (id,_,_) -> id + | C.AImplicit (id,_) -> id + | C.ACast (id,_,_,_) -> id + | C.AProd (id,_,_,_,_) -> id + | C.ALambda (id,_,_,_,_) -> id + | C.AAppl (id,_,_) -> id + | C.AConst (id,_,_,_) -> id + | C.AAbst (id,_,_) -> id + | C.AMutInd (id,_,_,_,_) -> id + | C.AMutConstruct (id,_,_,_,_,_)-> id + | C.AMutCase (id,_,_,_,_,_,_,_) -> id + | C.AFix (id,_,_,_) -> id + | C.ACoFix (id,_,_,_) -> id +;; + +let create_hint_from_term annotation_window annterm = + let module C = Cic in + match annterm with + C.ARel (id,_,_,_) -> + link_hints annotation_window + [| "Binder", "" |] + | C.AVar (id,_,_) -> + link_hints annotation_window + [| "relURI???", "" |] + | C.AMeta (id,_,_) -> + link_hints annotation_window + [| "Number", "" |] + | C.ASort (id,_,_) -> + link_hints annotation_window + [| "Value", "" |] + | C.AImplicit (id,_) -> + link_hints annotation_window [| |] + | C.ACast (id,_,bo,ty) -> + let boid = get_id bo + and tyid = get_id ty in + link_hints annotation_window + [| "Body", "" ; + "Type", "" + |] + | C.AProd (id,_,_,ty,bo) -> + let boid = get_id bo + and tyid = get_id ty in + link_hints annotation_window + [| "Binder", + "" ; + "Body", "" ; + "Type", "" + |] + | C.ALambda (id,_,_,ty,bo) -> + let boid = get_id bo + and tyid = get_id ty in + link_hints annotation_window + [| "Binder", + "" ; + "Body", "" ; + "Type", "" + |] + | C.AAppl (id,_,args) -> + let argsid = + Array.mapi + (fun i te -> "Argument " ^ string_of_int i, "") + (Array.of_list args) + in + link_hints annotation_window argsid + | C.AConst (id,_,_,_) -> + link_hints annotation_window + [| "Uri???", "" |] + | C.AAbst (id,_,_) -> + link_hints annotation_window + [| "Uri???", "" |] + | C.AMutInd (id,_,_,_,_) -> + link_hints annotation_window + [| "Uri???", "" |] + | C.AMutConstruct (id,_,_,_,_,_) -> + link_hints annotation_window + [| "Uri???", "" |] + | C.AMutCase (id,_,_,_,_,outty,te,pl) -> + let outtyid = get_id outty + and teid = get_id te + and plid = + Array.mapi + (fun i te -> "Pattern " ^ string_of_int i, "") + (Array.of_list pl) + in + link_hints annotation_window + (Array.append + [| "Uri???", "" ; + "Case Type", "" ; + "Term", "" ; + |] + plid) + | C.AFix (id,_,_,funl) -> + let funtylid = + Array.mapi + (fun i (_,_,ty,_) -> + "Type " ^ string_of_int i, "") + (Array.of_list funl) + and funbolid = + Array.mapi + (fun i (_,_,_,bo) -> + "Body " ^ string_of_int i, "") + (Array.of_list funl) + and funnamel = + Array.mapi + (fun i (_,_,_,_) -> + "Name " ^ string_of_int i, "") + (Array.of_list funl) + and funrecindexl = + Array.mapi + (fun i (_,_,_,_) -> + "Recursive Index??? " ^ string_of_int i, "") + (Array.of_list funl) + in + link_hints annotation_window + (Array.concat + [ funtylid ; + funbolid ; + funnamel ; + funrecindexl ; + [| "NoFun???", "" |] + ] + ) + | C.ACoFix (id,_,_,funl) -> + let funtylid = + Array.mapi + (fun i (_,ty,_) -> + "Type " ^ string_of_int i, "") + (Array.of_list funl) + and funbolid = + Array.mapi + (fun i (_,_,bo) -> + "Body " ^ string_of_int i, "") + (Array.of_list funl) + and funnamel = + Array.mapi + (fun i (_,_,_) -> + "Name " ^ string_of_int i, "") + (Array.of_list funl) + in + link_hints annotation_window + (Array.concat + [ funtylid ; + funbolid ; + funnamel ; + [| "NoFun???", "" |] + ] + ) +;; + +(*CSC: da riscrivere completamente eliminando il paciugo degli array - liste *) +let create_hint_from_obj annotation_window annobj = + let module C = Cic in + match annobj with + C.ADefinition (id,_,_,bo,ty,_) -> + let boid = get_id bo + and tyid = get_id ty in + link_hints annotation_window + [| "Name", "" ; + "Ingredients", "" ; + "Body", "" ; + "Type", "" + |] + | C.AAxiom (id,_,_,ty,_) -> + let tyid = get_id ty in + link_hints annotation_window + [| "Name", "" ; + "Ingredients", "" ; + "Type", "" + |] + | C.AVariable (id,_,_,ty) -> + let tyid = get_id ty in + link_hints annotation_window + [| "Name", "" ; + "Type", "" + |] + | C.ACurrentProof (id,_,_,conjs,bo,ty) -> + let boid = get_id bo + and tyid = get_id ty + and conjsid = List.map (fun (_,te) -> get_id te) conjs in + link_hints annotation_window + (Array.append + [| "Name", "" ; + "Ingredients", "" ; + "Body", "" ; + "Type", "" + |] + (Array.mapi + (fun i id -> + "Conjecture " ^ string_of_int i, "" + ) (Array.of_list conjsid) + ) + ) + | C.AInductiveDefinition (id,_,itl,_,_) -> + let itlids = + List.map + (fun (_,_,arity,cons) -> + get_id arity, + List.map (fun (_,ty,_) -> get_id ty) cons + ) itl + in + link_hints annotation_window + (Array.concat + [ + [| "Ingredients","" |]; + (Array.mapi + (fun i _ -> + "Type Name " ^ string_of_int i, + "" + ) (Array.of_list itlids) + ) ; + (Array.mapi + (fun i (id,_) -> + "Type " ^ string_of_int i, "" + ) (Array.of_list itlids) + ) ; + (Array.concat + (list_mapi + (fun i (_,consid) -> + (Array.mapi + (fun j _ -> + "Constructor Name " ^ string_of_int i ^ " " ^ string_of_int j, + "" + ) (Array.of_list consid) + ) ; + ) itlids + ) + ) ; + (Array.concat + (list_mapi + (fun i (_,consid) -> + (Array.mapi + (fun j id -> + "Constructor " ^ string_of_int i ^ " " ^ string_of_int j, + "" + ) (Array.of_list consid) + ) ; + ) itlids + ) + ) + ] + ) +;; + +exception IdUnknown of string;; + +let create_hints annotation_window (annobj,ids_to_targets) xpath = + try + match Hashtbl.find ids_to_targets xpath with + Cic.Object annobj -> create_hint_from_obj annotation_window annobj + | Cic.Term annterm -> create_hint_from_term annotation_window annterm + with + Not_found -> raise (IdUnknown xpath) +;; diff --git a/helm/interface/cicCache.ml b/helm/interface/cicCache.ml new file mode 100644 index 000000000..1b8488a40 --- /dev/null +++ b/helm/interface/cicCache.ml @@ -0,0 +1,187 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a trival cache system (an hash-table) for cic *) +(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) +(* *) +(******************************************************************************) + +let raise e = print_endline "***" ; flush stdout ; print_endline (Printexc.to_string e) ; flush stdout ; raise e;; + +(*CSC: forse i due seguenti tipi sono da unificare? *) +type cooked_obj = + Cooked of Cic.obj + | Frozen of Cic.obj + | Unchecked of Cic.obj +type type_checked_obj = + CheckedObj of Cic.obj (* cooked obj *) + | UncheckedObj of Cic.obj (* uncooked obj *) +;; + +exception NoFunctionProvided;; + +(* CSC: da sostituire con un (...) option ref *) +let cook_obj = ref (fun obj uri -> raise NoFunctionProvided);; + +exception CircularDependency of string;; +exception CouldNotUnfreeze of string;; +exception Impossible;; +exception UncookedObj;; + +module HashedType = + struct + type t = UriManager.uri * int (* uri, livello di cottura *) + let equal (u1,n1) (u2,n2) = UriManager.eq u1 u2 && n1 = n2 + let hash = Hashtbl.hash + end +;; + +(* Hashtable that uses == instead of = for testing equality *) +module HashTable = Hashtbl.Make(HashedType);; + +let hashtable = HashTable.create 271;; + +(* n is the number of time that the object must be cooked *) +let get_obj_and_type_checking_info uri n = + try + HashTable.find hashtable (uri,n) + with + Not_found -> + try + match HashTable.find hashtable (uri,0) with + Cooked _ + | Frozen _ -> raise Impossible + | Unchecked _ as t -> t + with + Not_found -> + let filename = Getter.get uri in + let (annobj,_) = CicParser.term_of_xml filename uri false in + let obj = Deannotate.deannotate_obj annobj in + let output = Unchecked obj in + HashTable.add hashtable (uri,0) output ; + output +;; + +(* DANGEROUS!!! *) +(* USEFUL ONLY DURING THE FIXING OF THE FILES *) +(* change_obj uri (Some newobj) *) +(* maps uri to newobj in cache. *) +(* change_obj uri None *) +(* maps uri to a freeze dummy-object. *) +let change_obj uri newobj = + let newobj = + match newobj with + Some newobj' -> Unchecked newobj' + | None -> Frozen (Cic.Variable ("frozen-dummy", Cic.Implicit)) + in + HashTable.remove hashtable (uri,0) ; + HashTable.add hashtable (uri,0) newobj +;; + +let is_annotation_uri uri = + Str.string_match (Str.regexp ".*\.ann$") (UriManager.string_of_uri uri) 0 +;; + +(* returns both the annotated and deannotated uncooked forms (plus the *) +(* map from ids to annotation targets) *) +let get_annobj_and_type_checking_info uri = + let filename = Getter.get uri in + match CicParser.term_of_xml filename uri true with + (_, None) -> raise Impossible + | (annobj, Some ids_to_targets) -> + (* If uri is the uri of an annotation, let's use the annotation file *) + if is_annotation_uri uri then + AnnotationParser.annotate (Getter.get_ann uri) ids_to_targets ; + try + (annobj, ids_to_targets, HashTable.find hashtable (uri,0)) + with + Not_found -> + let obj = Deannotate.deannotate_obj annobj in + let output = Unchecked obj in + HashTable.add hashtable (uri,0) output ; + (annobj, ids_to_targets, output) +;; + + +(* get_obj uri *) +(* returns the cic object whose uri is uri. If the term is not just in cache, *) +(* then it is parsed via CicParser.term_of_xml from the file whose name is *) +(* the result of Getter.get uri *) +let get_obj uri = + match get_obj_and_type_checking_info uri 0 with + Unchecked obj -> obj + | Frozen obj -> obj + | Cooked obj -> obj +;; + +(* get_annobj uri *) +(* returns the cic object whose uri is uri either in annotated and *) +(* deannotated form. The term is put into the cache if it's not there yet. *) +let get_annobj uri = + let (ann, ids_to_targets, deann) = get_annobj_and_type_checking_info uri in + let deannobj = + match deann with + Unchecked obj -> obj + | Frozen _ -> raise (CircularDependency (UriManager.string_of_uri uri)) + | Cooked obj -> obj + in + (ann, ids_to_targets, deannobj) +;; + +(*CSC Commento falso *) +(* get_obj uri *) +(* returns the cooked cic object whose uri is uri. The term must be present *) +(* and cooked in cache *) +let rec get_cooked_obj uri cookingsno = + match get_obj_and_type_checking_info uri cookingsno with + Unchecked _ + | Frozen _ -> raise UncookedObj + | Cooked obj -> obj +;; + +(* is_type_checked uri *) +(* CSC: commento falso ed obsoleto *) +(* returns true if the term has been type-checked *) +(* otherwise it returns false and freeze the term for type-checking *) +(* set_type_checking_info must be called to unfreeze the term *) +let is_type_checked uri cookingsno = + match get_obj_and_type_checking_info uri cookingsno with + Cooked obj -> CheckedObj obj + | Unchecked obj -> + HashTable.remove hashtable (uri,0) ; + HashTable.add hashtable (uri,0) (Frozen obj) ; + UncheckedObj obj + | Frozen _ -> raise (CircularDependency (UriManager.string_of_uri uri)) +;; + +(* set_type_checking_info uri *) +(* must be called once the type-checking of uri is finished *) +(* The object whose uri is uri is unfreezed *) +let set_type_checking_info uri = + match HashTable.find hashtable (uri,0) with + Frozen obj -> + (* let's cook the object at every level *) + HashTable.remove hashtable (uri,0) ; + let obj' = CicSubstitution.undebrujin_inductive_def uri obj in + HashTable.add hashtable (uri,0) (Cooked obj') ; + let cooked_objs = !cook_obj obj' uri in + let last_cooked_level = ref 0 in + let last_cooked_obj = ref obj' in + List.iter + (fun (n,cobj) -> + for i = !last_cooked_level + 1 to n do + HashTable.add hashtable (uri,i) (Cooked !last_cooked_obj) + done ; + HashTable.add hashtable (uri,n + 1) (Cooked cobj) ; + last_cooked_level := n + 1 ; + last_cooked_obj := cobj + ) cooked_objs ; + for i = !last_cooked_level + 1 to UriManager.depth_of_uri uri + 1 do + HashTable.add hashtable (uri,i) (Cooked !last_cooked_obj) + done + | _ -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri)) +;; diff --git a/helm/interface/cicCache.mli b/helm/interface/cicCache.mli new file mode 100644 index 000000000..e6cb313ce --- /dev/null +++ b/helm/interface/cicCache.mli @@ -0,0 +1,56 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a trival cache system (an hash-table) for cic *)(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *)(* *) +(******************************************************************************) + +exception CircularDependency of string;; + +(* get_obj uri *) +(* returns the cic object whose uri is uri. If the term is not just in cache, *) +(* then it is parsed via CicParser.term_of_xml from the file whose name is *) +(* the result of Getter.get uri *) +val get_obj : UriManager.uri -> Cic.obj + +(* get_annobj uri *) +(* returns the cic object whose uri is uri either in annotated and in *) +(* deannotated form. It returns also the map from ids to annotation targets. *) +(* The term is put in cache if it's not there yet. *) +(* The functions raise CircularDependency if asked to retrieve a Frozen object*) +val get_annobj : + UriManager.uri -> Cic.annobj * (Cic.id, Cic.anntarget) Hashtbl.t * Cic.obj + +(* DANGEROUS!!! *) +(* USEFUL ONLY DURING THE FIXING OF THE FILES *) +(* change_obj uri (Some newobj) *) +(* maps uri to newobj in cache. *) +(* change_obj uri None *) +(* maps uri to a freeze dummy-object. *) +val change_obj : UriManager.uri -> Cic.obj option -> unit + +type type_checked_obj = + CheckedObj of Cic.obj (* cooked obj *) + | UncheckedObj of Cic.obj (* uncooked obj *) + +(* is_type_checked uri cookingsno *) +(*CSC commento falso ed obsoleto *) +(* returns (true,object) if the object has been type-checked *) +(* otherwise it returns (false,object) and freeze the object for *) +(* type-checking *) +(* set_type_checking_info must be called to unfreeze the object *) +val is_type_checked : UriManager.uri -> int -> type_checked_obj + +(* set_type_checking_info uri *) +(* must be called once the type-checking of uri is finished *) +(* The object whose uri is uri is unfreezed and won't be type-checked *) +(* again in the future (is_type_checked will return true) *) +val set_type_checking_info : UriManager.uri -> unit + +(* get_cooked_obj uri cookingsno *) +val get_cooked_obj : UriManager.uri -> int -> Cic.obj + +val cook_obj : (Cic.obj -> UriManager.uri -> (int * Cic.obj) list) ref diff --git a/helm/interface/cicCooking.ml b/helm/interface/cicCooking.ml new file mode 100644 index 000000000..4d72fb3cb --- /dev/null +++ b/helm/interface/cicCooking.ml @@ -0,0 +1,182 @@ +exception Impossible;; +exception NotImplemented of int * string;; +exception WrongUriToConstant;; +exception WrongUriToVariable of string;; +exception WrongUriToInductiveDefinition;; + +(* mem x lol is true if x is a member of one *) +(* of the lists of the list of (int * list) lol *) +let mem x lol = + List.fold_right (fun (_,l) i -> i || List.mem x l) lol false +;; + +(* cook var term *) +let cook curi cookingsno var = + let rec aux k = + let module C = Cic in + function + C.Rel n as t -> + (match n with + n when n >= k -> C.Rel (n + 1) + | _ -> C.Rel n + ) + | C.Var uri as t -> + if UriManager.eq uri var then + C.Rel k + else + t + | C.Meta _ as t -> t + | C.Sort _ as t -> t + | C.Implicit as t -> t + | C.Cast (te, ty) -> C.Cast (aux k te, aux k ty) + | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k + 1) t) + | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t) + | C.Appl (he::tl) -> + (* Get rid of C.Appl (C.Appl l1) l2 *) + let newtl = List.map (aux k) tl in + (match aux k he with + C.Appl (he'::tl') -> C.Appl (he'::(tl'@newtl)) + | t -> C.Appl (t::newtl) + ) + | C.Appl [] -> raise Impossible + | C.Const (uri,_) -> + if match CicCache.get_obj uri with + C.Definition (_,_,_,params) when mem var params -> true + | C.Definition _ -> false + | C.Axiom (_,_,params) when mem var params -> true + | C.Axiom _ -> false + | C.CurrentProof _ -> + raise (NotImplemented (2,(UriManager.string_of_uri uri))) + | _ -> raise WrongUriToConstant + then + C.Appl + ((C.Const (uri,UriManager.relative_depth curi uri cookingsno)):: + [C.Rel k]) + else + C.Const (uri,UriManager.relative_depth curi uri cookingsno) + | C.Abst _ as t -> t + | C.MutInd (uri,_,i) -> + if match CicCache.get_obj uri with + C.InductiveDefinition (_,params,_) when mem var params -> true + | C.InductiveDefinition _ -> false + | _ -> raise WrongUriToInductiveDefinition + then + C.Appl ((C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i))::[C.Rel k]) + else + C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i) + | C.MutConstruct (uri,_,i,j) -> + if match CicCache.get_obj uri with + C.InductiveDefinition (_,params,_) when mem var params -> true + | C.InductiveDefinition _ -> false + | _ -> raise WrongUriToInductiveDefinition + then + C.Appl ((C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j))::[C.Rel k]) + else + C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j) + | C.MutCase (uri,_,i,outt,term,pl) -> + let substitutedfl = + List.map (aux k) pl + in + C.MutCase (uri,UriManager.relative_depth curi uri cookingsno,i, + aux k outt,aux k term, substitutedfl) + | C.Fix (i,fl) -> + let len = List.length fl in + let substitutedfl = + List.map + (fun (name,i,ty,bo) -> (name,i,aux k ty, aux (k+len) bo)) + fl + in + C.Fix (i, substitutedfl) + | C.CoFix (i,fl) -> + let len = List.length fl in + let substitutedfl = + List.map + (fun (name,ty,bo) -> (name,aux k ty, aux (k+len) bo)) + fl + in + C.CoFix (i, substitutedfl) + in + aux 1 +;; + +let cook_gen add_binder curi cookingsno ty vars = + let module C = Cic in + let module U = UriManager in + let rec cookrec ty = + function + var::tl -> + let (varname, vartype) = + match CicCache.get_obj var with + C.Variable (varname, vartype) -> (varname, vartype) + | _ -> raise (WrongUriToVariable (U.string_of_uri var)) + in + cookrec (add_binder (C.Name varname) vartype (cook curi cookingsno var ty)) tl + | _ -> ty + in + cookrec ty vars +;; + +let cook_prod = + cook_gen (fun n s t -> Cic.Prod (n,s,t)) +and cook_lambda = + cook_gen (fun n s t -> Cic.Lambda (n,s,t)) +;; + +(*CSC: sbagliato da rifare e completare *) +let cook_one_level obj curi cookingsno vars = + let module C = Cic in + match obj with + C.Definition (id,te,ty,params) -> + let ty' = cook_prod curi cookingsno ty vars in + let te' = cook_lambda curi cookingsno te vars in + C.Definition (id,te',ty',params) + | C.Axiom (id,ty,parameters) -> + let ty' = cook_prod curi cookingsno ty vars in + C.Axiom (id,ty',parameters) + | C.Variable _ as obj -> obj + | C.CurrentProof (id,conjs,te,ty) -> + let ty' = cook_prod curi cookingsno ty vars in + let te' = cook_lambda curi cookingsno te vars in + C.CurrentProof (id,conjs,te',ty') + | C.InductiveDefinition (dl, params, n_ind_params) -> + let dl' = + List.map + (fun (name,inductive,arity,constructors) -> + let constructors' = + List.map + (fun (name,ty,r) -> + let r' = + match !r with + None -> raise Impossible + | Some r -> List.map (fun _ -> false) vars @ r + in + (name,cook_prod curi cookingsno ty vars,ref (Some r')) + ) constructors + in + (name,inductive,cook_prod curi cookingsno arity vars,constructors') + ) dl + in + C.InductiveDefinition (dl', params, n_ind_params + List.length vars) +;; + +let cook_obj obj uri = + let module C = Cic in + let params = + match obj with + C.Definition (_,_,_,params) -> params + | C.Axiom (_,_,params) -> params + | C.Variable _ -> [] + | C.CurrentProof _ -> [] + | C.InductiveDefinition (_,params,_) -> params + in + let rec cook_all_levels obj = + function + [] -> [] + | (n,vars)::tl -> + let cooked_obj = cook_one_level obj uri (n + 1) (List.rev vars) in + (n,cooked_obj)::(cook_all_levels cooked_obj tl) + in + cook_all_levels obj (List.rev params) +;; + +CicCache.cook_obj := cook_obj;; diff --git a/helm/interface/cicCooking.mli b/helm/interface/cicCooking.mli new file mode 100644 index 000000000..586e5d78a --- /dev/null +++ b/helm/interface/cicCooking.mli @@ -0,0 +1,6 @@ +exception Impossible +exception NotImplemented of int * string +exception WrongUriToConstant +exception WrongUriToVariable of string +exception WrongUriToInductiveDefinition +val cook_obj : Cic.obj -> UriManager.uri -> (int * Cic.obj) list diff --git a/helm/interface/cicFindParameters.ml b/helm/interface/cicFindParameters.ml new file mode 100644 index 000000000..607dd525c --- /dev/null +++ b/helm/interface/cicFindParameters.ml @@ -0,0 +1,137 @@ +exception WrongUriToConstant;; +exception WrongUriToInductiveDefinition;; +exception CircularDependency of string;; + +module OrderedUris = + struct + type t = UriManager.uri + let compare (s1 : t) (s2 : t) = + (* library function for = *) + compare s1 s2 + (*if s1 = s2 then 0 else if s1 < s2 then (-1) else 1*) + end +;; + +let filename_of_uri uri = + let uri' = UriManager.string_of_uri uri in + let fn = Str.replace_first (Str.regexp "cic:") Configuration.helm_dir uri' in + fn ^ ".xml" +;; + +(* quite inefficient coding of a set of strings: the only operations *) +(* performed are mem O(log n), and union O(n * log n?) *) +(* Perhaps a better implementation would be an array of bits or a map *) +(* from uri to booleans *) +module SetOfUris = Set.Make(OrderedUris);; + +let (@@) = SetOfUris.union;; + +let rec parameters_of te ty pparams= + let module S = SetOfUris in + let module C = Cic in + let rec aux = + function + C.Rel _ -> S.empty + | C.Var uri -> S.singleton uri + | C.Meta _ -> S.empty + | C.Sort _ -> S.empty + | C.Implicit -> S.empty + | C.Cast (te, ty) -> aux te @@ aux ty + | C.Prod (_, s, t) -> aux s @@ aux t + | C.Lambda (_, s, t) -> aux s @@ aux t + | C.Appl l -> List.fold_right (fun x i -> aux x @@ i) l S.empty + | C.Const (uri,_) -> + (* the parameters could be not exact but only possible *) + fix_params uri (Some (filename_of_uri uri)) ; + (* now the parameters are surely possible *) + (match CicCache.get_obj uri with + C.Definition (_, _, _, params) -> + List.fold_right + (fun (_,l) i -> + List.fold_right + (fun x i -> S.singleton x @@ i) l i + ) params S.empty + | C.Axiom (_, _, params) -> + List.fold_right + (fun (_,l) i -> + List.fold_right + (fun x i -> S.singleton x @@ i) l i + ) params S.empty + | C.CurrentProof _ -> S.empty (*CSC wrong *) + | _ -> raise WrongUriToConstant + ) + | C.Abst _ -> S.empty + | C.MutInd (uri,_,_) -> + (match CicCache.get_obj uri with + C.InductiveDefinition (_, params, _) -> + List.fold_right + (fun (_,l) i -> + List.fold_right + (fun x i -> S.singleton x @@ i) l i + ) params S.empty + | _ -> raise WrongUriToInductiveDefinition + ) + | C.MutConstruct (uri,_,_,_) -> + (match CicCache.get_obj uri with + C.InductiveDefinition (_, params, _) -> + List.fold_right + (fun (_,l) i -> + List.fold_right + (fun x i -> S.singleton x @@ i) l i + ) params S.empty + | _ -> raise WrongUriToInductiveDefinition + ) + | C.MutCase (uri,_,_,outtype,term,patterns) -> + (*CSC cosa basta? Ci vuole anche uri? *) + (match CicCache.get_obj uri with + C.InductiveDefinition (_, params, _) -> + List.fold_right + (fun (_,l) i -> + List.fold_right + (fun x i -> S.singleton x @@ i) l i + ) params S.empty + | _ -> raise WrongUriToInductiveDefinition + ) @@ aux outtype @@ aux term @@ + List.fold_right (fun x i -> aux x @@ i) patterns S.empty + | C.Fix (_,fl) -> + List.fold_right + (fun (_,_,ty,bo) i -> aux ty @@ aux bo @@ i) + fl S.empty + | C.CoFix (_,fl) -> + List.fold_right + (fun (_,ty,bo) i -> aux ty @@ aux bo @@ i) + fl S.empty + in + let actual_params = aux te @@ aux ty in + (* sort_actual_params wants in input the ordered list of possible params *) + let rec sort_actual_params2 = + function + [] -> [] + | he::tl when S.mem he actual_params -> he::(sort_actual_params2 tl) + | _::tl -> sort_actual_params2 tl + in + let rec sort_actual_params = + function + [] -> [] + | (n,l)::tl -> (n, sort_actual_params2 l)::(sort_actual_params tl) + in + sort_actual_params pparams + +and fix_params uri filename = + let module C = Cic in + let (ann, _, deann) = CicCache.get_annobj uri in + match ann, deann with + (C.ADefinition (xid, ann, id, te, ty, C.Possible pparams), + C.Definition (id', te', ty', _)) -> + (* let's freeze the object to avoid circular dependencies *) + CicCache.change_obj uri None ; + let real_params = parameters_of te' ty' pparams in + let fixed = + C.ADefinition (xid,ann,id,te,ty,C.Actual real_params) + in + Xml.pp (Cic2Xml.pp fixed uri) filename ; + (* unfreeze and fix the object *) + CicCache.change_obj uri + (Some (C.Definition (id', te', ty', real_params))) + | _ -> () +;; diff --git a/helm/interface/cicParser.ml b/helm/interface/cicParser.ml new file mode 100644 index 000000000..ec8c5efb8 --- /dev/null +++ b/helm/interface/cicParser.ml @@ -0,0 +1,69 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This is the main (top level) module of a parser for cic objects from xml *) +(* files to the internal representation. It uses the modules cicParser2 *) +(* (objects level) and cicParser3 (terms level) *) +(* *) +(******************************************************************************) + +exception Warnings;; + +class warner = + object + method warn w = + print_endline ("WARNING: " ^ w) ; + (raise Warnings : unit) + end +;; + +exception EmptyUri;; + +(* given an uri u it returns the list of tokens of the base uri of u *) +(* e.g.: token_of_uri "cic:/a/b/c/d.xml" returns ["a" ; "b" ; "c"] *) +let tokens_of_uri uri = + let uri' = UriManager.string_of_uri uri in + let rec chop_list = + function + [] -> raise EmptyUri + | he::[fn] -> [he] + | he::tl -> he::(chop_list tl) + in + let trimmed_uri = Str.replace_first (Str.regexp "cic:") "" uri' in + let list_of_tokens = Str.split (Str.regexp "/") trimmed_uri in + chop_list list_of_tokens +;; + +(* given the filename of an xml file of a cic object it returns its internal *) +(* representation. process_annotations is true if the annotations do really *) +(* matter *) +let term_of_xml filename uri process_annotations = + let module Y = Pxp_yacc in + try + let d = + (* sets the current base uri to resolve relative URIs *) + CicParser3.current_sp := tokens_of_uri uri ; + CicParser3.current_uri := uri ; + CicParser3.process_annotations := process_annotations ; + CicParser3.ids_to_targets := + if process_annotations then Some (Hashtbl.create 500) else None ; + let config = {Y.default_config with Y.warner = new warner} in + Y.parse_document_entity config +(*PXP (Y.ExtID (Pxp_types.System filename, + new Pxp_reader.resolve_as_file ~url_of_id ())) +*) (PxpUriResolver.from_file filename) + CicParser3.domspec + in + let ids_to_targets = !CicParser3.ids_to_targets in + let res = (CicParser2.get_term d#root, ids_to_targets) in + CicParser3.ids_to_targets := None ; (* let's help the GC *) + res + with + e -> + print_endline (Pxp_types.string_of_exn e) ; + raise e +;; diff --git a/helm/interface/cicParser.mli b/helm/interface/cicParser.mli new file mode 100644 index 000000000..961a262fe --- /dev/null +++ b/helm/interface/cicParser.mli @@ -0,0 +1,19 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 22/03/2000 *) +(* *) +(* This is the main (top level) module of a parser for cic objects from xml *) +(* files to the internal representation. It uses the modules cicParser2 *) +(* (objects level) and cicParser3 (terms level) *) +(* *) +(******************************************************************************) + +(* given the filename of an xml file of a cic object and it's uri, it returns *) +(* its internal annotated representation. The boolean is set to true if the *) +(* annotations do really matter *) +val term_of_xml : + string -> UriManager.uri -> bool -> + Cic.annobj * (Cic.id, Cic.anntarget) Hashtbl.t option diff --git a/helm/interface/cicParser2.ml b/helm/interface/cicParser2.ml new file mode 100644 index 000000000..343e22b19 --- /dev/null +++ b/helm/interface/cicParser2.ml @@ -0,0 +1,250 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module is the objects level of a parser for cic objects from xml *) +(* files to the internal representation. It uses the module cicParser3 *) +(* cicParser3 (terms level) and it is used only through cicParser2 (top *) +(* level). *) +(* *) +(******************************************************************************) + +exception IllFormedXml of int;; +exception NotImplemented;; + +(* Utility functions that transform a Pxp attribute into something useful *) + +(* mk_absolute_uris "n1: v1 ... vn n2 : u1 ... un ...." *) +(* returns [(n1,[absolute_uri_for_v1 ; ... ; absolute_uri_for_vn]) ; (n2,...) *) +let mk_absolute_uris s = + let l = (Str.split (Str.regexp ":") s) in + let absolute_of_relative n v = + let module P3 = CicParser3 in + let rec mkburi = + function + (0,_) -> "/" + | (n,he::tl) when n > 0 -> + "/" ^ he ^ mkburi (n - 1, tl) + | _ -> raise (IllFormedXml 12) + in + let m = List.length !P3.current_sp - (int_of_string n) in + let buri = mkburi (m, !P3.current_sp) in + UriManager.uri_of_string ("cic:" ^ buri ^ v ^ ".var") + in + let rec absolutize = + function + [] -> [] + | [no ; vs] -> + let vars = (Str.split (Str.regexp " ") vs) in + [(int_of_string no, List.map (absolute_of_relative no) vars)] + | no::vs::tl -> + let vars = (Str.split (Str.regexp " ") vs) in + let rec add_prefix = + function + [no2] -> ([], no2) + | he::tl -> + let (pvars, no2) = add_prefix tl in + ((absolute_of_relative no he)::pvars, no2) + | _ -> raise (IllFormedXml 11) + in + let (pvars, no2) = add_prefix vars in + (int_of_string no, pvars)::(absolutize (no2::tl)) + | _ -> raise (IllFormedXml 10) + in + (* last parameter must be applied first *) + absolutize l +;; + +let option_uri_list_of_attr a1 a2 = + let module T = Pxp_types in + let parameters = + match a1 with + T.Value s -> mk_absolute_uris s + | _ -> raise (IllFormedXml 0) + in + match a2 with + T.Value "POSSIBLE" -> Cic.Possible parameters + | T.Implied_value -> Cic.Actual parameters + | _ -> raise (IllFormedXml 0) +;; + +let uri_list_of_attr a = + let module T = Pxp_types in + match a with + T.Value s -> mk_absolute_uris s + | _ -> raise (IllFormedXml 0) +;; + +let string_of_attr a = + let module T = Pxp_types in + match a with + T.Value s -> s + | _ -> raise (IllFormedXml 0) +;; + +let int_of_attr a = + int_of_string (string_of_attr a) +;; + +let bool_of_attr a = + bool_of_string (string_of_attr a) +;; + +(* Other utility functions *) + +let get_content n = + match n#sub_nodes with + [ t ] -> t + | _ -> raise (IllFormedXml 1) +;; + +let register_id id node = + if !CicParser3.process_annotations then + match !CicParser3.ids_to_targets with + None -> assert false + | Some ids_to_targets -> + Hashtbl.add ids_to_targets id (Cic.Object node) +;; + +(* Functions that, given the list of sons of a node of the cic dom (objects *) +(* level), retrieve the internal representation associated to the node. *) +(* Everytime a cic term subtree is found, it is translated to the internal *) +(* representation using the method to_cic_term defined in cicParser3. *) +(* Each function raise IllFormedXml if something goes wrong, but this should *) +(* be impossible due to the presence of the dtd *) +(* The functions should really be obvious looking at their name and the cic *) +(* dtd *) + +(* called when a CurrentProof is found *) +let get_conjs_value_type l = + let rec rget (c, v, t) l = + let module D = Pxp_document in + match l with + [] -> (c, v, t) + | conj::tl when conj#node_type = D.T_element "Conjecture" -> + let no = int_of_attr (conj#attribute "no") + and typ = (get_content conj)#extension#to_cic_term in + rget ((no, typ)::c, v, t) tl + | value::tl when value#node_type = D.T_element "body" -> + let v' = (get_content value)#extension#to_cic_term in + (match v with + None -> rget (c, Some v', t) tl + | _ -> raise (IllFormedXml 2) + ) + | typ::tl when typ#node_type = D.T_element "type" -> + let t' = (get_content typ)#extension#to_cic_term in + (match t with + None -> rget (c, v, Some t') tl + | _ -> raise (IllFormedXml 3) + ) + | _ -> raise (IllFormedXml 4) + in + match rget ([], None, None) l with + (c, Some v, Some t) -> (c, v, t) + | _ -> raise (IllFormedXml 5) +;; + +(* used only by get_inductive_types; called one time for each inductive *) +(* definitions in a block of inductive definitions *) +let get_names_arity_constructors l = + let rec rget (a,c) l = + let module D = Pxp_document in + match l with + [] -> (a, c) + | arity::tl when arity#node_type = D.T_element "arity" -> + let a' = (get_content arity)#extension#to_cic_term in + rget (Some a',c) tl + | con::tl when con#node_type = D.T_element "Constructor" -> + let id = string_of_attr (con#attribute "name") + and ty = (get_content con)#extension#to_cic_term in + rget (a,(id,ty,ref None)::c) tl + | _ -> raise (IllFormedXml 9) + in + match rget (None,[]) l with + (Some a, c) -> (a, List.rev c) + | _ -> raise (IllFormedXml 8) +;; + +(* called when an InductiveDefinition is found *) +let rec get_inductive_types = + function + [] -> [] + | he::tl -> + let tyname = string_of_attr (he#attribute "name") + and inductive = bool_of_attr (he#attribute "inductive") + and (arity,cons) = + get_names_arity_constructors (he#sub_nodes) + in + (tyname,inductive,arity,cons)::(get_inductive_types tl) (*CSC 0 a caso *) +;; + +(* This is the main function and also the only one used directly from *) +(* cicParser. Given the root of the dom tree, it returns the internal *) +(* representation of the cic object described in the tree *) +(* It uses the previous functions and the to_cic_term method defined *) +(* in cicParser3 (used for subtrees that encode cic terms) *) +let rec get_term n = + let module D = Pxp_document in + let module C = Cic in + let ntype = n # node_type in + match ntype with + D.T_element "Definition" -> + let id = string_of_attr (n # attribute "name") + and params = + option_uri_list_of_attr (n#attribute "params") (n#attribute "paramMode") + and (value, typ) = + let sons = n#sub_nodes in + match sons with + [v ; t] when + v#node_type = D.T_element "body" && + t#node_type = D.T_element "type" -> + let v' = get_content v + and t' = get_content t in + (v'#extension#to_cic_term, t'#extension#to_cic_term) + | _ -> raise (IllFormedXml 6) + and xid = string_of_attr (n#attribute "id") in + let res = C.ADefinition (xid, ref None, id, value, typ, params) in + register_id xid res ; + res + | D.T_element "Axiom" -> + let id = string_of_attr (n # attribute "name") + and params = uri_list_of_attr (n # attribute "params") + and typ = + (get_content (get_content n))#extension#to_cic_term + and xid = string_of_attr (n#attribute "id") in + let res = C.AAxiom (xid, ref None, id, typ, params) in + register_id xid res ; + res + | D.T_element "CurrentProof" -> + let name = string_of_attr (n#attribute "name") + and xid = string_of_attr (n#attribute "id") in + let sons = n#sub_nodes in + let (conjs, value, typ) = get_conjs_value_type sons in + let res = C.ACurrentProof (xid, ref None, name, conjs, value, typ) in + register_id xid res ; + res + | D.T_element "InductiveDefinition" -> + let sons = n#sub_nodes + and xid = string_of_attr (n#attribute "id") in + let inductiveTypes = get_inductive_types sons + and params = uri_list_of_attr (n#attribute "params") + and nparams = int_of_attr (n#attribute "noParams") in + let res = + C.AInductiveDefinition (xid, ref None, inductiveTypes, params, nparams) + in + register_id xid res ; + res + | D.T_element "Variable" -> + let name = string_of_attr (n#attribute "name") + and xid = string_of_attr (n#attribute "id") in + let typ = (get_content (get_content n))#extension#to_cic_term in + let res = C.AVariable (xid,ref None,name,typ) in + register_id xid res ; + res + | D.T_element _ + | D.T_data -> + raise (IllFormedXml 7) +;; diff --git a/helm/interface/cicParser2.mli b/helm/interface/cicParser2.mli new file mode 100644 index 000000000..50a551faf --- /dev/null +++ b/helm/interface/cicParser2.mli @@ -0,0 +1,32 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module is the objects level of a parser for cic objects from xml *) +(* files to the internal representation. It uses the module cicParser3 *) +(* cicParser3 (terms level) and it is used only through cicParser2 (top *) +(* level). *) +(* *) +(******************************************************************************) + +exception IllFormedXml of int +exception NotImplemented + +(* This is the main function and also the only one used directly from *) +(* cicParser. Given the root of the dom tree, it returns the internal *) +(* representation of the cic object described in the tree *) +(* It uses the previous functions and the to_cic_term method defined *) +(* in cicParser3 (used for subtrees that encode cic terms) *) +val get_term : + < attribute : string -> Pxp_types.att_value; + node_type : Pxp_document.node_type; + sub_nodes : < attribute : string -> Pxp_types.att_value; + node_type : Pxp_document.node_type; + sub_nodes : CicParser3.cic_term Pxp_document.node list; + .. > + list; + .. > -> + Cic.annobj diff --git a/helm/interface/cicParser3.ml b/helm/interface/cicParser3.ml new file mode 100644 index 000000000..d0c31b0f0 --- /dev/null +++ b/helm/interface/cicParser3.ml @@ -0,0 +1,515 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module is the terms level of a parser for cic objects from xml *) +(* files to the internal representation. It is used by the module cicParser2 *) +(* (objects level). It defines an extension of the standard dom using the *) +(* object-oriented extension machinery of markup: an object with a method *) +(* to_cic_term that returns the internal representation of the subtree is *) +(* added to each node of the dom tree *) +(* *) +(******************************************************************************) + +exception IllFormedXml of int;; + +(* The hashtable from the current identifiers to the object or the terms *) +let ids_to_targets = ref None;; + +(* The list of tokens of the current section path. *) +(* Used to resolve relative URIs *) +let current_sp = ref [];; + +(* The uri of the object been parsed *) +let current_uri = ref (UriManager.uri_of_string "cic:/.xml");; + +(* True if annotation really matter *) +let process_annotations = ref false;; + +(* Utility functions to map a markup attribute to something useful *) + +let cic_attr_of_xml_attr = + function + Pxp_types.Value s -> Cic.Name s + | Pxp_types.Implied_value -> Cic.Anonimous + | _ -> raise (IllFormedXml 1) + +let cic_sort_of_xml_attr = + function + Pxp_types.Value "Prop" -> Cic.Prop + | Pxp_types.Value "Set" -> Cic.Set + | Pxp_types.Value "Type" -> Cic.Type + | _ -> raise (IllFormedXml 2) + +let int_of_xml_attr = + function + Pxp_types.Value n -> int_of_string n + | _ -> raise (IllFormedXml 3) + +let uri_of_xml_attr = + function + Pxp_types.Value s -> UriManager.uri_of_string s + | _ -> raise (IllFormedXml 4) + +let string_of_xml_attr = + function + Pxp_types.Value s -> s + | _ -> raise (IllFormedXml 5) + +let binder_of_xml_attr = + function + Pxp_types.Value s -> if !process_annotations then Some s else None + | _ -> raise (IllFormedXml 17) +;; + +let register_id id node = + if !process_annotations then + match !ids_to_targets with + None -> assert false + | Some ids_to_targets -> + Hashtbl.add ids_to_targets id (Cic.Term node) +;; + +(* the "interface" of the class linked to each node of the dom tree *) + +class virtual cic_term = + object (self) + + (* fields and methods ever required by markup *) + val mutable node = (None : cic_term Pxp_document.node option) + + method clone = {< >} + method node = + match node with + None -> + assert false + | Some n -> n + method set_node n = + node <- Some n + + (* a method that returns the internal representation of the tree (term) *) + (* rooted in this node *) + method virtual to_cic_term : Cic.annterm + end +;; + +(* the class of the objects linked to nodes that are not roots of cic terms *) +class eltype_not_of_cic = + object (self) + + inherit cic_term + + method to_cic_term = raise (IllFormedXml 6) + end +;; + +(* the class of the objects linked to nodes whose content is a cic term *) +(* (syntactic sugar xml entities) e.g. ... *) +class eltype_transparent = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + match n#sub_nodes with + [ t ] -> t#extension#to_cic_term + | _ -> raise (IllFormedXml 7) + end +;; + +(* A class for each cic node type *) + +class eltype_fix = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let nofun = int_of_xml_attr (n#attribute "noFun") + and id = string_of_xml_attr (n#attribute "id") + and functions = + let sons = n#sub_nodes in + List.map + (function + f when f#node_type = Pxp_document.T_element "FixFunction" -> + let name = string_of_xml_attr (f#attribute "name") + and recindex = int_of_xml_attr (f#attribute "recIndex") + and (ty, body) = + match f#sub_nodes with + [t ; b] when + t#node_type = Pxp_document.T_element "type" && + b#node_type = Pxp_document.T_element "body" -> + (t#extension#to_cic_term, b#extension#to_cic_term) + | _ -> raise (IllFormedXml 14) + in + (name, recindex, ty, body) + | _ -> raise (IllFormedXml 13) + ) sons + in + let res = Cic.AFix (id, ref None, nofun, functions) in + register_id id res ; + res + end +;; + +class eltype_cofix = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let nofun = int_of_xml_attr (n#attribute "noFun") + and id = string_of_xml_attr (n#attribute "id") + and functions = + let sons = n#sub_nodes in + List.map + (function + f when f#node_type = Pxp_document.T_element "CofixFunction" -> + let name = string_of_xml_attr (f#attribute "name") + and (ty, body) = + match f#sub_nodes with + [t ; b] when + t#node_type = Pxp_document.T_element "type" && + b#node_type = Pxp_document.T_element "body" -> + (t#extension#to_cic_term, b#extension#to_cic_term) + | _ -> raise (IllFormedXml 16) + in + (name, ty, body) + | _ -> raise (IllFormedXml 15) + ) sons + in + let res = Cic.ACoFix (id, ref None, nofun, functions) in + register_id id res ; + res + end +;; + +class eltype_implicit = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let id = string_of_xml_attr (n#attribute "id") in + let res = Cic.AImplicit (id, ref None) in + register_id id res ; + res + end +;; + +class eltype_rel = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let value = int_of_xml_attr (n#attribute "value") + and binder = binder_of_xml_attr (n#attribute "binder") + and id = string_of_xml_attr (n#attribute "id") in + let res = Cic.ARel (id,ref None,value,binder) in + register_id id res ; + res + end +;; + +class eltype_meta = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let value = int_of_xml_attr (n#attribute "no") + and id = string_of_xml_attr (n#attribute "id") in + let res = Cic.AMeta (id,ref None,value) in + register_id id res ; + res + end +;; + +class eltype_var = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let name = string_of_xml_attr (n#attribute "relUri") + and xid = string_of_xml_attr (n#attribute "id") in + match Str.split (Str.regexp ",") name with + [index; id] -> + let get_prefix n = + let rec aux = + function + (0,_) -> "/" + | (n,he::tl) when n > 0 -> "/" ^ he ^ aux (n - 1, tl) + | _ -> raise (IllFormedXml 19) + in + aux (List.length !current_sp - n,!current_sp) + in + let res = + Cic.AVar + (xid,ref None, + (UriManager.uri_of_string + ("cic:" ^ get_prefix (int_of_string index) ^ id ^ ".var")) + ) + in + register_id id res ; + res + | _ -> raise (IllFormedXml 18) + end +;; + +class eltype_apply = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let children = n#sub_nodes + and id = string_of_xml_attr (n#attribute "id") in + if List.length children < 2 then raise (IllFormedXml 8) + else + let res = + Cic.AAppl + (id,ref None,List.map (fun x -> x#extension#to_cic_term) children) + in + register_id id res ; + res + end +;; + +class eltype_cast = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let sons = n#sub_nodes + and id = string_of_xml_attr (n#attribute "id") in + match sons with + [te ; ty] when + te#node_type = Pxp_document.T_element "term" && + ty#node_type = Pxp_document.T_element "type" -> + let term = te#extension#to_cic_term + and typ = ty#extension#to_cic_term in + let res = Cic.ACast (id,ref None,term,typ) in + register_id id res ; + res + | _ -> raise (IllFormedXml 9) + end +;; + +class eltype_sort = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let sort = cic_sort_of_xml_attr (n#attribute "value") + and id = string_of_xml_attr (n#attribute "id") in + let res = Cic.ASort (id,ref None,sort) in + register_id id res ; + res + end +;; + +class eltype_abst = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let value = uri_of_xml_attr (n#attribute "uri") + and id = string_of_xml_attr (n#attribute "id") in + let res = Cic.AAbst (id,ref None,value) in + register_id id res ; + res + end +;; + +class eltype_const = + object (self) + + inherit cic_term + + method to_cic_term = + let module U = UriManager in + let n = self#node in + let value = uri_of_xml_attr (n#attribute "uri") + and id = string_of_xml_attr (n#attribute "id") in + let res = + Cic.AConst (id,ref None,value, U.relative_depth !current_uri value 0) + in + register_id id res ; + res + end +;; + +class eltype_mutind = + object (self) + + inherit cic_term + + method to_cic_term = + let module U = UriManager in + let n = self#node in + let name = uri_of_xml_attr (n#attribute "uri") + and noType = int_of_xml_attr (n#attribute "noType") + and id = string_of_xml_attr (n#attribute "id") in + let res = + Cic.AMutInd + (id,ref None,name, U.relative_depth !current_uri name 0, noType) + in + register_id id res ; + res + end +;; + +class eltype_mutconstruct = + object (self) + + inherit cic_term + + method to_cic_term = + let module U = UriManager in + let n = self#node in + let name = uri_of_xml_attr (n#attribute "uri") + and noType = int_of_xml_attr (n#attribute "noType") + and noConstr = int_of_xml_attr (n#attribute "noConstr") + and id = string_of_xml_attr (n#attribute "id") in + let res = + Cic.AMutConstruct + (id, ref None, name, U.relative_depth !current_uri name 0, + noType, noConstr) + in + register_id id res ; + res + end +;; + +class eltype_prod = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let sons = n#sub_nodes + and id = string_of_xml_attr (n#attribute "id") in + match sons with + [s ; t] when + s#node_type = Pxp_document.T_element "source" && + t#node_type = Pxp_document.T_element "target" -> + let name = cic_attr_of_xml_attr (t#attribute "binder") + and source = s#extension#to_cic_term + and target = t#extension#to_cic_term in + let res = Cic.AProd (id,ref None,name,source,target) in + register_id id res ; + res + | _ -> raise (IllFormedXml 10) + end +;; + +class eltype_mutcase = + object (self) + + inherit cic_term + + method to_cic_term = + let module U = UriManager in + let n = self#node in + let sons = n#sub_nodes + and id = string_of_xml_attr (n#attribute "id") in + match sons with + ty::te::patterns when + ty#node_type = Pxp_document.T_element "patternsType" && + te#node_type = Pxp_document.T_element "inductiveTerm" -> + let ci = uri_of_xml_attr (n#attribute "uriType") + and typeno = int_of_xml_attr (n#attribute "noType") + and inductiveType = ty#extension#to_cic_term + and inductiveTerm = te#extension#to_cic_term + and lpattern= List.map (fun x -> x#extension#to_cic_term) patterns + in + let res = + Cic.AMutCase (id,ref None,ci,U.relative_depth !current_uri ci 0, + typeno,inductiveType,inductiveTerm,lpattern) + in + register_id id res ; + res + | _ -> raise (IllFormedXml 11) + end +;; + +class eltype_lambda = + object (self) + + inherit cic_term + + method to_cic_term = + let n = self#node in + let sons = n#sub_nodes + and id = string_of_xml_attr (n#attribute "id") in + match sons with + [s ; t] when + s#node_type = Pxp_document.T_element "source" && + t#node_type = Pxp_document.T_element "target" -> + let name = cic_attr_of_xml_attr (t#attribute "binder") + and source = s#extension#to_cic_term + and target = t#extension#to_cic_term in + let res = Cic.ALambda (id,ref None,name,source,target) in + register_id id res ; + res + | _ -> raise (IllFormedXml 12) + end +;; + +(* The definition of domspec, an hashtable that maps each node type to the *) +(* object that must be linked to it. Used by markup. *) + +let domspec = + let module D = Pxp_document in + D.make_spec_from_alist + ~data_exemplar: (new D.data_impl (new eltype_not_of_cic)) + ~default_element_exemplar: (new D.element_impl (new eltype_not_of_cic)) + ~element_alist: + [ "REL", (new D.element_impl (new eltype_rel)) ; + "VAR", (new D.element_impl (new eltype_var)) ; + "META", (new D.element_impl (new eltype_meta)) ; + "SORT", (new D.element_impl (new eltype_sort)) ; + "IMPLICIT", (new D.element_impl (new eltype_implicit)) ; + "CAST", (new D.element_impl (new eltype_cast)) ; + "PROD", (new D.element_impl (new eltype_prod)) ; + "LAMBDA", (new D.element_impl (new eltype_lambda)) ; + "APPLY", (new D.element_impl (new eltype_apply)) ; + "CONST", (new D.element_impl (new eltype_const)) ; + "ABST", (new D.element_impl (new eltype_abst)) ; + "MUTIND", (new D.element_impl (new eltype_mutind)) ; + "MUTCONSTRUCT", (new D.element_impl (new eltype_mutconstruct)) ; + "MUTCASE", (new D.element_impl (new eltype_mutcase)) ; + "FIX", (new D.element_impl (new eltype_fix)) ; + "COFIX", (new D.element_impl (new eltype_cofix)) ; + "arity", (new D.element_impl (new eltype_transparent)) ; + "term", (new D.element_impl (new eltype_transparent)) ; + "type", (new D.element_impl (new eltype_transparent)) ; + "body", (new D.element_impl (new eltype_transparent)) ; + "source", (new D.element_impl (new eltype_transparent)) ; + "target", (new D.element_impl (new eltype_transparent)) ; + "patternsType", (new D.element_impl (new eltype_transparent)) ; + "inductiveTerm", (new D.element_impl (new eltype_transparent)) ; + "pattern", (new D.element_impl (new eltype_transparent)) + ] + () +;; diff --git a/helm/interface/cicParser3.mli b/helm/interface/cicParser3.mli new file mode 100644 index 000000000..dd71ab6ea --- /dev/null +++ b/helm/interface/cicParser3.mli @@ -0,0 +1,42 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module is the terms level of a parser for cic objects from xml *) +(* files to the internal representation. It is used by the module cicParser2 *) +(* (objects level). It defines an extension of the standard dom using the *) +(* object-oriented extension machinery of markup: an object with a method *) +(* to_cic_term that returns the internal representation of the subtree is *) +(* added to each node of the dom tree *) +(* *) +(******************************************************************************) + +exception IllFormedXml of int + +val ids_to_targets : (Cic.id, Cic.anntarget) Hashtbl.t option ref +val current_sp : string list ref +val current_uri : UriManager.uri ref +val process_annotations : bool ref + +(* the "interface" of the class linked to each node of the dom tree *) +class virtual cic_term : + object ('a) + + (* fields and methods ever required by markup *) + val mutable node : cic_term Pxp_document.node option + method clone : 'a + method node : cic_term Pxp_document.node + method set_node : cic_term Pxp_document.node -> unit + + (* a method that returns the internal representation of the tree (term) *) + (* rooted in this node *) + method virtual to_cic_term : Cic.annterm + + end + +(* The definition of domspec, an hashtable that maps each node type to the *) +(* object that must be linked to it. Used by markup. *) +val domspec : cic_term Pxp_document.spec diff --git a/helm/interface/cicPp.ml b/helm/interface/cicPp.ml new file mode 100644 index 000000000..932978664 --- /dev/null +++ b/helm/interface/cicPp.ml @@ -0,0 +1,183 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a very simple Coq-like pretty printer that, given *) +(* an object of cic (internal representation) returns a string describing the *) +(* object in a syntax similar to that of coq *) +(* *) +(******************************************************************************) + +exception CicPpInternalError;; + +(* Utility functions *) + +let string_of_name = + function + Cic.Name s -> s + | Cic.Anonimous -> "_" +;; + +(* get_nth l n returns the nth element of the list l if it exists or raise *) +(* a CicPpInternalError if l has less than n elements or n < 1 *) +let rec get_nth l n = + match (n,l) with + (1, he::_) -> he + | (n, he::tail) when n > 1 -> get_nth tail (n-1) + | (_,_) -> raise CicPpInternalError +;; + +(* pp t l *) +(* pretty-prints a term t of cic in an environment l where l is a list of *) +(* identifier names used to resolve DeBrujin indexes. The head of l is the *) +(* name associated to the greatest DeBrujin index in t *) +let rec pp t l = + let module C = Cic in + match t with + C.Rel n -> + (match get_nth l n with + C.Name s -> s + | _ -> raise CicPpInternalError + ) + | C.Var uri -> UriManager.name_of_uri uri + | C.Meta n -> "?" ^ (string_of_int n) + | C.Sort s -> + (match s with + C.Prop -> "Prop" + | C.Set -> "Set" + | C.Type -> "Type" + ) + | C.Implicit -> "?" + | C.Prod (b,s,t) -> + (match b with + C.Name n -> "(" ^ n ^ ":" ^ pp s l ^ ")" ^ pp t (b::l) + | C.Anonimous -> "(" ^ pp s l ^ "->" ^ pp t (b::l) ^ ")" + ) + | C.Cast (v,t) -> pp v l + | C.Lambda (b,s,t) -> + "[" ^ string_of_name b ^ ":" ^ pp s l ^ "]" ^ pp t (b::l) + | C.Appl li -> + "(" ^ + (List.fold_right + (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i) + li "" + ) ^ ")" + | C.Const (uri,_) -> UriManager.name_of_uri uri + | C.Abst uri -> UriManager.name_of_uri uri + | C.MutInd (uri,_,n) -> + (match CicCache.get_obj uri with + C.InductiveDefinition (dl,_,_) -> + let (name,_,_,_) = get_nth dl (n+1) in + name + | _ -> raise CicPpInternalError + ) + | C.MutConstruct (uri,_,n1,n2) -> + (match CicCache.get_obj uri with + C.InductiveDefinition (dl,_,_) -> + let (_,_,_,cons) = get_nth dl (n1+1) in + let (id,_,_) = get_nth cons n2 in + id + | _ -> raise CicPpInternalError + ) + | C.MutCase (uri,_,n1,ty,te,patterns) -> + let connames = + (match CicCache.get_obj uri with + C.InductiveDefinition (dl,_,_) -> + let (_,_,_,cons) = get_nth dl (n1+1) in + List.map (fun (id,_,_) -> id) cons + | _ -> raise CicPpInternalError + ) + in + "\n<" ^ pp ty l ^ ">Cases " ^ pp te l ^ " of " ^ + List.fold_right (fun (x,y) i -> "\n " ^ x ^ " => " ^ pp y l ^ i) + (List.combine connames patterns) "" ^ + "\nend" + | C.Fix (no, funs) -> + let snames = List.map (fun (name,_,_,_) -> name) funs in + let names = List.rev (List.map (function name -> C.Name name) snames) in + "\nFix " ^ get_nth snames (no + 1) ^ " {" ^ + List.fold_right + (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^ + " : " ^ pp ty l ^ " := \n" ^ + pp bo (names@l) ^ i) + funs "" ^ + "}\n" + | C.CoFix (no,funs) -> + let snames = List.map (fun (name,_,_) -> name) funs in + let names = List.rev (List.map (function name -> C.Name name) snames) in + "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^ + List.fold_right + (fun (name,ty,bo) i -> "\n" ^ name ^ + " : " ^ pp ty l ^ " := \n" ^ + pp bo (names@l) ^ i) + funs "" ^ + "}\n" +;; + +(* ppinductiveType (typename, inductive, arity, cons) names *) +(* pretty-prints a single inductive definition (typename, inductive, arity, *) +(* cons) where the cic terms in the inductive definition need to be *) +(* evaluated in the environment names that is the list of typenames of the *) +(* mutual inductive definitions defined in the block of mutual inductive *) +(* definitions to which this one belongs to *) +let ppinductiveType (typename, inductive, arity, cons) names = + (if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^ + (*CSC: bug found: was pp arity names ^ " =\n " ^*) + pp arity [] ^ " =\n " ^ + List.fold_right + (fun (id,ty,_) i -> id ^ " : " ^ pp ty names ^ + (if i = "" then "\n" else "\n | ") ^ i) + cons "" +;; + +(* ppobj obj returns a string with describing the cic object obj in a syntax *) +(* similar to the one used by Coq *) +let ppobj obj = + let module C = Cic in + let module U = UriManager in + match obj with + C.Definition (id, t1, t2, params) -> + "Definition of " ^ id ^ + "(" ^ + List.fold_right + (fun (_,x) i -> + List.fold_right + (fun x i -> + U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i' + ) x "" ^ match i with "" -> "" | i' -> " " ^ i' + ) params "" ^ ")" ^ + ":\n" ^ pp t1 [] ^ " : " ^ pp t2 [] + | C.Axiom (id, ty, params) -> + "Axiom " ^ id ^ "(" ^ + List.fold_right + (fun (_,x) i -> + List.fold_right + (fun x i -> + U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i' + ) x "" ^ match i with "" -> "" | i' -> " " ^ i' + ) params "" ^ + "):\n" ^ pp ty [] + | C.Variable (name, ty) -> + "Variable " ^ name ^ ":\n" ^ pp ty [] + | C.CurrentProof (name, conjectures, value, ty) -> + "Current Proof:\n" ^ + List.fold_right + (fun (n, t) i -> "?" ^ (string_of_int n) ^ ": " ^ pp t [] ^ "\n" ^ i) + conjectures "" ^ + "\n" ^ pp value [] ^ " : " ^ pp ty [] + | C.InductiveDefinition (l, params, nparams) -> + "Parameters = " ^ + List.fold_right + (fun (_,x) i -> + List.fold_right + (fun x i -> + U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i' + ) x "" ^ match i with "" -> "" | i' -> " " ^ i' + ) params "" ^ "\n" ^ + "NParams = " ^ string_of_int nparams ^ "\n" ^ + let names = List.rev (List.map (fun (n,_,_,_) -> C.Name n) l) in + List.fold_right (fun x i -> ppinductiveType x names ^ i) l "" +;; diff --git a/helm/interface/cicPp.mli b/helm/interface/cicPp.mli new file mode 100644 index 000000000..166079936 --- /dev/null +++ b/helm/interface/cicPp.mli @@ -0,0 +1,16 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a very simple Coq-like pretty printer that, given *) +(* an object of cic (internal representation) returns a string describing the *) +(* object in a syntax similar to that of coq *) +(* *) +(******************************************************************************) + +(* ppobj obj returns a string with describing the cic object obj in a syntax *) +(* similar to the one used by Coq *) +val ppobj : Cic.obj -> string diff --git a/helm/interface/cicReduction.ml b/helm/interface/cicReduction.ml new file mode 100644 index 000000000..6497cd378 --- /dev/null +++ b/helm/interface/cicReduction.ml @@ -0,0 +1,253 @@ +exception CicReductionInternalError;; +exception WrongUriToInductiveDefinition;; + +let fdebug = ref 1;; +let debug t env s = + let rec debug_aux t i = + let module C = Cic in + let module U = UriManager in + CicPp.ppobj (C.Variable ("DEBUG", + C.Prod (C.Name "-9", C.Const (U.uri_of_string "cic:/dummy-9",0), + C.Prod (C.Name "-8", C.Const (U.uri_of_string "cic:/dummy-8",0), + C.Prod (C.Name "-7", C.Const (U.uri_of_string "cic:/dummy-7",0), + C.Prod (C.Name "-6", C.Const (U.uri_of_string "cic:/dummy-6",0), + C.Prod (C.Name "-5", C.Const (U.uri_of_string "cic:/dummy-5",0), + C.Prod (C.Name "-4", C.Const (U.uri_of_string "cic:/dummy-4",0), + C.Prod (C.Name "-3", C.Const (U.uri_of_string "cic:/dummy-3",0), + C.Prod (C.Name "-2", C.Const (U.uri_of_string "cic:/dummy-2",0), + C.Prod (C.Name "-1", C.Const (U.uri_of_string "cic:/dummy-1",0), + t + ) + ) + ) + ) + ) + ) + ) + ) + ) + )) ^ "\n" ^ i + in + if !fdebug = 0 then + begin + print_endline (s ^ "\n" ^ List.fold_right debug_aux (t::env) "") ; + flush stdout + end +;; + +exception Impossible of int;; +exception ReferenceToDefinition;; +exception ReferenceToAxiom;; +exception ReferenceToVariable;; +exception ReferenceToCurrentProof;; +exception ReferenceToInductiveDefinition;; + +(* takes a well-typed term *) +let whd = + let rec whdaux l = + let module C = Cic in + let module S = CicSubstitution in + function + C.Rel _ as t -> if l = [] then t else C.Appl (t::l) + | C.Var _ as t -> if l = [] then t else C.Appl (t::l) + | C.Meta _ as t -> if l = [] then t else C.Appl (t::l) + | C.Sort _ as t -> t (* l should be empty *) + | C.Implicit as t -> t + | C.Cast (te,ty) -> whdaux l te (*CSC E' GIUSTO BUTTARE IL CAST? *) + | C.Prod _ as t -> t (* l should be empty *) + | C.Lambda (name,s,t) as t' -> + (match l with + [] -> t' + | he::tl -> whdaux tl (S.subst he t) + (* when name is Anonimous the substitution should be superfluous *) + ) + | C.Appl (he::tl) -> whdaux (tl@l) he + | C.Appl [] -> raise (Impossible 1) + | C.Const (uri,cookingsno) as t -> + (match CicCache.get_cooked_obj uri cookingsno with + C.Definition (_,body,_,_) -> whdaux l body + | C.Axiom _ -> if l = [] then t else C.Appl (t::l) + (*CSC: Prossima riga sbagliata: Var punta alle variabili, non Const *) + | C.Variable _ -> if l = [] then t else C.Appl (t::l) + | C.CurrentProof (_,_,body,_) -> whdaux l body + | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition + ) + | C.Abst _ as t -> t (*CSC l should be empty ????? *) + | C.MutInd (uri,_,_) as t -> if l = [] then t else C.Appl (t::l) + | C.MutConstruct (uri,_,_,_) as t -> if l = [] then t else C.Appl (t::l) + | C.MutCase (mutind,cookingsno,i,_,term,pl) as t -> + let decofix = + function + C.CoFix (i,fl) as t -> + let (_,_,body) = List.nth fl i in + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) + fl + body + in + whdaux [] body' + | C.Appl (C.CoFix (i,fl) :: tl) -> + let (_,_,body) = List.nth fl i in + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) + fl + body + in + whdaux tl body' + | t -> t + in + (match decofix (whdaux [] term) with + C.MutConstruct (_,_,_,j) -> whdaux l (List.nth pl (j-1)) + | C.Appl (C.MutConstruct (_,_,_,j) :: tl) -> + let (arity, r, num_ingredients) = + match CicCache.get_obj mutind with + C.InductiveDefinition (tl,ingredients,r) -> + let (_,_,arity,_) = List.nth tl i + and num_ingredients = + List.fold_right + (fun (k,l) i -> + if k < cookingsno then i + List.length l else i + ) ingredients 0 + in + (arity,r,num_ingredients) + | _ -> raise WrongUriToInductiveDefinition + in + let ts = + let num_to_eat = r + num_ingredients in + let rec eat_first = + function + (0,l) -> l + | (n,he::tl) when n > 0 -> eat_first (n - 1, tl) + | _ -> raise (Impossible 5) + in + eat_first (num_to_eat,tl) + in + whdaux (ts@l) (List.nth pl (j-1)) + | C.Abst _| C.Cast _ | C.Implicit -> + raise (Impossible 2) (* we don't trust our whd ;-) *) + | _ -> t + ) + | C.Fix (i,fl) as t -> + let (_,recindex,_,body) = List.nth fl i in + let recparam = + try + Some (List.nth l recindex) + with + _ -> None + in + (match recparam with + Some recparam -> + (match whdaux [] recparam with + C.MutConstruct _ + | C.Appl ((C.MutConstruct _)::_) -> + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl))) + fl + body + in + (* Possible optimization: substituting whd recparam in l *) + whdaux l body' + | _ -> if l = [] then t else C.Appl (t::l) + ) + | None -> if l = [] then t else C.Appl (t::l) + ) + | C.CoFix (i,fl) as t -> + (*CSC vecchio codice + let (_,_,body) = List.nth fl i in + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) + fl + body + in + whdaux l body' + *) + if l = [] then t else C.Appl (t::l) + in + whdaux [] +;; + +(* t1, t2 must be well-typed *) +let are_convertible t1 t2 = + let module U = UriManager in + let rec aux t1 t2 = + debug t1 [t2] "PREWHD"; + (* this trivial euristic cuts down the total time of about five times ;-) *) + (* this because most of the time t1 and t2 are "sintactically" the same *) + if t1 = t2 then + true + else + begin + let module C = Cic in + let t1' = whd t1 + and t2' = whd t2 in + debug t1' [t2'] "POSTWHD"; + (*if !fdebug = 0 then ignore(Unix.system "read" );*) + match (t1',t2') with + (C.Rel n1, C.Rel n2) -> n1 = n2 + | (C.Var uri1, C.Var uri2) -> U.eq uri1 uri2 + | (C.Meta n1, C.Meta n2) -> n1 = n2 + | (C.Sort s1, C.Sort s2) -> true (*CSC da finire con gli universi *) + | (C.Prod (_,s1,t1), C.Prod(_,s2,t2)) -> + aux s1 s2 && aux t1 t2 + | (C.Lambda (_,s1,t1), C.Lambda(_,s2,t2)) -> + aux s1 s2 && aux t1 t2 + | (C.Appl l1, C.Appl l2) -> + (try + List.fold_right2 (fun x y b -> aux x y && b) l1 l2 true + with + Invalid_argument _ -> false + ) + | (C.Const (uri1,_), C.Const (uri2,_)) -> + (*CSC: questo commento e' chiaro o delirante? Io lo sto scrivendo *) + (*CSC: mentre sono delirante, quindi ... *) + (* WARNING: it is really important that the two cookingsno are not *) + (* checked for equality. This allows not to cook an object with no *) + (* ingredients only to update the cookingsno. E.g: if a term t has *) + (* a reference to a term t1 which does not depend on any variable *) + (* and t1 depends on a term t2 (that can't depend on any variable *) + (* because of t1), then t1 cooked at every level could be the same *) + (* as t1 cooked at level 0. Doing so, t2 will be extended in t *) + (* with cookingsno 0 and not 2. But this will not cause any trouble*) + (* if here we don't check that the two cookingsno are equal. *) + U.eq uri1 uri2 + | (C.MutInd (uri1,k1,i1), C.MutInd (uri2,k2,i2)) -> + (* WARNIG: see the previous warning *) + U.eq uri1 uri2 && i1 = i2 + | (C.MutConstruct (uri1,_,i1,j1), C.MutConstruct (uri2,_,i2,j2)) -> + (* WARNIG: see the previous warning *) + U.eq uri1 uri2 && i1 = i2 && j1 = j2 + | (C.MutCase (uri1,_,i1,outtype1,term1,pl1), + C.MutCase (uri2,_,i2,outtype2,term2,pl2)) -> + (* WARNIG: see the previous warning *) + (* aux outtype1 outtype2 should be true if aux pl1 pl2 *) + U.eq uri1 uri2 && i1 = i2 && aux outtype1 outtype2 && + aux term1 term2 && + List.fold_right2 (fun x y b -> b && aux x y) pl1 pl2 true + | (C.Fix (i1,fl1), C.Fix (i2,fl2)) -> + i1 = i2 && + List.fold_right2 + (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) b -> + b && recindex1 = recindex2 && aux ty1 ty2 && aux bo1 bo2) + fl1 fl2 true + | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) -> + i1 = i2 && + List.fold_right2 + (fun (_,ty1,bo1) (_,ty2,bo2) b -> + b && aux ty1 ty2 && aux bo1 bo2) + fl1 fl2 true + | (C.Abst _, _) | (_, C.Abst _) | (C.Cast _, _) | (_, C.Cast _) + | (C.Implicit, _) | (_, C.Implicit) -> + raise (Impossible 3) (* we don't trust our whd ;-) *) + | (_,_) -> false + end + in + aux t1 t2 +;; diff --git a/helm/interface/cicReduction.mli b/helm/interface/cicReduction.mli new file mode 100644 index 000000000..bcc91b011 --- /dev/null +++ b/helm/interface/cicReduction.mli @@ -0,0 +1,9 @@ +exception WrongUriToInductiveDefinition +exception ReferenceToDefinition +exception ReferenceToAxiom +exception ReferenceToVariable +exception ReferenceToCurrentProof +exception ReferenceToInductiveDefinition +val fdebug : int ref +val whd : Cic.term -> Cic.term +val are_convertible : Cic.term -> Cic.term -> bool diff --git a/helm/interface/cicSubstitution.ml b/helm/interface/cicSubstitution.ml new file mode 100644 index 000000000..e69a8a96a --- /dev/null +++ b/helm/interface/cicSubstitution.ml @@ -0,0 +1,115 @@ +let lift n = + let rec liftaux k = + let module C = Cic in + function + C.Rel m -> + if m < k then + C.Rel m + else + C.Rel (m + n) + | C.Var _ as t -> t + | C.Meta _ as t -> t + | C.Sort _ as t -> t + | C.Implicit as t -> t + | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty) + | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t) + | C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t) + | C.Appl l -> C.Appl (List.map (liftaux k) l) + | C.Const _ as t -> t + | C.Abst _ as t -> t + | C.MutInd _ as t -> t + | C.MutConstruct _ as t -> t + | C.MutCase (sp,cookingsno,i,outty,t,pl) -> + C.MutCase (sp, cookingsno, i, liftaux k outty, liftaux k t, + List.map (liftaux k) pl) + | C.Fix (i, fl) -> + let len = List.length fl in + let liftedfl = + List.map + (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (k+len) bo)) + fl + in + C.Fix (i, liftedfl) + | C.CoFix (i, fl) -> + let len = List.length fl in + let liftedfl = + List.map + (fun (name, ty, bo) -> (name, liftaux k ty, liftaux (k+len) bo)) + fl + in + C.CoFix (i, liftedfl) + in + liftaux 1 +;; + +let subst arg = + let rec substaux k = + let module C = Cic in + function + C.Rel n as t -> + (match n with + n when n = k -> lift (k - 1) arg + | n when n < k -> t + | _ -> C.Rel (n - 1) + ) + | C.Var _ as t -> t + | C.Meta _ as t -> t + | C.Sort _ as t -> t + | C.Implicit as t -> t + | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty) (*CSC ??? *) + | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t) + | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t) + | C.Appl l -> C.Appl (List.map (substaux k) l) + | C.Const _ as t -> t + | C.Abst _ as t -> t + | C.MutInd _ as t -> t + | C.MutConstruct _ as t -> t + | C.MutCase (sp,cookingsno,i,outt,t,pl) -> + C.MutCase (sp,cookingsno,i,substaux k outt, substaux k t, + List.map (substaux k) pl) + | C.Fix (i,fl) -> + let len = List.length fl in + let substitutedfl = + List.map + (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo)) + fl + in + C.Fix (i, substitutedfl) + | C.CoFix (i,fl) -> + let len = List.length fl in + let substitutedfl = + List.map + (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo)) + fl + in + C.CoFix (i, substitutedfl) + in + substaux 1 +;; + +let undebrujin_inductive_def uri = + function + Cic.InductiveDefinition (dl,params,n_ind_params) -> + let dl' = + List.map + (fun (name,inductive,arity,constructors) -> + let constructors' = + List.map + (fun (name,ty,r) -> + let ty' = + let counter = ref (List.length dl) in + List.fold_right + (fun _ -> + decr counter ; + subst (Cic.MutInd (uri,0,!counter)) + ) dl ty + in + (name,ty',r) + ) constructors + in + (name,inductive,arity,constructors') + ) dl + in + Cic.InductiveDefinition (dl', params, n_ind_params) + | obj -> obj +;; diff --git a/helm/interface/cicSubstitution.mli b/helm/interface/cicSubstitution.mli new file mode 100644 index 000000000..f83cf05e0 --- /dev/null +++ b/helm/interface/cicSubstitution.mli @@ -0,0 +1,3 @@ +val lift : int -> Cic.term -> Cic.term +val subst : Cic.term -> Cic.term -> Cic.term +val undebrujin_inductive_def : UriManager.uri -> Cic.obj -> Cic.obj diff --git a/helm/interface/cicTypeChecker.ml b/helm/interface/cicTypeChecker.ml new file mode 100644 index 000000000..63433937b --- /dev/null +++ b/helm/interface/cicTypeChecker.ml @@ -0,0 +1,1200 @@ +exception NotImplemented;; +exception Impossible;; +exception NotWellTyped of string;; +exception WrongUriToConstant of string;; +exception WrongUriToVariable of string;; +exception WrongUriToMutualInductiveDefinitions of string;; +exception ListTooShort;; +exception NotPositiveOccurrences of string;; +exception NotWellFormedTypeOfInductiveConstructor of string;; +exception WrongRequiredArgument of string;; + +let fdebug = ref 0;; +let debug t env = + let rec debug_aux t i = + let module C = Cic in + let module U = UriManager in + CicPp.ppobj (C.Variable ("DEBUG", + C.Prod (C.Name "-15", C.Const (U.uri_of_string "cic:/dummy-15",0), + C.Prod (C.Name "-14", C.Const (U.uri_of_string "cic:/dummy-14",0), + C.Prod (C.Name "-13", C.Const (U.uri_of_string "cic:/dummy-13",0), + C.Prod (C.Name "-12", C.Const (U.uri_of_string "cic:/dummy-12",0), + C.Prod (C.Name "-11", C.Const (U.uri_of_string "cic:/dummy-11",0), + C.Prod (C.Name "-10", C.Const (U.uri_of_string "cic:/dummy-10",0), + C.Prod (C.Name "-9", C.Const (U.uri_of_string "cic:/dummy-9",0), + C.Prod (C.Name "-8", C.Const (U.uri_of_string "cic:/dummy-8",0), + C.Prod (C.Name "-7", C.Const (U.uri_of_string "cic:/dummy-7",0), + C.Prod (C.Name "-6", C.Const (U.uri_of_string "cic:/dummy-6",0), + C.Prod (C.Name "-5", C.Const (U.uri_of_string "cic:/dummy-5",0), + C.Prod (C.Name "-4", C.Const (U.uri_of_string "cic:/dummy-4",0), + C.Prod (C.Name "-3", C.Const (U.uri_of_string "cic:/dummy-3",0), + C.Prod (C.Name "-2", C.Const (U.uri_of_string "cic:/dummy-2",0), + C.Prod (C.Name "-1", C.Const (U.uri_of_string "cic:/dummy-1",0), + t + ) + ) + ) + ) + ) + ) + ) + ) + ))))))) + )) ^ "\n" ^ i + in + if !fdebug = 0 then + raise (NotWellTyped ("\n" ^ List.fold_right debug_aux (t::env) "")) + (*print_endline ("\n" ^ List.fold_right debug_aux (t::env) "") ; flush stdout*) +;; + +let rec split l n = + match (l,n) with + (l,0) -> ([], l) + | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) + | (_,_) -> raise ListTooShort +;; + +exception CicCacheError;; + +let rec cooked_type_of_constant uri cookingsno = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let cobj = + match CicCache.is_type_checked uri cookingsno with + CicCache.CheckedObj cobj -> cobj + | CicCache.UncheckedObj uobj -> + (* let's typecheck the uncooked obj *) + (match uobj with + C.Definition (_,te,ty,_) -> + let _ = type_of ty in + if not (R.are_convertible (type_of te) ty) then + raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri))) + | C.Axiom (_,ty,_) -> + (* only to check that ty is well-typed *) + let _ = type_of ty in () + | C.CurrentProof (_,_,te,ty) -> + let _ = type_of ty in + if not (R.are_convertible (type_of te) ty) then + raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri))) + | _ -> raise (WrongUriToConstant (U.string_of_uri uri)) + ) ; + CicCache.set_type_checking_info uri ; + match CicCache.is_type_checked uri cookingsno with + CicCache.CheckedObj cobj -> cobj + | CicCache.UncheckedObj _ -> raise CicCacheError + in + match cobj with + C.Definition (_,_,ty,_) -> ty + | C.Axiom (_,ty,_) -> ty + | C.CurrentProof (_,_,_,ty) -> ty + | _ -> raise (WrongUriToConstant (U.string_of_uri uri)) + +and type_of_variable uri = + let module C = Cic in + let module R = CicReduction in + (* 0 because a variable is never cooked => no partial cooking at one level *) + match CicCache.is_type_checked uri 0 with + CicCache.CheckedObj (C.Variable (_,ty)) -> ty + | CicCache.UncheckedObj (C.Variable (_,ty)) -> + (* only to check that ty is well-typed *) + let _ = type_of ty in + CicCache.set_type_checking_info uri ; + ty + | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri)) + +and does_not_occur n nn te = + let module C = Cic in + (*CSC: whd sembra essere superflua perche' un caso in cui l'occorrenza *) + (*CSC: venga mangiata durante la whd sembra presentare problemi di *) + (*CSC: universi *) + match CicReduction.whd te with + C.Rel m when m > n && m <= nn -> false + | C.Rel _ + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit -> true + | C.Cast (te,ty) -> does_not_occur n nn te && does_not_occur n nn ty + | C.Prod (_,so,dest) -> + does_not_occur n nn so && does_not_occur (n + 1) (nn + 1) dest + | C.Lambda (_,so,dest) -> + does_not_occur n nn so && does_not_occur (n + 1) (nn + 1) dest + | C.Appl l -> + List.fold_right (fun x i -> i && does_not_occur n nn x) l true + | C.Const _ + | C.Abst _ + | C.MutInd _ + | C.MutConstruct _ -> true + | C.MutCase (_,_,_,out,te,pl) -> + does_not_occur n nn out && does_not_occur n nn te && + List.fold_right (fun x i -> i && does_not_occur n nn x) pl true + | C.Fix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len in + let nn_plus_len = nn + len in + List.fold_right + (fun (_,_,ty,bo) i -> + i && does_not_occur n_plus_len nn_plus_len ty && + does_not_occur n_plus_len nn_plus_len bo + ) fl true + | C.CoFix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len in + let nn_plus_len = nn + len in + List.fold_right + (fun (_,ty,bo) i -> + i && does_not_occur n_plus_len nn_plus_len ty && + does_not_occur n_plus_len nn_plus_len bo + ) fl true + +(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *) +(*CSC questa funzione e' simile alla are_all_occurrences_positive, ma fa *) +(*CSC dei controlli leggermente diversi. Viene invocata solamente dalla *) +(*CSC strictly_positive *) +(*CSC definizione (giusta???) tratta dalla mail di Hugo ;-) *) +and weakly_positive n nn uri te = + let module C = Cic in + (*CSC mettere in cicSubstitution *) + let rec subst_inductive_type_with_dummy_rel = + function + C.MutInd (uri',_,0) when UriManager.eq uri' uri -> + C.Rel 0 (* dummy rel *) + | C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri -> + C.Rel 0 (* dummy rel *) + | C.Cast (te,ty) -> subst_inductive_type_with_dummy_rel te + | C.Prod (name,so,ta) -> + C.Prod (name, subst_inductive_type_with_dummy_rel so, + subst_inductive_type_with_dummy_rel ta) + | C.Lambda (name,so,ta) -> + C.Lambda (name, subst_inductive_type_with_dummy_rel so, + subst_inductive_type_with_dummy_rel ta) + | C.Appl tl -> + C.Appl (List.map subst_inductive_type_with_dummy_rel tl) + | C.MutCase (uri,cookingsno,i,outtype,term,pl) -> + C.MutCase (uri,cookingsno,i, + subst_inductive_type_with_dummy_rel outtype, + subst_inductive_type_with_dummy_rel term, + List.map subst_inductive_type_with_dummy_rel pl) + | C.Fix (i,fl) -> + C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i, + subst_inductive_type_with_dummy_rel ty, + subst_inductive_type_with_dummy_rel bo)) fl) + | C.CoFix (i,fl) -> + C.CoFix (i,List.map (fun (name,ty,bo) -> (name, + subst_inductive_type_with_dummy_rel ty, + subst_inductive_type_with_dummy_rel bo)) fl) + | t -> t + in + match CicReduction.whd te with + C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri -> true + | C.MutInd (uri',_,0) when UriManager.eq uri' uri -> true + | C.Prod (C.Anonimous,source,dest) -> + strictly_positive n nn (subst_inductive_type_with_dummy_rel source) && + weakly_positive (n + 1) (nn + 1) uri dest + | C.Prod (name,source,dest) when does_not_occur 0 n dest -> + (* dummy abstraction, so we behave as in the anonimous case *) + strictly_positive n nn (subst_inductive_type_with_dummy_rel source) && + weakly_positive (n + 1) (nn + 1) uri dest + | C.Prod (_,source,dest) -> + does_not_occur n nn (subst_inductive_type_with_dummy_rel source) && + weakly_positive (n + 1) (nn + 1) uri dest + | _ -> raise (NotWellFormedTypeOfInductiveConstructor ("Guess where the error is ;-)")) + +(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *) +(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *) +and instantiate_parameters params c = + let module C = Cic in + match (c,params) with + (c,[]) -> c + | (C.Prod (_,_,ta), he::tl) -> + instantiate_parameters tl + (CicSubstitution.subst he ta) + | (C.Cast (te,_), _) -> instantiate_parameters params te + | (t,l) -> raise Impossible + +and strictly_positive n nn te = + let module C = Cic in + let module U = UriManager in + match CicReduction.whd te with + C.Rel _ -> true + | C.Cast (te,ty) -> + (*CSC: bisogna controllare ty????*) + strictly_positive n nn te + | C.Prod (_,so,ta) -> + does_not_occur n nn so && + strictly_positive (n+1) (nn+1) ta + | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> + List.fold_right (fun x i -> i && does_not_occur n nn x) tl true + | C.Appl ((C.MutInd (uri,_,i))::tl) -> + let (ok,paramsno,cl) = + match CicCache.get_obj uri with + C.InductiveDefinition (tl,_,paramsno) -> + let (_,_,_,cl) = List.nth tl i in + (List.length tl = 1, paramsno, cl) + | _ -> raise(WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) + in + let (params,arguments) = split tl paramsno in + let lifted_params = List.map (CicSubstitution.lift 1) params in + let cl' = + List.map (fun (_,te,_) -> instantiate_parameters lifted_params te) cl + in + ok && + List.fold_right + (fun x i -> i && does_not_occur n nn x) + arguments true && + (*CSC: MEGAPATCH3 (sara' quella giusta?)*) + List.fold_right + (fun x i -> + i && + weakly_positive (n+1) (nn+1) uri x + ) cl' true + | C.MutInd (uri,_,i) -> + (match CicCache.get_obj uri with + C.InductiveDefinition (tl,_,_) -> + List.length tl = 1 + | _ -> raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) + ) + | t -> does_not_occur n nn t + +(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *) +and are_all_occurrences_positive uri indparamsno i n nn te = + let module C = Cic in + match CicReduction.whd te with + C.Appl ((C.Rel m)::tl) when m = i -> + (*CSC: riscrivere fermandosi a 0 *) + (* let's check if the inductive type is applied at least to *) + (* indparamsno parameters *) + let last = + List.fold_left + (fun k x -> + if k = 0 then 0 + else + match CicReduction.whd x with + C.Rel m when m = n - (indparamsno - k) -> k - 1 + | _ -> raise (WrongRequiredArgument (UriManager.string_of_uri uri)) + ) indparamsno tl + in + if last = 0 then + List.fold_right (fun x i -> i && does_not_occur n nn x) tl true + else + raise (WrongRequiredArgument (UriManager.string_of_uri uri)) + | C.Rel m when m = i -> + if indparamsno = 0 then + true + else + raise (WrongRequiredArgument (UriManager.string_of_uri uri)) + | C.Prod (C.Anonimous,source,dest) -> + strictly_positive n nn source && + are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest + | C.Prod (name,source,dest) when does_not_occur 0 n dest -> + (* dummy abstraction, so we behave as in the anonimous case *) + strictly_positive n nn source && + are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest + | C.Prod (_,source,dest) -> + does_not_occur n nn source && + are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest + | _ -> raise (NotWellFormedTypeOfInductiveConstructor (UriManager.string_of_uri uri)) + +(*CSC: cambiare il nome, torna unit! *) +and cooked_mutual_inductive_defs uri = + let module U = UriManager in + function + Cic.InductiveDefinition (itl, _, indparamsno) -> + (* let's check if the arity of the inductive types are well *) + (* formed *) + List.iter (fun (_,_,x,_) -> let _ = type_of x in ()) itl ; + + (* let's check if the types of the inductive constructors *) + (* are well formed. *) + (* In order not to use type_of_aux we put the types of the *) + (* mutual inductive types at the head of the types of the *) + (* constructors using Prods *) + (*CSC: piccola??? inefficienza *) + let len = List.length itl in + let _ = + List.fold_right + (fun (_,_,_,cl) i -> + List.iter + (fun (name,te,r) -> + let augmented_term = + List.fold_right + (fun (name,_,ty,_) i -> Cic.Prod (Cic.Name name, ty, i)) + itl te + in + let _ = type_of augmented_term in + (* let's check also the positivity conditions *) + if not (are_all_occurrences_positive uri indparamsno i 0 len te) + then + raise (NotPositiveOccurrences (U.string_of_uri uri)) + else + match !r with + Some _ -> raise Impossible + | None -> r := Some (recursive_args 0 len te) + ) cl ; + (i + 1) + ) itl 1 + in + () + | _ -> + raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) + +and cooked_type_of_mutual_inductive_defs uri cookingsno i = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let cobj = + match CicCache.is_type_checked uri cookingsno with + CicCache.CheckedObj cobj -> cobj + | CicCache.UncheckedObj uobj -> + cooked_mutual_inductive_defs uri uobj ; + CicCache.set_type_checking_info uri ; + (match CicCache.is_type_checked uri cookingsno with + CicCache.CheckedObj cobj -> cobj + | CicCache.UncheckedObj _ -> raise CicCacheError + ) + in + match cobj with + C.InductiveDefinition (dl,_,_) -> + let (_,_,arity,_) = List.nth dl i in + arity + | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) + +and cooked_type_of_mutual_inductive_constr uri cookingsno i j = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let cobj = + match CicCache.is_type_checked uri cookingsno with + CicCache.CheckedObj cobj -> cobj + | CicCache.UncheckedObj uobj -> + cooked_mutual_inductive_defs uri uobj ; + CicCache.set_type_checking_info uri ; + (match CicCache.is_type_checked uri cookingsno with + CicCache.CheckedObj cobj -> cobj + | CicCache.UncheckedObj _ -> raise CicCacheError + ) + in + match cobj with + C.InductiveDefinition (dl,_,_) -> + let (_,_,_,cl) = List.nth dl i in + let (_,ty,_) = List.nth cl (j-1) in + ty + | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) + +and recursive_args n nn te = + let module C = Cic in + match CicReduction.whd te with + C.Rel _ -> [] + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit + | C.Cast _ (*CSC ??? *) -> raise Impossible (* due to type-checking *) + | C.Prod (_,so,de) -> + (not (does_not_occur n nn so))::(recursive_args (n+1) (nn + 1) de) + | C.Lambda _ -> raise Impossible (* due to type-checking *) + | C.Appl _ -> [] + | C.Const _ + | C.Abst _ -> raise Impossible + | C.MutInd _ + | C.MutConstruct _ + | C.MutCase _ + | C.Fix _ + | C.CoFix _ -> raise Impossible (* due to type-checking *) + +and get_new_safes p c rl safes n nn x = + let module C = Cic in + let module U = UriManager in + let module R = CicReduction in + match (R.whd c, R.whd p, rl) with + (C.Prod (_,_,ta1), C.Lambda (_,_,ta2), b::tl) -> + (* we are sure that the two sources are convertible because we *) + (* have just checked this. So let's go along ... *) + let safes' = + List.map (fun x -> x + 1) safes + in + let safes'' = + if b then 1::safes' else safes' + in + get_new_safes ta2 ta1 tl safes'' (n+1) (nn+1) (x+1) + | (C.MutInd _, e, []) -> (e,safes,n,nn,x) + | (C.Appl _, e, []) -> (e,safes,n,nn,x) + | (_,_,_) -> raise Impossible + +and eat_prods n te = + let module C = Cic in + let module R = CicReduction in + match (n, R.whd te) with + (0, _) -> te + | (n, C.Prod (_,_,ta)) when n > 0 -> eat_prods (n - 1) ta + | (_, _) -> raise Impossible + +and eat_lambdas n te = + let module C = Cic in + let module R = CicReduction in + match (n, R.whd te) with + (0, _) -> (te, 0) + | (n, C.Lambda (_,_,ta)) when n > 0 -> + let (te, k) = eat_lambdas (n - 1) ta in + (te, k + 1) + | (_, _) -> raise Impossible + +(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *) +and check_is_really_smaller_arg n nn kl x safes te = + (*CSC: forse la whd si puo' fare solo quando serve veramente. *) + (*CSC: cfr guarded_by_destructors *) + let module C = Cic in + let module U = UriManager in + match CicReduction.whd te with + C.Rel m when List.mem m safes -> true + | C.Rel _ -> false + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit + | C.Cast _ +(* | C.Cast (te,ty) -> + check_is_really_smaller_arg n nn kl x safes te && + check_is_really_smaller_arg n nn kl x safes ty*) +(* | C.Prod (_,so,ta) -> + check_is_really_smaller_arg n nn kl x safes so && + check_is_really_smaller_arg (n+1) (nn+1) kl (x+1) + (List.map (fun x -> x + 1) safes) ta*) + | C.Prod _ -> raise Impossible + | C.Lambda (_,so,ta) -> + check_is_really_smaller_arg n nn kl x safes so && + check_is_really_smaller_arg (n+1) (nn+1) kl (x+1) + (List.map (fun x -> x + 1) safes) ta + | C.Appl (he::_) -> + (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *) + (*CSC: solo perche' non abbiamo trovato controesempi *) + check_is_really_smaller_arg n nn kl x safes he + | C.Appl [] -> raise Impossible + | C.Const _ + | C.Abst _ + | C.MutInd _ -> raise Impossible + | C.MutConstruct _ -> false + | C.MutCase (uri,_,i,outtype,term,pl) -> + (match term with + C.Rel m when List.mem m safes || m = x -> + let (isinductive,paramsno,cl) = + match CicCache.get_obj uri with + C.InductiveDefinition (tl,_,paramsno) -> + let (_,isinductive,_,cl) = List.nth tl i in + let cl' = + List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl + in + (isinductive,paramsno,cl') + | _ -> + raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) + in + if not isinductive then + List.fold_right + (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p) + pl true + else + List.fold_right + (fun (p,(_,c,rl)) i -> + let rl' = + match !rl with + Some rl' -> + let (_,rl'') = split rl' paramsno in + rl'' + | None -> raise Impossible + in + let (e,safes',n',nn',x') = + get_new_safes p c rl' safes n nn x + in + i && + check_is_really_smaller_arg n' nn' kl x' safes' e + ) (List.combine pl cl) true + | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> + let (isinductive,paramsno,cl) = + match CicCache.get_obj uri with + C.InductiveDefinition (tl,_,paramsno) -> + let (_,isinductive,_,cl) = List.nth tl i in + let cl' = + List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl + in + (isinductive,paramsno,cl') + | _ -> + raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) + in + if not isinductive then + List.fold_right + (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p) + pl true + else + (*CSC: supponiamo come prima che nessun controllo sia necessario*) + (*CSC: sugli argomenti di una applicazione *) + List.fold_right + (fun (p,(_,c,rl)) i -> + let rl' = + match !rl with + Some rl' -> + let (_,rl'') = split rl' paramsno in + rl'' + | None -> raise Impossible + in + let (e, safes',n',nn',x') = + get_new_safes p c rl' safes n nn x + in + i && + check_is_really_smaller_arg n' nn' kl x' safes' e + ) (List.combine pl cl) true + | _ -> + List.fold_right + (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p) + pl true + ) + | C.Fix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,_,ty,bo) i -> + i && + check_is_really_smaller_arg n_plus_len nn_plus_len kl x_plus_len + safes' bo + ) fl true + | C.CoFix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,ty,bo) i -> + i && + check_is_really_smaller_arg n_plus_len nn_plus_len kl x_plus_len + safes' bo + ) fl true + +and guarded_by_destructors n nn kl x safes = + let module C = Cic in + let module U = UriManager in + function + C.Rel m when m > n && m <= nn -> false + | C.Rel _ + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit -> true + | C.Cast (te,ty) -> + guarded_by_destructors n nn kl x safes te && + guarded_by_destructors n nn kl x safes ty + | C.Prod (_,so,ta) -> + guarded_by_destructors n nn kl x safes so && + guarded_by_destructors (n+1) (nn+1) kl (x+1) + (List.map (fun x -> x + 1) safes) ta + | C.Lambda (_,so,ta) -> + guarded_by_destructors n nn kl x safes so && + guarded_by_destructors (n+1) (nn+1) kl (x+1) + (List.map (fun x -> x + 1) safes) ta + | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> + let k = List.nth kl (m - n - 1) in + if not (List.length tl > k) then false + else + List.fold_right + (fun param i -> + i && guarded_by_destructors n nn kl x safes param + ) tl true && + check_is_really_smaller_arg n nn kl x safes (List.nth tl k) + | C.Appl tl -> + List.fold_right (fun t i -> i && guarded_by_destructors n nn kl x safes t) + tl true + | C.Const _ + | C.Abst _ + | C.MutInd _ + | C.MutConstruct _ -> true + | C.MutCase (uri,_,i,outtype,term,pl) -> + (match term with + C.Rel m when List.mem m safes || m = x -> + let (isinductive,paramsno,cl) = + match CicCache.get_obj uri with + C.InductiveDefinition (tl,_,paramsno) -> + let (_,isinductive,_,cl) = List.nth tl i in + let cl' = + List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl + in + (isinductive,paramsno,cl') + | _ -> + raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) + in + if not isinductive then + guarded_by_destructors n nn kl x safes outtype && + guarded_by_destructors n nn kl x safes term && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun p i -> i && guarded_by_destructors n nn kl x safes p) + pl true + else + guarded_by_destructors n nn kl x safes outtype && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun (p,(_,c,rl)) i -> + let rl' = + match !rl with + Some rl' -> + let (_,rl'') = split rl' paramsno in + rl'' + | None -> raise Impossible + in + let (e,safes',n',nn',x') = + get_new_safes p c rl' safes n nn x + in + i && + guarded_by_destructors n' nn' kl x' safes' e + ) (List.combine pl cl) true + | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> + let (isinductive,paramsno,cl) = + match CicCache.get_obj uri with + C.InductiveDefinition (tl,_,paramsno) -> + let (_,isinductive,_,cl) = List.nth tl i in + let cl' = + List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl + in + (isinductive,paramsno,cl') + | _ -> + raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) + in + if not isinductive then + guarded_by_destructors n nn kl x safes outtype && + guarded_by_destructors n nn kl x safes term && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun p i -> i && guarded_by_destructors n nn kl x safes p) + pl true + else + guarded_by_destructors n nn kl x safes outtype && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun t i -> i && guarded_by_destructors n nn kl x safes t) + tl true && + List.fold_right + (fun (p,(_,c,rl)) i -> + let rl' = + match !rl with + Some rl' -> + let (_,rl'') = split rl' paramsno in + rl'' + | None -> raise Impossible + in + let (e, safes',n',nn',x') = + get_new_safes p c rl' safes n nn x + in + i && + guarded_by_destructors n' nn' kl x' safes' e + ) (List.combine pl cl) true + | _ -> + guarded_by_destructors n nn kl x safes outtype && + guarded_by_destructors n nn kl x safes term && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun p i -> i && guarded_by_destructors n nn kl x safes p) + pl true + ) + | C.Fix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,_,ty,bo) i -> + i && guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len + safes' ty && + guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len + safes' bo + ) fl true + | C.CoFix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,ty,bo) i -> + i && guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len + safes' ty && + guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len safes' + bo + ) fl true + +(*CSC h = 0 significa non ancora protetto *) +and guarded_by_constructors n nn h = + let module C = Cic in + function + C.Rel m when m > n && m <= nn -> h = 1 + | C.Rel _ + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit -> true (*CSC: ma alcuni sono impossibili!!!! vedi Prod *) + | C.Cast (te,ty) -> + guarded_by_constructors n nn h te && + guarded_by_constructors n nn h ty + | C.Prod (_,so,de) -> + raise Impossible (* the term has just been type-checked *) + | C.Lambda (_,so,de) -> + does_not_occur n nn so && + guarded_by_constructors (n + 1) (nn + 1) h de + | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> + h = 1 && + List.fold_right (fun x i -> i && does_not_occur n nn x) tl true + | C.Appl ((C.MutConstruct (uri,cookingsno,i,j))::tl) -> + let (is_coinductive, rl) = + match CicCache.get_cooked_obj uri cookingsno with + C.InductiveDefinition (itl,_,_) -> + let (_,is_inductive,_,cl) = List.nth itl i in + let (_,cons,rrec_args) = List.nth cl (j - 1) in + (match !rrec_args with + None -> raise Impossible + | Some rec_args -> (not is_inductive, rec_args) + ) + | _ -> + raise (WrongUriToMutualInductiveDefinitions + (UriManager.string_of_uri uri)) + in + is_coinductive && + List.fold_right + (fun (x,r) i -> + i && + if r then + guarded_by_constructors n nn 1 x + else + does_not_occur n nn x + ) (List.combine tl rl) true + | C.Appl l -> + List.fold_right (fun x i -> i && does_not_occur n nn x) l true + | C.Const _ + | C.Abst _ + | C.MutInd _ + | C.MutConstruct _ -> true (*CSC: ma alcuni sono impossibili!!!! vedi Prod *) + | C.MutCase (_,_,_,out,te,pl) -> + let rec returns_a_coinductive = + function + (*CSC: per le regole di tipaggio, la chiamata ricorsiva verra' *) + (*CSC: effettata solo una volta, per mangiarsi l'astrazione *) + (*CSC: non dummy *) + C.Lambda (_,_,de) -> returns_a_coinductive de + | C.MutInd (uri,_,i) -> + (*CSC: definire una funzioncina per questo codice sempre replicato *) + (match CicCache.get_obj uri with + C.InductiveDefinition (itl,_,_) -> + let (_,is_inductive,_,_) = List.nth itl i in + not is_inductive + | _ -> + raise (WrongUriToMutualInductiveDefinitions + (UriManager.string_of_uri uri)) + ) + (*CSC: bug nella prossima riga (manca la whd) *) + | C.Appl ((C.MutInd (uri,_,i))::_) -> + (match CicCache.get_obj uri with + C.InductiveDefinition (itl,_,_) -> + let (_,is_inductive,_,_) = List.nth itl i in + not is_inductive + | _ -> + raise (WrongUriToMutualInductiveDefinitions + (UriManager.string_of_uri uri)) + ) + | _ -> false + in + does_not_occur n nn out && + does_not_occur n nn te && + if returns_a_coinductive out then + List.fold_right + (fun x i -> i && guarded_by_constructors n nn h x) pl true + else + List.fold_right (fun x i -> i && does_not_occur n nn x) pl true + | C.Fix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len in + List.fold_right + (fun (_,_,ty,bo) i -> + i && does_not_occur n_plus_len nn_plus_len ty && + does_not_occur n_plus_len nn_plus_len bo + ) fl true + | C.CoFix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len in + List.fold_right + (fun (_,ty,bo) i -> + i && does_not_occur n_plus_len nn_plus_len ty && + does_not_occur n_plus_len nn_plus_len bo + ) fl true + +and check_allowed_sort_elimination uri i need_dummy ind arity1 arity2 = + let module C = Cic in + let module U = UriManager in + match (CicReduction.whd arity1, CicReduction.whd arity2) with + (C.Prod (_,so1,de1), C.Prod (_,so2,de2)) + when CicReduction.are_convertible so1 so2 -> + check_allowed_sort_elimination uri i need_dummy + (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2 + | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true + | (C.Sort C.Prop, C.Sort C.Set) when need_dummy -> + (match CicCache.get_obj uri with + C.InductiveDefinition (itl,_,_) -> + let (_,_,_,cl) = List.nth itl i in + (* is a singleton definition? *) + List.length cl = 1 + | _ -> + raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) + ) + | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true + | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true + | (C.Sort C.Set, C.Sort C.Type) when need_dummy -> + (match CicCache.get_obj uri with + C.InductiveDefinition (itl,_,_) -> + let (_,_,_,cl) = List.nth itl i in + (* is a small inductive type? *) + (*CSC: ottimizzare calcolando staticamente *) + let rec is_small = + function + C.Prod (_,so,de) -> + let s = type_of so in + (s = C.Sort C.Prop || s = C.Sort C.Set) && + is_small de + | _ -> true (*CSC: we trust the type-checker *) + in + List.fold_right (fun (_,x,_) i -> i && is_small x) cl true + | _ -> + raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) + ) + | (C.Sort C.Type, C.Sort _) when need_dummy -> true + | (C.Sort C.Prop, C.Prod (_,so,ta)) when not need_dummy -> + let res = CicReduction.are_convertible so ind + in + res && + (match CicReduction.whd ta with + C.Sort C.Prop -> true + | C.Sort C.Set -> + (match CicCache.get_obj uri with + C.InductiveDefinition (itl,_,_) -> + let (_,_,_,cl) = List.nth itl i in + (* is a singleton definition? *) + List.length cl = 1 + | _ -> + raise (WrongUriToMutualInductiveDefinitions + (U.string_of_uri uri)) + ) + | _ -> false + ) + | (C.Sort C.Set, C.Prod (_,so,ta)) when not need_dummy -> + let res = CicReduction.are_convertible so ind + in + res && + (match CicReduction.whd ta with + C.Sort C.Prop + | C.Sort C.Set -> true + | C.Sort C.Type -> + (match CicCache.get_obj uri with + C.InductiveDefinition (itl,_,_) -> + let (_,_,_,cl) = List.nth itl i in + (* is a small inductive type? *) + let rec is_small = + function + C.Prod (_,so,de) -> + let s = type_of so in + (s = C.Sort C.Prop || s = C.Sort C.Set) && + is_small de + | _ -> true (*CSC: we trust the type-checker *) + in + List.fold_right (fun (_,x,_) i -> i && is_small x) cl true + | _ -> + raise (WrongUriToMutualInductiveDefinitions + (U.string_of_uri uri)) + ) + | _ -> raise Impossible + ) + | (C.Sort C.Type, C.Prod (_,so,_)) when not need_dummy -> + CicReduction.are_convertible so ind + | (_,_) -> false + +and type_of_branch argsno need_dummy outtype term constype = + let module C = Cic in + let module R = CicReduction in + match R.whd constype with + C.MutInd (_,_,_) -> + if need_dummy then + outtype + else + C.Appl [outtype ; term] + | C.Appl (C.MutInd (_,_,_)::tl) -> + let (_,arguments) = split tl argsno + in + if need_dummy && arguments = [] then + outtype + else + C.Appl (outtype::arguments@(if need_dummy then [] else [term])) + | C.Prod (name,so,de) -> + C.Prod (C.Name "pippo",so,type_of_branch argsno need_dummy + (CicSubstitution.lift 1 outtype) + (C.Appl [CicSubstitution.lift 1 term ; C.Rel 1]) de) + | _ -> raise Impossible + + +and type_of t = + let rec type_of_aux env = + let module C = Cic in + let module R = CicReduction in + let module S = CicSubstitution in + let module U = UriManager in + function + C.Rel n -> S.lift n (List.nth env (n - 1)) + | C.Var uri -> + incr fdebug ; + let ty = type_of_variable uri in + decr fdebug ; + ty + | C.Meta n -> raise NotImplemented + | C.Sort s -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *) + | C.Implicit -> raise Impossible + | C.Cast (te,ty) -> + let _ = type_of ty in + if R.are_convertible (type_of_aux env te) ty then ty + else raise (NotWellTyped "Cast") + | C.Prod (_,s,t) -> + let sort1 = type_of_aux env s + and sort2 = type_of_aux (s::env) t in + sort_of_prod (sort1,sort2) + | C.Lambda (n,s,t) -> + let sort1 = type_of_aux env s + and type2 = type_of_aux (s::env) t in + let sort2 = type_of_aux (s::env) type2 in + (* only to check if the product is well-typed *) + let _ = sort_of_prod (sort1,sort2) in + C.Prod (n,s,type2) + | C.Appl (he::tl) when List.length tl > 0 -> + let hetype = type_of_aux env he + and tlbody_and_type = List.map (fun x -> (x, type_of_aux env x)) tl in + (try + eat_prods hetype tlbody_and_type + with _ -> debug (C.Appl (he::tl)) env ; C.Implicit) + | C.Appl _ -> raise (NotWellTyped "Appl: no arguments") + | C.Const (uri,cookingsno) -> + incr fdebug ; + let cty = cooked_type_of_constant uri cookingsno in + decr fdebug ; + cty + | C.Abst _ -> raise Impossible + | C.MutInd (uri,cookingsno,i) -> + incr fdebug ; + let cty = cooked_type_of_mutual_inductive_defs uri cookingsno i in + decr fdebug ; + cty + | C.MutConstruct (uri,cookingsno,i,j) -> + let cty = cooked_type_of_mutual_inductive_constr uri cookingsno i j + in + cty + | C.MutCase (uri,cookingsno,i,outtype,term,pl) -> + let outsort = type_of_aux env outtype in + let (need_dummy, k) = + let rec guess_args t = + match decast t with + C.Sort _ -> (true, 0) + | C.Prod (_, s, t) -> + let (b, n) = guess_args t in + if n = 0 then + (* last prod before sort *) + match CicReduction.whd s with + (*CSC vedi nota delirante su cookingsno in cicReduction.ml *) + C.MutInd (uri',_,i') when U.eq uri' uri && i' = i -> (false, 1) + | C.Appl ((C.MutInd (uri',_,i')) :: _) + when U.eq uri' uri && i' = i -> (false, 1) + | _ -> (true, 1) + else + (b, n + 1) + | _ -> raise (NotWellTyped "MutCase: outtype ill-formed") + in + (*CSC whd non serve dopo type_of_aux ? *) + let (b, k) = guess_args outsort in + if not b then (b, k - 1) else (b, k) + in + let (parameters, arguments) = + match R.whd (type_of_aux env term) with + (*CSC manca il caso dei CAST *) + C.MutInd (uri',_,i') -> + (*CSC vedi nota delirante sui cookingsno in cicReduction.ml*) + if U.eq uri uri' && i = i' then ([],[]) + else raise (NotWellTyped ("MutCase: the term is of type " ^ + (U.string_of_uri uri') ^ "," ^ string_of_int i' ^ + " instead of type " ^ (U.string_of_uri uri') ^ "," ^ + string_of_int i)) + | C.Appl (C.MutInd (uri',_,i') :: tl) -> + if U.eq uri uri' && i = i' then split tl (List.length tl - k) + else raise (NotWellTyped ("MutCase: the term is of type " ^ + (U.string_of_uri uri') ^ "," ^ string_of_int i' ^ + " instead of type " ^ (U.string_of_uri uri) ^ "," ^ + string_of_int i)) + | _ -> raise (NotWellTyped "MutCase: the term is not an inductive one") + in + (* let's control if the sort elimination is allowed: [(I q1 ... qr)|B] *) + let sort_of_ind_type = + if parameters = [] then + C.MutInd (uri,cookingsno,i) + else + C.Appl ((C.MutInd (uri,cookingsno,i))::parameters) + in + if not (check_allowed_sort_elimination uri i need_dummy + sort_of_ind_type (type_of_aux env sort_of_ind_type) outsort) + then + raise (NotWellTyped "MutCase: not allowed sort elimination") ; + + (* let's check if the type of branches are right *) + let (cl,parsno) = + match CicCache.get_cooked_obj uri cookingsno with + C.InductiveDefinition (tl,_,parsno) -> + let (_,_,_,cl) = List.nth tl i in (cl,parsno) + | _ -> + raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) + in + let (_,branches_ok) = + List.fold_left + (fun (j,b) (p,(_,c,_)) -> + let cons = + if parameters = [] then + (C.MutConstruct (uri,cookingsno,i,j)) + else + (C.Appl (C.MutConstruct (uri,cookingsno,i,j)::parameters)) + in + (j + 1, b && + R.are_convertible (type_of_aux env p) + (type_of_branch parsno need_dummy outtype cons + (type_of_aux env cons)) + ) + ) (1,true) (List.combine pl cl) + in + if not branches_ok then + raise (NotWellTyped "MutCase: wrong type of a branch") ; + + if not need_dummy then + C.Appl ((outtype::arguments)@[term]) + else if arguments = [] then + outtype + else + C.Appl (outtype::arguments) + | C.Fix (i,fl) -> + let types_times_kl = + List.rev + (List.map (fun (_,k,ty,_) -> let _ = type_of_aux env ty in (ty,k)) fl) + in + let (types,kl) = List.split types_times_kl in + let len = List.length types in + List.iter + (fun (name,x,ty,bo) -> + if (R.are_convertible (type_of_aux (types @ env) bo) + (CicSubstitution.lift len ty)) + then + begin + let (m, eaten) = eat_lambdas (x + 1) bo in + (*let's control the guarded by destructors conditions D{f,k,x,M}*) + if not (guarded_by_destructors eaten (len + eaten) kl 1 [] m) then + raise (NotWellTyped "Fix: not guarded by destructors") + end + else + raise (NotWellTyped "Fix: ill-typed bodies") + ) fl ; + + (*CSC: controlli mancanti solo su D{f,k,x,M} *) + let (_,_,ty,_) = List.nth fl i in + ty + | C.CoFix (i,fl) -> + let types = + List.rev (List.map (fun (_,ty,_) -> let _ = type_of_aux env ty in ty) fl) + in + let len = List.length types in + List.iter + (fun (_,ty,bo) -> + if (R.are_convertible (type_of_aux (types @ env) bo) + (CicSubstitution.lift len ty)) + then + begin + (* let's control the guarded by constructors conditions C{f,M} *) + if not (guarded_by_constructors 0 len 0 bo) then + raise (NotWellTyped "CoFix: not guarded by constructors") + end + else + raise (NotWellTyped "CoFix: ill-typed bodies") + ) fl ; + + let (_,ty,_) = List.nth fl i in + ty + + and decast = + let module C = Cic in + function + C.Cast (t,_) -> t + | t -> t + + and sort_of_prod (t1, t2) = + let module C = Cic in + match (decast t1, decast t2) with + (C.Sort s1, C.Sort s2) + when (s2 = C.Prop or s2 = C.Set) -> (* different from Coq manual!!! *) + C.Sort s2 + | (C.Sort s1, C.Sort s2) -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *) + | (_,_) -> raise (NotWellTyped "Prod") + + and eat_prods hetype = + (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *) + (*CSC: cucinati *) + function + [] -> hetype + | (hete, hety)::tl -> + (match (CicReduction.whd hetype) with + Cic.Prod (n,s,t) -> + if CicReduction.are_convertible s hety then + (CicReduction.fdebug := -1 ; + eat_prods (CicSubstitution.subst hete t) tl + ) + else + ( + CicReduction.fdebug := 0 ; + let _ = CicReduction.are_convertible s hety in + debug hete [hety ; s] ; + raise (NotWellTyped "Appl: wrong parameter-type") +) + | _ -> raise (NotWellTyped "Appl: wrong Prod-type") + ) + in + type_of_aux [] t +;; + +let typecheck uri = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + match CicCache.is_type_checked uri 0 with + CicCache.CheckedObj _ -> () + | CicCache.UncheckedObj uobj -> + (* let's typecheck the uncooked object *) + (match uobj with + C.Definition (_,te,ty,_) -> + let _ = type_of ty in + if not (R.are_convertible (type_of te ) ty) then + raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri))) + | C.Axiom (_,ty,_) -> + (* only to check that ty is well-typed *) + let _ = type_of ty in () + | C.CurrentProof (_,_,te,ty) -> + (*CSC [] wrong *) + let _ = type_of ty in + debug (type_of te) [] ; + if not (R.are_convertible (type_of te) ty) then + raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri))) + | C.Variable (_,ty) -> + (* only to check that ty is well-typed *) + (*CSC [] wrong *) + let _ = type_of ty in () + | C.InductiveDefinition _ -> + cooked_mutual_inductive_defs uri uobj + ) ; + CicCache.set_type_checking_info uri +;; diff --git a/helm/interface/cicTypeChecker.mli b/helm/interface/cicTypeChecker.mli new file mode 100644 index 000000000..21f4ab91b --- /dev/null +++ b/helm/interface/cicTypeChecker.mli @@ -0,0 +1,9 @@ +exception NotWellTyped of string +exception WrongUriToConstant of string +exception WrongUriToVariable of string +exception WrongUriToMutualInductiveDefinitions of string +exception ListTooShort +exception NotPositiveOccurrences of string +exception NotWellFormedTypeOfInductiveConstructor of string +exception WrongRequiredArgument of string +val typecheck : UriManager.uri -> unit diff --git a/helm/interface/cicXPath.ml b/helm/interface/cicXPath.ml new file mode 100644 index 000000000..2df970737 --- /dev/null +++ b/helm/interface/cicXPath.ml @@ -0,0 +1,51 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 14/06/2000 *) +(* *) +(* *) +(******************************************************************************) + +let get_annotation_from_term annterm = + let module C = Cic in + match annterm with + C.ARel (_,ann,_,_) -> ann + | C.AVar (_,ann,_) -> ann + | C.AMeta (_,ann,_) -> ann + | C.ASort (_,ann,_) -> ann + | C.AImplicit (_,ann) -> ann + | C.ACast (_,ann,_,_) -> ann + | C.AProd (_,ann,_,_,_) -> ann + | C.ALambda (_,ann,_,_,_) -> ann + | C.AAppl (_,ann,_) -> ann + | C.AConst (_,ann,_,_) -> ann + | C.AAbst (_,ann,_) -> ann + | C.AMutInd (_,ann,_,_,_) -> ann + | C.AMutConstruct (_,ann,_,_,_,_)-> ann + | C.AMutCase (_,ann,_,_,_,_,_,_) -> ann + | C.AFix (_,ann,_,_) -> ann + | C.ACoFix (_,ann,_,_) -> ann +;; + +let get_annotation_from_obj annobj = + let module C = Cic in + match annobj with + C.ADefinition (_,ann,_,_,_,_) -> ann + | C.AAxiom (_,ann,_,_,_) -> ann + | C.AVariable (_,ann,_,_) -> ann + | C.ACurrentProof (_,ann,_,_,_,_) -> ann + | C.AInductiveDefinition (_,ann,_,_,_) -> ann +;; + +exception IdUnknown of string;; + +let get_annotation (annobj,ids_to_targets) xpath = + try + match Hashtbl.find ids_to_targets xpath with + Cic.Object annobj -> get_annotation_from_obj annobj + | Cic.Term annterm -> get_annotation_from_term annterm + with + Not_found -> raise (IdUnknown xpath) +;; diff --git a/helm/interface/cicXPath.prima_degli_identificatori.ml b/helm/interface/cicXPath.prima_degli_identificatori.ml new file mode 100644 index 000000000..8a69d1a24 --- /dev/null +++ b/helm/interface/cicXPath.prima_degli_identificatori.ml @@ -0,0 +1,102 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 11/04/2000 *) +(* *) +(* *) +(******************************************************************************) + +(* functions to parse an XPath to retrieve the annotation *) + +exception WrongXPath of string;; + +let rec get_annotation_of_inductiveFun f xpath = + let module C = Cic in + match (xpath,f) with + 1::tl,(_,_,ty,_) -> get_annotation_of_term ty tl + | 2::tl,(_,_,_,te) -> get_annotation_of_term te tl + | l,_ -> + raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l "")) + +and get_annotation_of_coinductiveFun f xpath = + let module C = Cic in + match (xpath,f) with + 1::tl,(_,ty,_) -> get_annotation_of_term ty tl + | 2::tl,(_,_,te) -> get_annotation_of_term te tl + | l,_ -> + raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l "")) + +and get_annotation_of_inductiveType ty xpath = + let module C = Cic in + match (xpath,ty) with + 1::tl,(_,_,arity,_) -> get_annotation_of_term arity tl + | n::tl,(_,_,_,cons) when n <= List.length cons + 1 -> + let (_,ty,_) = List.nth cons (n-2) in + get_annotation_of_term ty tl + | l,_ -> + raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l "")) + +and get_annotation_of_term term xpath = + let module C = Cic in + match (xpath,term) with + [],C.ARel (_,ann,_,_) -> ann + | [],C.AVar (_,ann,_) -> ann + | [],C.AMeta (_,ann,_) -> ann + | [],C.ASort (_,ann,_) -> ann + | [],C.AImplicit (_,ann) -> ann + | [],C.ACast (_,ann,_,_) -> ann + | 1::tl,C.ACast (_,_,te,_) -> get_annotation_of_term te tl + | 2::tl,C.ACast (_,_,_,ty) -> get_annotation_of_term ty tl + | [],C.AProd (_,ann,_,_,_) -> ann + | 1::tl,C.AProd (_,_,_,so,_) -> get_annotation_of_term so tl + | 2::tl,C.AProd (_,_,_,_,ta) -> get_annotation_of_term ta tl + | [],C.ALambda (_,ann,_,_,_) -> ann + | 1::tl,C.ALambda (_,_,_,so,_) -> get_annotation_of_term so tl + | 2::tl,C.ALambda (_,_,_,_,ta) -> get_annotation_of_term ta tl + | [],C.AAppl (_,ann,_) -> ann + | n::tl,C.AAppl (_,_,l) when n <= List.length l -> + get_annotation_of_term (List.nth l (n-1)) tl + | [],C.AConst (_,ann,_,_) -> ann + | [],C.AAbst (_,ann,_) -> ann + | [],C.AMutInd (_,ann,_,_,_) -> ann + | [],C.AMutConstruct (_,ann,_,_,_,_) -> ann + | [],C.AMutCase (_,ann,_,_,_,_,_,_) -> ann + | 1::tl,C.AMutCase (_,_,_,_,_,outt,_,_) -> get_annotation_of_term outt tl + | 2::tl,C.AMutCase (_,_,_,_,_,_,te,_) -> get_annotation_of_term te tl + | n::tl,C.AMutCase (_,_,_,_,_,_,_,pl) when n <= List.length pl -> + get_annotation_of_term (List.nth pl (n-1)) tl + | [],C.AFix (_,ann,_,_) -> ann + | n::tl,C.AFix (_,_,_,fl) when n <= List.length fl -> + get_annotation_of_inductiveFun (List.nth fl (n-1)) tl + | [],C.ACoFix (_,ann,_,_) -> ann + | n::tl,C.ACoFix (_,_,_,fl) when n <= List.length fl -> + get_annotation_of_coinductiveFun (List.nth fl (n-1)) tl + | l,_ -> + raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l "")) +;; + +let get_annotation (annobj,_) xpath = + let module C = Cic in + match (xpath,annobj) with + [],C.ADefinition (_,ann,_,_,_,_) -> ann + | 1::tl,C.ADefinition (_,_,_,bo,_,_) -> get_annotation_of_term bo tl + | 2::tl,C.ADefinition (_,_,_,_,ty,_) -> get_annotation_of_term ty tl + | [],C.AAxiom (_,ann,_,_,_) -> ann + | 1::tl,C.AAxiom (_,_,_,ty,_) -> get_annotation_of_term ty tl + | [],C.AVariable (_,ann,_,_) -> ann + | 1::tl,C.AVariable (_,_,_,ty) -> get_annotation_of_term ty tl + | [],C.ACurrentProof (_,ann,_,_,_,_) -> ann + | n::tl,C.ACurrentProof (_,ann,_,conjs,_,_) when n <= List.length conjs -> + get_annotation_of_term (snd (List.nth conjs (n-1))) tl + | n::tl,C.ACurrentProof (_,ann,_,conjs,bo,_) when n = List.length conjs + 1 -> + get_annotation_of_term bo tl + | n::tl,C.ACurrentProof (_,ann,_,conjs,_,ty) when n = List.length conjs + 2 -> + get_annotation_of_term ty tl + | [],C.AInductiveDefinition (_,ann,_,_,_) -> ann + | n::tl,C.AInductiveDefinition (_,_,tys,_,_) when n <= List.length tys -> + get_annotation_of_inductiveType (List.nth tys (n-1)) tl + | l,_ -> + raise (WrongXPath (List.fold_right (fun n i -> string_of_int n ^ i) l "")) +;; diff --git a/helm/interface/configuration.ml b/helm/interface/configuration.ml new file mode 100644 index 000000000..6b0facf33 --- /dev/null +++ b/helm/interface/configuration.ml @@ -0,0 +1,78 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 06/05/2000 *) +(* *) +(* This is the parser that reads the configuration file of helm *) +(* *) +(******************************************************************************) + +(* this should be the only hard coded constant *) +let filename = "/home/cadet/sacerdot/local/etc/helm/configuration.xml";; + +exception Warnings;; + +class warner = + object + method warn w = + print_endline ("WARNING: " ^ w) ; + (raise Warnings : unit) + end +;; + +let xml_document () = + let module Y = Pxp_yacc in + try + let config = {Y.default_config with Y.warner = new warner} in + Y.parse_document_entity config (Y.from_file filename) Y.default_spec + with + e -> + print_endline (Pxp_types.string_of_exn e) ; + raise e +;; + +exception Impossible;; + +let vars = Hashtbl.create 14;; + +(* resolve tags and returns the string values of the variable tags *) +let rec resolve = + let module D = Pxp_document in + function + [] -> "" + | he::tl when he#node_type = D.T_element "value-of" -> + (match he#attribute "var" with + Pxp_types.Value var -> Hashtbl.find vars var + | _ -> raise Impossible + ) ^ resolve tl + | he::tl when he#node_type = D.T_data -> + he#data ^ resolve tl + | _ -> raise Impossible +;; + +(* we trust the xml file to be valid because of the validating xml parser *) +let _ = + List.iter + (function + n -> + match n#node_type with + Pxp_document.T_element var -> + Hashtbl.add vars var (resolve (n#sub_nodes)) + | _ -> raise Impossible + ) + ((xml_document ())#root#sub_nodes) +;; + +let helm_dir = Hashtbl.find vars "helm_dir";; +let dtd_dir = Hashtbl.find vars "dtd_dir";; +let servers_file = Hashtbl.find vars "servers_file";; +let uris_dbm = Hashtbl.find vars "uris_dbm";; +let dest = Hashtbl.find vars "dest";; +let indexname = Hashtbl.find vars "indexname";; +let tmpdir = Hashtbl.find vars "tmpdir";; +let helm_dir = Hashtbl.find vars "helm_dir";; +let getter_url = Hashtbl.find vars "getter_url";; + +let _ = Hashtbl.clear vars;; diff --git a/helm/interface/deannotate.ml b/helm/interface/deannotate.ml new file mode 100644 index 000000000..658554fff --- /dev/null +++ b/helm/interface/deannotate.ml @@ -0,0 +1,69 @@ +let expect_possible_parameters = ref false;; + +exception NotExpectingPossibleParameters;; + +let rec deannotate_term = + let module C = Cic in + function + C.ARel (_,_,n,_) -> C.Rel n + | C.AVar (_,_,uri) -> C.Var uri + | C.AMeta (_,_,n) -> C.Meta n + | C.ASort (_,_,s) -> C.Sort s + | C.AImplicit _ -> C.Implicit + | C.ACast (_,_,va,ty) -> C.Cast (deannotate_term va, deannotate_term ty) + | C.AProd (_,_,name,so,ta) -> + C.Prod (name, deannotate_term so, deannotate_term ta) + | C.ALambda (_,_,name,so,ta) -> + C.Lambda (name, deannotate_term so, deannotate_term ta) + | C.AAppl (_,_,l) -> C.Appl (List.map deannotate_term l) + | C.AConst (_,_,uri, cookingsno) -> C.Const (uri, cookingsno) + | C.AAbst (_,_,uri) -> C.Abst uri + | C.AMutInd (_,_,uri,cookingsno,i) -> C.MutInd (uri,cookingsno,i) + | C.AMutConstruct (_,_,uri,cookingsno,i,j) -> + C.MutConstruct (uri,cookingsno,i,j) + | C.AMutCase (_,_,uri,cookingsno,i,outtype,te,pl) -> + C.MutCase (uri,cookingsno,i,deannotate_term outtype, + deannotate_term te, List.map deannotate_term pl) + | C.AFix (_,_,funno,ifl) -> + C.Fix (funno, List.map deannotate_inductiveFun ifl) + | C.ACoFix (_,_,funno,ifl) -> + C.CoFix (funno, List.map deannotate_coinductiveFun ifl) + +and deannotate_inductiveFun (name,index,ty,bo) = + (name, index, deannotate_term ty, deannotate_term bo) + +and deannotate_coinductiveFun (name,ty,bo) = + (name, deannotate_term ty, deannotate_term bo) +;; + +let deannotate_inductiveType (name, isinductive, arity, cons) = + (name, isinductive, deannotate_term arity, + List.map (fun (id,ty,recs) -> (id,deannotate_term ty, recs)) cons) +;; + +let deannotate_obj = + let module C = Cic in + function + C.ADefinition (_, _, id, bo, ty, params) -> + (match params with + C.Possible params -> + if !expect_possible_parameters then + C.Definition (id, deannotate_term bo, deannotate_term ty, params) + else + raise NotExpectingPossibleParameters + | C.Actual params -> + C.Definition (id, deannotate_term bo, deannotate_term ty, params) + ) + | C.AAxiom (_, _, id, ty, params) -> + C.Axiom (id, deannotate_term ty, params) + | C.AVariable (_, _, name, ty) -> + C.Variable (name, deannotate_term ty) + | C.ACurrentProof (_, _, name, conjs, bo, ty) -> + C.CurrentProof ( + name, List.map (fun (id,con) -> (id,deannotate_term con)) conjs, + deannotate_term bo, deannotate_term ty + ) + | C.AInductiveDefinition (_, _, tys, params, parno) -> + C.InductiveDefinition ( List.map deannotate_inductiveType tys, + params, parno) +;; diff --git a/helm/interface/experiment.ml b/helm/interface/experiment.ml new file mode 100644 index 000000000..5c086bb19 --- /dev/null +++ b/helm/interface/experiment.ml @@ -0,0 +1,84 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This is a textual interface to the Coq-like pretty printer cicPp for cic *) +(* terms exported in xml. It uses directly the modules cicPp and cache and *) +(* indirectly all the other modules (cicParser, cicParser2, cicParser3, *) +(* getter). The syntax is "experiment[.opt] filename1 ... filenamen" where *) +(* filenamei is the path-name of an xml file describing a cic term. On stdout *) +(* are pretty-printed all the n terms *) +(* *) +(******************************************************************************) + +let pretty_print = ref true;; +let read_from_stdin = ref false;; +let uris_in_input = ref false;; + +let parse uri = + if !pretty_print then + begin + print_endline ("^^^" ^ uri ^ "^^^") ; + print_string (CicPp.ppobj (CicCache.get_obj (UriManager.uri_of_string uri))); + print_endline ("\n$$$" ^ uri ^ "$$$\n") + end + else + begin + print_string uri ; + let _ = CicCache.get_obj (UriManager.uri_of_string uri) in + print_endline " OK!" ; + flush stdout + end +;; + +let uri_of_filename fn = + if !uris_in_input then fn + else + let uri = + Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn + in + let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in + uri' +;; + +let read_filenames_from_stdin () = + let files = ref [] in + try + while true do + let l = Str.split (Str.regexp " ") (read_line ()) in + List.iter (fun x -> files := (uri_of_filename x) :: !files) l + done + with + End_of_file -> + files := List.rev !files ; + List.iter parse !files +;; + +(* filenames are read from command line and converted to uris via *) +(* uri_of_filenames; then the cic terms are load in cache via *) +(* CicCache.get_obj and then pretty printed via CicPp.ppobj *) + +let main() = + let files = ref [] in + Arg.parse + ["-nopp", Arg.Clear pretty_print, "Do not pretty print, parse only" ; + "-stdin", Arg.Set read_from_stdin, "Read from stdin" ; + "-uris", Arg.Set uris_in_input, "Read uris, not filenames" ; + "-update", Arg.Unit Getter.update, "Update the getter view of the world"] + (fun x -> files := (uri_of_filename x) :: !files) + " +usage: experiment file ... + +List of options:"; + if !read_from_stdin then read_filenames_from_stdin () + else + begin + files := List.rev !files; + List.iter parse !files + end +;; + +main();; diff --git a/helm/interface/fix_params.ml b/helm/interface/fix_params.ml new file mode 100644 index 000000000..b4de9fa6f --- /dev/null +++ b/helm/interface/fix_params.ml @@ -0,0 +1,49 @@ +let read_from_stdin = ref false;; + +let uri_of_filename fn = + let uri = + Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn + in + let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in + UriManager.uri_of_string uri' +;; + +let main() = + Deannotate.expect_possible_parameters := true ; + let files = ref [] in + Arg.parse + ["-stdin", Arg.Set read_from_stdin, "Read from stdin"] + (fun x -> files := (x, uri_of_filename x) :: !files) + " +usage: experiment file ... + +List of options:"; + if !read_from_stdin then + begin + try + while true do + let l = Str.split (Str.regexp " ") (read_line ()) in + List.iter (fun x -> files := (x, uri_of_filename x) :: !files) l + done + with + End_of_file -> () + end ; + files := List.rev !files; + Getter.update () ; + print_endline "ATTENTION: have you changed servers.txt so that you'll try \ + to repair your own objs instead of others'?" ; + flush stdout ; + List.iter + (function (fn, uri) -> + print_string (UriManager.string_of_uri uri) ; + flush stdout ; + (try + CicFindParameters.fix_params uri (Some fn) + with + e -> print_newline () ; flush stdout ; raise e ) ; + print_endline " OK!" ; + flush stdout + ) !files +;; + +main();; diff --git a/helm/interface/getter.ml b/helm/interface/getter.ml new file mode 100644 index 000000000..21c1901a1 --- /dev/null +++ b/helm/interface/getter.ml @@ -0,0 +1,143 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(******************************************************************************) + +exception ErrorGetting of string;; + +module OrderedStrings = + struct + type t = string + let compare (s1 : t) (s2 : t) = compare s1 s2 + end +;; + +module MapOfStrings = Map.Make(OrderedStrings);; + +let read_index url = + let module C = Configuration in + if Sys.command ("wget -c -P " ^ C.tmpdir ^ " " ^ url ^ "/\"" ^ + C.indexname ^ "\"") <> 0 + then + raise (ErrorGetting url) ; + let tmpfilename = C.tmpdir ^ "/" ^ C.indexname in + let fd = open_in tmpfilename in + let uris = ref [] in + try + while true do + uris := (input_line fd) :: !uris + done ; + [] (* only to make the compiler happy *) + with + End_of_file -> + Sys.remove tmpfilename ; + !uris +;; + +(* mk_urls_of_uris list_of_servers_base_urls *) +let rec mk_urls_of_uris = + function + [] -> MapOfStrings.empty + | he::tl -> + let map = mk_urls_of_uris tl in + let uris = read_index he in + let url_of_uri uri = + let url = uri ^ ".xml" in + let url' = Str.replace_first (Str.regexp "cic:") he url in + let url'' = Str.replace_first (Str.regexp "theory:") he url' in + url'' + in + List.fold_right + (fun uri m -> MapOfStrings.add uri (url_of_uri uri) m) + uris map +;; + +let update () = + let module C = Configuration in + let fd = open_in C.servers_file in + let servers = ref [] in + try + while true do + servers := (input_line fd) :: !servers + done + with + End_of_file -> + let urls_of_uris = mk_urls_of_uris (List.rev !servers) in + (try Sys.remove (C.uris_dbm ^ ".db") with _ -> ()) ; + let dbm = + Dbm.opendbm C.uris_dbm [Dbm.Dbm_wronly ; Dbm.Dbm_create] 0o660 + in + MapOfStrings.iter (fun uri url -> Dbm.add dbm uri url) urls_of_uris ; + Dbm.close dbm +;; + +(* url_of_uri : uri -> url *) +let url_of_uri uri = + let dbm = Dbm.opendbm Configuration.uris_dbm [Dbm.Dbm_rdonly] 0o660 in + let url = Dbm.find dbm (UriManager.string_of_uri uri) in + Dbm.close dbm ; + url +;; + +let filedir_of_uri uri = + let fn = UriManager.buri_of_uri uri in + let fn' = Str.replace_first (Str.regexp ".*:") Configuration.dest fn in + fn' +;; + +let name_and_ext_of_uri uri = + let str = UriManager.string_of_uri uri in + Str.replace_first (Str.regexp ".*/") "" str +;; + +(* get_file : uri -> filename *) +let get_file uri = + let dir = filedir_of_uri uri in + let fn = dir ^ "/" ^ name_and_ext_of_uri uri ^ ".xml" in + if not (Sys.file_exists fn) then + begin + let url = url_of_uri uri in + (*CSC: use -q for quiet mode *) + if Sys.command ("wget -c -P " ^ dir ^ " \"" ^ url ^"\"") <> 0 + then + raise (ErrorGetting url) ; + end ; + fn +;; + +(* get : uri -> filename *) +(* If uri is the URI of an annotation, the annotated object is processed *) +let get uri = + let module U = UriManager in + get_file + (U.uri_of_string + (Str.replace_first (Str.regexp "\.ann$") "" + (Str.replace_first (Str.regexp "\.types$") "" (U.string_of_uri uri)))) +;; + +(* get_ann : uri -> filename *) +(* If uri is the URI of an annotation, the annotation file is processed *) +let get_ann = get_file;; + +(* get_ann_file_name_and_uri : uri -> filename * annuri *) +(* If given an URI, it returns the name of the corresponding *) +(* annotation file and the annotation uri *) +let get_ann_file_name_and_uri uri = + let module U = UriManager in + let uri = U.string_of_uri uri in + let annuri = + U.uri_of_string ( + if Str.string_match (Str.regexp ".*\.ann$") uri 0 then + uri + else + uri ^ ".ann" + ) + in + let dir = filedir_of_uri annuri in + let fn = dir ^ "/" ^ name_and_ext_of_uri annuri ^ ".xml" in + (fn, annuri) +;; diff --git a/helm/interface/getter.mli b/helm/interface/getter.mli new file mode 100644 index 000000000..c0e882c99 --- /dev/null +++ b/helm/interface/getter.mli @@ -0,0 +1,25 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* *) +(******************************************************************************) + +(* get : uri -> filename *) +(* If uri is the URI of an annotation, the annotated object is processed *) +val get : UriManager.uri -> string + +(* get_ann : uri -> filename *) +(* If uri is the URI of an annotation, the annotation file is processed *) +val get_ann : UriManager.uri -> string + +(* get_ann_file_name_and_uri : uri -> filename * annuri *) +(* If given an URI, it returns the name of the corresponding *) +(* annotation file and the annotation uri *) +val get_ann_file_name_and_uri : UriManager.uri -> string * UriManager.uri + +(* synchronize with the servers *) +val update : unit -> unit diff --git a/helm/interface/gmon.out b/helm/interface/gmon.out new file mode 100644 index 000000000..c48b8406f Binary files /dev/null and b/helm/interface/gmon.out differ diff --git a/helm/interface/http_getter/http_getter.pl b/helm/interface/http_getter/http_getter.pl new file mode 100755 index 000000000..4ad358480 --- /dev/null +++ b/helm/interface/http_getter/http_getter.pl @@ -0,0 +1,272 @@ +#!/usr/bin/perl + +# next require defines: $helm_dir, $html_link +# LUCA - 12 sep 2000 +# require "/usr/lib/helm/configuration.pl"; +require "/home/cadet/sacerdot/local/lib/helm/configuration.pl"; +use HTTP::Daemon; +use HTTP::Status; +use HTTP::Request; +use LWP::UserAgent; +use DB_File; + +my $cont = ""; +my $d = new HTTP::Daemon LocalPort => 8081; +tie(%map, 'DB_File', 'urls_of_uris.db', O_RDONLY, 0664); +print "Please contact me at: url, ">\n"; +print "helm_dir: $helm_dir\n"; +$SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes +while (my $c = $d->accept) { + if (fork() == 0) { + while (my $r = $c->get_request) { + #CSC: mancano i controlli di sicurezza + + $cont = ""; + my $cicuri = $r->url; + $cicuri =~ s/^[^?]*\?url=(.*)/$1/; + print "*".$r->url."\n"; + my $http_method = $r->method; + my $http_path = $r->url->path; + if ($http_method eq 'GET' and $http_path eq "/get") { + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + $filename = $helm_dir.$filename.".xml"; + my $resolved = $map{$cicuri}; + print "$cicuri ==> $resolved ($filename)\n"; + if (stat($filename)) { + print "Using local copy\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + print "Downloading\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file\n"; + open(FD, $filename); + print FD $cont; + close(FD); + + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } + } elsif ($http_method eq 'GET' and $http_path eq "/annotate") { + my $do_annotate = ($cicuri =~ /\.ann$/); + my $target_to_annotate = $cicuri; + $target_to_annotate =~ s/(.*)\.ann$/$1/ if $do_annotate; + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + my $filename_target = $helm_dir.$filename if $do_annotate; + $filename = $helm_dir.$filename.".xml"; + $filename_target =~ s/(.*)\.ann$/$1.xml/ if $do_annotate; + my $resolved = $map{$cicuri}; + my $resolved_target = $map{$target_to_annotate} if $do_annotate; + if ($do_annotate) { + print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n"; + } else { + print "$cicuri ==> $resolved ($filename)\n"; + } + + # Retrieves the annotation + + if (stat($filename)) { + print "Using local copy for the annotation\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the annotation\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file for the annotation\n"; + open(FD, $filename); + print FD $cont; + close(FD); + } + my $annotation = $cont; + + # Retrieves the target to annotate + + $cont = ""; + if ($do_annotate) { + if (stat($filename_target)) { + print "Using local copy for the file to annotate\n"; + open(FD, $filename_target); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the file to annotate\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved_target"); + $response = $ua->request($request, \&callback); + + print "Storing file for the file to annotate\n"; + open(FD, $filename_target); + print FD $cont; + close(FD); + } + } + my $target = $cont; + + # Merging the annotation and the target + + $target =~ s/<\?xml [^?]*\?>//sg; + $target =~ s/]*>//sg; + $annotation =~ s/<\?xml [^?]*\?>//sg; + $annotation =~ s/]*>//sg; + my $merged = < + +$target +$annotation + +EOT + + # Answering the client + + my $res = new HTTP::Response; + $res->content($merged); + $c->send_response($res); + } elsif ($http_method eq 'GET' and $http_path eq "/getwithtypes") { + my $do_annotate = ($cicuri =~ /\.types$/); + my $target_to_annotate = $cicuri; + $target_to_annotate =~ s/(.*)\.types$/$1/ if $do_annotate; + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + my $filename_target = $helm_dir.$filename if $do_annotate; + $filename = $helm_dir.$filename.".xml"; + $filename_target =~ s/(.*)\.types$/$1.xml/ if $do_annotate; + my $resolved = $map{$cicuri}; + my $resolved_target = $map{$target_to_annotate} if $do_annotate; + if ($do_annotate) { + print "GETWITHTYPES!!\n"; + print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n"; + } else { + print "$cicuri ==> $resolved ($filename)\n"; + } + + # Retrieves the annotation + + if (stat($filename)) { + print "Using local copy for the types\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the types\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file for the types\n"; + open(FD, $filename); + print FD $cont; + close(FD); + } + my $annotation = $cont; + + # Retrieves the target to annotate + + $cont = ""; + my $target; + if ($do_annotate) { + if (stat($filename_target)) { + print "Using local copy for the file to type\n"; + open(FD, $filename_target); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the file to type\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved_target"); + $response = $ua->request($request, \&callback); + + print "Storing file for the file to type\n"; + open(FD, $filename_target); + print FD $cont; + close(FD); + } + $target = $cont; + } else { + $target = $annotation; + $annotation = ""; + } + + # Merging the annotation and the target + + $target =~ s/<\?xml [^?]*\?>//sg; + $target =~ s/]*>//sg; + $annotation =~ s/<\?xml [^?]*\?>//sg; + $annotation =~ s/]*>//sg; + my $merged = < + +$target + +$annotation + + +EOT + + # Answering the client + + my $res = new HTTP::Response; + $res->content($merged); + $c->send_response($res); + } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") { + my $filename = $cicuri; + $filename = $helm_dir."/dtd/".$filename; + print "DTD: $cicuri ==> ($filename)\n"; + if (stat($filename)) { + print "Using local copy\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + die "Could not find DTD!"; + } + } elsif ($http_method eq 'GET' and $http_path eq "/conf") { + my $quoted_html_link = $html_link; + $quoted_html_link =~ s/&/&/g; + $quoted_html_link =~ s//>/g; + $quoted_html_link =~ s/'/'/g; + $quoted_html_link =~ s/"/"/g; + print "Configuration requested, returned #$quoted_html_link#\n"; + $cont = "$quoted_html_link"; + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + print "INVALID REQUEST!!!!!\n"; + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + print "\nCONNECTION CLOSED\n\n"; + exit; + } # fork +} + +#================================ + +sub callback +{ + my ($data) = @_; + $cont .= $data; +} diff --git a/helm/interface/http_getter/http_getter.pl2 b/helm/interface/http_getter/http_getter.pl2 new file mode 100755 index 000000000..3adfa2be0 --- /dev/null +++ b/helm/interface/http_getter/http_getter.pl2 @@ -0,0 +1,199 @@ +#!/usr/bin/perl + +# next require defines: $helm_dir, $html_link +require "/usr/lib/helm/configuration.pl"; +use HTTP::Daemon; +use HTTP::Status; +use HTTP::Request; +use LWP::UserAgent; +use DB_File; + +my $cont = ""; +my $d = new HTTP::Daemon LocalPort => 8081; +tie(%map, 'DB_File', 'urls_of_uris.db', O_RDONLY, 0664); +print "Please contact me at: url, ">\n"; +print "helm_dir: $helm_dir\n"; +$SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes +while (my $c = $d->accept) { + if (fork() == 0) { + while (my $r = $c->get_request) { + #CSC: mancano i controlli di sicurezza + + $cont = ""; + my $cicuri = $r->url; + $cicuri =~ s/^[^?]*\?url=(.*)/$1/; + print "*".$r->url."\n"; + my $http_method = $r->method; + my $http_path = $r->url->path; + if ($http_method eq 'GET' and $http_path eq "/get") { + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + $filename = $helm_dir.$filename.".xml"; + my $resolved = $map{$cicuri}; + print "$cicuri ==> $resolved ($filename)\n"; + if (stat($filename)) { + print "Using local copy\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + print "Downloading\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file\n"; + open(FD, $filename); + print FD $cont; + close(FD); + + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } + } elsif ($http_method eq 'GET' and $http_path eq "/annotate") { + my $do_annotate = ($cicuri =~ /\.ann$/); + my $target_to_annotate = $cicuri; + $target_to_annotate =~ s/(.*)\.ann$/$1/ if $do_annotate; + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + my $filename_target = $helm_dir.$filename if $do_annotate; + $filename = $helm_dir.$filename.".xml"; + $filename_target =~ s/(.*)\.ann$/$1.xml/ if $do_annotate; + my $resolved = $map{$cicuri}; + my $resolved_target = $map{$target_to_annotate} if $do_annotate; + if ($do_annotate) { + print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n"; + } elsif ($http_method eq 'GET' and $http_path eq "/getwithtypes") { + my $do_annotate = ($cicuri =~ /\.types$/); + my $target_to_annotate = $cicuri; + $target_to_annotate =~ s/(.*)\.types$/$1/ if $do_annotate; + my $filename = $cicuri; + $filename =~ s/cic:(.*)/$1/; + $filename =~ s/theory:(.*)/$1/; + my $filename_target = $helm_dir.$filename if $do_annotate; + $filename = $helm_dir.$filename.".xml"; + $filename_target =~ s/(.*)\.types$/$1.xml/ if $do_annotate; + my $resolved = $map{$cicuri}; + my $resolved_target = $map{$target_to_annotate} if $do_annotate; + if ($do_annotate) { + print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n"; + } else { + print "$cicuri ==> $resolved ($filename)\n"; + } + + # Retrieves the annotation + + if (stat($filename)) { + print "Using local copy for the types\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the types\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved"); + $response = $ua->request($request, \&callback); + + print "Storing file for the types\n"; + open(FD, $filename); + print FD $cont; + close(FD); + } + my $annotation = $cont; + + # Retrieves the target to annotate + + $cont = ""; + if ($do_annotate) { + if (stat($filename_target)) { + print "Using local copy for the file to type\n"; + open(FD, $filename_target); + while() { $cont .= $_; } + close(FD); + } else { + print "Downloading the file to type\n"; + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => "$resolved_target"); + $response = $ua->request($request, \&callback); + + print "Storing file for the file to type\n"; + open(FD, $filename_target); + print FD $cont; + close(FD); + } + } + my $target = $cont; + + # Merging the annotation and the target + + $target =~ s/<\?xml [^?]*\?>//sg; + $target =~ s/]*>//sg; + $annotation =~ s/<\?xml [^?]*\?>//sg; + $annotation =~ s/]*>//sg; + my $merged = < + +$target + +$annotation + + +EOT + + # Answering the client + + my $res = new HTTP::Response; + $res->content($merged); + $c->send_response($res); + } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") { + my $filename = $cicuri; + $filename = $helm_dir."/dtd/".$filename; + print "DTD: $cicuri ==> ($filename)\n"; + if (stat($filename)) { + print "Using local copy\n"; + open(FD, $filename); + while() { $cont .= $_; } + close(FD); + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + die "Could not find DTD!"; + } + } elsif ($http_method eq 'GET' and $http_path eq "/conf") { + my $quoted_html_link = $html_link; + $quoted_html_link =~ s/&/&/g; + $quoted_html_link =~ s//>/g; + $quoted_html_link =~ s/'/'/g; + $quoted_html_link =~ s/"/"/g; + print "Configuration requested, returned #$quoted_html_link#\n"; + $cont = "$quoted_html_link"; + my $res = new HTTP::Response; + $res->content($cont); + $c->send_response($res); + } else { + print "INVALID REQUEST!!!!!\n"; + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + print "\nCONNECTION CLOSED\n\n"; + exit; + } # fork +} + +#================================ + +sub callback +{ + my ($data) = @_; + $cont .= $data; +} diff --git a/helm/interface/isterix b/helm/interface/isterix new file mode 100755 index 000000000..a1f696a3b --- /dev/null +++ b/helm/interface/isterix @@ -0,0 +1,12 @@ +#! /bin/sh + +export PATH=$PATH:/opt/java/jdk118/bin/ + +export CLASSPATH=. +export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xalan.jar +export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xerces.jar +export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/saxon-5.3.2/saxon.jar + +# Per (my)Coq 6.3.0 +export LD_LIBRARY_PATH=/home/lpadovan/helm/usr/lib/:$LD_LIBRARY_PATH +export LD_LIBRARY_PATH=/usr/local/lib/gtkmathview:$LD_LIBRARY_PATH diff --git a/helm/interface/javacore15005.txt b/helm/interface/javacore15005.txt new file mode 100644 index 000000000..992096462 --- /dev/null +++ b/helm/interface/javacore15005.txt @@ -0,0 +1,195 @@ +SIGSEGV received at bfffeacc in /home/cadet/sacerdot/jdk118/lib/linux/native_threads/libjitc.so. Processing terminated +java full version "JDK 1.1.8 IBM build l118-19991013 (JIT enabled: jitc)" +args: /home/cadet/sacerdot/jdk118/bin/linux/native_threads/java xaland 12345 12346 examples/style/annotatedcont.xsl examples/style/annotatedpres.xsl examples/style/theory_content.xsl examples/style/theory_pres.xsl + +Operating Environment +--------------------- +Host : cadet. +OS Level : 2.2.14-5.0smp.#1 SMP Tue Mar 7 21:01:40 EST 2000 +glibc Version : 2.1.3 +No. of Procs : 1 +Memory Info: + total: used: free: shared: buffers: cached: +Mem: 64503808 55078912 9424896 36126720 1527808 18075648 +Swap: 133885952 7442432 126443520 +MemTotal: 62992 kB +MemFree: 9204 kB +MemShared: 35280 kB +Buffers: 1492 kB +Cached: 17652 kB +BigTotal: 0 kB +BigFree: 0 kB +SwapTotal: 130748 kB +SwapFree: 123480 kB + +Application Environment +----------------------- +Signal Handlers - + SIGQUIT : ignored + SIGILL : sysThreadIDump (libjava.so) + SIGABRT : sysThreadIDump (libjava.so) + SIGFPE : sysThreadIDump (libjava.so) + SIGBUS : sysThreadIDump (libjava.so) + SIGSEGV : sysThreadIDump (libjava.so) + SIGPIPE : ignored + SIGUSR1 : doSuspendLoop (libjava.so) + +Environment Variables - + LESSOPEN=|/usr/bin/lesspipe.sh %s + SAL_DO_NOT_USE_INVERT50=true + HISTSIZE=1000 + HOSTNAME=cadet + LOGNAME=sacerdot + VISUAL=/usr/bin/emacs + LD_LIBRARY_PATH=/home/cadet/sacerdot/jdk118/lib/linux/native_threads:/usr/local/lib/gtkmathview:/home/pauillac/coq3/sacerdot/rvplayer5.0 + MAIL=/var/spool/mail/sacerdot + PAGER=less + CLASSPATH=.:/usr/share/java/bsf.jar:/usr/share/java/xalan.jar:/usr/share/java/xerces.jar:/home/cadet/sacerdot/jdk118/classes:/home/cadet/sacerdot/jdk118/lib/classes.jar:/home/cadet/sacerdot/jdk118/lib/rt.jar:/home/cadet/sacerdot/jdk118/lib/i18n.jar:/home/cadet/sacerdot/jdk118/lib/classes.zip + LESSCHARDEF=8bcccbcc18b95.33b. + ARCH=i586 + PROMPT=cad: + TERM=xterm + HOSTTYPE=i386 + PATH=/home/cadet/sacerdot/jdk118/bin:/home/pauillac/coq3/sacerdot/bin/i586:/home/pauillac/coq3/sacerdot/bin:/usr/bin/X11:/usr/bin:/usr/local/bin:/usr/ucb:/usr/bin:/bin:/usr/sbin:/sbin:/usr/games:. + PRINTER=hp11rv + HOME=/home/pauillac/coq3/sacerdot + SHELL=/bin/sh + ELANLIB=/home/pauillac/coq3/sacerdot/elan-dist.3.00/elanlib + PILOTPORT=/dev/ttyS1 + TEXINPUTS=:.:/home/pauillac/coq3/sacerdot/lib/latex/inputs:/usr/local/lib/tex/inputs3 + USER=sacerdot + ENSCRIPT=-Php11rvl -2 -r -B -L66 -k -h + MANPATH=/usr/man/preformat:/usr/man:/usr/X11/man:/usr/local/man:/home/pauillac/coq3/sacerdot/man + LESS=-m -e -q -d + JAVA_HOME=/home/cadet/sacerdot/jdk118 + DISPLAY=:0.0 + MAKEFLAGS= + HOST=cadet + OSTYPE=Linux + NNTPSERVER=news-rocq.inria.fr + WINDOWID=54525966 + SHLVL=4 + MAKELEVEL=1 + LS_COLORS=no=00:fi=00:di=01;34:ln=01;36:pi=40;33:so=01;35:bd=40;33;01:cd=40;33;01:or=01;05;37;41:mi=01;05;37;41:ex=01;32:*.cmd=01;32:*.exe=01;32:*.com=01;32:*.btm=01;32:*.bat=01;32:*.sh=01;32:*.csh=01;32:*.tar=01;31:*.tgz=01;31:*.arj=01;31:*.taz=01;31:*.lzh=01;31:*.zip=01;31:*.z=01;31:*.Z=01;31:*.gz=01;31:*.bz2=01;31:*.bz=01;31:*.tz=01;31:*.rpm=01;31:*.cpio=01;31:*.jpg=01;35:*.gif=01;35:*.bmp=01;35:*.xbm=01;35:*.xpm=01;35:*.png=01;35:*.tif=01;35: + EDITOR=/usr/bin/emacs + MFLAGS= + CVSROOT=/net/pauillac/constr/ARCHIVE + + +Current Thread Details +---------------------- + "main" (TID:0x402e62d8, sys_thread_t:0x804abe0) + Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING + Native Stack Data : base: bffff47c pointer bffbf96c used(260880) free(-13072) + ----- Monitors held ----- + ----- Native stack ----- + + + + + + + + + ?? + ?? + ?? + + java_lang_Compiler_start + + __irem_trap6 + ------ Java stack ------ () prio=5 *current thread* + org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + xaland.main(Compiled Code) +---------------------------------------------------------------------- + + +Total Thread Count: 3 +Active Thread Count: 3 +JNI Thread Count: 0 + +Full thread dump: + "Async Garbage Collector" (TID:0x402e6238, sys_thread_t:0x8091f50) + Native Thread State: ThreadID: 00000803 Reuse: 1 DAEMON MONITOR WAIT + Native Stack Data : base: bf5ffd84 pointer bf5ffb78 used(524) free(247284) + ----- Monitors held ----- + ----- Native stack ----- + sysMonitorWait + sysThreadSleep + threadSleep + SetOrigArgs + sysThread_shell + pthread_detach + __clone + ------ Java stack ------ () prio=1 +---------------------------------------------------------------------- + + "Finalizer thread" (TID:0x402e6288, sys_thread_t:0x8091cd0) + Native Thread State: ThreadID: 00000402 Reuse: 1 DAEMON MONITOR WAIT + Native Stack Data : base: bf7ffd84 pointer bf7ffbec used(408) free(247400) + ----- Monitors held ----- + ----- Native stack ----- + sysMonitorWait - waiting on Finalize me queue lock + finalizeOnExit + sysThread_shell + pthread_detach + __clone + ------ Java stack ------ () prio=1 +---------------------------------------------------------------------- + + "main" (TID:0x402e62d8, sys_thread_t:0x804abe0) + Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING + Native Stack Data : base: bffff47c pointer bffbf960 used(260892) free(-13084) + ----- Monitors held ----- + ----- Native stack ----- + + + + + + + + + ?? + ?? + ?? + + java_lang_Compiler_start + + __irem_trap6 + ------ Java stack ------ () prio=5 *current thread* + org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + xaland.main(Compiled Code) +---------------------------------------------------------------------- + + +System Monitor Status +--------------------- + JIT monitor: unowned. + JIT monitor: unowned. + JIT monitor: unowned. + JIT monitor: unowned. + JIT monitor: unowned. + Thread queue lock: unowned. + Name and type hash table lock: unowned. + String intern lock: unowned. + JNI pinning lock: unowned. + JNI global reference lock: unowned. + Zip lock: unowned. + BinClass lock: unowned. + Class loading lock: unowned. + Java stack lock: unowned. + Code rewrite lock: unowned. + Heap Lock: unowned. + Has finalization queue lock: unowned. + Finalize me queue lock: unowned. + Integer lock access-lock: unowned. + Monitor cache lock: unowned. + Monitor registry: unowned. + +Object Monitor Status +--------------------- diff --git a/helm/interface/javacore15021.txt b/helm/interface/javacore15021.txt new file mode 100644 index 000000000..bac0b8a76 --- /dev/null +++ b/helm/interface/javacore15021.txt @@ -0,0 +1,195 @@ +SIGSEGV received at bfffeacc in /home/cadet/sacerdot/jdk118/lib/linux/native_threads/libjitc.so. Processing terminated +java full version "JDK 1.1.8 IBM build l118-19991013 (JIT enabled: jitc)" +args: /home/cadet/sacerdot/jdk118/bin/linux/native_threads/java xaland 12345 12346 examples/style/annotatedcont.xsl examples/style/annotatedpres.xsl examples/style/theory_content.xsl examples/style/theory_pres.xsl + +Operating Environment +--------------------- +Host : cadet. +OS Level : 2.2.14-5.0smp.#1 SMP Tue Mar 7 21:01:40 EST 2000 +glibc Version : 2.1.3 +No. of Procs : 1 +Memory Info: + total: used: free: shared: buffers: cached: +Mem: 64503808 55672832 8830976 36130816 1536000 18612224 +Swap: 133885952 7442432 126443520 +MemTotal: 62992 kB +MemFree: 8624 kB +MemShared: 35284 kB +Buffers: 1500 kB +Cached: 18176 kB +BigTotal: 0 kB +BigFree: 0 kB +SwapTotal: 130748 kB +SwapFree: 123480 kB + +Application Environment +----------------------- +Signal Handlers - + SIGQUIT : ignored + SIGILL : sysThreadIDump (libjava.so) + SIGABRT : sysThreadIDump (libjava.so) + SIGFPE : sysThreadIDump (libjava.so) + SIGBUS : sysThreadIDump (libjava.so) + SIGSEGV : sysThreadIDump (libjava.so) + SIGPIPE : ignored + SIGUSR1 : doSuspendLoop (libjava.so) + +Environment Variables - + LESSOPEN=|/usr/bin/lesspipe.sh %s + SAL_DO_NOT_USE_INVERT50=true + HISTSIZE=1000 + HOSTNAME=cadet + LOGNAME=sacerdot + VISUAL=/usr/bin/emacs + LD_LIBRARY_PATH=/home/cadet/sacerdot/jdk118/lib/linux/native_threads:/usr/local/lib/gtkmathview:/home/pauillac/coq3/sacerdot/rvplayer5.0 + MAIL=/var/spool/mail/sacerdot + PAGER=less + CLASSPATH=.:/usr/share/java/bsf.jar:/usr/share/java/xalan.jar:/usr/share/java/xerces.jar:/home/cadet/sacerdot/jdk118/classes:/home/cadet/sacerdot/jdk118/lib/classes.jar:/home/cadet/sacerdot/jdk118/lib/rt.jar:/home/cadet/sacerdot/jdk118/lib/i18n.jar:/home/cadet/sacerdot/jdk118/lib/classes.zip + LESSCHARDEF=8bcccbcc18b95.33b. + ARCH=i586 + PROMPT=cad: + TERM=xterm + HOSTTYPE=i386 + PATH=/home/cadet/sacerdot/jdk118/bin:/home/pauillac/coq3/sacerdot/bin/i586:/home/pauillac/coq3/sacerdot/bin:/usr/bin/X11:/usr/bin:/usr/local/bin:/usr/ucb:/usr/bin:/bin:/usr/sbin:/sbin:/usr/games:. + PRINTER=hp11rv + HOME=/home/pauillac/coq3/sacerdot + SHELL=/bin/sh + ELANLIB=/home/pauillac/coq3/sacerdot/elan-dist.3.00/elanlib + PILOTPORT=/dev/ttyS1 + TEXINPUTS=:.:/home/pauillac/coq3/sacerdot/lib/latex/inputs:/usr/local/lib/tex/inputs3 + USER=sacerdot + ENSCRIPT=-Php11rvl -2 -r -B -L66 -k -h + MANPATH=/usr/man/preformat:/usr/man:/usr/X11/man:/usr/local/man:/home/pauillac/coq3/sacerdot/man + LESS=-m -e -q -d + JAVA_HOME=/home/cadet/sacerdot/jdk118 + DISPLAY=:0.0 + MAKEFLAGS= + HOST=cadet + OSTYPE=Linux + NNTPSERVER=news-rocq.inria.fr + WINDOWID=54525966 + SHLVL=4 + MAKELEVEL=1 + LS_COLORS=no=00:fi=00:di=01;34:ln=01;36:pi=40;33:so=01;35:bd=40;33;01:cd=40;33;01:or=01;05;37;41:mi=01;05;37;41:ex=01;32:*.cmd=01;32:*.exe=01;32:*.com=01;32:*.btm=01;32:*.bat=01;32:*.sh=01;32:*.csh=01;32:*.tar=01;31:*.tgz=01;31:*.arj=01;31:*.taz=01;31:*.lzh=01;31:*.zip=01;31:*.z=01;31:*.Z=01;31:*.gz=01;31:*.bz2=01;31:*.bz=01;31:*.tz=01;31:*.rpm=01;31:*.cpio=01;31:*.jpg=01;35:*.gif=01;35:*.bmp=01;35:*.xbm=01;35:*.xpm=01;35:*.png=01;35:*.tif=01;35: + EDITOR=/usr/bin/emacs + MFLAGS= + CVSROOT=/net/pauillac/constr/ARCHIVE + + +Current Thread Details +---------------------- + "main" (TID:0x402e62d8, sys_thread_t:0x804abe0) + Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING + Native Stack Data : base: bffff47c pointer bffbf96c used(260880) free(-13072) + ----- Monitors held ----- + ----- Native stack ----- + + + + + + + + + ?? + ?? + ?? + + java_lang_Compiler_start + + __irem_trap6 + ------ Java stack ------ () prio=5 *current thread* + org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + xaland.main(Compiled Code) +---------------------------------------------------------------------- + + +Total Thread Count: 3 +Active Thread Count: 3 +JNI Thread Count: 0 + +Full thread dump: + "Async Garbage Collector" (TID:0x402e6238, sys_thread_t:0x8091f50) + Native Thread State: ThreadID: 00000803 Reuse: 1 DAEMON MONITOR WAIT + Native Stack Data : base: bf5ffd84 pointer bf5ffb78 used(524) free(247284) + ----- Monitors held ----- + ----- Native stack ----- + sysMonitorWait + sysThreadSleep + threadSleep + SetOrigArgs + sysThread_shell + pthread_detach + __clone + ------ Java stack ------ () prio=1 +---------------------------------------------------------------------- + + "Finalizer thread" (TID:0x402e6288, sys_thread_t:0x8091cd0) + Native Thread State: ThreadID: 00000402 Reuse: 1 DAEMON MONITOR WAIT + Native Stack Data : base: bf7ffd84 pointer bf7ffbec used(408) free(247400) + ----- Monitors held ----- + ----- Native stack ----- + sysMonitorWait - waiting on Finalize me queue lock + finalizeOnExit + sysThread_shell + pthread_detach + __clone + ------ Java stack ------ () prio=1 +---------------------------------------------------------------------- + + "main" (TID:0x402e62d8, sys_thread_t:0x804abe0) + Native Thread State: ThreadID: 00000400 Reuse: 1 USER PRIMORDIAL RUNNING + Native Stack Data : base: bffff47c pointer bffbf960 used(260892) free(-13084) + ----- Monitors held ----- + ----- Native stack ----- + + + + + + + + + ?? + ?? + ?? + + java_lang_Compiler_start + + __irem_trap6 + ------ Java stack ------ () prio=5 *current thread* + org.apache.xalan.xslt.XSLTEngineImpl.createStylesheetRoot(XSLTEngineImpl.java:715) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + org.apache.xalan.xslt.XSLTEngineImpl.processStylesheet(Compiled Code) + xaland.main(Compiled Code) +---------------------------------------------------------------------- + + +System Monitor Status +--------------------- + JIT monitor: unowned. + JIT monitor: unowned. + JIT monitor: unowned. + JIT monitor: unowned. + JIT monitor: unowned. + Thread queue lock: unowned. + Name and type hash table lock: unowned. + String intern lock: unowned. + JNI pinning lock: unowned. + JNI global reference lock: unowned. + Zip lock: unowned. + BinClass lock: unowned. + Class loading lock: unowned. + Java stack lock: unowned. + Code rewrite lock: unowned. + Heap Lock: unowned. + Has finalization queue lock: unowned. + Finalize me queue lock: unowned. + Integer lock access-lock: unowned. + Monitor cache lock: unowned. + Monitor registry: unowned. + +Object Monitor Status +--------------------- diff --git a/helm/interface/latinize.pl b/helm/interface/latinize.pl new file mode 100755 index 000000000..7fa678736 --- /dev/null +++ b/helm/interface/latinize.pl @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +while() +{ + s/→/->/g; + s/⇒/=>/g; + s/λ/\\/g; + s/Π/||/g; + print; +} diff --git a/helm/interface/mkindex.sh b/helm/interface/mkindex.sh new file mode 100755 index 000000000..b47864fae --- /dev/null +++ b/helm/interface/mkindex.sh @@ -0,0 +1,3 @@ +#!/bin/bash + +echo `find . -name "*.xml"` | /really_very_local/helm/PARSER/coq_like_pretty_printer/uris_of_filenames.pl > index.txt diff --git a/helm/interface/mml.dtd b/helm/interface/mml.dtd new file mode 100644 index 000000000..10ce5cb5d --- /dev/null +++ b/helm/interface/mml.dtd @@ -0,0 +1,55 @@ + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/interface/mml.ml b/helm/interface/mml.ml new file mode 100644 index 000000000..88c281350 --- /dev/null +++ b/helm/interface/mml.ml @@ -0,0 +1,11 @@ +type expr = + Null + | Mi of string + | Mo of string + | Mn of string + | Mtext of string + | Mrow of expr list + | Mfenced of string * string * string * expr list (* open, close, separators *) +type fragment = + Math of expr list +;; diff --git a/helm/interface/mmlinterface.ml b/helm/interface/mmlinterface.ml new file mode 100755 index 000000000..76f6e5a78 --- /dev/null +++ b/helm/interface/mmlinterface.ml @@ -0,0 +1,653 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This is a simple gtk interface to the Coq-like pretty printer cicPp for *) +(* cic terms exported in xml. It uses directly the modules cicPp and *) +(* cicCcache and indirectly all the other modules (cicParser, cicParser2, *) +(* cicParser3, getter). *) +(* The syntax is "gtkInterface[.opt] filename1 ... filenamen" where *) +(* filenamei is the path-name of an xml file describing a cic term. *) +(* The terms are loaded in cache and then pretty-printed one at a time and *) +(* only once, when the user wants to look at it: if the user wants to look at *) +(* a term again, then the pretty-printed term is showed again, but not *) +(* recomputed *) +(* *) +(******************************************************************************) + +(* DEFINITION OF THE URI TREE AND USEFUL FUNCTIONS ON IT *) + +type item = + Dir of string * item list ref + | File of string * UriManager.uri +;; + +let uritree = ref [] +let theoryuritree = ref [] + +let get_name = + function + Dir (name,_) -> name + | File (name,_) -> name +;; + +let get_uri = + function + Dir _ -> None + | File (_,uri) -> Some uri +;; + +(* STUFF TO BUILD THE URI TREE *) + +exception EmptyUri +exception DuplicatedUri +exception ConflictingUris + +let insert_in_uri_tree uri = + let rec aux l = + function + [name] -> + (try + let _ = List.find (fun item -> name = get_name item) !l in + raise DuplicatedUri + with + Not_found -> l := (File (name,uri))::!l + ) + | name::tl -> + (try + match List.find (fun item -> name = get_name item) !l with + Dir (_,children) -> aux children tl + | File _ -> raise ConflictingUris + with + Not_found -> + let children = ref [] in + l := (Dir (name,children))::!l ; + aux children tl + ) + | [] -> raise EmptyUri + in + aux +;; + +(* Imperative procedure that builds the two uri trees *) +let build_uri_tree () = + let dbh = Dbm.opendbm Configuration.uris_dbm [Dbm.Dbm_rdonly] 0 in + Dbm.iter + (fun uri _ -> + let cicregexp = Str.regexp "cic:" + and theoryregexp = Str.regexp "theory:" in + if Str.string_match cicregexp uri 0 then + let s = Str.replace_first cicregexp "" uri in + let l = Str.split (Str.regexp "/") s in + insert_in_uri_tree (UriManager.uri_of_string uri) uritree l + else if Str.string_match theoryregexp uri 0 then + let s = Str.replace_first theoryregexp "" uri in + let l = Str.split (Str.regexp "/") s in + insert_in_uri_tree (UriManager.uri_of_string uri) theoryuritree l + ) dbh ; + Dbm.close dbh +;; + +(* GLOBAL REFERENCES (USED BY CALLBACKS) *) + +let annotated_obj = ref None;; (* reference to a couple option where *) + (* the first component is the current *) + (* annotated object and the second is *) + (* the map from ids to annotated targets *) +let ann = ref (ref None);; (* current annotation *) +let radio_some_status = ref false;; (* is the radio_some button selected? *) + +let theory_visited_uris = ref [];; +let theory_to_visit_uris = ref [];; +let visited_uris = ref [];; +let to_visit_uris = ref [];; + +(* CALLBACKS *) + +exception NoCurrentUri;; +exception NoNextOrPrevUri;; +exception GtkInterfaceInternalError;; + +let theory_get_current_uri () = + match !theory_visited_uris with + [] -> raise NoCurrentUri + | uri::_ -> uri +;; + +let get_current_uri () = + match !visited_uris with + [] -> raise NoCurrentUri + | uri::_ -> uri +;; + +let get_annotated_obj () = + match !annotated_obj with + None -> + let (annobj, ids_to_targets,_) = + (CicCache.get_annobj (get_current_uri ())) + in + annotated_obj := Some (annobj, ids_to_targets) ; + (annobj, ids_to_targets) + | Some annobj -> annobj +;; + +let filename_of_uri uri = + Getter.get uri +;; + +let theory_update_output rendering_window uri = + rendering_window#label#set_text (UriManager.string_of_uri uri) ; + ignore (rendering_window#errors#delete_text 0 rendering_window#errors#length) ; + let mmlfile = XsltProcessor.process uri true "theory" in + rendering_window#output#load mmlfile +;; + +let update_output rendering_window uri = + rendering_window#label#set_text (UriManager.string_of_uri uri) ; + ignore (rendering_window#errors#delete_text 0 rendering_window#errors#length) ; + let mmlfile = XsltProcessor.process uri true "cic" in + rendering_window#output#load mmlfile +;; + +let theory_next rendering_window () = + match !theory_to_visit_uris with + [] -> raise NoNextOrPrevUri + | uri::tl -> + theory_to_visit_uris := tl ; + theory_visited_uris := uri::!theory_visited_uris ; + theory_update_output rendering_window uri ; + rendering_window#prevb#misc#set_sensitive true ; + if tl = [] then + rendering_window#nextb#misc#set_sensitive false +;; + +let next rendering_window () = + match !to_visit_uris with + [] -> raise NoNextOrPrevUri + | uri::tl -> + to_visit_uris := tl ; + visited_uris := uri::!visited_uris ; + annotated_obj := None ; + update_output rendering_window uri ; + rendering_window#prevb#misc#set_sensitive true ; + if tl = [] then + rendering_window#nextb#misc#set_sensitive false +;; + +let theory_prev rendering_window () = + match !theory_visited_uris with + [] -> raise NoCurrentUri + | [_] -> raise NoNextOrPrevUri + | uri::(uri'::tl as newvu) -> + theory_visited_uris := newvu ; + theory_to_visit_uris := uri::!theory_to_visit_uris ; + theory_update_output rendering_window uri' ; + rendering_window#nextb#misc#set_sensitive true ; + if tl = [] then + rendering_window#prevb#misc#set_sensitive false +;; + +let prev rendering_window () = + match !visited_uris with + [] -> raise NoCurrentUri + | [_] -> raise NoNextOrPrevUri + | uri::(uri'::tl as newvu) -> + visited_uris := newvu ; + to_visit_uris := uri::!to_visit_uris ; + annotated_obj := None ; + update_output rendering_window uri' ; + rendering_window#nextb#misc#set_sensitive true ; + if tl = [] then + rendering_window#prevb#misc#set_sensitive false +;; + +(* called when an hyperlink is clicked *) +let jump rendering_window s = + let uri = UriManager.uri_of_string s in + rendering_window#show () ; + rendering_window#prevb#misc#set_sensitive true ; + rendering_window#nextb#misc#set_sensitive false ; + visited_uris := uri::!visited_uris ; + to_visit_uris := [] ; + annotated_obj := None ; + update_output rendering_window uri +;; + +let changefont rendering_window () = + rendering_window#output#set_font_size rendering_window#spinb#value_as_int +;; + + +let theory_selection_changed rendering_window uri () = + match uri with + None -> () + | Some uri' -> + if !theory_visited_uris <> [] then + rendering_window#prevb#misc#set_sensitive true ; + rendering_window#nextb#misc#set_sensitive false ; + theory_visited_uris := uri'::!theory_visited_uris ; + theory_to_visit_uris := [] ; + rendering_window#show () ; + theory_update_output rendering_window uri' +;; + +let selection_changed rendering_window uri () = + match uri with + None -> () + | Some uri' -> + if !visited_uris <> [] then + rendering_window#prevb#misc#set_sensitive true ; + rendering_window#nextb#misc#set_sensitive false ; + visited_uris := uri'::!visited_uris ; + to_visit_uris := [] ; + annotated_obj := None ; + rendering_window#show () ; + update_output rendering_window uri' +;; + +(* CSC: unificare con la creazione la prima volta *) +let rec updateb_pressed theory_rendering_window rendering_window + (sw1, sw ,(hbox : GPack.box)) mktree () += + Getter.update () ; + (* let's empty the uri trees and rebuild them *) + uritree := [] ; + theoryuritree := [] ; + build_uri_tree () ; + hbox#remove !sw1#coerce ; + hbox#remove !sw#coerce ; + + let sw3 = + GBin.scrolled_window ~width:250 ~height:600 + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let tree1 = + GTree.tree ~selection_mode:`BROWSE ~packing:sw3#add_with_viewport () in + let tree_item1 = GTree.tree_item ~label:"theory:/" ~packing:tree1#append () in + sw1 := sw3 ; + ignore(tree_item1#connect#select + (theory_selection_changed theory_rendering_window None)) ; + mktree theory_selection_changed theory_rendering_window tree_item1 + (Dir ("theory:/",theoryuritree)) ; + + let sw2 = + GBin.scrolled_window ~width:250 ~height:600 + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let tree = + GTree.tree ~selection_mode:`BROWSE ~packing:sw2#add_with_viewport () in + let tree_item = GTree.tree_item ~label:"cic:/" ~packing:tree#append () in + sw := sw2 ; + ignore(tree_item#connect#select (selection_changed rendering_window None)) ; + mktree selection_changed rendering_window tree_item (Dir ("cic:/",uritree)) +;; + +let theory_check rendering_window () = + let output = + try + TheoryTypeChecker.typecheck (theory_get_current_uri ()); + "Type Checking was successful" + with + TheoryTypeChecker.NotWellTyped s -> + "Type Checking was NOT successful:\n\t" ^ s + in + (* next "cast" can't got rid of, but I don't know why *) + let errors = (rendering_window#errors : GEdit.text) in + let _ = errors#delete_text 0 errors#length in + errors#insert output +;; + +let check rendering_window () = + let output = + try + CicTypeChecker.typecheck (get_current_uri ()); + "Type Checking was successful" + with + CicTypeChecker.NotWellTyped s -> "Type Checking was NOT successful:\n\t" ^ s + in + (* next "cast" can't got rid of, but I don't know why *) + let errors = (rendering_window#errors : GEdit.text) in + let _ = errors#delete_text 0 errors#length in + errors#insert output +;; + +let annotateb_pressed rendering_window annotation_window () = + let xpath = (rendering_window#output#get_selection : string option) in + match xpath with + None -> (rendering_window#errors : GEdit.text)#insert "\nNo selection!\n" + | Some xpath -> + try + let annobj = get_annotated_obj () + (* next "cast" can't got rid of, but I don't know why *) + and annotation = (annotation_window#annotation : GEdit.text) in + ann := CicXPath.get_annotation annobj xpath ; + CicAnnotationHinter.create_hints annotation_window annobj xpath ; + annotation#delete_text 0 annotation#length ; + begin + match !(!ann) with + None -> + annotation#misc#set_sensitive false ; + annotation_window#radio_none#set_active true ; + radio_some_status := false + | Some ann' -> + annotation#insert ann' ; + annotation#misc#set_sensitive true ; + annotation_window#radio_some#set_active true ; + radio_some_status := true + end ; + GMain.Grab.add (annotation_window#window_to_annotate#coerce) ; + annotation_window#show () ; + with + e -> + (* next "cast" can't got rid of, but I don't know why *) + let errors = (rendering_window#errors : GEdit.text) in + errors#insert ("\n" ^ Printexc.to_string e ^ "\n") +;; + +(* called when the annotation is confirmed *) +let save_annotation annotation = + if !radio_some_status then + !ann := Some (annotation#get_chars 0 annotation#length) + else + !ann := None ; + match !annotated_obj with + None -> raise GtkInterfaceInternalError + | Some (annobj,_) -> + let uri = get_current_uri () in + let annxml = Annotation2Xml.pp_annotation annobj uri in + Xml.pp annxml (Some (fst (Getter.get_ann_file_name_and_uri uri))) +;; + +let parse_no_cache uri = + let module U = UriManager in + XsltProcessor.process uri false "cic" +;; + + +(* STUFF TO BUILD THE GTK INTERFACE *) + +(* Stuff to build the tree window *) + +(* selection_changed is actually selection_changed or theory_selection_changed*) +let mktree selection_changed rendering_window = + let rec aux treeitem = + function + Dir (dirname, content) -> + let subtree = GTree.tree () in + treeitem#set_subtree subtree ; + List.iter + (fun ti -> + let label = get_name ti + and uri = get_uri ti in + let treeitem2 = GTree.tree_item ~label:label () in + subtree#append treeitem2 ; + ignore(treeitem2#connect#select + (selection_changed rendering_window uri)) ; + aux treeitem2 ti + ) !content + | _ -> () + in + aux +;; + +class annotation_window output label = + let window_to_annotate = + GWindow.window ~title:"Annotating environment" ~border_width:2 () in + let hbox1 = + GPack.hbox ~packing:window_to_annotate#add () in + let vbox1 = + GPack.vbox ~packing:(hbox1#pack ~padding:5) () in + let hbox2 = + GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in + let radio_some = GButton.radio_button ~label:"Annotation below" + ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in + let radio_none = GButton.radio_button ~label:"No annotation" + ~group:radio_some#group + ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) + ~active:true () in + let annotation = GEdit.text ~editable:true ~width:400 ~height:180 + ~packing:(vbox1#pack ~padding:5) () in + let table = + GPack.table ~rows:3 ~columns:3 ~packing:(vbox1#pack ~padding:5) () in + let annotation_hints = + Array.init 9 + (function i -> + GButton.button ~label:("Hint " ^ string_of_int i) + ~packing:(table#attach ~left:(i mod 3) ~top:(i / 3)) () + ) in + let vbox2 = + GPack.vbox ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in + let confirmb = + GButton.button ~label:"O.K." + ~packing:(vbox2#pack ~expand:false ~fill:false ~padding:5) () in + let abortb = + GButton.button ~label:"Abort" + ~packing:(vbox2#pack ~expand:false ~fill:false ~padding:5) () in +object (self) + method window_to_annotate = window_to_annotate + method annotation = annotation + method radio_some = radio_some + method radio_none = radio_none + method annotation_hints = annotation_hints + method output = (output : GMathView.math_view) + method show () = window_to_annotate#show () + initializer + (* signal handlers here *) + ignore (window_to_annotate#event#connect#delete + (fun _ -> + window_to_annotate#misc#hide () ; + GMain.Grab.remove (window_to_annotate#coerce) ; + true + )) ; + ignore (confirmb#connect#clicked + (fun () -> + window_to_annotate#misc#hide () ; + save_annotation annotation ; + GMain.Grab.remove (window_to_annotate#coerce) ; + let new_current_uri = + (snd (Getter.get_ann_file_name_and_uri (get_current_uri ()))) + in + visited_uris := new_current_uri::(List.tl !visited_uris) ; + label#set_text (UriManager.string_of_uri new_current_uri) ; + output#load (parse_no_cache new_current_uri) + )) ; + ignore (abortb#connect#clicked + (fun () -> + window_to_annotate#misc#hide () ; + GMain.Grab.remove (window_to_annotate#coerce) + )); + ignore (radio_some#connect#clicked + (fun () -> annotation#misc#set_sensitive true ; radio_some_status := true)) ; + ignore (radio_none #connect#clicked + (fun () -> + annotation#misc#set_sensitive false; + radio_some_status := false) + ) +end;; + +class rendering_window annotation_window output (label : GMisc.label) = + let window = + GWindow.window ~title:"MathML viewer" ~border_width:2 () in + let vbox = + GPack.vbox ~packing:window#add () in + let _ = vbox#pack ~expand:false ~fill:false ~padding:5 label#coerce in + let paned = + GPack.paned `HORIZONTAL ~packing:(vbox#pack ~padding:5) () in + let scrolled_window0 = + GBin.scrolled_window ~border_width:10 ~packing:paned#add1 () in + let _ = scrolled_window0#add output#coerce in + let scrolled_window = + GBin.scrolled_window + ~border_width:10 ~packing:paned#add2 ~width:240 ~height:100 () in + let errors = GEdit.text ~packing:scrolled_window#add_with_viewport () in + let hbox = + GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in + let prevb = + GButton.button ~label:"Prev" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let nextb = + GButton.button ~label:"Next" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let checkb = + GButton.button ~label:"Check" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let annotateb = + GButton.button ~label:"Annotate" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let spinb = + let sadj = + GData.adjustment ~value:14.0 ~lower:5.0 ~upper:50.0 ~step_incr:1.0 () + in + GEdit.spin_button + ~adjustment:sadj ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) + () in + let closeb = + GButton.button ~label:"Close" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in +object(self) + method nextb = nextb + method prevb = prevb + method label = label + method spinb = spinb + method output = (output : GMathView.math_view) + method errors = errors + method show () = window#show () + initializer + nextb#misc#set_sensitive false ; + prevb#misc#set_sensitive false ; + + (* signal handlers here *) + ignore(output#connect#jump (jump self)) ; + ignore(nextb#connect#clicked (next self)) ; + ignore(prevb#connect#clicked (prev self)) ; + ignore(checkb#connect#clicked (check self)) ; + ignore(spinb#connect#changed (changefont self)) ; + ignore(closeb#connect#clicked window#misc#hide) ; + ignore(annotateb#connect#clicked (annotateb_pressed self annotation_window)) ; + ignore(window#event#connect#delete (fun _ -> window#misc#hide () ; true )) +end;; + +class theory_rendering_window rendering_window = + let window = + GWindow.window ~title:"MathML theory viewer" ~border_width:2 () in + let vbox = + GPack.vbox ~packing:window#add () in + let label = + GMisc.label ~text:"???" + ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in + let paned = + GPack.paned `HORIZONTAL ~packing:(vbox#pack ~padding:5) () in + let scrolled_window0 = + GBin.scrolled_window ~border_width:10 ~packing:paned#add1 () in + let output = + GMathView.math_view ~width:400 ~height:380 ~packing:scrolled_window0#add () in + let scrolled_window = + GBin.scrolled_window + ~border_width:10 ~packing:paned#add2 ~width:240 ~height:100 () in + let errors = GEdit.text ~packing:scrolled_window#add_with_viewport () in + let hbox = + GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in + let prevb = + GButton.button ~label:"Prev" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let nextb = + GButton.button ~label:"Next" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let checkb = + GButton.button ~label:"Check" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let spinb = + let sadj = + GData.adjustment ~value:14.0 ~lower:5.0 ~upper:50.0 ~step_incr:1.0 () + in + GEdit.spin_button + ~adjustment:sadj ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) + () in + let closeb = + GButton.button ~label:"Close" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in +object(self) + method nextb = nextb + method prevb = prevb + method label = label + method output = (output : GMathView.math_view) + method errors = errors + method spinb = spinb + method show () = window#show () + initializer + nextb#misc#set_sensitive false ; + prevb#misc#set_sensitive false ; + + (* signal handlers here *) + ignore(output#connect#jump (jump rendering_window)) ; + ignore(nextb#connect#clicked (theory_next self)) ; + ignore(prevb#connect#clicked (theory_prev self)) ; + ignore(checkb#connect#clicked (theory_check self)) ; + ignore(spinb#connect#changed (changefont self)) ; + ignore(closeb#connect#clicked window#misc#hide) ; + ignore(window#event#connect#delete (fun _ -> window#misc#hide () ; true )) +end;; + +(* CSC: fare in modo che i due alberi vengano svuotati invece che distrutti *) +class selection_window theory_rendering_window rendering_window = + let label = "cic:/" in + let theorylabel = "theory:/" in + let win = GWindow.window ~title:"Known uris" ~border_width:2 () in + let vbox = GPack.vbox ~packing:win#add () in + let hbox1 = GPack.hbox ~packing:(vbox#pack ~padding:5) () in + let sw1 = GBin.scrolled_window ~width:250 ~height:600 + ~packing:(hbox1#pack ~padding:5) () in + let tree1 = + GTree.tree ~selection_mode:`BROWSE ~packing:sw1#add_with_viewport () in + let tree_item1 = + GTree.tree_item ~label:theorylabel ~packing:tree1#append () in + let sw = GBin.scrolled_window ~width:250 ~height:600 + ~packing:(hbox1#pack ~padding:5) () in + let tree = + GTree.tree ~selection_mode:`BROWSE ~packing:sw#add_with_viewport () in + let tree_item = + GTree.tree_item ~label:label ~packing:tree#append () in + let hbox = + GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in + let updateb = + GButton.button ~label:"Update" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let quitb = + GButton.button ~label:"Quit" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in +object (self) + method show () = win#show () + initializer + mktree theory_selection_changed theory_rendering_window tree_item1 + (Dir ("theory:/",theoryuritree)); + mktree selection_changed rendering_window tree_item + (Dir ("cic:/",uritree)); + + (* signal handlers here *) + ignore (tree_item1#connect#select + ~callback:(theory_selection_changed theory_rendering_window None)) ; + ignore (tree_item#connect#select + ~callback:(selection_changed rendering_window None)) ; + ignore (win#connect#destroy ~callback:GMain.Main.quit) ; + ignore (quitb#connect#clicked GMain.Main.quit) ; + ignore(updateb#connect#clicked (updateb_pressed + theory_rendering_window rendering_window (ref sw1, ref sw, hbox1) mktree)) +end;; + + +(* MAIN *) + +let _ = + build_uri_tree () ; + let output = GMathView.math_view ~width:400 ~height:380 () + and label = GMisc.label ~text:"???" () in + let annotation_window = new annotation_window output label in + let rendering_window = new rendering_window annotation_window output label in + let theory_rendering_window = new theory_rendering_window rendering_window in + let selection_window = + new selection_window theory_rendering_window rendering_window + in + selection_window#show () ; + GMain.Main.main () +;; diff --git a/helm/interface/mmlinterface.opt.saved b/helm/interface/mmlinterface.opt.saved new file mode 100755 index 000000000..cb5708ade Binary files /dev/null and b/helm/interface/mmlinterface.opt.saved differ diff --git a/helm/interface/pxpUriResolver.ml b/helm/interface/pxpUriResolver.ml new file mode 100644 index 000000000..b5b37f398 --- /dev/null +++ b/helm/interface/pxpUriResolver.ml @@ -0,0 +1,101 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 11/10/2000 *) +(* *) +(* *) +(******************************************************************************) + +let resolve = + function + "http://localhost:8081/getdtd?url=cic.dtd" -> + "/home/pauillac/coq3/sacerdot/HELM/INTERFACE/examples/dtd/cic.dtd" + | "http://localhost:8081/getdtd?url=maththeory.dtd" -> + "/home/pauillac/coq3/sacerdot/HELM/INTERFACE/examples/dtd/maththeory.dtd" + | "http://localhost:8081/getdtd?url=annotations.dtd" -> + "/home/pauillac/coq3/sacerdot/HELM/INTERFACE/examples/dtd/annotations.dtd" + | s -> s +;; + +let url_syntax = + let enable_if = + function + `Not_recognized -> Neturl.Url_part_not_recognized + | `Allowed -> Neturl.Url_part_allowed + | `Required -> Neturl.Url_part_required + in + { Neturl.null_url_syntax with + Neturl.url_enable_scheme = enable_if `Allowed; + Neturl.url_enable_host = enable_if `Allowed; + Neturl.url_enable_path = Neturl.Url_part_required; + Neturl.url_accepts_8bits = true; + } +;; + +let file_url_of_id xid = + let file_url_of_sysname sysname = + (* By convention, we can assume that sysname is a URL conforming + * to RFC 1738 with the exception that it may contain non-ASCII + * UTF-8 characters. + *) + try + Neturl.url_of_string url_syntax sysname + (* may raise Malformed_URL *) + with + Neturl.Malformed_URL -> raise Pxp_reader.Not_competent + in + let url = + match xid with + Pxp_types.Anonymous -> raise Pxp_reader.Not_competent + | Pxp_types.Public (_,sysname) -> + let sysname = resolve sysname in + if sysname <> "" then file_url_of_sysname sysname + else raise Pxp_reader.Not_competent + | Pxp_types.System sysname -> + let sysname = resolve sysname in + file_url_of_sysname sysname + in + let scheme = + try Neturl.url_scheme url with Not_found -> "file" in + let host = + try Neturl.url_host url with Not_found -> "" in + + if scheme <> "file" then raise Pxp_reader.Not_competent; + if host <> "" && host <> "localhost" then raise Pxp_reader.Not_competent; + + url +;; + +let from_file ?system_encoding utf8_filename = + + let r = + new Pxp_reader.resolve_as_file + ?system_encoding:system_encoding + ~url_of_id:file_url_of_id + () + in + + let utf8_abs_filename = + if utf8_filename <> "" && utf8_filename.[0] = '/' then + utf8_filename + else + Sys.getcwd() ^ "/" ^ utf8_filename + in + + let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in + let url = Neturl.make_url + ~scheme:"file" + ~host:"localhost" + ~path:(Neturl.split_path utf8_abs_filename) + syntax + in + + let xid = Pxp_types.System (Neturl.string_of_url url) in + + + Pxp_yacc.ExtID(xid, r) +;; + + diff --git a/helm/interface/reduction.ml b/helm/interface/reduction.ml new file mode 100644 index 000000000..8acb8eb94 --- /dev/null +++ b/helm/interface/reduction.ml @@ -0,0 +1,70 @@ +let read_from_stdin = ref false;; +let uris_in_input = ref false;; +let reduction_only = ref false;; + +let parse uri = + print_endline ("^^^" ^ uri ^ "^^^") ; + print_string (CicPp.ppobj (CicCache.get_obj (UriManager.uri_of_string uri))) ; + print_endline ("\n$$$" ^ uri ^ "$$$\n") +;; + +let uri_of_filename fn = + if !uris_in_input then fn + else + let uri = + Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn + in + let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in + uri' +;; + +(* filenames are read from command line and converted to uris via *) +(* uri_of_filenames; then the cic terms are load in cache via *) +(* CicCache.get_obj and then pretty printed via CicPp.ppobj *) + +exception NotADefinition;; + +let main () = + let files = ref [] in + Arg.parse + ["-stdin", Arg.Set read_from_stdin, "Read from stdin" ; + "-uris", Arg.Set uris_in_input, "Read uris, not filenames" ; + "-update", Arg.Unit Getter.update, "Update the getter view of the world" ; + "-reduction", Arg.Set reduction_only, "Do reduction instead of tyepchecking"] + (fun x -> files := (uri_of_filename x) :: !files) + " +usage: experiment file ... + +List of options:"; + if !read_from_stdin then + begin + try + while true do + let l = Str.split (Str.regexp " ") (read_line ()) in + List.iter (fun x -> files := (uri_of_filename x) :: !files) l + done + with + End_of_file -> () + end ; + files := List.rev !files; + List.iter + (function x -> + print_string x ; + flush stdout ; + (try + if !reduction_only then + match CicCache.get_obj (UriManager.uri_of_string x) with + Cic.Definition (_,bo,_,_) -> + CicTypeChecker.typecheck (UriManager.uri_of_string x) ; + ignore (CicReduction.whd bo) + | _ -> raise NotADefinition + else + CicTypeChecker.typecheck (UriManager.uri_of_string x) + with + e -> print_newline () ; flush stdout ; raise e ) ; + print_endline " OK!" ; + flush stdout + ) !files +;; + +main ();; diff --git a/helm/interface/servers.txt b/helm/interface/servers.txt new file mode 100644 index 000000000..b91a71522 --- /dev/null +++ b/helm/interface/servers.txt @@ -0,0 +1,2 @@ +http://caristudenti.students.cs.unibo.it/~sacerdot/helm +http://pagadebit.students.cs.unibo.it/really_very_local/helm/PARSER/examples diff --git a/helm/interface/servers.txt.example b/helm/interface/servers.txt.example new file mode 100644 index 000000000..0a1221dde --- /dev/null +++ b/helm/interface/servers.txt.example @@ -0,0 +1,2 @@ +http://rigoletto.casamia.csc/helm1/coq +http://rigoletto.casamia.csc/helm2/coq diff --git a/helm/interface/servers.txt.universita b/helm/interface/servers.txt.universita new file mode 100755 index 000000000..c24a58cad --- /dev/null +++ b/helm/interface/servers.txt.universita @@ -0,0 +1,2 @@ +http://phd.cs.unibo.it/helm/PARSER/examples +http://caristudenti.students.cs.unibo.it/~sacerdot/helm diff --git a/helm/interface/theory.ml b/helm/interface/theory.ml new file mode 100644 index 000000000..be5b288b3 --- /dev/null +++ b/helm/interface/theory.ml @@ -0,0 +1,9 @@ +type theory_elem = + Theorem of string (* uri *) + | Definition of string (* uri *) + | Axiom of string (* uri *) + | Variable of string (* uri *) + | Section of string * theory_elem list (* uri, subtheory *) +and theory = + string * theory_elem list (* uri, subtheory *) +;; diff --git a/helm/interface/theoryCache.ml b/helm/interface/theoryCache.ml new file mode 100644 index 000000000..47a8646b5 --- /dev/null +++ b/helm/interface/theoryCache.ml @@ -0,0 +1,32 @@ +type check_status = Checked | Unchecked;; + +let hashtable = Hashtbl.create 17;; + +let get_term_and_type_checking_info uri = + try + Hashtbl.find hashtable uri + with + Not_found -> + let filename = Getter.get uri in + let term = TheoryParser.theory_of_xml filename in + Hashtbl.add hashtable uri (term, Unchecked) ; + (term, Unchecked) +;; + + +let get_theory uri = + fst (get_term_and_type_checking_info uri) +;; + +let is_type_checked uri = + match snd (get_term_and_type_checking_info uri) with + Checked -> true + | Unchecked -> false +;; + +let set_type_checking_info uri = + match Hashtbl.find hashtable uri with + (term, _) -> + Hashtbl.remove hashtable uri ; + Hashtbl.add hashtable uri (term, Checked) +;; diff --git a/helm/interface/theoryParser.ml b/helm/interface/theoryParser.ml new file mode 100644 index 000000000..abc352807 --- /dev/null +++ b/helm/interface/theoryParser.ml @@ -0,0 +1,29 @@ +exception Warnings;; + +class warner = + object + method warn w = + print_endline ("WARNING: " ^ w) ; + (raise Warnings : unit) + end +;; + +exception EmptyUri;; + +let theory_of_xml filename = + let module Y = Pxp_yacc in + try + let d = + let config = {Y.default_config with Y.warner = new warner} in + Y.parse_document_entity config +(*PXP (Y.ExtID (Pxp_types.System filename, + new Pxp_reader.resolve_as_file ~url_of_id ())) +*) (PxpUriResolver.from_file filename) + Y.default_spec + in + TheoryParser2.get_theory d#root + with + e -> + print_endline (Pxp_types.string_of_exn e) ; + raise e +;; diff --git a/helm/interface/theoryParser2.ml b/helm/interface/theoryParser2.ml new file mode 100644 index 000000000..666b024fc --- /dev/null +++ b/helm/interface/theoryParser2.ml @@ -0,0 +1,41 @@ +exception IllFormedXml of int;; + +(* Utility functions that transform a Pxp attribute into something useful *) + +let string_of_attr a = + let module T = Pxp_types in + match a with + T.Value s -> s + | _ -> raise (IllFormedXml 0) + +let get_theory n = + let module D = Pxp_document in + let module T = Theory in + let rec get_theory_elem n = + let ntype = n # node_type in + match ntype with + D.T_element "THEOREM" -> + let uri = string_of_attr (n # attribute "uri") in + T.Theorem uri + | D.T_element "DEFINITION" -> + let uri = string_of_attr (n # attribute "uri") in + T.Definition uri + | D.T_element "AXIOM" -> + let uri = string_of_attr (n # attribute "uri") in + T.Axiom uri + | D.T_element "VARIABLE" -> + let uri = string_of_attr (n # attribute "uri") in + T.Variable uri + | D.T_element "SECTION" -> + let uri = string_of_attr (n # attribute "uri") + and subtheory = List.map get_theory_elem (n # sub_nodes) in + T.Section (uri, subtheory) + | D.T_element _ | D.T_data | _ -> + raise (IllFormedXml 1) + in + match n # node_type with + D.T_element "Theory" -> + let uri = string_of_attr (n # attribute "uri") in + (uri, List.map get_theory_elem (n # sub_nodes)) + | _ -> raise (IllFormedXml 2) +;; diff --git a/helm/interface/theoryTypeChecker.ml b/helm/interface/theoryTypeChecker.ml new file mode 100644 index 000000000..2d2453633 --- /dev/null +++ b/helm/interface/theoryTypeChecker.ml @@ -0,0 +1,29 @@ +exception NotWellTyped of string;; + +let typecheck uri = + let rec typecheck_term curi t = + let module T = Theory in + let module P = CicTypeChecker in + let module C = CicCache in + let module U = UriManager in + let obj_typecheck uri = + try + P.typecheck (U.uri_of_string uri) + with + P.NotWellTyped s -> + raise (NotWellTyped + ("Type Checking was NOT successfull due to an error during " ^ + "type-checking of term " ^ uri ^ ":\n\n" ^ s)) + in + match t with + T.Theorem uri -> obj_typecheck (curi ^ "/" ^ uri) + | T.Definition uri -> obj_typecheck (curi ^ "/" ^ uri) + | T.Axiom uri -> obj_typecheck (curi ^ "/" ^ uri) + | T.Variable uri -> obj_typecheck (curi ^ "/" ^ uri) + | T.Section (uri,l) -> typecheck_theory l (curi ^ "/" ^ uri) + and typecheck_theory l curi = + List.iter (typecheck_term curi) l + in + let (uri, l) = TheoryCache.get_theory uri in + typecheck_theory l uri +;; diff --git a/helm/interface/toglie_helm_xref.pl b/helm/interface/toglie_helm_xref.pl new file mode 100755 index 000000000..13c9739ab --- /dev/null +++ b/helm/interface/toglie_helm_xref.pl @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +while() +{ + s/helm:xref="[^"]*"//g; + s/helm:xref='[^']*'//g; + print; +} diff --git a/helm/interface/toglie_helm_xref.sh b/helm/interface/toglie_helm_xref.sh new file mode 100755 index 000000000..b3cb4e0d4 --- /dev/null +++ b/helm/interface/toglie_helm_xref.sh @@ -0,0 +1,5 @@ +#!/bin/bash + +echo "****" $1 +cp $1 /tmp/pippo +cat /tmp/pippo | ./toglie_helm_xref.pl > $1 diff --git a/helm/interface/uriManager.ml b/helm/interface/uriManager.ml new file mode 100644 index 000000000..d03d9970f --- /dev/null +++ b/helm/interface/uriManager.ml @@ -0,0 +1,86 @@ +(* "cic:/a/b/c.con" => [| "cic:/a" ; "cic:/a/b" ; "cic:/a/b/c.con" ; "c" |] *) +type uri = string array;; + +let eq uri1 uri2 = + uri1 == uri2 +;; + +let string_of_uri uri = uri.(Array.length uri - 2);; +let name_of_uri uri = uri.(Array.length uri - 1);; +let buri_of_uri uri = uri.(Array.length uri - 3);; +let depth_of_uri uri = Array.length uri - 2;; + +(*CSC: ora e' diventato poco efficiente, migliorare *) +let relative_depth curi uri cookingsno = + let rec length_of_current_prefix l1 l2 = + match (l1, l2) with + (he1::tl1, he2::tl2) when he1 == he2 -> + 1 + length_of_current_prefix tl1 tl2 + | (_,_) -> 0 + in + depth_of_uri uri - + length_of_current_prefix + (Array.to_list (Array.sub curi 0 (Array.length curi - (2 + cookingsno)))) + (Array.to_list (Array.sub uri 0 (Array.length uri - 2))) + (*CSC: vecchio codice da eliminare + if eq curi uri then 0 + else + depth_of_uri uri - + length_of_current_prefix (Array.to_list curi) (Array.to_list uri) + *) +;; + +module OrderedStrings = + struct + type t = string + let compare (s1 : t) (s2 : t) = compare s1 s2 + end +;; + +module SetOfStrings = Map.Make(OrderedStrings);; + +(*CSC: commento obsoleto ed errato *) +(* Invariant: the map is the identity function, *) +(* i.e. (SetOfStrings.find str !set_of_uri) == str *) +let set_of_uri = ref SetOfStrings.empty;; +let set_of_prefixes = ref SetOfStrings.empty;; + +(* similar to uri_of_string, but used for prefixes of uris *) +let normalize prefix = + try + SetOfStrings.find prefix !set_of_prefixes + with + Not_found -> + set_of_prefixes := SetOfStrings.add prefix prefix !set_of_prefixes ; + prefix +;; + +exception IllFormedUri of string;; + +let mk_prefixes str = + let rec aux curi = + function + [he] -> + let prefix_uri = curi ^ "/" ^ he + and name = List.hd (Str.split (Str.regexp "\.") he) in + [ normalize prefix_uri ; name ] + | he::tl -> + let prefix_uri = curi ^ "/" ^ he in + (normalize prefix_uri)::(aux prefix_uri tl) + | _ -> raise (IllFormedUri str) + in + let tokens = (Str.split (Str.regexp "/") str) in + (* ty = "cic:" *) + let (ty, sp) = (List.hd tokens, List.tl tokens) in + aux ty sp +;; + +let uri_of_string str = + try + SetOfStrings.find str !set_of_uri + with + Not_found -> + let uri = Array.of_list (mk_prefixes str) in + set_of_uri := SetOfStrings.add str uri !set_of_uri ; + uri +;; diff --git a/helm/interface/uriManager.ml.implementazione_banale b/helm/interface/uriManager.ml.implementazione_banale new file mode 100644 index 000000000..cd0d71f71 --- /dev/null +++ b/helm/interface/uriManager.ml.implementazione_banale @@ -0,0 +1,18 @@ +type uri = string;; + +let eq uri1 uri2 = + uri1 = uri2 +;; + +let string_of_uri uri = uri;; +let uri_of_string str = str;; + +let name_of_uri uri = + let l = Str.split (Str.regexp "/") uri in + let name_suf = List.nth l (List.length l - 1) in + List.hd (Str.split (Str.regexp "\.") name_suf) +;; + +let depth_of_uri uri = + List.length (Str.split (Str.regexp "/") uri) - 2 +;; diff --git a/helm/interface/uriManager.ml.implementazione_doppia b/helm/interface/uriManager.ml.implementazione_doppia new file mode 100644 index 000000000..d03d9970f --- /dev/null +++ b/helm/interface/uriManager.ml.implementazione_doppia @@ -0,0 +1,86 @@ +(* "cic:/a/b/c.con" => [| "cic:/a" ; "cic:/a/b" ; "cic:/a/b/c.con" ; "c" |] *) +type uri = string array;; + +let eq uri1 uri2 = + uri1 == uri2 +;; + +let string_of_uri uri = uri.(Array.length uri - 2);; +let name_of_uri uri = uri.(Array.length uri - 1);; +let buri_of_uri uri = uri.(Array.length uri - 3);; +let depth_of_uri uri = Array.length uri - 2;; + +(*CSC: ora e' diventato poco efficiente, migliorare *) +let relative_depth curi uri cookingsno = + let rec length_of_current_prefix l1 l2 = + match (l1, l2) with + (he1::tl1, he2::tl2) when he1 == he2 -> + 1 + length_of_current_prefix tl1 tl2 + | (_,_) -> 0 + in + depth_of_uri uri - + length_of_current_prefix + (Array.to_list (Array.sub curi 0 (Array.length curi - (2 + cookingsno)))) + (Array.to_list (Array.sub uri 0 (Array.length uri - 2))) + (*CSC: vecchio codice da eliminare + if eq curi uri then 0 + else + depth_of_uri uri - + length_of_current_prefix (Array.to_list curi) (Array.to_list uri) + *) +;; + +module OrderedStrings = + struct + type t = string + let compare (s1 : t) (s2 : t) = compare s1 s2 + end +;; + +module SetOfStrings = Map.Make(OrderedStrings);; + +(*CSC: commento obsoleto ed errato *) +(* Invariant: the map is the identity function, *) +(* i.e. (SetOfStrings.find str !set_of_uri) == str *) +let set_of_uri = ref SetOfStrings.empty;; +let set_of_prefixes = ref SetOfStrings.empty;; + +(* similar to uri_of_string, but used for prefixes of uris *) +let normalize prefix = + try + SetOfStrings.find prefix !set_of_prefixes + with + Not_found -> + set_of_prefixes := SetOfStrings.add prefix prefix !set_of_prefixes ; + prefix +;; + +exception IllFormedUri of string;; + +let mk_prefixes str = + let rec aux curi = + function + [he] -> + let prefix_uri = curi ^ "/" ^ he + and name = List.hd (Str.split (Str.regexp "\.") he) in + [ normalize prefix_uri ; name ] + | he::tl -> + let prefix_uri = curi ^ "/" ^ he in + (normalize prefix_uri)::(aux prefix_uri tl) + | _ -> raise (IllFormedUri str) + in + let tokens = (Str.split (Str.regexp "/") str) in + (* ty = "cic:" *) + let (ty, sp) = (List.hd tokens, List.tl tokens) in + aux ty sp +;; + +let uri_of_string str = + try + SetOfStrings.find str !set_of_uri + with + Not_found -> + let uri = Array.of_list (mk_prefixes str) in + set_of_uri := SetOfStrings.add str uri !set_of_uri ; + uri +;; diff --git a/helm/interface/uriManager.ml.implementazione_semplice b/helm/interface/uriManager.ml.implementazione_semplice new file mode 100644 index 000000000..8b8921b3e --- /dev/null +++ b/helm/interface/uriManager.ml.implementazione_semplice @@ -0,0 +1,39 @@ +type uri = string;; + +let eq uri1 uri2 = + uri1 == uri2 +;; + +let string_of_uri uri = uri;; + +let name_of_uri uri = + let l = Str.split (Str.regexp "/") uri in + let name_suf = List.nth l (List.length l - 1) in + List.hd (Str.split (Str.regexp "\.") name_suf) +;; + +let depth_of_uri uri = + List.length (Str.split (Str.regexp "/") uri) - 2 +;; + +module OrderedStrings = + struct + type t = string + let compare (s1 : t) (s2 : t) = compare s1 s2 + end +;; + +module SetOfStrings = Map.Make(OrderedStrings);; + +(* Invariant: the map is the identity function, *) +(* i.e. (SetOfStrings.find str !set_of_uri) == str *) +let set_of_uri = ref SetOfStrings.empty;; + +let uri_of_string str = + try + SetOfStrings.find str !set_of_uri + with + Not_found -> + set_of_uri := SetOfStrings.add str str !set_of_uri ; + str +;; diff --git a/helm/interface/uriManager.mli b/helm/interface/uriManager.mli new file mode 100644 index 000000000..8cffc943a --- /dev/null +++ b/helm/interface/uriManager.mli @@ -0,0 +1,15 @@ +type uri + +val eq : uri -> uri -> bool + +val uri_of_string : string -> uri + +val string_of_uri : uri -> string (* complete uri *) +val name_of_uri : uri -> string (* name only (without extension)*) +val buri_of_uri : uri -> string (* base uri only *) +val depth_of_uri : uri -> int (* length of the path *) + +(* relative_depth curi uri cookingsno *) +(* is the number of times to cook uri to use it when the current uri is curi *) +(* cooked cookingsno times *) +val relative_depth : uri -> uri -> int -> int diff --git a/helm/interface/uris_of_filenames.pl b/helm/interface/uris_of_filenames.pl new file mode 100755 index 000000000..d738f51b7 --- /dev/null +++ b/helm/interface/uris_of_filenames.pl @@ -0,0 +1,15 @@ +#!/usr/bin/perl + +while() { + chomp; + split / /; + for (@_) { + if (/.*\.(con|var|ind)\.xml/) + { s/\./cic:/; } + elsif (/.*\.theory\.xml/) + { s/\./theory:/; } + s/\.xml//; + print; + print "\n"; + } +} diff --git a/helm/interface/urls_of_uris.db b/helm/interface/urls_of_uris.db new file mode 100644 index 000000000..ef6b46a51 Binary files /dev/null and b/helm/interface/urls_of_uris.db differ diff --git a/helm/interface/xaland-cpp/xaland.cpp b/helm/interface/xaland-cpp/xaland.cpp new file mode 100644 index 000000000..e22140267 --- /dev/null +++ b/helm/interface/xaland-cpp/xaland.cpp @@ -0,0 +1,207 @@ +// Base header file. Must be first. +#include + +#include +#include + +#include + +#include + +#include + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +int main(int argc, const char* []) +{ +#if !defined(XALAN_NO_NAMESPACES) + using std::cerr; + using std::endl; + using std::ofstream; +#endif + + if (argc != 1) { + cerr << "Usage: SimpleTransform" + << endl + << endl; + } else { + try { + // Call the static initializer for Xerces... + XMLPlatformUtils::Initialize(); + + { + // Initialize the Xalan XSLT subsystem... + XSLTInit theInit; + + // Create the support objects that are necessary for + // running the processor... + XercesDOMSupport theDOMSupport; + XercesParserLiaison theParserLiaison(theDOMSupport); + XPathSupportDefault theXPathSupport(theDOMSupport); + XSLTProcessorEnvSupportDefault theXSLTProcessorEnvSupport; + XObjectFactoryDefault theXObjectFactory; + XPathFactoryDefault theXPathFactory; + + // Create a processor... + XSLTEngineImpl theProcessor( + theParserLiaison, + theXPathSupport, + theXSLTProcessorEnvSupport, + theDOMSupport, + theXObjectFactory, + theXPathFactory); + + // Connect the processor to the support object... + theXSLTProcessorEnvSupport.setProcessor(&theProcessor); + + // Create a stylesheet construction context, and a stylesheet + // execution context... + StylesheetConstructionContextDefault theConstructionContext( + theProcessor, + theXSLTProcessorEnvSupport, + theXPathFactory); + + StylesheetExecutionContextDefault theExecutionContext( + theProcessor, + theXSLTProcessorEnvSupport, + theXPathSupport, + theXObjectFactory); + + // Our input files...The assumption is that the executable will be + // run from same directory as the input files. + const XalanDOMString theXMLFileName("foo.xml"); + const XalanDOMString theXSLFileName("foo.xsl"); + + // Our input sources... + XSLTInputSource theInputSource(c_wstr(theXMLFileName)); + XSLTInputSource theStylesheetSource(c_wstr(theXSLFileName)); + + // Our output target... + const XalanDOMString theOutputFileName("foo.out"); + XSLTResultTarget theResultTarget(theOutputFileName); + + theProcessor.process( + theInputSource, + theStylesheetSource, + theResultTarget, + theConstructionContext, + theExecutionContext); + + } + + // Call the static terminator for Xerces... + XMLPlatformUtils::Terminate(); + } + catch(...) { + cerr << "Exception caught!!!" + << endl + << endl; + } + } + + return 0; +} + +/**************************************************/ +/* + +public class xaland { + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + theory_processor.reset(); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + processor.reset(); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! * / + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} + +*/ diff --git a/helm/interface/xaland-java/rompi.class b/helm/interface/xaland-java/rompi.class new file mode 100644 index 000000000..4abfe3865 Binary files /dev/null and b/helm/interface/xaland-java/rompi.class differ diff --git a/helm/interface/xaland-java/rompi.java b/helm/interface/xaland-java/rompi.java new file mode 100644 index 000000000..6a633dbc9 --- /dev/null +++ b/helm/interface/xaland-java/rompi.java @@ -0,0 +1,12 @@ +import java.net.*; + +public class rompi { + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException + { + /* Wait forever ;-) */ + DatagramSocket socket2 = new DatagramSocket(12346); + DatagramPacket packet2 = new DatagramPacket(new byte[1],1); + System.out.println("Ho preso il socket e non lo lascio piu', caro pu, caro pu"); + socket2.receive(packet2); + } +} diff --git a/helm/interface/xaland-java/sped.class b/helm/interface/xaland-java/sped.class new file mode 100644 index 000000000..cc6f53dac Binary files /dev/null and b/helm/interface/xaland-java/sped.class differ diff --git a/helm/interface/xaland-java/sped.java b/helm/interface/xaland-java/sped.java new file mode 100644 index 000000000..9d96610d4 --- /dev/null +++ b/helm/interface/xaland-java/sped.java @@ -0,0 +1,28 @@ +import java.net.*; + +public class sped { + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException + { + String input = argv[0]; + String out1 = argv[1]; + String out2 = argv[2]; + + String sent = input + " " + out1 + " " + out2; + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket = new DatagramSocket(); + + int strlen = sent.length(); + byte buf[] = new byte[strlen]; + sent.getBytes(0,strlen,buf,0); + DatagramPacket packet = new DatagramPacket(buf,strlen,address,12345); + + socket.send(packet); + + + /* Wait for answer (or forever ;-) */ + DatagramSocket socket2 = new DatagramSocket(12346); + DatagramPacket packet2 = new DatagramPacket(new byte[1],1); + socket2.receive(packet2); + } +} diff --git a/helm/interface/xaland-java/xaland.class b/helm/interface/xaland-java/xaland.class new file mode 100644 index 000000000..6871fda4b Binary files /dev/null and b/helm/interface/xaland-java/xaland.class differ diff --git a/helm/interface/xaland-java/xaland.java b/helm/interface/xaland-java/xaland.java new file mode 100644 index 000000000..9eda83124 --- /dev/null +++ b/helm/interface/xaland-java/xaland.java @@ -0,0 +1,89 @@ +import org.apache.xalan.xslt.*; +import java.net.*; +import java.io.*; + +public class xaland { + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + theory_processor.reset(); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + processor.reset(); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! */ + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} diff --git a/helm/interface/xaland-java/xaland.java.prima_del_loro_baco b/helm/interface/xaland-java/xaland.java.prima_del_loro_baco new file mode 100644 index 000000000..b46ffa6aa --- /dev/null +++ b/helm/interface/xaland-java/xaland.java.prima_del_loro_baco @@ -0,0 +1,85 @@ +import org.apache.xalan.xslt.*; +import java.net.*; +import java.io.*; + +public class xaland { + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! */ + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} diff --git a/helm/interface/xaland-java/xaland.java.prima_del_loro_baco_ma_dopo_i_reset b/helm/interface/xaland-java/xaland.java.prima_del_loro_baco_ma_dopo_i_reset new file mode 100644 index 000000000..1467cdd2e --- /dev/null +++ b/helm/interface/xaland-java/xaland.java.prima_del_loro_baco_ma_dopo_i_reset @@ -0,0 +1,87 @@ +import org.apache.xalan.xslt.*; +import java.net.*; +import java.io.*; + +public class xaland { + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + theory_processor.reset(); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + processor.reset(); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! */ + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} diff --git a/helm/interface/xaland.class b/helm/interface/xaland.class new file mode 100644 index 000000000..6871fda4b Binary files /dev/null and b/helm/interface/xaland.class differ diff --git a/helm/interface/xml.ml b/helm/interface/xml.ml new file mode 100644 index 000000000..5cb3dbd06 --- /dev/null +++ b/helm/interface/xml.ml @@ -0,0 +1,72 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* A tactic to print Coq objects in XML *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 18/10/2000 *) +(* *) +(* This module defines a pretty-printer and the stream of commands to the pp *) +(* *) +(******************************************************************************) + + +(* the type token for XML cdata, empty elements and not-empty elements *) +(* Usage: *) +(* Str cdata *) +(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) +(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) +(* content *) +type token = Str of string + | Empty of string * (string * string) list + | NEmpty of string * (string * string) list * token Stream.t +;; + +(* currified versions of the constructors make the code more readable *) +let xml_empty name attrs = [< 'Empty(name,attrs) >] +let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >] +let xml_cdata str = [< 'Str str >] + +(* Usage: *) +(* pp tokens None pretty prints the output on stdout *) +(* pp tokens (Some filename) pretty prints the output on the file filename *) +let pp strm fn = + let channel = ref stdout in + let rec pp_r m = + parser + [< 'Str a ; s >] -> + print_spaces m ; + fprint_string (a ^ "\n") ; + pp_r m s + | [< 'Empty(n,l) ; s >] -> + print_spaces m ; + fprint_string ("<" ^ n) ; + List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; + fprint_string "/>\n" ; + pp_r m s + | [< 'NEmpty(n,l,c) ; s >] -> + print_spaces m ; + fprint_string ("<" ^ n) ; + List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; + fprint_string ">\n" ; + pp_r (m+1) c ; + print_spaces m ; + fprint_string ("\n") ; + pp_r m s + | [< >] -> () + and print_spaces m = + for i = 1 to m do fprint_string " " done + and fprint_string str = + output_string !channel str + in + match fn with + Some filename -> + channel := open_out filename ; + pp_r 0 strm ; + close_out !channel ; + print_string ("\nWriting on file \"" ^ filename ^ "\" was succesfull\n"); + flush stdout + | None -> + pp_r 0 strm +;; diff --git a/helm/interface/xml.mli b/helm/interface/xml.mli new file mode 100644 index 000000000..a82c582f6 --- /dev/null +++ b/helm/interface/xml.mli @@ -0,0 +1,35 @@ +(******************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* A tactic to print Coq objects in XML *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 18/10/2000 *) +(* *) +(* This module defines a pretty-printer and the stream of commands to the pp *) +(* *) +(******************************************************************************) + +(* Tokens for XML cdata, empty elements and not-empty elements *) +(* Usage: *) +(* Str cdata *) +(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) +(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) +(* content *) +type token = + | Str of string + | Empty of string * (string * string) list + | NEmpty of string * (string * string) list * token Stream.t + +(* currified versions of the token constructors make the code more readable *) +val xml_empty : string -> (string * string) list -> token Stream.t +val xml_nempty : + string -> (string * string) list -> token Stream.t -> token Stream.t +val xml_cdata : string -> token Stream.t + +(* The pretty printer for streams of token *) +(* Usage: *) +(* pp tokens None pretty prints the output on stdout *) +(* pp tokens (Some filename) pretty prints the output on the file filename *) +val pp : token Stream.t -> string option -> unit diff --git a/helm/interface/xsltProcessor.ml b/helm/interface/xsltProcessor.ml new file mode 100644 index 000000000..c82a8f5f8 --- /dev/null +++ b/helm/interface/xsltProcessor.ml @@ -0,0 +1,64 @@ +exception XsltProcessorCouldNotSend;; +exception XsltProcessorCouldNotReceive;; + +let portserver = 12345;; +let portclient = 12346;; +let time_to_wait = 10;; + +let rec process uri usecache mode = + let module U = Unix in + let uri = UriManager.string_of_uri uri in + let pid = string_of_int (U.getpid ()) + and filename' = + let uri' = Str.replace_first (Str.regexp ".*:") "" uri in + Str.global_replace (Str.regexp "/") "_" + (Str.global_replace (Str.regexp "_") "__" uri') + in let tmpfile = "/tmp/helm_" ^ filename' ^ "_" ^ pid in + (* test if the cache can be used *) + let tmp_file_exists = Sys.file_exists tmpfile in + if usecache && tmp_file_exists then + tmpfile + else + let url = Configuration.getter_url ^ uri in + (* purge the cache if asked to *) + if not usecache && tmp_file_exists then + Sys.remove tmpfile ; + let string_to_send = mode ^ " " ^ url ^ " " ^ tmpfile in + (* next function is for looping in case the server is not responding *) + let rec contact_server () = + let socketclient = U.socket U.PF_INET U.SOCK_DGRAM 0 + and socketserver = U.socket U.PF_INET U.SOCK_DGRAM 0 in + let bounded = ref false in + while not !bounded do + try + U.bind socketclient (U.ADDR_INET(U.inet_addr_any,portclient)) ; + bounded := true + with _ -> + print_endline "Port unavailable. Retrying..." ; flush stdout ; + U.sleep 5 (* wait hoping the inetaddr is released *) + done ; + let n = + U.sendto socketserver string_to_send 0 (String.length string_to_send) + [] (U.ADDR_INET(U.inet_addr_any,portserver)) + in + if n = -1 then raise XsltProcessorCouldNotSend ; + U.close socketserver ; + let process_signal _ = U.close socketclient in + Sys.set_signal Sys.sigalrm (Sys.Signal_handle process_signal) ; + (* if the server does not respond, repeat the query *) + ignore (U.alarm time_to_wait) ; + try + if U.recv socketclient "" 0 0 [] = -1 then + raise XsltProcessorCouldNotReceive ; + ignore (U.alarm 0) ; (* stop the bomb *) + Sys.set_signal Sys.sigalrm Sys.Signal_default ; + U.close socketclient ; + tmpfile + with + U.Unix_error(_,"recv",_) -> + print_endline "Xaland server not responding. Retrying..." ; + flush stdout; + contact_server () + in + contact_server () +;; diff --git a/helm/pacchetti/Makefile b/helm/pacchetti/Makefile new file mode 100644 index 000000000..e47e23f45 --- /dev/null +++ b/helm/pacchetti/Makefile @@ -0,0 +1,76 @@ +all: helm_configuration helm_data helm_http_getter helm_xsltd helm_gtk_interface +clean: + rm -f helm_*.spec helm_*.tar.gz + +helm_configuration: prep_helm_configuration clean_helm_configuration + +prep_helm_configuration: + cvs export -D20100101 configuration + mv configuration/helm_configuration-0.0.1-1.spec . + (cd configuration ; autoconf) + mv configuration helm_configuration-0.0.1 + tar -zcvf helm_configuration-0.0.1-1.tar.gz helm_configuration-0.0.1 + +clean_helm_configuration: + rm -rf helm_configuration-0.0.1 + + + +helm_data: prep_helm_data clean_helm_data + +prep_helm_data: + cvs export -D20100101 helm_data + mv helm_data/helm_data-0.0.1-1.spec . + (cd helm_data ; cvs export -D20100101 dtd ; cvs export -D20100101 style ; autoconf) + mv helm_data helm_data-0.0.1 + tar -zcvf helm_data-0.0.1-1.tar.gz helm_data-0.0.1 + +clean_helm_data: + rm -rf helm_data-0.0.1 + + + +helm_http_getter: prep_helm_http_getter clean_helm_http_getter + +prep_helm_http_getter: + cvs export -D20100101 http_getter + mv http_getter/helm_http_getter-0.0.1-1.spec . + (cd http_getter ; autoconf) + mv http_getter helm_http_getter-0.0.1 + tar -zcvf helm_http_getter-0.0.1-1.tar.gz helm_http_getter-0.0.1 + +clean_helm_http_getter: + rm -rf helm_http_getter-0.0.1 + + + +helm_xsltd: prep_helm_xsltd clean_helm_xsltd + +prep_helm_xsltd: + cvs export -D20100101 xsltd + mv xsltd/helm_xsltd-0.0.1-1.spec . + (cd xsltd ; autoconf) + mv xsltd helm_xsltd-0.0.1 + tar -zcvf helm_xsltd-0.0.1-1.tar.gz helm_xsltd-0.0.1 + +clean_helm_xsltd: + rm -rf helm_xsltd-0.0.1 + + + +helm_gtk_interface: prep_helm_gtk_interface clean_helm_gtk_interface + +prep_helm_gtk_interface: + cvs export -D20100101 interface + mv interface/helm_gtk_interface-0.0.1-1.spec . + (cd interface ; autoconf) + mv interface helm_gtk_interface-0.0.1 + tar -zcvf helm_gtk_interface-0.0.1-1.tar.gz helm_gtk_interface-0.0.1 + +clean_helm_gtk_interface: + rm -rf helm_gtk_interface-0.0.1 + + + + +PHONY: all clean helm_configuration prep_helm_configuration clean_helm_configuration diff --git a/helm/scripts/Makefile b/helm/scripts/Makefile new file mode 100644 index 000000000..f0ddad968 --- /dev/null +++ b/helm/scripts/Makefile @@ -0,0 +1,18 @@ + +all: + ./makeit V7 marcello marcello marcello.cshrc + ./makeit V7 marcello marcello marcello.rc + ./makeit V7 marcello phd marcello_phd.cshrc + ./makeit V7 marcello phd marcello_phd.rc + ./makeit V7 phd phd phd.cshrc + ./makeit V7 phd phd phd.rc + ./makeit V7 phd marcello phd_marcello.cshrc + ./makeit V7 phd marcello phd_marcello.rc + chmod a+x marcello*rc phd*rc + +clean: + rm -f marcello*rc phd*rc + +cleanbak: + rm -f *~ + diff --git a/helm/scripts/makeit b/helm/scripts/makeit new file mode 100755 index 000000000..bbd7cfd05 --- /dev/null +++ b/helm/scripts/makeit @@ -0,0 +1,11 @@ +#!/bin/sh + +if test $# != 3; then + echo "Usage: makeit " + echo + echo " is either V6.2 or V7" + echo " is either phd or marcello" + exit 1 +fi + +sed -e "s/@COQV@/$1/" -e "s/@WHERE@/$2/" -e "s/@FROM@/$3/" diff --git a/helm/scripts/start-tomcat b/helm/scripts/start-tomcat new file mode 100755 index 000000000..ac9912ee3 --- /dev/null +++ b/helm/scripts/start-tomcat @@ -0,0 +1,8 @@ +#!/bin/sh +trap stop-tomcat-debug EXIT +start-tomcat-debug >/dev/null +echo TOMCAT is on its way, wait a few seconds before using it. +echo Press enter to kill TOMCAT. +echo +read +echo Shutting down... diff --git a/helm/scripts/start-tomcat-debug b/helm/scripts/start-tomcat-debug new file mode 100755 index 000000000..bae236b46 --- /dev/null +++ b/helm/scripts/start-tomcat-debug @@ -0,0 +1,2 @@ +#!/bin/sh +$HELMROOT/shared/libraries/tomcat/bin/startup.sh diff --git a/helm/scripts/stop-tomcat-debug b/helm/scripts/stop-tomcat-debug new file mode 100755 index 000000000..89f4e5d31 --- /dev/null +++ b/helm/scripts/stop-tomcat-debug @@ -0,0 +1,2 @@ +#! /bin/sh +exec $HELMROOT/shared/libraries/tomcat/bin/shutdown.sh diff --git a/helm/scripts/template.cshrc b/helm/scripts/template.cshrc new file mode 100644 index 000000000..cd11bf582 --- /dev/null +++ b/helm/scripts/template.cshrc @@ -0,0 +1,69 @@ + +set COQV=@COQV@ +set WHERE=@WHERE@ +set FROM=@FROM@ + +setenv CVS_RSH=ssh + +echo "Configuring HELM for $WHERE (from $FROM), Coq $COQV" + +if ($WHERE == phd) then + setenv HELMROOT /projects/helm + setenv JAVA_HOME /opt/java/jdk1.3 + setenv PATH .:$JAVA_HOME/bin/:$PATH + if ($?LD_LIBRARY_PATH == 1) then + setenv LD_LIBRARY_PATH /usr/local/lib:$LD_LIBRARY_PATH + else + setenv LD_LIBRARY_PATH /usr/local/lib + endif +else + setenv HELMROOT /home/projects/helm + setenv JAVA_HOME /usr/local/jdk1.3 + setenv PATH .:$JAVA_HOME/bin:$HELMROOT/local/bin:$PATH + if ($?LD_LIBRARY_PATH == 1) then + setenv LD_LIBRARY_PATH $HELMROOT/local/lib:$LD_LIBRARY_PATH + else + setenv LD_LIBRARY_PATH $HELMROOT/local/lib + endif +endif + +if ($WHERE == $FROM) then + set FONTROOT=$HELMROOT +else + if ($FROM == phd) then + set FONTROOT=/projects/helm + else + set FONTROOT=/home/projects/helm + endif +endif + +setenv PATH $HELMROOT/http_getter:$PATH +setenv PATH $HELMROOT/V7/interface:$PATH +setenv PATH $HELMROOT/shared/scripts:$PATH + +setenv HELM_CONFIGURATION_DIR $HELMROOT/$COQV/$WHERE/local/etc/helm +setenv HELM_STYLE_DIR $HELMROOT/$COQV/style +setenv HELM_LIB_DIR $HELMROOT/$COQV/$WHERE/local/lib/helm +setenv HTTP_GETTER_RDF_DIR $HELMROOT/shared/V7/rdf_library +setenv HTTP_GETTER_RDF_DBM $HELMROOT/shared/V7/rdf_urls_of_uris.db +setenv HTTP_GETTER_XSLT_DBM $HELMROOT/shared/V7/xslt_urls_of_uris.db +setenv HTTP_GETTER_PORT 48081 + +echo HELM_CONFIGURATION_DIR=$HELM_CONFIGURATION_DIR +echo HELM_LIB_DIR=$HELM_LIB_DIR +echo HELM_STYLE_DIR=$HELM_STYLE_DIR + +setenv CLASSPATH . +setenv CLASSPATH $CLASSPATH\:$HELMROOT/uwobo/lib/xalan.jar +setenv CLASSPATH $CLASSPATH\:$HELMROOT/uwobo/lib/xerces.jar +setenv CLASSPATH $CLASSPATH\:$HELMROOT/uwobo/lib/uwobo_client.jar +setenv CLASSPATH $CLASSPATH\:$HELMROOT/uwobo/lib/uwobo_server.jar + +setenv MATHENGINECONF $HELMROOT/$COQV/$WHERE/local/etc/helm/helm-math-engine-configuration.xml + +umask 002 + +# Stix font +xset fp +xset fp+ $FONTROOT/fonts/mathematica/Type1/ +xset fp rehash diff --git a/helm/scripts/template.rc b/helm/scripts/template.rc new file mode 100644 index 000000000..6fb3c0cdc --- /dev/null +++ b/helm/scripts/template.rc @@ -0,0 +1,61 @@ + +COQV=@COQV@ +WHERE=@WHERE@ +FROM=@FROM@ + +export CVS_RSH=ssh + +echo "Configuring HELM for $WHERE (from $FROM), Coq $COQV" + +if test $WHERE = phd; then + export HELMROOT=/projects/helm + export JAVA_HOME=/opt/java/jdk1.3 + export PATH=.:$JAVA_HOME/bin/:$PATH + export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH +else + export HELMROOT=/home/projects/helm + export JAVA_HOME=/usr/local/jdk1.3 + export PATH=.:$JAVA_HOME/bin:$HELMROOT/local/bin:$PATH + export LD_LIBRARY_PATH=$HELMROOT/local/lib:$LD_LIBRARY_PATH +fi + +if test $WHERE = $FROM; then + FONTROOT=$HELMROOT +else + if test $FROM = phd; then + FONTROOT=/projects/helm + else + FONTROOT=/home/projects/helm + fi +fi + +export PATH=$HELMROOT/http_getter:$PATH +export PATH=$HELMROOT/V7/interface:$PATH +export PATH=$HELMROOT/shared/scripts:$PATH + +export HELM_CONFIGURATION_DIR=$HELMROOT/$COQV/$WHERE/local/etc/helm +export HELM_STYLE_DIR=$HELMROOT/$COQV/style +export HELM_LIB_DIR=$HELMROOT/$COQV/$WHERE/local/lib/helm +export HTTP_GETTER_RDF_DIR=$HELMROOT/shared/V7/rdf_library +export HTTP_GETTER_RDF_DBM=$HELMROOT/shared/V7/rdf_urls_of_uris.db +export HTTP_GETTER_XSLT_DBM=$HELMROOT/shared/V7/xslt_urls_of_uris.db +export HTTP_GETTER_PORT=48081 + +echo HELM_CONFIGURATION_DIR=$HELM_CONFIGURATION_DIR +echo HELM_LIB_DIR=$HELM_LIB_DIR +echo HELM_STYLE_DIR=$HELM_STYLE_DIR + +# export CLASSPATH=. +# export CLASSPATH=$CLASSPATH:$HELMROOT/uwobo/lib/xalan.jar +# export CLASSPATH=$CLASSPATH:$HELMROOT/uwobo/lib/xerces.jar +# export CLASSPATH=$CLASSPATH:$HELMROOT/uwobo/lib/uwobo_client.jar +# export CLASSPATH=$CLASSPATH:$HELMROOT/uwobo/lib/uwobo_server.jar + +export MATHENGINECONF=$HELMROOT/$COQV/$WHERE/local/etc/helm/helm-math-engine-configuration.xml + +umask 002 + +# Stix font +xset fp +xset fp+ $FONTROOT/fonts/mathematica/Type1/ +xset fp rehash diff --git a/helm/style/annotatedcont.xsl b/helm/style/annotatedcont.xsl new file mode 100644 index 000000000..e97d08f2b --- /dev/null +++ b/helm/style/annotatedcont.xsl @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/annotatedcont.xsl.csc b/helm/style/annotatedcont.xsl.csc new file mode 100644 index 000000000..3508d6be4 --- /dev/null +++ b/helm/style/annotatedcont.xsl.csc @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/annotatedpres.xsl b/helm/style/annotatedpres.xsl new file mode 100644 index 000000000..511f915f5 --- /dev/null +++ b/helm/style/annotatedpres.xsl @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/basic.xsl b/helm/style/basic.xsl new file mode 100644 index 000000000..93eb28052 --- /dev/null +++ b/helm/style/basic.xsl @@ -0,0 +1,253 @@ + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + $x + + + app + + $x + + + + + + + + + + + + + + + + + + + + + + + + + app + + + + + + + + + + + + + + + + app + + + + + + + + + x + + + + app + + x + + + + app + + x + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/content.xsl b/helm/style/content.xsl new file mode 100644 index 000000000..24b97e6e6 --- /dev/null +++ b/helm/style/content.xsl @@ -0,0 +1,274 @@ + + + + + + + + + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + + + + + arrow + + + + prod + + + + + + + + + + + + + + + + + cast + + + + + + + + + + + + + + + + + + + + + + + + + letin + + + + + let + + + + + + + + + + + + + + + + + app + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + mutcase + + + + + + + + + + + + + + + app + + + + LAMBDA + + + + LAMBDA + + + + + + + + fix + + + + + + + + + cofix + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/content.xsl.csc b/helm/style/content.xsl.csc new file mode 100644 index 000000000..5f7c1e131 --- /dev/null +++ b/helm/style/content.xsl.csc @@ -0,0 +1,258 @@ + + + + + + + + + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + [[]] + + + + + + + + + + + + + + + + + + + + arrow + + + + + + prod + + + [[]] + + + + + + + + + + + + + + + + + + + + cast + + + + + + + + + + + + + [[]] + + + + + + + + + + + + + + + + + app + + + + + + + + + + + + [[]] + + + + + + + + [[]] + + + + + + + + [[]] + + + + + + + + + + + + [[]] + + + + + + + + + + [[]] + + + + + + + + + + mutcase + + + + + + + + + + + + + + + + + + + app + + + + LAMBDA + + + + LAMBDA + + + + + + + + + fix + + + + + + + + + cofix + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/content_senza_tipi.13.9.00.xsl b/helm/style/content_senza_tipi.13.9.00.xsl new file mode 100644 index 000000000..7de998720 --- /dev/null +++ b/helm/style/content_senza_tipi.13.9.00.xsl @@ -0,0 +1,215 @@ + + + + + + + + + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + + + + + arrow + + + + prod + + + + + + + + + + + + + + + + + cast + + + + + + + + + + + + + + + + + + + + + app + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + mutcase + + + + + + + + + + + + + + + app + + + + LAMBDA + + + + LAMBDA + + + + + + + + fix + + + + + + + + + cofix + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/content_to_html.xsl b/helm/style/content_to_html.xsl new file mode 100644 index 000000000..dd1c07794 --- /dev/null +++ b/helm/style/content_to_html.xsl @@ -0,0 +1,657 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +   + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + P + + : + + +
+ + + + . + + + + + + + P + + : + + . + + + + + + + + ( + + + +
+ + + + + ® + + + + ) + + + ( + + + ® + + ) + + + + + + + ( + + + + +
+ + + + + + + + ) + + + ( + + +   + + + ) + + + + + + + + + ( + + +
+ + + :> + + + + ) + + + ( + + :> + + ) + + + + + + + + + + + + Prop + + + Set + + + Type + + + + + < + + + + > + CASE + + + + OF + +
+ + + + + +    + + + | + + + + Þ + + + + + + + < + + > + CASE + + OF + + + + | + + + + Þ + + + + + + + + + + + FIX + + { + +
+ + + + + : + + + +
+ + + + := + + + + +
+ + + + } + + + FIX + + { + + + : + + := + + + + } + + + ; + + + + + + + + + + COFIX + + { +
+ + + + + + : + + + +
+ + + + := + + + + + +
+ + + + } + + + COFIX + + { + + + : + + := + + + + } + + + ; + + + + + + + + + + + + + + + + + + + + + + + l + + : + + +
+ + + + . + + + + + + + l + + : + + . + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

+DEFINITION ()
+TYPE =
+ + + + + +
+BODY =
+ + + + + + +

+ + + + + + +

+AXIOM ()
+TYPE = + + +

+ + + + + + +

+UNFINISHED PROOF ()
+THESIS: + +
+CONJECTURES: + +
+ + + + : + + + + +
+PROOF: + + + +

+ + + + + + +

+ + + + + + INDUCTIVE DEFINITION + + + COINDUCTIVE DEFINITION + + + + + AND + + + () + [ + + + + : + + + + ]
+ OF ARITY + + +
+ BUILT FROM: + +
+ + + + + +    + + + | + + + + : + + + + + +

+ + + + + + +

+VARIABLE
+TYPE = + + +

+ + + + + + + + + + +

BEGIN OF SECTION

+ +

END OF SECTION

+ + + diff --git a/helm/style/html_init.xsl b/helm/style/html_init.xsl new file mode 100644 index 000000000..9e81b169c --- /dev/null +++ b/helm/style/html_init.xsl @@ -0,0 +1,259 @@ + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ( + + + +
+ + + + + + + + + + + + + + + ) + + + ( + + + + + + + + + + + ) + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + ( + + + +
+ + + + + + + + - + + + + + ) + + + ( + + + + + + - + + + ) + + + + + + + + + + + + + + + + + + + Ø + + + + + + + + + + + + + + + + + + + + + + $ + + + : + + + +
+ + + + . + + + + + + + + + + $ + + + : + + . + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/html_reals.xsl b/helm/style/html_reals.xsl new file mode 100644 index 000000000..04ff478c5 --- /dev/null +++ b/helm/style/html_reals.xsl @@ -0,0 +1,234 @@ + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + + lim + + + + ® + + +
+ + + + + + + + + + + + + lim + + + + ® + + + + + + + + + + + + + + + + + + + + + + d + / + + d + + + + + + + + + + + + + + + + | + + + + | + + + + + + + + + + + + + + ! + + + + + + + + + + + (sqr + + + + ) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + { + + + + , +
+ + + + + + + } + + + + + + + + + { + + , + + } + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/html_set.xsl b/helm/style/html_set.xsl new file mode 100644 index 000000000..6c7f66b1b --- /dev/null +++ b/helm/style/html_set.xsl @@ -0,0 +1,463 @@ + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + ( + + + +
+ + + + + + + + Î + + + + + ) + + + ( + + + + + + Î + + + ) + + + + + + + + + + + + + + + + + + ( + + + +
+ + + + Ï + + + + ) + + + ( + + Ï + + ) + + + + + + + + + + + + + + + Æ + + + + + + + + + + { + + : + + +
+ + + + | + + + + } + + + { + + : + + | + + } + + + + + + + { + + + + + , +
+ + + + + + + + } + + + { + + + + + } + + + , + + + + + + + + + + + + + + + + + + + + + + + + + + ( + + + +
+ + + + + + + + Ç + + + + + ) + + + ( + + + + + + Ç + + + ) + + + + + + + + + + + + + + + + + + ( + + + +
+ + + + + + + + È + + + + + ) + + + ( + + + + + + È + + + ) + + + + + + + + + + + + + + + + + ( + + + +
+ + + + + + + + Í + + + + + ) + + + ( + + + + + + Í + + + ) + + + + + + + + + + + + + + + + + ( + + + +
+ + + + + + + + Ì + + + + + ) + + + ( + + + + + + Ì + + + ) + + + + + + + + + + + + + + + + + + + ( + + + +
+ + + + + + + + / + + + + + ) + + + ( + + + + + + / + + + ) + + + + + + + + + + + + | + + + + | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/mml2mmlv1_0.xsl b/helm/style/mml2mmlv1_0.xsl new file mode 100644 index 000000000..67e1accfb --- /dev/null +++ b/helm/style/mml2mmlv1_0.xsl @@ -0,0 +1,1957 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + i + + + + + + + + - + + + + + + + + + i + + + + + + + + / + + + + + + + + / + + + + + + + + Polar + + + + + + + + + + Polar + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ln + + + exp + + + arcsin + + + arccos + + + arctan + + + arcsec + + + arccsc + + + arccot + + + arcsinh + + + arccosh + + + arctanh + + + arcsech + + + arccsch + + + arccoth + + + sin + + + cos + + + tan + + + + + + -1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Λ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + id + + + + + + + + + + + + / + + + + + + + + + + e + + + + + + + + + + + + ! + + + + + + + + + + max + + + min + + + + + + + + + + + | + + + + + + + + + + + + + + max + + + min + + + + + + + + + | + + + + + + + max + + + min + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + % + + + / + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + * + + + + + + + + + + + + + + + + + + + + + 2 + + + + + + + + + gcd + + + + gcd + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + not + + + + + + + + + + for all + + + + + + + : + + , + + + + + + + + + + + + + + + + , + + + : + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + arg + + + Real + + + Imaginary + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + = + + + > + + + < + + + + + + + + + + + + + + + + + + + + + + + + + + ln + + + + + ln + + + + + + + + + + + + + + + + log + + + + + + log + + + + + + + + log + + + + log + + + + + + + + + + + + + + + + + + + + + + + + + d + + + + d + + + + + + + + + + d + + d + + + + + + + + + + + + + + + + d + + + + d + + + + + + + + + + d + + d + + + + + + + + + + + + + + + + + + div + + + grad + + + curl + + + + + + + + + + + + + + + + + + + Δ + 2 + + + + + + + + + + + + + + | + + + + + + + + + | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + = + + + + + + + + + + + + + + + + + + + + + + + + + + + lim + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + sin + + + cos + + + tan + + + sec + + + csc + + + cot + + + sinh + + + cosh + + + tanh + + + sech + + + csch + + + coth + + + arcsin + + + arccos + + + arctan + + + + + + + + + + + + + + + + + + + + σ + + + + + + + + + + + + σ + + + + + + + 2 + + + + + + + + median + + + + + + + + + + + + mode + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + det + + + + + + + + T + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + . + + + + + + + diff --git a/helm/style/mml2mmlv1_0_original.xsl b/helm/style/mml2mmlv1_0_original.xsl new file mode 100644 index 000000000..44c34df74 --- /dev/null +++ b/helm/style/mml2mmlv1_0_original.xsl @@ -0,0 +1,1848 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + i + + + + + + + + - + + + + + + + + + i + + + + + + + + / + + + + + + + + / + + + + + + + + Polar + + + + + + + + + + Polar + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ln + + + exp + + + arcsin + + + arccos + + + arctan + + + arcsec + + + arccsc + + + arccot + + + arcsinh + + + arccosh + + + arctanh + + + arcsech + + + arccsch + + + arccoth + + + sin + + + cos + + + tan + + + + + + -1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Λ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + id + + + + + + + + + + + / + + + + + + + + + + e + + + + + + + + + + + ! + + + + + + + + + max + + + min + + + + + + + + + + + | + + + + + + + + + + + + + + max + + + min + + + + + + + + + | + + + + + + + max + + + min + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + % + + + / + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 2 + + + + + + + + gcd + + + + gcd + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + not + + + + + + + + + for all + + + + + + + : + + , + + + + + + + + + + + + + + + , + + + : + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + arg + + + Real + + + Imaginary + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + = + + + > + + + < + + + + + + + + + + + + + + + + + + + + + + + + + ln + + + + + ln + + + + + + + + + + + + + + + log + + + + + + log + + + + + + + + log + + + + log + + + + + + + + + + + + + + + + + + + + + + + + d + + + + d + + + + + + + + + + d + + d + + + + + + + + + + + + + + + d + + + + d + + + + + + + + + + d + + d + + + + + + + + + + + + + + + + + div + + + grad + + + curl + + + + + + + + + + + + + + + + + + Δ + 2 + + + + + + + + + + + + + | + + + + + + + + + | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + = + + + + + + + + + + + + + + + + + + + + + + + + + + lim + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + sin + + + cos + + + tan + + + sec + + + csc + + + cot + + + sinh + + + cosh + + + tanh + + + sech + + + csch + + + coth + + + arcsin + + + arccos + + + arctan + + + + + + + + + + + + + + + + + + σ + + + + + + + + + + + σ + + + + + + + 2 + + + + + + + median + + + + + + + + + + + mode + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + det + + + + + + + + T + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + . + + + + + + + diff --git a/helm/style/mmlextension.xsl b/helm/style/mmlextension.xsl new file mode 100644 index 000000000..566ccdf0a --- /dev/null +++ b/helm/style/mmlextension.xsl @@ -0,0 +1,1382 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + type="text/xhtml" + + + + + + + + + + + + DEFINITION () OF TYPE + + + + + + + __ + + + + + + + + AS + + + + + + + __ + + + + + + + + + + + + + + + + + AXIOM () OF TYPE + + + + + + + __ + + + + + + + + + + + + + + + + + UNFINISHED PROOF () + + + + + + + THESIS: + + + + + + + __ + + + + + + + + CONJECTURES: + + + + + + + + __ + : + + + + + + + + + CORRESPONDING PROOF: + + + + + + + __ + + + + + + + + + + + + + + + + + + + + + + INDUCTIVE DEFINITION + + + COINDUCTIVE DEFINITION + + + + + AND + + + _ + () + + + + + + + __ + [ + + + + + + + + + : + + + + + + + + + ] + + + + + + + ] + + + + + + + + + OF ARITY + + + + + + + __ + + + + + + + + BUILT FROM + + + + + + + + + + __ + + + | + _ + + + OF + _ + + + + + + + + + + + + + + + + + + + VARIABLE OF TYPE + + + + + + + __ + + + + + + + + + + + + + + + + + + + + + + + + + : + + + + + + + + + + + + : + + + + + + + + + + + + + + + + + + + + + + + + + + + + Π + + + + + + + . + + + + + + + + Π + + : + + . + + + + + + + + + + + + ( + + + + + + + + → + + + + + + + + ) + + + + + + + ( + + → + + ) + + + + + + + + + + + ( + + + + + + + + + ( + + + + + + + + + ) + + + + + + + ( + + + _ + + + ) + + + + + + + + + + + ( + + + + + + + + :> + + + + + + + + ) + + + + + + + ( + + :> + + ) + + + + + Prop + + + Set + + + Type + + + + + + + + + + < + + + > + CASES + _ + + + + + + + + + + > + CASES + _ + + + + + + + + + OF + + + + + + + + + + + | + + + | + + + _ + + + ⇒ + + + + + + + + + + |_ + ⇒ + + + + + + + + + + END + + + + + + + <> + CASES + _ + + _ + OF + + + + | + + + + ⇒ + + + _ + END + + + + + + + + + + + FIX + _ + + { + + + + + + + __ + + + + + + + + : + + + + + + + + + + + := + + + + + + + + + := + + + + + + + + + + + + + } + + + + + + + FIX + + { + + + + + + + : + + := + + + } + + + + + + + + + + + + + + + + + COFIX + _ + + { + + + + + + + __ + + + + + + + + : + + + + + + + + + + + := + + + + + + + + + := + + + + + + + + + + + + + } + + + + + + + COFIX + + { + + + + + + + : + + := + + + } + + + + + + + + + + + + + + + + + + + + + + + + + we proved + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ( + + ) + + + + + + + + + + + + + Consider + + + + + + + + + + + + + + + Rewrite + _ + + _ + with + _ + + _ + by + _ + + _ + in + _ + + _ + and apply + _ + + + + + + + + + + + + + + + + + Consider + + + + + + + + + In particular, we have + + + + + + ( + + ) + + + + + + + + ( + + ) + + + + + + + + + + + + + + + + + + + + + + + + Consider + _ + + + + + + + + + We prove + _ + + _ + by cases: + + + + + + * + + + + + + + + * + + + + + + + + ERROR + + + + + + + + + + + + + Rewrite + _ + + _ + with + _ + + _ + by + _ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + λ + + + + + + + . + + + + + + + + λ + + : + + . + + + + + + + + + + + + + + + + + + + + + + + + + + + ( + + + + + + + __ + + = + + + + + + + + ) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ( + + + + + + + __ + + + + + + + + + + ) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + { + + + + + + { + | + + + + + + } + + + + + + + + + { + + + , + + + + + + + { + + + , + + + + + + + } + + + + + + + + + + + + + + + + | + + | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + > + + + + + + + + + + + diff --git a/helm/style/mmlextension_andrea.xsl b/helm/style/mmlextension_andrea.xsl new file mode 100644 index 000000000..b4bbcdbdb --- /dev/null +++ b/helm/style/mmlextension_andrea.xsl @@ -0,0 +1,1052 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + type="text/xhtml" + + + + + + + + + + + + DEFINITION () OF TYPE + + + + + + + __ + + + + + + + + AS + + + + + + + __ + + + + + + + + + + + + + + + + + AXIOM () OF TYPE + + + + + + + __ + + + + + + + + + + + + + + + + + UNFINISHED PROOF () + + + + + + + THESIS: + + + + + + + __ + + + + + + + + CONJECTURES: + + + + + + + + __ + : + + + + + + + + + CORRESPONDING PROOF: + + + + + + + __ + + + + + + + + + + + + + + + + + + + + + + INDUCTIVE DEFINITION + + + COINDUCTIVE DEFINITION + + + + + AND + + + _ + () + + + + + + + __ + [ + + + + + + + + + : + + + + + + + + + ] + + + + + + + ] + + + + + + + + + OF ARITY + + + + + + + __ + + + + + + + + BUILT FROM + + + + + + + + + + __ + + + | + _ + + + OF + _ + + + + + + + + + + + + + + + + + + + VARIABLE OF TYPE + + + + + + + __ + + + + + + + + + + + + + + + + + + + + + + + + + : + + + + + + + + + + + + : + + + + + + + + + + + + + + + + + + + + + + + + + + + + Π + + + + + + + . + + + + + + + + Π + + : + + . + + + + + + + + + + + + ( + + + + + + + + → + + + + + + + + ) + + + + + + + ( + + → + + ) + + + + + + + + + + + ( + + + + + + + + + ( + + + + + + + + + ) + + + + + + + ( + + + _ + + + ) + + + + + + + + + + + ( + + + + + + + + :> + + + + + + + + ) + + + + + + + ( + + :> + + ) + + + + + Prop + + + Set + + + Type + + + + + + + + + + < + + + > + CASES + _ + + + + + + + + + + > + CASES + _ + + + + + + + + + OF + + + + + + + + + + + | + + + | + + + _ + + + ⇒ + + + + + + + + + + |_ + ⇒ + + + + + + + + + + END + + + + + + + <> + CASES + _ + + _ + OF + + + + | + + + + ⇒ + + + _ + END + + + + + + + + + + + FIX + _ + + { + + + + + + + __ + + + + + + + + : + + + + + + + + + + + := + + + + + + + + + := + + + + + + + + + + + + + } + + + + + + + FIX + + { + + + + + + + : + + := + + + } + + + + + + + + + + + + + + + + + COFIX + _ + + { + + + + + + + __ + + + + + + + + : + + + + + + + + + + + := + + + + + + + + + := + + + + + + + + + + + + + } + + + + + + + COFIX + + { + + + + + + + : + + := + + + } + + + + + + + + + + + + + + + + + + + + + + + + λ + + + + + + + . + + + + + + + + λ + + : + + . + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ( + + + + + + + + __ + + + + + + + + + + + ) + + + + + + + + + + + + + + + + + + + + + + { + + + + + + __ + | + + + + + + } + + + + + + + + + { + + + , + + + + + + + _ + + + , + + + + + + + } + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + > + + + + + + + + diff --git a/helm/style/mmlextension_irene.xsl b/helm/style/mmlextension_irene.xsl new file mode 100644 index 000000000..90852b79e --- /dev/null +++ b/helm/style/mmlextension_irene.xsl @@ -0,0 +1,868 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + DEFINITION () OF TYPE + + + + + + + __ + + + + + + + + AS + + + + + + + __ + + + + + + + + + + + + + + + + + AXIOM () OF TYPE + + + + + + + __ + + + + + + + + + + + + + + + + + UNFINISHED PROOF () + + + + + + + THESIS: + + + + + + + __ + + + + + + + + CONJECTURES: + + + + + + + + __ + : + + + + + + + + + CORRESPONDING PROOF: + + + + + + + __ + + + + + + + + + + + + + + + + + + + + + + INDUCTIVE DEFINITION + + + COINDUCTIVE DEFINITION + + + + + AND + + + _ + () + + + + + + + __ + [ + + + + + + + + + : + + + + + + + + + ] + + + + + + + ] + + + + + + + + + OF ARITY + + + + + + + __ + + + + + + + + BUILT FROM + + + + + + + + + + __ + + + | + _ + + + OF + _ + + + + + + + + + + + + + + + + + + + VARIABLE OF TYPE + + + + + + + __ + + + + + + + + + + + + + + + + + + + + + + + + + + + + Π + + : + + + + + + + + + + + . + + + + + + + + + . + + + + + + + + Π + + : + + . + + + + + + + + + + + + ( + + + + + + + + → + + + + + + + + ) + + + + + + + ( + + → + + ) + + + + + + + + + + + ( + + + + + + + + + ( + + + + + + + + + ) + + + + + + + ( + + + _ + + + ) + + + + + + + + + + + ( + + + + + + + + :> + + + + + + + + ) + + + + + + + ( + + :> + + ) + + + + + Prop + + + Set + + + Type + + + + + + + + + + < + + + > + CASES + _ + + + + + + + + + + > + CASES + _ + + + + + + + + + OF + + + + + + + + + + + | + + + | + + + _ + + + ⇒ + + + + + + + + + + |_ + ⇒ + + + + + + + + + + END + + + + + + + <> + CASES + _ + + _ + OF + + + + | + + + + ⇒ + + + _ + END + + + + + + + + + + + FIX + _ + + { + + + + + + + __ + + + + + + + + : + + + + + + + + + + + := + + + + + + + + + := + + + + + + + + + + + + + } + + + + + + + FIX + + { + + + + + + + : + + := + + + } + + + + + + + + + + + + + + + + + COFIX + _ + + { + + + + + + + __ + + + + + + + + : + + + + + + + + + + + := + + + + + + + + + := + + + + + + + + + + + + + } + + + + + + + COFIX + + { + + + + + + + : + + := + + + } + + + + + + + + + + + + + + + + + + + + + + + + + + λ + + + : + + + + + + + + + + + . + + + + + + + + + . + + + + + + + + λ + + : + + . + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + > + + + + + + + + diff --git a/helm/style/objcontent.xsl b/helm/style/objcontent.xsl new file mode 100644 index 000000000..6ad0a4922 --- /dev/null +++ b/helm/style/objcontent.xsl @@ -0,0 +1,232 @@ + + + + + + + + + + + + + + + + + + + + + type="text/xml" + href="" type="text/xsl" + type="xslt" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +PROD + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + app + + + + + + + + + + + + + + + + + + + + + + + + + + $ + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/objcontent.xsl.csc b/helm/style/objcontent.xsl.csc new file mode 100644 index 000000000..d2a846cba --- /dev/null +++ b/helm/style/objcontent.xsl.csc @@ -0,0 +1,223 @@ + + + + + + + + + + + + + + + + + + + + + type="text/xml" + href="" type="text/xsl" + type="xslt" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +PROD + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + app + + + + + + + + + + + + + + + + + + + + + + + + + + $ + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/objcontent_old.xsl b/helm/style/objcontent_old.xsl new file mode 100644 index 000000000..d3514b499 --- /dev/null +++ b/helm/style/objcontent_old.xsl @@ -0,0 +1,220 @@ + + + + + + + + + + + + + + + + + + + + + type="text/xml" + href="" type="text/xsl" + type="xslt" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +PROD + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + app + + + + + + + + + + + + + + + + + + + + + + + + + + $ + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/params.xsl b/helm/style/params.xsl new file mode 100644 index 000000000..034eeba97 --- /dev/null +++ b/helm/style/params.xsl @@ -0,0 +1,191 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + + + + + + diff --git a/helm/style/proof31-10-00.xsl b/helm/style/proof31-10-00.xsl new file mode 100644 index 000000000..3c4234307 --- /dev/null +++ b/helm/style/proof31-10-00.xsl @@ -0,0 +1,210 @@ + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + rewrite + + + rw_step + + + + + + + + + + + and_ind + + + + + + + + + + + or_ind + + + + + + + + + proof + + + + + + + + + + + + + + + + + + + + + + + + + rw_step + + + + + + + + + + + + + + + + + + + + + + + + + + rewrite_and_apply + + rw_step + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + app + + + + + + + + + + + app + + * + * + * + + + + + + app + + + + + + + + + + + + + + diff --git a/helm/style/proofs.xsl b/helm/style/proofs.xsl new file mode 100644 index 000000000..88af829f8 --- /dev/null +++ b/helm/style/proofs.xsl @@ -0,0 +1,243 @@ + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + thread + + + rw_step + + + + + + + + + + thread + + + app + + + + + + + + + and_ind + + + + + + + + + + + or_ind + + + + + + + + + proof + + + + + + + + + + + + + + + + + + + + + + prev + + + + + + + + + + + + + + + rw_step + + + + + + + + + thread + + + + + + + + + + + + + + + + + + + + + + + + + + + rewrite_and_apply + + rw_step + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + app + + + + + + + + + + + app + + * + * + * + + + + + + app + + + + + + + + + + + + + + diff --git a/helm/style/reals.xsl b/helm/style/reals.xsl new file mode 100644 index 000000000..6c47f9562 --- /dev/null +++ b/helm/style/reals.xsl @@ -0,0 +1,277 @@ + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + 0 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + $x + + + + + + app + + $x + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + $x + + + app + + $x + + + + + + + + + + + + + + diff --git a/helm/style/ricerca.xsl b/helm/style/ricerca.xsl new file mode 100644 index 000000000..e0fa13a93 --- /dev/null +++ b/helm/style/ricerca.xsl @@ -0,0 +1,91 @@ + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + + +
+ + + + + + + + + + +
+ + + + + + + + +
+ + + + + + + + + + + + + diff --git a/helm/style/rootcontent.xsl b/helm/style/rootcontent.xsl new file mode 100644 index 000000000..9e85f0344 --- /dev/null +++ b/helm/style/rootcontent.xsl @@ -0,0 +1,30 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/rootcontent_withproofs.xsl b/helm/style/rootcontent_withproofs.xsl new file mode 100644 index 000000000..11d668436 --- /dev/null +++ b/helm/style/rootcontent_withproofs.xsl @@ -0,0 +1,29 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/roottheory.xsl b/helm/style/roottheory.xsl new file mode 100644 index 000000000..d293ee6f2 --- /dev/null +++ b/helm/style/roottheory.xsl @@ -0,0 +1,22 @@ + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/set.xsl b/helm/style/set.xsl new file mode 100644 index 000000000..303c872ef --- /dev/null +++ b/helm/style/set.xsl @@ -0,0 +1,487 @@ + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/theory_content.xsl b/helm/style/theory_content.xsl new file mode 100644 index 000000000..9b65cc5b2 --- /dev/null +++ b/helm/style/theory_content.xsl @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + + +http://localhost:8081/get?url= + + + + +
+ +
+ + + + + + +
+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/style/theory_pres.xsl b/helm/style/theory_pres.xsl new file mode 100644 index 000000000..9a96cdc03 --- /dev/null +++ b/helm/style/theory_pres.xsl @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + BEGIN SECTION + + END SECTION + + + + + BEGIN SECTION + + END SECTION + + + + + diff --git a/helm/xmltheory/Coq_v2theoryxml/.depend b/helm/xmltheory/Coq_v2theoryxml/.depend new file mode 100644 index 000000000..e69de29bb diff --git a/helm/xmltheory/Coq_v2theoryxml/Makefile b/helm/xmltheory/Coq_v2theoryxml/Makefile new file mode 100644 index 000000000..1f9fae538 --- /dev/null +++ b/helm/xmltheory/Coq_v2theoryxml/Makefile @@ -0,0 +1,17 @@ +COQTOP=/home/projects/helm/EXPORT/V7 +OCAMLC=ocamlc -I $(COQTOP)/config -I $(COQTOP)/toplevel + +COQV2THEORYXMLOBJS= \ + $(COQTOP)/config/coq_config.cmo \ + $(COQTOP)/toplevel/usage.cmo \ + coq_v2theoryxml.cmo + +coq_v2theoryxml: $(COQV2THEORYXMLOBJS) + $(OCAMLC) -o $@ unix.cma $(COQV2THEORYXMLOBJS) + +coq_v2theoryxml.cmo: coq_v2theoryxml.ml + $(OCAMLC) -c $< + +.PHONY: clean +clean: + rm -f coq_v2theoryxml *.cmo *.cmi diff --git a/helm/xmltheory/Coq_v2theoryxml/coq_v2theoryxml.ml b/helm/xmltheory/Coq_v2theoryxml/coq_v2theoryxml.ml new file mode 100644 index 000000000..b1e856e1a --- /dev/null +++ b/helm/xmltheory/Coq_v2theoryxml/coq_v2theoryxml.ml @@ -0,0 +1,176 @@ +(* environment *) + +let environment = Unix.environment () + +let bindir = ref Coq_config.bindir +let binary = "coqtop.byte" +let image = ref "" +let xml_theory_library_root = ref ( + try + Sys.getenv "XML_THEORY_LIBRARY_ROOT" + with Not_found -> "" +) + +(* the $COQBIN environment variable has priority over the Coq_config value *) +let _ = + try + let c = Sys.getenv "COQBIN" in + if c <> "" then bindir := c + with Not_found -> () + +(* coq_v2theoryxml options *) + +let keep = ref false + +(* Verifies that a string do not contains others caracters than letters, + digits, or `_` *) + +let check_module_name s = + let err () = + output_string stderr + "Modules names must only contain letters, digits, or underscores\n"; + output_string stderr + "and must begin with a letter\n"; + exit 1 + in + match String.get s 0 with + | 'a' .. 'z' | 'A' .. 'Z' -> + for i = 1 to (String.length s)-1 do + match String.get s i with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> () + | _ -> err () + done + | _ -> err () + + (* compilation of a file [file] with command [command] and args [args] *) + +let compile command args file = + let dirname = Filename.dirname file in + let basename = Filename.basename file in + let modulename = + if Filename.check_suffix basename ".vo" then + Filename.chop_suffix basename ".vo" + else + basename + in + check_module_name modulename; + let tmpfile = Filename.temp_file "coq_v2theoryxml" ".v" in + let args' = + command :: "-batch" :: "-silent" :: "-is" :: "barestate" :: args + @ ["-load-vernac-source"; tmpfile] in + let devnull = + if Sys.os_type = "Unix" then + Unix.openfile "/dev/null" [] 0o777 + else + Unix.stdin + in + let oc = open_out tmpfile in + Printf.fprintf oc "Require XmlTheory.\n" ; + Printf.fprintf oc "XmlTheory Begin %s \"%s\".\n" modulename + !xml_theory_library_root ; + Printf.fprintf oc "Load %s.\n" modulename; + Printf.fprintf oc "XmlTheory End.\n" ; + flush oc; + close_out oc; + try + let pid = + Unix.create_process_env command + (Array.of_list args') environment devnull Unix.stdout Unix.stderr in + let status = Unix.waitpid [] pid in + if not !keep then Sys.remove tmpfile ; + match status with + | _, Unix.WEXITED 0 -> () + | _, Unix.WEXITED 127 -> + Printf.printf "Cannot execute %s\n" command; + exit 1 + | _, Unix.WEXITED c -> exit c + | _ -> exit 1 + with _ -> + if not !keep then Sys.remove tmpfile; exit 1 + +(* parsing of the command line + * + * special treatment for -bindir and -i. + * other options are passed to coqtop *) + +let usage () = + Usage.print_usage + "Usage: coq_v2theoryxml module...\n +options are: + -xml-theory-library-root d specify the path to the root of the XML library + (overrides $XML_THEORY_LIBRARY_ROOT) + -image f specify an alternative executable for Coq + -t keep temporary files\n\n" ; + flush stderr ; + exit 1 + +let parse_args () = + let rec parse (cfiles,args) = function + | [] -> + List.rev cfiles, List.rev args + | "-xml-theory-library-root" :: v :: rem -> + xml_theory_library_root := v ; parse (cfiles,args) rem + | "-t" :: rem -> + keep := true ; parse (cfiles,args) rem + | "-boot" :: rem -> + bindir:= Filename.concat Coq_config.coqtop "bin"; + parse (cfiles, "-boot"::args) rem + | "-bindir" :: d :: rem -> + bindir := d ; parse (cfiles,args) rem + | "-bindir" :: [] -> + usage () + | "-byte" :: rem -> + parse (cfiles,args) rem + | "-opt" :: rem -> + raise (Failure "To load ML modules, only -byte is allowed") + | "-image" :: f :: rem -> + image := f; parse (cfiles,args) rem + | "-image" :: [] -> + usage () + | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () + | ("-libdir"|"-outputstate"|"-I"|"-include" + |"-inputstate"|"-is"|"-load-vernac-source"|"-load-vernac-object" + |"-load-ml-source"|"-require"|"-load-ml-object"|"-user" + |"-init-file" as o) :: rem -> + begin + match rem with + | s :: rem' -> parse (cfiles,s::o::args) rem' + | [] -> usage () + end + | "-R" as o :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem + | ("-notactics"|"-debug"|"-db"|"-debugger"|"-nolib"|"-batch"|"-nois" + |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" + |"-silent"|"-m" as o) :: rem -> + parse (cfiles,o::args) rem + | ("-v"|"--version") :: _ -> + Usage.version () + | "-where" :: _ -> + print_endline Coq_config.coqlib; exit 0 + | f :: rem -> parse (f::cfiles,args) rem + in + parse ([],[]) (List.tl (Array.to_list Sys.argv)) + +(* main: we parse the command line, define the command to compile files + * and then call the compilation on each file *) + +let main () = + let cfiles, args = parse_args () in + if cfiles = [] then begin + prerr_endline "coq_v2theoryxml: too few arguments" ; + usage () + end; + let coqtopname = + if !image <> "" then !image else Filename.concat !bindir (binary ^ Coq_config.exec_extension) + in + if !xml_theory_library_root = "" then + begin + prerr_endline "coq_v2theoryxml: you must either set $XML_THEORY_LIBRARY_ROOT or use -xml-theory-library-root"; + usage () + end + else + List.iter (compile coqtopname args) cfiles ; + prerr_endline + ("\nWARNING: all the URIs in the generated XML files are broken." ^ + "\n See the README in the XML contrib to learn how to fix them.\n") + +let _ = Printexc.print main (); exit 0 diff --git a/helm/xmltheory/FakeCoq_vo2xml/README b/helm/xmltheory/FakeCoq_vo2xml/README new file mode 100644 index 000000000..4accfcafc --- /dev/null +++ b/helm/xmltheory/FakeCoq_vo2xml/README @@ -0,0 +1,3 @@ +# This coq_vo2xml must be put in PATH before the real coq_vo2xml. +# It's aim is to run coq_v2theoryxml instead of coq_vo2xml +# Remember to set $XML_THEORY_LIBRARY_ROOT before starting this coq_vo2xml diff --git a/helm/xmltheory/FakeCoq_vo2xml/coq_vo2xml b/helm/xmltheory/FakeCoq_vo2xml/coq_vo2xml new file mode 100755 index 000000000..34e44a0a4 --- /dev/null +++ b/helm/xmltheory/FakeCoq_vo2xml/coq_vo2xml @@ -0,0 +1,4 @@ +#!/bin/bash + +BASEDIR=/home/projects/helm/EXPORT/xmltheory +$BASEDIR/Coq_v2theoryxml/coq_v2theoryxml -R $BASEDIR/XmlTheory Bologna.XmlTheory $@ diff --git a/helm/xmltheory/XmlTheory/.depend b/helm/xmltheory/XmlTheory/.depend new file mode 100644 index 000000000..2b814a941 --- /dev/null +++ b/helm/xmltheory/XmlTheory/.depend @@ -0,0 +1,8 @@ +xmltheoryentries.cmo: xmltheoryentries.ml iXml.cmi +xmltheoryentries.cmx: xmltheoryentries.ml iXml.cmx +iXml.cmo: iXml.ml iXml.cmi +iXml.cmx: iXml.ml iXml.cmi +iXml.cmi: iXml.mli +XmlTheory.vo: XmlTheory.v iXml.cmo xmltheoryentries.cmo +XmlTheory.vi: XmlTheory.v iXml.cmo xmltheoryentries.cmo +XmlTheory.html: XmlTheory.v iXml.cmo xmltheoryentries.cmo diff --git a/helm/xmltheory/XmlTheory/COME_COMPILARE b/helm/xmltheory/XmlTheory/COME_COMPILARE new file mode 100644 index 000000000..f1389cc35 --- /dev/null +++ b/helm/xmltheory/XmlTheory/COME_COMPILARE @@ -0,0 +1,5 @@ +# Settare + +OPT=-byte # Nota: questo andrebbe fatto nel Make, ma un bug di coq_makefile + # lo impedisce +COQTOP=... diff --git a/helm/xmltheory/XmlTheory/Make b/helm/xmltheory/XmlTheory/Make new file mode 100644 index 000000000..a927b6345 --- /dev/null +++ b/helm/xmltheory/XmlTheory/Make @@ -0,0 +1,5 @@ +-R . Bologna.XmlTheory +-I $(COQTOP)/contrib/xml +XmlTheory.v +iXml.ml +xmltheoryentries.ml diff --git a/helm/xmltheory/XmlTheory/Makefile b/helm/xmltheory/XmlTheory/Makefile new file mode 100644 index 000000000..1dc9d35c4 --- /dev/null +++ b/helm/xmltheory/XmlTheory/Makefile @@ -0,0 +1,165 @@ +############################################################################## +## The Calculus of Inductive Constructions ## +## ## +## Projet Coq ## +## ## +## INRIA ENS-CNRS ## +## Rocquencourt Lyon ## +## ## +## Coq V7 ## +## ## +## ## +############################################################################## + +# WARNING +# +# This Makefile has been automagically generated by coq_makefile +# Edit at your own risks ! +# +# END OF WARNING + +# +# This Makefile was generated by the command line : +# coq_makefile -f Make -o Makefile +# + +########################## +# # +# Variables definitions. # +# # +########################## + +CAMLP4LIB=`camlp4 -where` +MAKE=make "COQBIN=$(COQBIN)" "OPT=$(OPT)" +COQSRC=-I $(COQTOP)/kernel -I $(COQTOP)/lib \ + -I $(COQTOP)/library -I $(COQTOP)/parsing -I $(COQTOP)/pretyping \ + -I $(COQTOP)/proofs -I $(COQTOP)/syntax -I $(COQTOP)/tactics \ + -I $(COQTOP)/toplevel -I $(CAMLP4LIB) +ZFLAGS=$(OCAMLLIBS) $(COQSRC) +COQFLAGS=-q $(OPT) $(COQLIBS) +COQC=$(COQBIN)coqc +COQFULL=$(COQBIN)coqc $(FULLOPT) -q $(COQLIBS) +GALLINA=gallina +COQ2HTML=coq2html +COQ2LATEX=coq2latex +CAMLC=ocamlc -c +CAMLOPTC=ocamlopt -c +CAMLLINK=ocamlc +CAMLOPTLINK=ocamlopt +COQDEP=$(COQBIN)coqdep -c +COQVO2XML=coq_vo2xml + +######################### +# # +# Libraries definition. # +# # +######################### + +OCAMLLIBS=-I .\ + -I $(COQTOP)/contrib/xml +COQLIBS=-I .\ + -R . Bologna.XmlTheory\ + -I $(COQTOP)/contrib/xml + +################################### +# # +# Definition of the "all" target. # +# # +################################### + +all: XmlTheory.vo\ + iXml.cmo\ + xmltheoryentries.cmo + +spec: XmlTheory.vi + +gallina: XmlTheory.g + +html: XmlTheory.html + +tex: XmlTheory.tex + +gallinatex: XmlTheory.g.tex + +gallinahtml: XmlTheory.g.html + +xml: .xml_time_stamp +.xml_time_stamp: XmlTheory.vo + $(COQVO2XML) $(COQFLAGS) $(?:%.o=%) + touch .xml_time_stamp + +#################### +# # +# Special targets. # +# # +#################### + +.PHONY: all opt byte archclean clean install depend xml + +.SUFFIXES: .mli .ml .cmo .cmi .cmx .v .vo .vi .g .html .tex .g.tex .g.html + +.mli.cmi: + $(CAMLC) $(ZDEBUG) $(ZFLAGS) $< + +.ml.cmo: + $(CAMLC) $(ZDEBUG) $(ZFLAGS) $< + +.ml.cmx: + $(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $< + +.v.vo: + $(COQC) $(COQDEBUG) $(COQFLAGS) $* + +.v.vi: + $(COQC) -i $(COQDEBUG) $(COQFLAGS) $* + +.v.g: + $(GALLINA) $< + +.v.html: + $(COQ2HTML) $< + +.v.tex: + $(COQ2LATEX) $< -latex -o $@ + +.v.g.html: + $(GALLINA) -stdout $< | $(COQ2HTML) -f > $@ + +.v.g.tex: + $(GALLINA) -stdout $< | $(COQ2LATEX) - -latex -o $@ + +byte: + $(MAKE) all "OPT=" + +opt: + $(MAKE) all "OPT=-opt" + +include .depend + +depend: + rm .depend + $(COQDEP) -i $(COQLIBS) *.v *.ml *.mli >.depend + $(COQDEP) $(COQLIBS) -suffix .html *.v >>.depend + +install: + @if test -z $(TARGETDIR); then echo "You must set TARGETDIR (for instance with 'make TARGETDIR=foobla install')"; exit 1; fi + cp -f *.vo $(TARGETDIR) + cp -f *.cmo $(TARGETDIR) + +Makefile: Make + mv -f Makefile Makefile.bak + $(COQBIN)coq_makefile -f Make -o Makefile + +clean: + rm -f *.cmo *.cmi *.cmx *.o *.vo *.vi *~ + +archclean: + rm -f *.cmx *.o + +# WARNING +# +# This Makefile has been automagically generated by coq_makefile +# Edit at your own risks ! +# +# END OF WARNING + diff --git a/helm/xmltheory/XmlTheory/README b/helm/xmltheory/XmlTheory/README new file mode 100644 index 000000000..ce4c86c98 --- /dev/null +++ b/helm/xmltheory/XmlTheory/README @@ -0,0 +1,78 @@ +Here we show the procedure to follow to add the recognition of +a new syntactical form. + +Form to recognize in the model: + +Lemma existsDec : (l:(list A)){(list_exists l)}+{~(list_exists l)}. + +1. cd V7 ; grep "Lemma" */*.ml4 + the result should be one or a few files. In this case the + only file is parsing/g_vernac.ml4. In the case of many files, + only one is the good one. +2. open the file and search for Lemma: + thm_tok: + [ [ "Theorem" -> <:ast< "THEOREM" >> + | IDENT "Lemma" -> <:ast< "LEMMA" >> + | IDENT "Fact" -> <:ast< "FACT" >> + | IDENT "Remark" -> <:ast< "REMARK" >> + | IDENT "Decl" -> <:ast< "DECL" >> ] ] + + so a Lemma is mapped into an ast of phylum thm_tok. + Let's search for thm_tok. Many occurrences are found, + but the only one that matches the form to recognize is + + gallina: + (* Definition, Goal *) + [ [ thm = thm_tok; id = identarg; ":"; c = constrarg -> + <:ast< (StartProof $thm $id $c) >> + + So the ast created is tagged StartProof +3. grep "StartProof" */*.ml (usually toplevel/...) + Open the file and search for StartProof. + This is found: + let _ = + add "StartProof" + (function + | [VARG_STRING kind;VARG_IDENTIFIER s;VARG_CONSTR com] -> + ... +4. edit xmltheoryentries.ml and copy the entry for another rule, + substituting StartProof as the parameter for set_hook and + using the above match (with V. added where appropriate) after function: + +let module V = Vernacinterp in + set_hook "StartProof" + (function + [V.VARG_STRING kind;V.VARG_IDENTIFIER s;V.VARG_CONSTR com] -> + ??? + | _ -> fail () + ) +;; + + Finally, write OCaml code to print to XML the availables interesting + infos. In our case the code becomes + +let module V = Vernacinterp in + set_hook "StartProof" + (function + [V.VARG_STRING kind;V.VARG_IDENTIFIER s;V.VARG_CONSTR com] -> + IXml.output + (Xml.xml_empty + "THEOREM" + ["uri", Names.string_of_id s ^ ".con"; "as",kind] + ) + | _ -> fail () + ) +;; + + IXml.output should always be present and the code inside + (that is simply XML written in OCaml form) should be changed. + The syntax is + Xml.xml_empty "name" ["att1","value1" ; ... ; "attn","valuen"] + to create an empty element name with attributes att1 ... attn. + To create a non-empty element, use + Xml.xml_nempty "name" ["att1","value1" ; ... ; "attn","valuen"] + stream + where stream is an OCaml stream of other XML elements, as: + * another Xml.xml_nempty + * an Xml.xml_empty + * [< stream1 ; ... ; streamk >] diff --git a/helm/xmltheory/XmlTheory/XmlTheory.v b/helm/xmltheory/XmlTheory/XmlTheory.v new file mode 100644 index 000000000..54fdf82e6 --- /dev/null +++ b/helm/xmltheory/XmlTheory/XmlTheory.v @@ -0,0 +1,15 @@ +Declare ML Module "iXml" "xmltheoryentries". + +(*Vecchio, ma funzionante +Grammar vernac vernac : ast := + xml_theory_begin [ "XmlTheory" "Begin" stringarg($s) stringarg($f) "." ] -> + [(XMLTHEORYBEGIN $s $f)] +| xml_theory_end [ "XmlTheory" "End" "." ] -> + [(XMLTHEORYEND)]. +*) + +Grammar vernac vernac : ast := + xml_theory_begin [ "XmlTheory" "Begin" identarg($s) stringarg($f) "." ] -> + [(XMLTHEORYBEGIN $s $f)] +| xml_theory_end [ "XmlTheory" "End" "." ] -> + [(XMLTHEORYEND)]. diff --git a/helm/xmltheory/XmlTheory/iXml.ml b/helm/xmltheory/XmlTheory/iXml.ml new file mode 100644 index 000000000..98fb186d8 --- /dev/null +++ b/helm/xmltheory/XmlTheory/iXml.ml @@ -0,0 +1,53 @@ +exception NoOpenNonEmptyElements + +type sectionTree = + Leaf of Xml.token Stream.t + | Node of string * (string * string) list * sectionTree list ref +;; + +let rec token_stream_of_section_tree_list = + function + he::tl -> + [< token_stream_of_section_tree_list tl; token_stream_of_section_tree he >] + | [] -> [<>] +and token_stream_of_section_tree = + function + Leaf t -> [< t >] + | Node (elem_name, attr_list, section_tree) -> + Xml.xml_nempty elem_name attr_list + (token_stream_of_section_tree_list !section_tree) +;; + +let section_stack = ref [];; +let xmloutput = ref (ref []);; +let filename = ref "";; + +let reset_output fname = + filename := fname ; + xmloutput := ref [] ; + section_stack := [] +;; + +let output n = + let xmloutput = !xmloutput in + xmloutput := (Leaf n) :: !xmloutput +;; + +let open_non_empty_element elem_name attr_list = + let newxmloutput = ref [] in + !xmloutput := (Node (elem_name, attr_list, newxmloutput)) :: !(!xmloutput) ; + section_stack := !xmloutput :: !section_stack ; + xmloutput := newxmloutput +;; + +let close_non_empty_element () = + match !section_stack with + oldxmloutput::oldsection_stack -> + xmloutput := oldxmloutput ; + section_stack := oldsection_stack + | _ -> raise NoOpenNonEmptyElements +;; + +let print_output () = + Xml.pp (token_stream_of_section_tree_list !(!xmloutput)) (Some !filename) +;; diff --git a/helm/xmltheory/XmlTheory/iXml.mli b/helm/xmltheory/XmlTheory/iXml.mli new file mode 100644 index 000000000..11fad8202 --- /dev/null +++ b/helm/xmltheory/XmlTheory/iXml.mli @@ -0,0 +1,7 @@ +exception NoOpenNonEmptyElements + +val reset_output : string -> unit +val output : Xml.token Stream.t -> unit +val open_non_empty_element : string -> (string * string) list -> unit +val close_non_empty_element : unit -> unit +val print_output : unit -> unit diff --git a/helm/xmltheory/XmlTheory/xmltheoryentries.ml b/helm/xmltheory/XmlTheory/xmltheoryentries.ml new file mode 100644 index 000000000..de3c5030a --- /dev/null +++ b/helm/xmltheory/XmlTheory/xmltheoryentries.ml @@ -0,0 +1,371 @@ +(*********************) +(* Utility functions *) +(*********************) + +let fail () = + Pp.warning "XmlTheory: AST not recognized" +;; + +(* name is the name of the function to hook *) +(* hook is an hook partial-function to recognize particular inputs *) +let set_hook name hook = + let module V = Vernacinterp in + let old = V.vinterp_map name in + V.vinterp_add name + (fun l () -> + old l () ; + hook l + ) +;; + + +(*****************************************************) +(* Vernacular administrative commands for the module *) +(*****************************************************) + +let header = +"\n" ^ +"\n" +;; + +(*Vecchio, ma funzionante +let module V = Vernacinterp in + V.vinterp_add "XMLTHEORYBEGIN" + (function + [V.VARG_STRING curi ; V.VARG_STRING filename] -> + fun () -> + IXml.reset_output filename ; + IXml.output (Xml.xml_cdata header) ; + IXml.open_non_empty_element "Theory" ["uri","cic:" ^ curi] + | _ -> V.bad_vernac_args "XMLTHEORYBEGIN" + ) +;; +*) + +let module V = Vernacinterp in +let module L = Library in +let module S = System in +let module N = Names in + V.vinterp_add "XMLTHEORYBEGIN" + (function + [V.VARG_IDENTIFIER id ; V.VARG_STRING root_dir] -> + fun () -> + let s = N.string_of_id id in + let lpe,_ = + S.find_file_in_path (L.get_load_path ()) (s^".v") + in + let curi = "/" ^ String.concat "/" lpe.S.coq_dirpath in + let dirname = root_dir ^ curi in + Unix.system ("mkdir -p " ^ dirname) ; + let filename = dirname ^ "/" ^ s ^ ".theory" in + IXml.reset_output filename ; + IXml.output (Xml.xml_cdata header) ; + IXml.open_non_empty_element "Theory" ["uri","cic:" ^ curi ^ "/" ^ s] + | _ -> V.bad_vernac_args "XMLTHEORYBEGIN" + ) +;; + +let module V = Vernacinterp in + V.vinterp_add "XMLTHEORYEND" + (function + [] -> + fun () -> + IXml.close_non_empty_element () ; + IXml.print_output () + | _ -> V.bad_vernac_args "XMLTHEORYEND" + ) +;; + + +(**********************************************************) +(* All the vernacular commands on which one is interested *) +(* should be overridden here *) +(**********************************************************) + +let module V = Vernacinterp in +let module N = Names in +let module S = System in +let module L = Library in + set_hook "Require" + (function + [V.VARG_STRING import; V.VARG_STRING specif; V.VARG_IDENTIFIER id] -> + (* id is the identifier of the module, but we need the absolute *) + (* identifier as an URI. *) + (* E.g.: Logic ==> theory:/Coq/Init/Logic.theory *) + let name = N.string_of_id id in + let ({S.coq_dirpath = coq_dirpath},_) = L.module_filename name in + let uri = + "theory:/" ^ (String.concat "/" coq_dirpath) ^ "/" ^ name ^ ".theory" + in + IXml.output + (Xml.xml_nempty "vernacular" [] + (Xml.xml_empty + "Require" + ["import",import; "specif",specif; "uri",uri] + ) + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in +let module T = Nametab in +let module N = Names in + set_hook "HintsResolve" + (function + (V.VARG_VARGLIST l)::lh -> + IXml.output + (Xml.xml_nempty "vernacular" [] + (Xml.xml_nempty + "HintsResolve" [] + [< Xml.xml_nempty "dbs" [] + (List.fold_right + (function + (V.VARG_IDENTIFIER x) -> + (function i -> + [< Xml.xml_empty "db" ["name",N.string_of_id x]; + i + >] + ) + | _ -> Vernacinterp.bad_vernac_args "HintsResolve" + ) + l [<>]) ; + Xml.xml_nempty "hints" [] + (List.fold_right + (function + (V.VARG_QUALID x) -> + (function i -> + [< Xml.xml_empty "hint" ["name",T.string_of_qualid x]; + i + >] + ) + | _ -> Vernacinterp.bad_vernac_args "HintsResolve" + ) + lh [<>] + ) + >] + ) + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "IMPLICIT_ARGS_ON" + (function + [] -> + IXml.output + (Xml.xml_nempty "vernacular" [] + (Xml.xml_empty + "ImplicitArguments" + ["status","ON"] + ) + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "DEFINITION" + (function + (* Coq anomaly: a Local definition is a Definition at the syntax *) + (* level but a Variable at the logical level. Here we have to *) + (* recognize the two cases and treat them differently *) + (V.VARG_STRING "LOCAL":: V.VARG_IDENTIFIER id:: V.VARG_CONSTR c:: rest) -> + IXml.output + (Xml.xml_nempty "VARIABLES" ["as","LOCAL"] + (Xml.xml_empty + "VARIABLE" + ["uri",Names.string_of_id id ^ ".var"] + ) + ) + | (V.VARG_STRING kind:: V.VARG_IDENTIFIER id:: V.VARG_CONSTR c :: rest) -> + IXml.output + (Xml.xml_empty + "DEFINITION" + ["uri", Names.string_of_id id ^ ".con" ; "as",kind] + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "BeginSection" + (function + [V.VARG_IDENTIFIER id] -> + IXml.open_non_empty_element "SECTION" ["uri", Names.string_of_id id] + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "EndSection" + (function + [V.VARG_IDENTIFIER id] -> + IXml.close_non_empty_element () + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "StartProof" + (function + [V.VARG_STRING kind;V.VARG_IDENTIFIER s;V.VARG_CONSTR com] -> + IXml.output + (Xml.xml_empty + "THEOREM" + ["uri", Names.string_of_id s ^ ".con"; "as",kind] + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "MUTUALINDUCTIVE" + (function + [V.VARG_STRING f; V.VARG_VARGLIST indl] -> + (* we need the name of the first inductive defined *) + (* type in the block to get the URI *) + let name = + match indl with + (V.VARG_VARGLIST ((V.VARG_IDENTIFIER name)::_))::_ -> name + | _ -> assert false + in + IXml.output + (Xml.xml_empty + "DEFINITION" + ["uri", Names.string_of_id name ^ ".ind"; "as",f] + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "VARIABLE" + (function + [V.VARG_STRING kind; V.VARG_BINDERLIST slcl] -> + (* here we need all the names *) + let names = + List.flatten (List.map fst slcl) + in + IXml.output + (Xml.xml_nempty "VARIABLES" ["as",kind] + (List.fold_right + (fun name s -> + [< (Xml.xml_empty + "VARIABLE" + ["uri",Names.string_of_id name ^ ".var"] + ) ; s + >] + ) names [<>] + ) + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in +let module T = Nametab in +let module N = Names in + set_hook "COERCION" + (function + [V.VARG_STRING kind; V.VARG_STRING identity; V.VARG_QUALID qid; + V.VARG_QUALID qids; V.VARG_QUALID qidt] -> + (* let's substitute empty strings with non-empty strings *) + (* to get a stricter DTD *) + let remove_empty_string s = if s = "" then "UNSPECIFIED" else s in + let kind = remove_empty_string kind in + let identity = remove_empty_string identity in + IXml.output + (Xml.xml_nempty "vernacular" [] + (Xml.xml_empty + "Coercion" + ["kind",kind; "identity",identity ; "name",T.string_of_qualid qid ; + "source",T.string_of_qualid qids;"target",T.string_of_qualid qidt] + ) + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "MUTUALRECURSIVE" + (function + [V.VARG_VARGLIST lmi] -> + (* we need the name of the first inductive defined *) + (* type in the block to get the URI *) + let name = + match lmi with + (V.VARG_VARGLIST ((V.VARG_IDENTIFIER name)::_))::_ -> name + | _ -> assert false + in + IXml.output + (Xml.xml_empty + "DEFINITION" + ["uri", Names.string_of_id name ^ ".con" ; "as","Fixpoint"] + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "MUTUALCORECURSIVE" + (function + [V.VARG_VARGLIST lmi] -> + (* we need the name of the first inductive defined *) + (* type in the block to get the URI *) + let name = + match lmi with + (V.VARG_VARGLIST ((V.VARG_IDENTIFIER name)::_))::_ -> name + | _ -> assert false + in + IXml.output + (Xml.xml_empty + "DEFINITION" + ["uri", Names.string_of_id name ^ ".con" ; "as","CoFixpoint"] + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "RECORD" + (function + [V.VARG_STRING coe; + V.VARG_IDENTIFIER struc; + V.VARG_BINDERLIST binders; + V.VARG_CONSTR sort; + V.VARG_VARGLIST namec; + V.VARG_VARGLIST cfs] -> + IXml.output + (Xml.xml_empty + "DEFINITION" + ["uri", Names.string_of_id struc ^ ".ind" ; "as","Record"] + ) + | _ -> fail () + ) +;; + +let module V = Vernacinterp in + set_hook "PARAMETER" + (function + [V.VARG_STRING kind; V.VARG_BINDERLIST slcl] -> + (* here we need all the names *) + let names = + List.flatten (List.map fst slcl) + in + IXml.output + (Xml.xml_nempty "AXIOMS" ["as",kind] + (List.fold_right + (fun name s -> + [< (Xml.xml_empty + "AXIOM" + ["uri",Names.string_of_id name ^ ".con"] + ) ; s + >] + ) names [<>] + ) + ) + | _ -> fail () + ) +;; diff --git a/helm/xmltheory/maththeory.dtd b/helm/xmltheory/maththeory.dtd new file mode 100644 index 000000000..f010b6500 --- /dev/null +++ b/helm/xmltheory/maththeory.dtd @@ -0,0 +1,78 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/xsltd/Makefile b/helm/xsltd/Makefile new file mode 100644 index 000000000..83c51d9d5 --- /dev/null +++ b/helm/xsltd/Makefile @@ -0,0 +1,29 @@ +start-xaland: + java -ss1024K -oss8192K \ + xaland 12345 12346 \ + $(HELM_STYLES_DIR)/rootcontent.xsl \ + $(HELM_STYLES_DIR)/annotatedpres.xsl \ + $(HELM_STYLES_DIR)/theory_content.xsl \ + $(HELM_STYLES_DIR)/theory_pres.xsl + +start-xaland-2: + java -ss1024K -oss8192K \ + xaland2 12345 12346 \ + $(HELM_STYLES_DIR)/rootcontent.xsl \ + $(HELM_STYLES_DIR)/annotatedpres.xsl \ + $(HELM_STYLES_DIR)/theory_content.xsl \ + $(HELM_STYLES_DIR)/theory_pres.xsl + +start-xaland-old: + java xaland 12345 12346 \ + $(HELM_STYLES_DIR)/style_prima_del_linguaggio_naturale/rootcontent.xsl \ + $(HELM_STYLES_DIR)/style_prima_del_linguaggio_naturale/annotatedpres.xsl \ + $(HELM_STYLES_DIR)/style_prima_del_linguaggio_naturale/theory_content.xsl \ + $(HELM_STYLES_DIR)/style_prima_del_linguaggio_naturale/theory_pres.xsl + +start-xaland3: + java xaland 12347 12348 \ + $(HELM_STYLES_DIR)/rootcontent.xsl \ + $(HELM_STYLES_DIR)/annotatedpres.xsl \ + $(HELM_STYLES_DIR)/theory_content.xsl \ + $(HELM_STYLES_DIR)/theory_pres.xsl diff --git a/helm/xsltd/cadet b/helm/xsltd/cadet new file mode 100755 index 000000000..6206c54cd --- /dev/null +++ b/helm/xsltd/cadet @@ -0,0 +1,11 @@ +#! /bin/sh + +export PATH=~/HELM/installation/jdk118/bin:$PATH + +#export CLASSPATH=/home/cadet/sacerdot/xalan-j_1_1/xalan.jar:/home/cadet/sacerdot/xalan-j_1_1/xerces.jar:. +export CLASSPATH=~/HELM/installation/xalan-j_1_2/xalan.jar:~/HELM/installation/xalan-j_1_2/xerces.jar:. +#export CLASSPATH=~/HELM/installation/xalan-j_1_2_1/xalan.jar:~/HELM/installation/xalan-j_1_2_1/xerces.jar:. +#export CLASSPATH=/home/cadet/sacerdot/xalan-j_2_0_D01/bin/xalan.jar:/home/cadet/sacerdot/xalan-j_2_0_D01/bin/xerces.jar:. + +export HELM_STYLES_DIR=../V6.2/examples/style +#export HELM_STYLES_DIR=../V7/examples/style diff --git a/helm/xsltd/isterix b/helm/xsltd/isterix new file mode 100755 index 000000000..e11d92c8b --- /dev/null +++ b/helm/xsltd/isterix @@ -0,0 +1,10 @@ +#! /bin/sh + +export PATH=$PATH:/opt/java/jdk118/bin/ + +export CLASSPATH=. +export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xalan.jar +export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/xalan_1_1/xerces.jar +export CLASSPATH=$CLASSPATH:/home/lpadovan/helm/java/saxon-5.3.2/saxon.jar + +export HELM_STYLES_DIR=../V6.2/examples/style diff --git a/helm/xsltd/xaland-cpp/xaland.cpp b/helm/xsltd/xaland-cpp/xaland.cpp new file mode 100644 index 000000000..e22140267 --- /dev/null +++ b/helm/xsltd/xaland-cpp/xaland.cpp @@ -0,0 +1,207 @@ +// Base header file. Must be first. +#include + +#include +#include + +#include + +#include + +#include + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +int main(int argc, const char* []) +{ +#if !defined(XALAN_NO_NAMESPACES) + using std::cerr; + using std::endl; + using std::ofstream; +#endif + + if (argc != 1) { + cerr << "Usage: SimpleTransform" + << endl + << endl; + } else { + try { + // Call the static initializer for Xerces... + XMLPlatformUtils::Initialize(); + + { + // Initialize the Xalan XSLT subsystem... + XSLTInit theInit; + + // Create the support objects that are necessary for + // running the processor... + XercesDOMSupport theDOMSupport; + XercesParserLiaison theParserLiaison(theDOMSupport); + XPathSupportDefault theXPathSupport(theDOMSupport); + XSLTProcessorEnvSupportDefault theXSLTProcessorEnvSupport; + XObjectFactoryDefault theXObjectFactory; + XPathFactoryDefault theXPathFactory; + + // Create a processor... + XSLTEngineImpl theProcessor( + theParserLiaison, + theXPathSupport, + theXSLTProcessorEnvSupport, + theDOMSupport, + theXObjectFactory, + theXPathFactory); + + // Connect the processor to the support object... + theXSLTProcessorEnvSupport.setProcessor(&theProcessor); + + // Create a stylesheet construction context, and a stylesheet + // execution context... + StylesheetConstructionContextDefault theConstructionContext( + theProcessor, + theXSLTProcessorEnvSupport, + theXPathFactory); + + StylesheetExecutionContextDefault theExecutionContext( + theProcessor, + theXSLTProcessorEnvSupport, + theXPathSupport, + theXObjectFactory); + + // Our input files...The assumption is that the executable will be + // run from same directory as the input files. + const XalanDOMString theXMLFileName("foo.xml"); + const XalanDOMString theXSLFileName("foo.xsl"); + + // Our input sources... + XSLTInputSource theInputSource(c_wstr(theXMLFileName)); + XSLTInputSource theStylesheetSource(c_wstr(theXSLFileName)); + + // Our output target... + const XalanDOMString theOutputFileName("foo.out"); + XSLTResultTarget theResultTarget(theOutputFileName); + + theProcessor.process( + theInputSource, + theStylesheetSource, + theResultTarget, + theConstructionContext, + theExecutionContext); + + } + + // Call the static terminator for Xerces... + XMLPlatformUtils::Terminate(); + } + catch(...) { + cerr << "Exception caught!!!" + << endl + << endl; + } + } + + return 0; +} + +/**************************************************/ +/* + +public class xaland { + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + theory_processor.reset(); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + processor.reset(); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! * / + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} + +*/ diff --git a/helm/xsltd/xaland-java/rompi.class b/helm/xsltd/xaland-java/rompi.class new file mode 100644 index 000000000..4abfe3865 Binary files /dev/null and b/helm/xsltd/xaland-java/rompi.class differ diff --git a/helm/xsltd/xaland-java/rompi.java b/helm/xsltd/xaland-java/rompi.java new file mode 100644 index 000000000..6a633dbc9 --- /dev/null +++ b/helm/xsltd/xaland-java/rompi.java @@ -0,0 +1,12 @@ +import java.net.*; + +public class rompi { + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException + { + /* Wait forever ;-) */ + DatagramSocket socket2 = new DatagramSocket(12346); + DatagramPacket packet2 = new DatagramPacket(new byte[1],1); + System.out.println("Ho preso il socket e non lo lascio piu', caro pu, caro pu"); + socket2.receive(packet2); + } +} diff --git a/helm/xsltd/xaland-java/sped.class b/helm/xsltd/xaland-java/sped.class new file mode 100644 index 000000000..cc6f53dac Binary files /dev/null and b/helm/xsltd/xaland-java/sped.class differ diff --git a/helm/xsltd/xaland-java/sped.java b/helm/xsltd/xaland-java/sped.java new file mode 100644 index 000000000..9d96610d4 --- /dev/null +++ b/helm/xsltd/xaland-java/sped.java @@ -0,0 +1,28 @@ +import java.net.*; + +public class sped { + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException + { + String input = argv[0]; + String out1 = argv[1]; + String out2 = argv[2]; + + String sent = input + " " + out1 + " " + out2; + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket = new DatagramSocket(); + + int strlen = sent.length(); + byte buf[] = new byte[strlen]; + sent.getBytes(0,strlen,buf,0); + DatagramPacket packet = new DatagramPacket(buf,strlen,address,12345); + + socket.send(packet); + + + /* Wait for answer (or forever ;-) */ + DatagramSocket socket2 = new DatagramSocket(12346); + DatagramPacket packet2 = new DatagramPacket(new byte[1],1); + socket2.receive(packet2); + } +} diff --git a/helm/xsltd/xaland-java/xaland.class b/helm/xsltd/xaland-java/xaland.class new file mode 100644 index 000000000..6871fda4b Binary files /dev/null and b/helm/xsltd/xaland-java/xaland.class differ diff --git a/helm/xsltd/xaland-java/xaland.java b/helm/xsltd/xaland-java/xaland.java new file mode 100644 index 000000000..1b9312c46 --- /dev/null +++ b/helm/xsltd/xaland-java/xaland.java @@ -0,0 +1,91 @@ +import org.apache.xalan.xslt.*; +import java.net.*; +import java.io.*; + +public class xaland { +/* + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } +*/ + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + theory_processor.reset(); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = + XSLTProcessorFactory.getProcessor(new org.apache.xalan.xpath.xdom.XercesLiaison()); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + processor.reset(); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! */ + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} diff --git a/helm/xsltd/xaland-java/xaland.java.prima_del_loro_baco b/helm/xsltd/xaland-java/xaland.java.prima_del_loro_baco new file mode 100644 index 000000000..b46ffa6aa --- /dev/null +++ b/helm/xsltd/xaland-java/xaland.java.prima_del_loro_baco @@ -0,0 +1,85 @@ +import org.apache.xalan.xslt.*; +import java.net.*; +import java.io.*; + +public class xaland { + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! */ + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} diff --git a/helm/xsltd/xaland-java/xaland.java.prima_del_loro_baco_ma_dopo_i_reset b/helm/xsltd/xaland-java/xaland.java.prima_del_loro_baco_ma_dopo_i_reset new file mode 100644 index 000000000..1467cdd2e --- /dev/null +++ b/helm/xsltd/xaland-java/xaland.java.prima_del_loro_baco_ma_dopo_i_reset @@ -0,0 +1,87 @@ +import org.apache.xalan.xslt.*; +import java.net.*; +import java.io.*; + +public class xaland { + public static void Transform(StylesheetRoot style, String xmlSourceURL, String OutputURL) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + XSLTInputSource xmlSource = new XSLTInputSource (xmlSourceURL); + XSLTResultTarget xmlResult = new XSLTResultTarget (OutputURL); + style.process(xmlSource, xmlResult); + } + + public static void main(String argv[]) throws java.io.IOException, java.net.MalformedURLException, org.xml.sax.SAXException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + XSLTProcessor theory_processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot theory_style1 = + theory_processor.processStylesheet(theory_xsl1); + theory_processor.reset(); + StylesheetRoot theory_style2 = + theory_processor.processStylesheet(theory_xsl2); + theory_processor.setStylesheet(theory_style2); + + XSLTProcessor processor = XSLTProcessorFactory.getProcessor(); + StylesheetRoot style1 = processor.processStylesheet(xsl1); + processor.reset(); + StylesheetRoot style2 = processor.processStylesheet(xsl2); + processor.setStylesheet(style2); + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! */ + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + processor.setDocumentHandler(style2.getSAXSerializer(fout)); + XSLTResultTarget content = new XSLTResultTarget(processor); + style1.process(new XSLTInputSource(input), content); + } else if (mode.equals("theory")) { + theory_processor.setDocumentHandler( + theory_style2.getSAXSerializer(fout)); + XSLTResultTarget content = + new XSLTResultTarget(theory_processor); + theory_style1.process(new XSLTInputSource(input), content); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +} diff --git a/helm/xsltd/xaland-java2/xaland2.class b/helm/xsltd/xaland-java2/xaland2.class new file mode 100644 index 000000000..95b42c712 Binary files /dev/null and b/helm/xsltd/xaland-java2/xaland2.class differ diff --git a/helm/xsltd/xaland-java2/xaland2.java b/helm/xsltd/xaland-java2/xaland2.java new file mode 100644 index 000000000..9d91d37fb --- /dev/null +++ b/helm/xsltd/xaland-java2/xaland2.java @@ -0,0 +1,134 @@ +import java.net.*; +import java.io.*; + +// Imported TraX classes +import org.apache.trax.Processor; +import org.apache.trax.Templates; +import org.apache.trax.Transformer; +import org.apache.trax.Result; +import org.apache.trax.ProcessorException; +import org.apache.trax.ProcessorFactoryException; +import org.apache.trax.TransformException; + +// Imported SAX classes +import org.xml.sax.InputSource; +import org.xml.sax.SAXException; +import org.xml.sax.Parser; +import org.xml.sax.helpers.ParserAdapter; +import org.xml.sax.helpers.XMLReaderFactory; +import org.xml.sax.XMLReader; +import org.xml.sax.ContentHandler; +import org.xml.sax.ext.LexicalHandler; + +// Imported DOM classes +import org.w3c.dom.Node; + +// Imported Serializer classes +import org.apache.serialize.OutputFormat; +import org.apache.serialize.Serializer; +import org.apache.serialize.SerializerFactory; + +// Imported JAVA API for XML Parsing 1.0 classes +import javax.xml.parsers.DocumentBuilder; +import javax.xml.parsers.DocumentBuilderFactory; +import javax.xml.parsers.ParserConfigurationException; + + +public class xaland2 { + public static void main(String argv[]) throws IOException, MalformedURLException, SAXException, ParserConfigurationException + { + int port = Integer.parseInt(argv[0]); + int port2 = Integer.parseInt(argv[1]); + String xsl1 = argv[2]; + String xsl2 = argv[3]; + String theory_xsl1 = argv[4]; + String theory_xsl2 = argv[5]; + + Processor theory_processor = Processor.newInstance("xslt"); + Templates theory_style1 = theory_processor.process(new InputSource(theory_xsl1)); + Transformer theory_transformer1 = theory_style1.newTransformer(); + + Templates theory_style2 = theory_processor.process(new InputSource(theory_xsl2)); + Transformer theory_transformer2 = theory_style2.newTransformer(); + + + Processor processor = Processor.newInstance("xslt"); + Templates style1 = processor.process(new InputSource(xsl1)); + Transformer transformer1 = style1.newTransformer(); + + Templates style2 = processor.process(new InputSource(xsl2)); + Transformer transformer2 = style2.newTransformer(); + + + DatagramSocket socket = new DatagramSocket(port); + + System.out.println("Demon activated on input port " + port + + " and output port " + port2); + while(true) { + System.out.print("Ready..."); + + /* Warning: the packet must be a fresh one! */ + DatagramPacket packet = new DatagramPacket(new byte[1024],1024); + socket.receive(packet); + byte data[] = packet.getData(); + int datalen = packet.getLength(); + String received = new String(data,0,datalen); + + int first = received.indexOf(' '); + int last = received.lastIndexOf(' '); + String mode = received.substring(0,first); + String input = received.substring(first+1,last); + String output = received.substring(last+1); + + System.out.println("request received! Parameters are"); + System.out.println("Mode: " + mode + " "); + System.out.println("Input file: \"" + input + "\""); + System.out.println("Output file: \"" + output + "\"\n"); + + if ((new File(output)).exists()) { + System.out.println("Using cached version\n"); + } else { + FileOutputStream fout = new FileOutputStream(output); + if (mode.equals("cic")) { + XMLReader reader = XMLReaderFactory.createXMLReader(); + ContentHandler chandler = transformer1.getInputContentHandler(); + reader.setContentHandler(chandler); + if (chandler instanceof LexicalHandler) + reader.setProperty("http://xml.org/sax/properties/lexical-handler", chandler); + else + reader.setProperty("http://xml.org/sax/properties/lexical-handler", null); + + transformer1.setContentHandler(transformer2.getInputContentHandler()); + Serializer serializer = SerializerFactory.getSerializer("xml"); + serializer.setOutputStream(fout); + transformer2.setContentHandler(serializer.asContentHandler()); + + reader.parse(input); + } else if (mode.equals("theory")) { + XMLReader reader = XMLReaderFactory.createXMLReader(); + ContentHandler chandler = theory_transformer1.getInputContentHandler(); + reader.setContentHandler(chandler); + if (chandler instanceof LexicalHandler) + reader.setProperty("http://xml.org/sax/properties/lexical-handler", chandler); + else + reader.setProperty("http://xml.org/sax/properties/lexical-handler", null); + + theory_transformer1.setContentHandler(theory_transformer2.getInputContentHandler()); + Serializer serializer = SerializerFactory.getSerializer("xml"); + serializer.setOutputStream(fout); + theory_transformer2.setContentHandler(serializer.asContentHandler()); + + reader.parse(input); + } + } + + InetAddress address = InetAddress.getLocalHost(); + DatagramSocket socket2 = new DatagramSocket(); + + byte buf[] = new byte[0]; + DatagramPacket packet2 = new DatagramPacket(buf,0,address,port2); + + socket2.send(packet2); + } + } +}