File: test.ml

package info (click to toggle)
lablgtkmathview 0.7.8-7
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 332 kB
  • sloc: ml: 777; ansic: 177; makefile: 139; xml: 132
file content (397 lines) | stat: -rw-r--r-- 14,291 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
(* Copyright (C) 2000-2003, Luca Padovani <luca.padovani@cs.unibo.it>,
 *                          Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>.
 *
 * This file is part of lablgtkmathview, the Ocaml binding
 * for the GtkMathView widget.
 * 
 * lablgtkmathview is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * lablgtkmathview is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with lablgtkmathview; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 * 
 * For details, send a mail to the author.
 *)

(******************************************************************************)
(*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
(*                                 25/09/2000                                 *)
(*                                                                            *)
(*     This is a simple test for the OCaml (LablGtk indeed) binding of the    *)
(*                             MathView widget                                *)
(******************************************************************************)

let helmns = Gdome.domString "http://www.cs.unibo.it/helm";;

(*
let choose_selection mmlwidget (element : Gdome.element option) =
 let module G = Gdome in
  let rec aux element =
   if element#hasAttributeNS
       ~namespaceURI:Misc.helmns
       ~localName:(G.domString "xref")
   then
     mmlwidget#set_selection (Some element)
   else
    try
      match element#get_parentNode with
         None -> assert false
       (*CSC: OCAML DIVERGES!
       | Some p -> aux (new G.element_of_node p)
       *)
       | Some p -> aux (new Gdome.element_of_node p)
    with
       GdomeInit.DOMCastException _ ->
        prerr_endline
         "******* trying to select above the document root ********"
  in 
   match element with
     Some x -> aux x
   | None   -> mmlwidget#set_selection None
;;     
*)

(* Callbacks *)
let selection_changed mathview (element : Gdome.element option) =
 let rec aux element =
  if element#hasAttributeNS
      ~namespaceURI:helmns
      ~localName:(Gdome.domString "xref")
  then
   mathview#set_selection (Some element)
  else
   try
     match element#get_parentNode with
        None -> mathview#set_selection None
      | Some p -> aux (new Gdome.element_of_node p)
   with
      GdomeInit.DOMCastException _ ->
       prerr_endline "******* trying to select above the document root ********"
 in
 print_endline ("selection_changed: " ^
  (match element with
      None -> "selection_changed on nothing"
    | Some element -> element#get_tagName#to_string
  )
 ) ;
 match element with
   None -> ()
 | Some el -> aux el;
 flush stdout
;;

let element_over mathview ((element : Gdome.element option), _, _, _) =
 print_endline ("element_over: " ^
  (match element with
      None -> "element_over on nothing"
    | Some element -> element#get_tagName#to_string
  )
 ) ;
 flush stdout
;;

let rec jump (element : Gdome.element) =
 let module G = Gdome in
  let attr = (element#getAttribute ~name:(G.domString "href"))#to_string in
   if attr = "" then
    match element#get_parentNode with
       Some p ->
        begin
         try
          jump (new Gdome.element_of_node p)
         with
          GdomeInit.DOMCastException _ ->
           print_string "jump: NO HREF FOR THIS NODE\n" ;
           flush stdout ;
           false
        end
     | None -> assert false (* every element has a parent *)
   else
    begin
     print_endline ("jump: " ^ attr) ;
     flush stdout ;
     true
    end
;;

let rec action mathview (element : Gdome.element) =
 let module G = Gdome in
  if element#get_tagName#to_string = "m:maction" then
   let selection =
    if element#hasAttribute ~name:(G.domString "selection") then
     int_of_string (element#getAttribute ~name:(G.domString "selection"))#to_string
    else
     1
   in
    mathview#freeze ;
    (* the widget will cast the index back into a reasonable range *)
    element#setAttribute ~name:(G.domString "selection") ~value:(G.domString (string_of_int (selection + 1))) ;
    mathview#thaw ;
    true
  else
   match element#get_parentNode with
      Some p ->
       begin
        try
	 action mathview (new Gdome.element_of_node p)
	with
	 GdomeInit.DOMCastException _ ->
	  print_string "action: NO MACTION FOUND\n" ;
	  flush stdout ;
	  false
       end
     | None -> assert false (* every element has a parent *)

let click mathview ((element : Gdome.element option), _, _, _) =
 let module G = Gdome in
  match element with
     None -> print_string "CLICKED ON NOTHING\n" ; flush stdout
   | Some element ->
      if not (jump element) then
      if not (mathview#action_toggle element) then
       ()
;;

let load_uri mathview () =
 mathview#load_uri ~filename:"test.xml" ;
 print_string "load: SEEMS TO WORK\n" ;
 flush stdout
;;

let get_document mathview () =
 (match mathview#get_document with
 | None -> print_string "no document loaded\n"
 | Some doc ->
     let name = "out.xml" in
     ignore ((Gdome.domImplementation ())#saveDocumentToFile ~doc ~name ());
     print_string ("document loaded and saved to " ^ name ^ "\n"));
 flush stdout
;;

let load_doc mathview () =
 mathview#load_root ~root:(((Gdome.domImplementation ())#createDocumentFromURI ~uri:"test.xml" ())#get_documentElement) ;
 print_string "load from DOM: SEEMS TO WORK\n" ;
 flush stdout
;;

let test_get_selection mathview () =
 let selection =
   match mathview#get_selection with
      Some element -> element#get_tagName#to_string
    | None -> "no selection! but there are " ^ (string_of_int (List.length mathview#get_selections)) ^ " multiple selections!"
 in
  print_string ("selection: " ^ selection ^ "\n") ;
  flush stdout
;;

let test_set_selection mathview () =
 begin
   match mathview#get_selection with
      Some element -> 
       begin
        match element#get_parentNode with
           Some p ->
            begin
             try
              mathview#set_selection (Some (new Gdome.element_of_node p));
              print_string "set selection: SEEMS TO WORK\n"
             with
              GdomeInit.DOMCastException _ ->
               print_string "EXCEPTION: no parent\n"
            end
         | None -> assert false (* every element has a parent *)
       end
    | None ->
       mathview#set_selection None;
       print_string "no selection\n"
 end ;
 flush stdout
;;

let test_add_selection (mathview : GMathViewAux.multi_selection_math_view) () =
 match mathview#get_selection with
    Some e -> mathview#add_selection e
  | None ->
     begin
      print_string "no selection to add\n" ;
      flush stdout
     end
;;

let test_reset_selections (mathview : GMathViewAux.multi_selection_math_view) () =
 mathview#set_selection None ;
 mathview#remove_selections

let select_over (mathview : GMathViewAux.multi_selection_math_view) =
  (fun (_,_,_,state) ->
    let c = function
      | `SHIFT    -> "shift"
      | `LOCK     -> "lock"
      | `CONTROL  -> "control"
      | `MOD1     -> "mod1"
      | _         -> ""
    in
    let msg =
      String.concat ","
        (List.filter (fun s -> s <> "")
          (List.map c (Gdk.Convert.modifier state)))
    in
    if msg <> "" then begin
      print_endline ("modifiers: " ^ msg);
      flush stdout
    end)

let unload mathview () =
 mathview#unload ;
 print_string "unload: SEEMS TO WORK\n" ;
 flush stdout
;;

let get_size mathview () =
 let width, height = mathview#get_size in
 print_string ("width: " ^ string_of_int width ^ ", height: " ^ string_of_int height ^ "\n") ;
 flush stdout
;;

let get_top mathview () =
 let (x,y) = mathview#get_top in
  print_string ("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_adjustments mathview () =
 let hadj, vadj = mathview#get_adjustments in
  hadj#set_value ((hadj#lower +. hadj#upper) /. 2.0) ;
  vadj#set_value ((vadj#lower +. vadj#upper) /. 2.0) ;
  print_string "hadjustment: 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 "buffer: SEEMS TO WORK (hint: force the widget redrawing)\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 ("font_size: " ^ string_of_int (mathview#get_font_size) ^ "\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 ("log_verbosity: " ^
  string_of_int mathview#get_log_verbosity ^
  "\n") ;
 flush stdout
;;

let x_coord = ref 0
;;

(*
let get_element_at mathview () =
 begin
  match mathview#get_element_at !x_coord 10 with
     None -> print_string ("there is no element at " ^ (string_of_int !x_coord) ^ " 10\n")
   | Some e -> print_string ("at " ^ (string_of_int !x_coord) ^ " 10 found element " ^ (e#get_nodeName#to_string) ^ "\n")
 end ;
 x_coord := !x_coord + 10 ;
 flush stdout
;;
*)

let _ = (GtkMain.Main.init ())
;;

(* 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= GMathViewAux.multi_selection_math_view ~packing:sw#add ~width:50 ~height:50 () in
let table = GPack.table ~rows:6 ~columns:5 ~packing:vbox#pack () 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_document = GButton.button ~label:"get_document" ~packing:(table#attach ~left:1 ~top:1) () in
let button_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_add_selection = GButton.button ~label:"add_selection" ~packing:(table#attach ~left:3 ~top:3) () in
let button_reset_selections = GButton.button ~label:"reset_selections" ~packing:(table#attach ~left:4 ~top:3) () in
let button_get_size = GButton.button ~label:"get_size" ~packing:(table#attach ~left:0 ~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_adjustments = GButton.button ~label:"get_adjustments" ~packing:(table#attach ~left:0 ~top:2) () in
let button_get_buffer = GButton.button ~label:"get_buffer" ~packing:(table#attach ~left:2 ~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_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_load_dom = GButton.button ~label:"load from DOM" ~packing:(table#attach ~left:2 ~top:5) () in
(* let button_get_element_at = GButton.button ~label:"get_element_at" ~packing:(table#attach ~left:3 ~top:5) () in *)
(* Signals connection *)
ignore(button_load#connect#clicked (load_uri mathview)) ;
ignore(button_unload#connect#clicked (unload mathview)) ;
ignore(button_get_document#connect#clicked (get_document mathview)) ;
ignore(button_selection#connect#clicked (test_get_selection mathview)) ;
ignore(button_set_selection#connect#clicked (test_set_selection mathview)) ;
ignore(button_add_selection#connect#clicked (test_add_selection mathview)) ;
ignore(button_reset_selections#connect#clicked (test_reset_selections mathview)) ;
ignore(button_get_size#connect#clicked (get_size 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_adjustments#connect#clicked (get_adjustments mathview)) ;
ignore(button_get_buffer#connect#clicked (get_buffer 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_log_verbosity#connect#clicked (set_log_verbosity mathview)) ;
ignore(button_get_log_verbosity#connect#clicked (get_log_verbosity mathview)) ;
ignore(mathview#connect#click (click mathview)) ;
ignore(mathview#connect#selection_changed (selection_changed mathview));
ignore(mathview#connect#element_over (element_over mathview)) ;
ignore(mathview#connect#select_over (select_over mathview));
ignore(button_load_dom#connect#clicked (load_doc mathview)) ;
ignore(main_window#connect#destroy (fun _ -> GMain.quit ()));
(* ignore(button_get_element_at#connect#clicked (get_element_at mathview)) ; *)
(* Main Loop *)
main_window#show () ;
GMain.Main.main ()
;;