]> matita.cs.unibo.it Git - helm.git/blob - helm/gTopLevel/gTopLevel.ml
* Many improvements.
[helm.git] / helm / gTopLevel / gTopLevel.ml
1 (* Copyright (C) 2000, HELM Team.
2  * 
3  * This file is part of HELM, an Hypertextual, Electronic
4  * Library of Mathematics, developed at the Computer Science
5  * Department, University of Bologna, Italy.
6  * 
7  * HELM is free software; you can redistribute it and/or
8  * modify it under the terms of the GNU General Public License
9  * as published by the Free Software Foundation; either version 2
10  * of the License, or (at your option) any later version.
11  * 
12  * HELM is distributed in the hope that it will be useful,
13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with HELM; if not, write to the Free Software
19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://cs.unibo.it/helm/.
24  *)
25
26 (******************************************************************************)
27 (*                                                                            *)
28 (*                               PROJECT HELM                                 *)
29 (*                                                                            *)
30 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
31 (*                                 06/01/2002                                 *)
32 (*                                                                            *)
33 (*                                                                            *)
34 (******************************************************************************)
35
36 (* GLOBAL CONSTANTS *)
37
38 let helmns = Gdome.domString "http://www.cs.unibo.it/helm";;
39
40 let htmlheader =
41  "<html>" ^
42  " <body bgColor=\"white\">"
43 ;;
44
45 let htmlfooter =
46  " </body>" ^
47  "</html>"
48 ;;
49
50 (* GLOBAL REFERENCES (USED BY CALLBACKS) *)
51
52 let htmlheader_and_content = ref htmlheader;;
53
54 let current_cic_infos = ref None;;
55
56
57 (* MISC FUNCTIONS *)
58
59 let domImpl = Gdome.domImplementation ();;
60
61 let parseStyle name =
62  let style =
63   domImpl#createDocumentFromURI
64 (*
65    ~uri:("http://phd.cs.unibo.it:8081/getxslt?uri=" ^ name) ?mode:None
66 *)
67    ~uri:("styles/" ^ name) ()
68  in
69   Gdome_xslt.processStylesheet style
70 ;;
71
72 let d_c = parseStyle "drop_coercions.xsl";;
73 let tc1 = parseStyle "objtheorycontent.xsl";;
74 let hc2 = parseStyle "content_to_html.xsl";;
75 let l   = parseStyle "link.xsl";;
76
77 let c1 = parseStyle "rootcontent.xsl";;
78 let g  = parseStyle "genmmlid.xsl";;
79 let c2 = parseStyle "annotatedpres.xsl";;
80
81
82 let getterURL = Configuration.getter_url;;
83 let processorURL = Configuration.processor_url;;
84 (*
85 let processorURL = "http://phd.cs.unibo.it:8080/helm/servelt/uwobo/";;
86 let getterURL = "http://phd.cs.unibo.it:8081/";;
87 let processorURL = "http://localhost:8080/helm/servelt/uwobo/";;
88 let getterURL = "http://localhost:8081/";;
89 *)
90
91 let mml_styles = [d_c ; c1 ; g ; c2 ; l];;
92 let mml_args =
93  ["processorURL", "'" ^ processorURL ^ "'" ;
94   "getterURL", "'" ^ getterURL ^ "'" ;
95   "draw_graphURL", "'http%3A//phd.cs.unibo.it%3A8083/'" ;
96   "uri_set_queueURL", "'http%3A//phd.cs.unibo.it%3A8084/'" ;
97   "UNICODEvsSYMBOL", "'symbol'" ;
98   "doctype-public", "'-//W3C//DTD%20XHTML%201.0%20Transitional//EN'" ;
99   "encoding", "'iso-8859-1'" ;
100   "media-type", "'text/html'" ;
101   "keys", "'d_c%2CC1%2CG%2CC2%2CL'" ;
102   "interfaceURL", "'http%3A//phd.cs.unibo.it/helm/html/cic/index.html'" ;
103   "naturalLanguage", "'no'" ;
104   "annotations", "'no'" ;
105   "topurl", "'http://phd.cs.unibo.it/helm'" ;
106   "CICURI", "'cic:/Coq/Init/Datatypes/bool_ind.con'" ]
107 ;;
108
109 let sequent_styles = [d_c ; c1 ; g ; c2 ; l];;
110 let sequent_args =
111  ["processorURL", "'" ^ processorURL ^ "'" ;
112   "getterURL", "'" ^ getterURL ^ "'" ;
113   "draw_graphURL", "'http%3A//phd.cs.unibo.it%3A8083/'" ;
114   "uri_set_queueURL", "'http%3A//phd.cs.unibo.it%3A8084/'" ;
115   "UNICODEvsSYMBOL", "'symbol'" ;
116   "doctype-public", "'-//W3C//DTD%20XHTML%201.0%20Transitional//EN'" ;
117   "encoding", "'iso-8859-1'" ;
118   "media-type", "'text/html'" ;
119   "keys", "'d_c%2CC1%2CG%2CC2%2CL'" ;
120   "interfaceURL", "'http%3A//phd.cs.unibo.it/helm/html/cic/index.html'" ;
121   "naturalLanguage", "'no'" ;
122   "annotations", "'no'" ;
123   "topurl", "'http://phd.cs.unibo.it/helm'" ;
124   "CICURI", "'cic:/Coq/Init/Datatypes/bool_ind.con'" ]
125 ;;
126
127 let parse_file filename =
128  let inch = open_in filename in
129   let rec read_lines () =
130    try
131     let line = input_line inch in
132      line ^ read_lines ()
133    with
134     End_of_file -> ""
135   in
136    read_lines ()
137 ;;
138
139 let applyStylesheets input styles args =
140  List.fold_left (fun i style -> Gdome_xslt.applyStylesheet i style args)
141   input styles
142 ;;
143
144 let mml_of_cic_object annobj ids_to_inner_sorts =
145  let xml =
146   Cic2Xml.print_object
147    (UriManager.uri_of_string "cic:/dummy.con") ids_to_inner_sorts annobj 
148  in
149   let input =
150    Xml2Gdome.document_of_xml domImpl xml 
151   in
152    let output = applyStylesheets input mml_styles mml_args in
153     output
154 ;;
155
156
157 (* CALLBACKS *)
158
159 let refresh_proof (output : GMathView.math_view) =
160  let currentproof =
161   match !ProofEngine.proof with
162      None -> assert false
163    | Some (metasenv,bo,ty) -> Cic.CurrentProof ("unnamed", metasenv, bo, ty)
164  in
165  let (acic, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts) =
166   Cic2acic.acic_object_of_cic_object currentproof
167  in
168   let mml = mml_of_cic_object acic ids_to_inner_sorts in
169    output#load_tree mml ;
170    current_cic_infos := Some (ids_to_terms,ids_to_father_ids)
171 ;;
172
173 let refresh_sequent (proofw : GMathView.math_view) =
174  let metasenv =
175   match !ProofEngine.proof with
176      None -> assert false
177    | Some (metasenv,_,_) -> metasenv
178  in
179  let currentsequent =
180   match !ProofEngine.goal with
181      None -> assert false
182    | Some (_,sequent) -> sequent
183  in
184   let sequent_gdome = SequentPp.XmlPp.print_sequent metasenv currentsequent in
185    let sequent_doc =
186     Xml2Gdome.document_of_xml domImpl sequent_gdome
187    in
188     let sequent_mml =
189      applyStylesheets sequent_doc sequent_styles sequent_args
190     in
191      proofw#load_tree ~dom:sequent_mml
192 (*
193 ignore(domImpl#saveDocumentToFile ~doc:sequent_doc
194  ~name:"/public/sacerdot/guruguru1" ~indent:true ()) ;
195 ignore(domImpl#saveDocumentToFile ~doc:sequent_mml
196  ~name:"/public/sacerdot/guruguru2" ~indent:true ())
197 *)
198 ;;
199
200 let exact rendering_window () =
201  let proofw = (rendering_window#proofw : GMathView.math_view) in
202  let output = (rendering_window#output : GMathView.math_view) in
203  let inputt = (rendering_window#inputt : GEdit.text) in
204 (*CSC: Gran cut&paste da sotto... *)
205   let inputlen = inputt#length in
206   let input = inputt#get_chars 0 inputlen ^ "\n" in
207    let lexbuf = Lexing.from_string input in
208    let context =
209     List.map
210      (function (_,n,_) -> n)
211      (match !ProofEngine.goal with
212          None -> assert false
213        | Some (_,(ctx,_)) -> ctx
214      )
215    in
216     try
217      while true do
218       (* Execute the actions *)
219       match
220        CicTextualParserContext.main context CicTextualLexer.token lexbuf
221       with
222          None -> ()
223        | Some expr ->
224           try
225            ProofEngine.exact expr ;
226            proofw#unload ;
227            refresh_proof output
228           with
229            e ->
230             print_endline ("? " ^ CicPp.ppterm expr) ; flush stdout ;
231             raise e
232      done
233     with
234        CicTextualParser0.Eof ->
235         inputt#delete_text 0 inputlen
236      | e ->
237         print_endline ("Error: " ^ Printexc.to_string e) ; flush stdout
238 ;;
239
240 let intros rendering_window () =
241  let proofw = (rendering_window#proofw : GMathView.math_view) in
242  let output = (rendering_window#output : GMathView.math_view) in
243   begin
244    try
245     ProofEngine.intros () ;
246    with
247     e ->
248      print_endline "? Intros " ;
249      raise e
250   end ;
251   refresh_sequent proofw ;
252   refresh_proof output
253 ;;
254
255 exception OpenConjecturesStillThere;;
256 exception WrongProof;;
257
258 let save rendering_window () =
259  match !ProofEngine.proof with
260     None -> assert false
261   | Some ([],bo,ty) ->
262      if CicReduction.are_convertible (CicTypeChecker.type_of_aux' [] [] bo) ty then
263       begin
264        (*CSC: Wrong: [] is just plainly wrong *)
265        let proof = Cic.Definition ("unnamed",bo,ty,[]) in
266         let (acic, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts) =
267          Cic2acic.acic_object_of_cic_object proof
268         in
269          let mml = mml_of_cic_object acic ids_to_inner_sorts in
270           (rendering_window#output : GMathView.math_view)#load_tree mml ;
271           current_cic_infos := Some (ids_to_terms,ids_to_father_ids)
272       end
273      else
274       raise WrongProof
275   | _ -> raise OpenConjecturesStillThere
276 ;;
277
278 let proveit rendering_window () =
279  let module L = LogicalOperations in
280  let module G = Gdome in
281  match rendering_window#output#get_selection with
282    Some node ->
283     let xpath =
284      ((node : Gdome.element)#getAttributeNS
285      (*CSC: OCAML DIVERGE
286      ((element : G.element)#getAttributeNS
287      *)
288        ~namespaceURI:helmns
289        ~localName:(G.domString "xref"))#to_string
290     in
291      if xpath = "" then assert false (* "ERROR: No xref found!!!" *)
292      else
293       begin
294        try
295         match !current_cic_infos with
296            Some (ids_to_terms, ids_to_father_ids) ->
297             let id = xpath in
298              if L.to_sequent id ids_to_terms ids_to_father_ids then
299               refresh_proof rendering_window#output ;
300              refresh_sequent rendering_window#proofw
301          | None -> assert false (* "ERROR: No current term!!!" *)
302        with
303         e -> print_endline ("Error: " ^ Printexc.to_string e) ; flush stdout
304       end
305  | None -> assert false (* "ERROR: No selection!!!" *)
306 ;;
307
308 let output_html outputhtml msg =
309  htmlheader_and_content := !htmlheader_and_content ^ msg ;
310  outputhtml#source (!htmlheader_and_content ^ htmlfooter)
311 ;;
312
313 let state rendering_window () =
314  let inputt = (rendering_window#inputt : GEdit.text) in
315  let oldinputt = (rendering_window#oldinputt : GEdit.text) in
316  let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in
317  let output = (rendering_window#output : GMathView.math_view) in
318  let proofw = (rendering_window#proofw : GMathView.math_view) in
319   let inputlen = inputt#length in
320   let input = inputt#get_chars 0 inputlen ^ "\n" in
321    (* Do something interesting *)
322    let lexbuf = Lexing.from_string input in
323     try
324      while true do
325       (* Execute the actions *)
326       match CicTextualParser.main CicTextualLexer.token lexbuf with
327          None -> ()
328        | Some expr ->
329           try
330            let _  = CicTypeChecker.type_of_aux' [] [] expr in
331             ProofEngine.proof := Some ([1,expr], Cic.Meta 1, expr) ;
332             ProofEngine.goal := Some (1,([],expr)) ;
333             refresh_sequent proofw ;
334             refresh_proof output ;
335           with
336            e ->
337             print_endline ("? " ^ CicPp.ppterm expr) ;
338             raise e
339      done
340     with
341        CicTextualParser0.Eof ->
342         inputt#delete_text 0 inputlen ;
343         ignore(oldinputt#insert_text input oldinputt#length) ;
344      | e ->
345         print_endline ("Error: " ^ Printexc.to_string e) ; flush stdout
346 ;;
347
348 let choose_selection
349      (mmlwidget : GMathView.math_view) (element : Gdome.element option)
350 =
351  let module G = Gdome in
352   let rec aux element =
353    if element#hasAttributeNS
354        ~namespaceURI:helmns
355        ~localName:(G.domString "xref")
356    then
357      mmlwidget#set_selection (Some element)
358    else
359       match element#get_parentNode with
360          None -> assert false
361        (*CSC: OCAML DIVERGES!
362        | Some p -> aux (new G.element_of_node p)
363        *)
364        | Some p -> aux (new Gdome.element_of_node p)
365   in
366    match element with
367      Some x -> aux x
368    | None   -> mmlwidget#set_selection None
369 ;;
370
371 (* STUFF TO BUILD THE GTK INTERFACE *)
372
373 (* Stuff for the widget settings *)
374
375 let export_to_postscript (output : GMathView.math_view) () =
376  output#export_to_postscript ~filename:"output.ps" ();
377 ;;
378
379 let activate_t1 (output : GMathView.math_view) button_set_anti_aliasing
380  button_set_kerning button_set_transparency button_export_to_postscript
381  button_t1 ()
382 =
383  let is_set = button_t1#active in
384   output#set_font_manager_type
385    (if is_set then `font_manager_t1 else `font_manager_gtk) ;
386   if is_set then
387    begin
388     button_set_anti_aliasing#misc#set_sensitive true ;
389     button_set_kerning#misc#set_sensitive true ;
390     button_set_transparency#misc#set_sensitive true ;
391     button_export_to_postscript#misc#set_sensitive true ;
392    end
393   else
394    begin
395     button_set_anti_aliasing#misc#set_sensitive false ;
396     button_set_kerning#misc#set_sensitive false ;
397     button_set_transparency#misc#set_sensitive false ;
398     button_export_to_postscript#misc#set_sensitive false ;
399    end
400 ;;
401
402 let set_anti_aliasing output button_set_anti_aliasing () =
403  output#set_anti_aliasing button_set_anti_aliasing#active
404 ;;
405
406 let set_kerning output button_set_kerning () =
407  output#set_kerning button_set_kerning#active
408 ;;
409
410 let set_transparency output button_set_transparency () =
411  output#set_transparency button_set_transparency#active
412 ;;
413
414 let changefont output font_size_spinb () =
415  output#set_font_size font_size_spinb#value_as_int
416 ;;
417
418 let set_log_verbosity output log_verbosity_spinb () =
419  output#set_log_verbosity log_verbosity_spinb#value_as_int
420 ;;
421
422 class settings_window (output : GMathView.math_view) sw
423  button_export_to_postscript selection_changed_callback
424 =
425  let settings_window = GWindow.window ~title:"GtkMathView settings" () in
426  let vbox =
427   GPack.vbox ~packing:settings_window#add () in
428  let table =
429   GPack.table
430    ~rows:1 ~columns:3 ~homogeneous:false ~row_spacings:5 ~col_spacings:5
431    ~border_width:5 ~packing:vbox#add () in
432  let button_t1 =
433   GButton.toggle_button ~label:"activate t1 fonts"
434    ~packing:(table#attach ~left:0 ~top:0) () in
435  let button_set_anti_aliasing =
436   GButton.toggle_button ~label:"set_anti_aliasing"
437    ~packing:(table#attach ~left:0 ~top:1) () in
438  let button_set_kerning =
439   GButton.toggle_button ~label:"set_kerning"
440    ~packing:(table#attach ~left:1 ~top:1) () in
441  let button_set_transparency =
442   GButton.toggle_button ~label:"set_transparency"
443    ~packing:(table#attach ~left:2 ~top:1) () in
444  let table =
445   GPack.table
446    ~rows:2 ~columns:2 ~homogeneous:false ~row_spacings:5 ~col_spacings:5
447    ~border_width:5 ~packing:vbox#add () in
448  let font_size_label =
449   GMisc.label ~text:"font size:"
450    ~packing:(table#attach ~left:0 ~top:0 ~expand:`NONE) () in
451  let font_size_spinb =
452   let sadj =
453    GData.adjustment ~value:14.0 ~lower:5.0 ~upper:50.0 ~step_incr:1.0 ()
454   in
455    GEdit.spin_button 
456     ~adjustment:sadj ~packing:(table#attach ~left:1 ~top:0 ~fill:`NONE) () in
457  let log_verbosity_label =
458   GMisc.label ~text:"log verbosity:"
459    ~packing:(table#attach ~left:0 ~top:1) () in
460  let log_verbosity_spinb =
461   let sadj =
462    GData.adjustment ~value:0.0 ~lower:0.0 ~upper:3.0 ~step_incr:1.0 ()
463   in
464    GEdit.spin_button 
465     ~adjustment:sadj ~packing:(table#attach ~left:1 ~top:1) () in
466  let hbox =
467   GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
468  let closeb =
469   GButton.button ~label:"Close"
470    ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
471 object(self)
472  method show = settings_window#show
473  initializer
474   button_set_anti_aliasing#misc#set_sensitive false ;
475   button_set_kerning#misc#set_sensitive false ;
476   button_set_transparency#misc#set_sensitive false ;
477   (* Signals connection *)
478   ignore(button_t1#connect#clicked
479    (activate_t1 output button_set_anti_aliasing button_set_kerning
480     button_set_transparency button_export_to_postscript button_t1)) ;
481   ignore(font_size_spinb#connect#changed (changefont output font_size_spinb)) ;
482   ignore(button_set_anti_aliasing#connect#toggled
483    (set_anti_aliasing output button_set_anti_aliasing));
484   ignore(button_set_kerning#connect#toggled
485    (set_kerning output button_set_kerning)) ;
486   ignore(button_set_transparency#connect#toggled
487    (set_transparency output button_set_transparency)) ;
488   ignore(log_verbosity_spinb#connect#changed
489    (set_log_verbosity output log_verbosity_spinb)) ;
490   ignore(closeb#connect#clicked settings_window#misc#hide)
491 end;;
492
493 (* Main windows *)
494
495 class rendering_window output proofw (label : GMisc.label) =
496  let window =
497   GWindow.window ~title:"MathML viewer" ~border_width:2 () in
498  let hbox0 =
499   GPack.hbox ~packing:window#add () in
500  let vbox =
501   GPack.vbox ~packing:(hbox0#pack ~expand:false ~fill:false ~padding:5) () in
502  let _ = vbox#pack ~expand:false ~fill:false ~padding:5 label#coerce in
503  let scrolled_window0 =
504   GBin.scrolled_window ~border_width:10
505    ~packing:(vbox#pack ~expand:true ~padding:5) () in
506  let _ = scrolled_window0#add output#coerce in
507  let hbox1 =
508   GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
509  let settingsb =
510   GButton.button ~label:"Settings"
511    ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
512  let button_export_to_postscript =
513   GButton.button ~label:"export_to_postscript"
514   ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
515  let saveb =
516   GButton.button ~label:"Save"
517    ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
518  let closeb =
519   GButton.button ~label:"Close"
520    ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
521  let hbox2 =
522   GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
523  let proveitb =
524   GButton.button ~label:"Prove It"
525    ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in
526  let oldinputt = GEdit.text ~editable:false ~width:400 ~height:180
527    ~packing:(vbox#pack ~padding:5) () in
528  let stateb =
529   GButton.button ~label:"State"
530    ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
531  let inputt = GEdit.text ~editable:true ~width:400 ~height: 100
532    ~packing:(vbox#pack ~padding:5) () in
533  let vbox1 =
534   GPack.vbox ~packing:(hbox0#pack ~expand:false ~fill:false ~padding:5) () in
535  let scrolled_window1 =
536   GBin.scrolled_window ~border_width:10
537    ~packing:(vbox1#pack ~expand:true ~padding:5) () in
538  let _ = scrolled_window1#add proofw#coerce in
539  let hbox3 =
540   GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in
541  let exactb =
542   GButton.button ~label:"Exact"
543    ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
544  let introsb =
545   GButton.button ~label:"Intros"
546    ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
547  let outputhtml =
548   GHtml.xmhtml
549    ~source:"<html><body bgColor=\"white\"></body></html>"
550    ~width:400 ~height: 200
551    ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5)
552    ~show:true () in
553 object(self)
554  method outputhtml = outputhtml
555  method oldinputt = oldinputt
556  method inputt = inputt
557  method output = (output : GMathView.math_view)
558  method proofw = (proofw : GMathView.math_view)
559  method show () = window#show ()
560  initializer
561   button_export_to_postscript#misc#set_sensitive false ;
562
563   (* signal handlers here *)
564   ignore(output#connect#selection_changed
565    (function elem -> proofw#unload ; choose_selection output elem)) ;
566   ignore(proofw#connect#selection_changed (choose_selection proofw)) ;
567   ignore(closeb#connect#clicked (fun _ -> GMain.Main.quit ())) ;
568   let settings_window = new settings_window output scrolled_window0
569    button_export_to_postscript (choose_selection output) in
570   ignore(settingsb#connect#clicked settings_window#show) ;
571   ignore(button_export_to_postscript#connect#clicked (export_to_postscript output)) ;
572   ignore(saveb#connect#clicked (save self)) ;
573   ignore(proveitb#connect#clicked (proveit self)) ;
574   ignore(window#event#connect#delete (fun _ -> GMain.Main.quit () ; true )) ;
575   ignore(stateb#connect#clicked (state self)) ;
576   ignore(exactb#connect#clicked (exact self)) ;
577   ignore(introsb#connect#clicked (intros self)) ;
578   Logger.log_callback :=
579    (Logger.log_to_html ~print_and_flush:(output_html outputhtml))
580 end;;
581
582 (* MAIN *)
583
584 let initialize_everything () =
585  let module U = Unix in
586   let output = GMathView.math_view ~width:400 ~height:280 ()
587   and proofw = GMathView.math_view ~width:400 ~height:275 ()
588   and label = GMisc.label ~text:"gTopLevel" () in
589     let rendering_window =
590      new rendering_window output proofw label
591     in
592      rendering_window#show () ;
593      GMain.Main.main ()
594 ;;
595
596 let _ =
597  CicCooking.init () ;
598  initialize_everything ()
599 ;;