diff options
Diffstat (limited to 'otherlibs/labltk/examples_labltk')
| -rw-r--r-- | otherlibs/labltk/examples_labltk/.cvsignore | 8 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/Lambda2.back.gif | bin | 53441 -> 0 bytes | |||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/Makefile | 53 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/Makefile.nt | 50 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/README | 20 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/calc.ml | 129 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/clock.ml | 133 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/demo.ml | 167 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/eyes.ml | 65 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/hello.ml | 38 | ||||
| -rwxr-xr-x | otherlibs/labltk/examples_labltk/hello.tcl | 5 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/lang.ml | 75 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/taquin.ml | 143 | ||||
| -rw-r--r-- | otherlibs/labltk/examples_labltk/tetris.ml | 710 |
14 files changed, 0 insertions, 1596 deletions
diff --git a/otherlibs/labltk/examples_labltk/.cvsignore b/otherlibs/labltk/examples_labltk/.cvsignore deleted file mode 100644 index c1f6ec642f..0000000000 --- a/otherlibs/labltk/examples_labltk/.cvsignore +++ /dev/null @@ -1,8 +0,0 @@ -calc -clock -demo -eyes -hello -tetris -lang -taquin diff --git a/otherlibs/labltk/examples_labltk/Lambda2.back.gif b/otherlibs/labltk/examples_labltk/Lambda2.back.gif Binary files differdeleted file mode 100644 index fdd1f078f4..0000000000 --- a/otherlibs/labltk/examples_labltk/Lambda2.back.gif +++ /dev/null diff --git a/otherlibs/labltk/examples_labltk/Makefile b/otherlibs/labltk/examples_labltk/Makefile deleted file mode 100644 index 3fa02632bf..0000000000 --- a/otherlibs/labltk/examples_labltk/Makefile +++ /dev/null @@ -1,53 +0,0 @@ -include ../support/Makefile.common - -COMPFLAGS=-I ../lib -I ../labltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support - -all: hello demo eyes calc clock tetris lang - -opt: hello.opt demo.opt eyes.opt calc.opt clock.opt tetris.opt - -hello: hello.cmo - $(CAMLC) $(COMPFLAGS) -o hello $(LIBNAME).cma hello.cmo - -demo: demo.cmo - $(CAMLC) $(COMPFLAGS) -o demo $(LIBNAME).cma demo.cmo - -eyes: eyes.cmo - $(CAMLC) $(COMPFLAGS) -o eyes $(LIBNAME).cma eyes.cmo - -calc: calc.cmo - $(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo - -clock: clock.cmo - $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo - -clock.opt: clock.cmx - $(CAMLOPT) $(COMPFLAGS) -o clock.opt \ - $(LIBNAME).cmxa unix.cmxa clock.cmx - -tetris: tetris.cmo - $(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo - -taquin: taquin.cmo - $(CAMLC) $(COMPFLAGS) -o taquin $(LIBNAME).cma taquin.cmo - -lang: lang.cmo - $(CAMLC) $(COMPFLAGS) -o lang $(LIBNAME).cma lang.cmo - -clean: - rm -f hello demo eyes calc clock tetris lang *.opt *.o *.cm* - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .opt - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.cmx.opt: - $(CAMLOPT) $(COMPFLAGS) -o $@ $(LIBNAME).cmxa $< diff --git a/otherlibs/labltk/examples_labltk/Makefile.nt b/otherlibs/labltk/examples_labltk/Makefile.nt deleted file mode 100644 index 825d9e42be..0000000000 --- a/otherlibs/labltk/examples_labltk/Makefile.nt +++ /dev/null @@ -1,50 +0,0 @@ -include ../support/Makefile.common.nt - -# We are using the non-installed library ! -COMPFLAGS= -I ../lib -I ../labltk -I ../support -LINKFLAGS= -I ../lib -I ../labltk -I ../support - -# Use pieces of Makefile.config -TKLINKOPT=$(LIBNAME).cma $(TKLIBS) - -all: hello.exe demo.exe eyes.exe calc.exe clock.exe tetris.exe lang.exe - -hello.exe: hello.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ hello.cmo - -demo.exe: demo.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ demo.cmo - -eyes.exe: eyes.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ eyes.cmo - -calc.exe: calc.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ calc.cmo - -clock.exe: clock.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ - -o $@ clock.cmo - -tetris.exe: tetris.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ tetris.cmo - -lang.exe: lang.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ lang.cmo - -clean : - rm -f *.cm? *.exe - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_labltk/README b/otherlibs/labltk/examples_labltk/README deleted file mode 100644 index ec0f20de60..0000000000 --- a/otherlibs/labltk/examples_labltk/README +++ /dev/null @@ -1,20 +0,0 @@ -$Id$ - -Some examples for LablTk. -They are written in classic mode, except testris.ml which uses label -commutation. -You may either compile them here, or just run them as scripts with - labltk example.ml - -hello.ml A very simple example of CamlTk -hello.tcl The same programme in Tcl/Tk - -demo.ml A demonstration using many widget classes - -eyes.ml A "bind" test - -calc.ml A little calculator - -clock.ml An analog clock (uses unix.cma) - -tetris.ml You NEED a game also (uses -labels) diff --git a/otherlibs/labltk/examples_labltk/calc.ml b/otherlibs/labltk/examples_labltk/calc.ml deleted file mode 100644 index 088bf192f9..0000000000 --- a/otherlibs/labltk/examples_labltk/calc.ml +++ /dev/null @@ -1,129 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* A simple calculator demonstrating OO programming with O'Labl - and LablTk. - - LablTk itself is not OO, but it is good to wrap complex - structures in objects. Even if the absence of initializers - makes things a little bit awkward. -*) - -open StdLabels -open Tk - -let mem_string ~elt:c s = - try - for i = 0 to String.length s -1 do - if s.[i] = c then raise Exit - done; false - with Exit -> true - -let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)] - -(* The abstract calculator class. - Does not use Tk (only Textvariable) *) - -class calc () = object (calc) - val variable = Textvariable.create () - val mutable x = 0.0 - val mutable op = None - val mutable displaying = true - - method set = Textvariable.set variable - method get = Textvariable.get variable - method insert s = calc#set (calc#get ^ s) - method get_float = float_of_string (calc#get) - - method command s = - if s <> "" then match s.[0] with - '0'..'9' -> - if displaying then (calc#set ""; displaying <- false); - calc#insert s - | '.' -> - if displaying then - (calc#set "0."; displaying <- false) - else - if not (mem_string ~elt:'.' calc#get) then calc#insert s - | '+'|'-'|'*'|'/' as c -> - displaying <- true; - begin match op with - None -> - x <- calc#get_float; - op <- Some (List.assoc c ops) - | Some f -> - x <- f x (calc#get_float); - op <- Some (List.assoc c ops); - calc#set (Printf.sprintf "%g" x) - end - | '='|'\n'|'\r' -> - displaying <- true; - begin match op with - None -> () - | Some f -> - x <- f x (calc#get_float); - op <- None; - calc#set (Printf.sprintf "%g" x) - end - | 'q' -> closeTk (); exit 0 - | _ -> () -end - -(* Buttons for the calculator *) - -let m = - [|["7";"8";"9";"+"]; - ["4";"5";"6";"-"]; - ["1";"2";"3";"*"]; - ["0";".";"=";"/"]|] - -(* The physical calculator. Inherits from the abstract one *) - -class calculator ~parent = object - inherit calc () as calc - - val label = Label.create ~anchor:`E ~relief:`Sunken ~padx:10 parent - val frame = Frame.create parent - - initializer - let buttons = - Array.map ~f: - (List.map ~f: - (fun text -> - Button.create ~text ~command:(fun () -> calc#command text) frame)) - m - in - Label.configure ~textvariable:variable label; - calc#set "0"; - bind ~events:[`KeyPress] ~fields:[`Char] - ~action:(fun ev -> calc#command ev.ev_Char) - parent; - for i = 0 to Array.length m - 1 do - Grid.configure ~row:i buttons.(i) - done; - pack ~side:`Top ~fill:`X [label]; - pack ~side:`Bottom ~fill:`Both ~expand:true [frame]; -end - -(* Finally start everything *) - -let top = openTk () - -let applet = new calculator ~parent:top - -let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml deleted file mode 100644 index 57a59b825b..0000000000 --- a/otherlibs/labltk/examples_labltk/clock.ml +++ /dev/null @@ -1,133 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Clock/V, a simple clock. - Reverts every time you push the right button. - Adapted from ASCII/V May 1997 - - Uses Tk and Unix, so you must link with - labltklink unix.cma clock.ml -o clock -cclib -lunix -*) - -open Tk - -(* pi is not a constant! *) -let pi = acos (-1.) - -(* The main class: - * create it with a parent: [new clock parent:top] - * initialize with [#init] -*) - -class clock ~parent = object (self) - - (* Instance variables *) - val canvas = Canvas.create ~width:100 ~height:100 parent - val mutable height = 100 - val mutable width = 100 - val mutable rflag = -1 - - (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) - method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) - method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) - - initializer - (* Create the oval border *) - Canvas.create_oval canvas ~tags:["cadran"] - ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2) - ~width:3 ~outline:`Yellow ~fill:`White; - (* Draw the figures *) - self#draw_figures; - (* Create the arrows with dummy position *) - Canvas.create_line canvas - ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] - ~tags:["hours"] ~fill:`Red; - Canvas.create_line canvas - ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] - ~tags:["minutes"] ~fill:`Blue; - Canvas.create_line canvas - ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] - ~tags:["seconds"] ~fill:`Black; - (* Setup a timer every second *) - let rec timer () = - self#draw_arrows (Unix.localtime (Unix.time ())); - Timer.add ~ms:1000 ~callback:timer; () - in timer (); - (* Redraw when configured (changes size) *) - bind canvas ~events:[`Configure] ~action: - begin fun _ -> - width <- Winfo.width canvas; - height <- Winfo.height canvas; - self#redraw - end; - (* Change direction with right button *) - bind canvas ~events:[`ButtonPressDetail 3] - ~action:(fun _ -> rflag <- -rflag; self#redraw); - (* Pack, expanding in both directions *) - pack ~fill:`Both ~expand:true [canvas] - - (* Redraw everything *) - method redraw = - Canvas.coords_set canvas (`Tag "cadran") - ~xys:[ 1, 1; width - 2, height - 2 ]; - self#draw_figures; - self#draw_arrows (Unix.localtime (Unix.time ())) - - (* Delete and redraw the figures *) - method draw_figures = - Canvas.delete canvas [`Tag "figures"]; - for i = 1 to 12 do - let angle = float (rflag * i - 3) *. pi /. 6. in - Canvas.create_text canvas - ~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle)) - ~tags:["figures"] - ~text:(string_of_int i) ~font:"variable" - ~anchor:`Center - done - - (* Resize and reposition the arrows *) - method draw_arrows tm = - Canvas.configure_line ~width:(min width height / 40) - canvas (`Tag "hours"); - let hangle = - float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) - *. pi /. 360. in - Canvas.coords_set canvas (`Tag "hours") - ~xys:[ self#x 0., self#y 0.; - self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ]; - Canvas.configure_line ~width:(min width height / 50) - canvas (`Tag "minutes"); - let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in - Canvas.coords_set canvas (`Tag "minutes") - ~xys:[ self#x 0., self#y 0.; - self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ]; - let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in - Canvas.coords_set canvas (`Tag "seconds") - ~xys:[ self#x 0., self#y 0.; - self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ] -end - -(* Initialize the Tcl interpreter *) -let top = openTk () - -(* Create a clock on the main window *) -let clock = - new clock ~parent:top - -(* Wait for events *) -let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml deleted file mode 100644 index 2ccc448b19..0000000000 --- a/otherlibs/labltk/examples_labltk/demo.ml +++ /dev/null @@ -1,167 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Some CamlTk4 Demonstration by JPF *) - -(* First, open these modules for convenience *) -open StdLabels -open Tk - -(* Dummy let *) -let _ = - -(* Initialize Tk *) -let top = openTk () in -(* Title setting *) -Wm.title_set top "LablTk demo"; - -(* Base frame *) -let base = Frame.create top in -pack [base]; - -(* Menu bar *) -let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in -pack ~fill:`X [bar]; - - (* Menu and Menubutton *) - let meb = Menubutton.create ~text:"Menu" bar in - let men = Menu.create meb in - Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men; - Menubutton.configure ~menu:men meb; - - (* Frames *) - let base2 = Frame.create base in - let left = Frame.create base2 in - let right = Frame.create base2 in - pack [base2]; - pack ~side:`Left [left; right]; - - (* Widgets on left and right *) - - (* Button *) - let but = Button.create ~text:"Welcome to LablTk" left in - - (* Canvas *) - let can = - Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left - in - let oval = Canvas.create_oval ~x1: 10 ~y1: 10 - ~x2: 90 ~y2: 90 - ~fill: `Red - can - in ignore oval; - - (* Check button *) - let che = Checkbutton.create ~text:"Check" left in - - (* Entry *) - let ent = Entry.create ~width:10 left in - - (* Label *) - let lab = Label.create ~text:"Welcome to LablTk" left in - - (* Listbox *) - let lis = Listbox.create left in - Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"]; - - (* Message *) - let mes = Message.create - ~text: "Hello this is a message widget with very long text, but ..." - left in - - (* Radio buttons *) - let tv = Textvariable.create () in - Textvariable.set tv "One"; - let radf = Frame.create right in - let rads = List.map - ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf) - ["One"; "Two"; "Three"] in - - (* Scale *) - let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in - - (* Text and scrollbar *) - let texf = Frame.create right in - - (* Text *) - let tex = Text.create ~width:20 ~height:8 texf in - Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex; - - (* Scrollbar *) - let scr = Scrollbar.create texf in - - (* Text and Scrollbar widget link *) - let scroll_link sb tx = - Text.configure ~yscrollcommand:(Scrollbar.set sb) tx; - Scrollbar.configure ~command:(Text.yview tx) sb in - scroll_link scr tex; - - pack ~side:`Right ~fill:`Y [scr]; - pack ~side:`Left ~fill:`Both ~expand:true [tex]; - - (* Pack them *) - pack ~side:`Left [meb]; - pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; - pack [coe radf; coe sca; coe texf]; - pack rads; - - (* Toplevel *) - let top2 = Toplevel.create top in - Wm.title_set top2 "LablTk demo control"; - let defcol = `Color "#dfdfdf" in - let selcol = `Color "#ffdfdf" in - let buttons = - List.map ~f:(fun (w, t, c, a) -> - let b = Button.create ~text:t ~command:c top2 in - bind ~events:[`Enter] ~action:(fun _ -> a selcol) b; - bind ~events:[`Leave] ~action:(fun _ -> a defcol) b; - b) - [coe bar, "Frame", (fun () -> ()), - (fun background -> Frame.configure ~background bar); - coe meb, "Menubutton", (fun () -> ()), - (fun background -> Menubutton.configure ~background meb); - coe but, "Button", (fun () -> ()), - (fun background -> Button.configure ~background but); - coe can, "Canvas", (fun () -> ()), - (fun background -> Canvas.configure ~background can); - coe che, "CheckButton", (fun () -> ()), - (fun background -> Checkbutton.configure ~background che); - coe ent, "Entry", (fun () -> ()), - (fun background -> Entry.configure ~background ent); - coe lab, "Label", (fun () -> ()), - (fun background -> Label.configure ~background lab); - coe lis, "Listbox", (fun () -> ()), - (fun background -> Listbox.configure ~background lis); - coe mes, "Message", (fun () -> ()), - (fun background -> Message.configure ~background mes); - coe radf, "Radiobox", (fun () -> ()), - (fun background -> - List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads); - coe sca, "Scale", (fun () -> ()), - (fun background -> Scale.configure ~background sca); - coe tex, "Text", (fun () -> ()), - (fun background -> Text.configure ~background tex); - coe scr, "Scrollbar", (fun () -> ()), - (fun background -> Scrollbar.configure ~background scr) - ] - in - pack ~fill:`X buttons; - -(* Main Loop *) -Printexc.print mainLoop () - diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml deleted file mode 100644 index ce62159dbe..0000000000 --- a/otherlibs/labltk/examples_labltk/eyes.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk - -let _ = - let top = openTk () in - let fw = Frame.create top in - pack [fw]; - let c = Canvas.create ~width: 200 ~height: 200 fw in - let create_eye cx cy wx wy ewx ewy bnd = - let o2 = Canvas.create_oval - ~x1:(cx - wx) ~y1:(cy - wy) - ~x2:(cx + wx) ~y2:(cy + wy) - ~outline: `Black ~width: 7 - ~fill: `White - c - and o = Canvas.create_oval - ~x1:(cx - ewx) ~y1:(cy - ewy) - ~x2:(cx + ewx) ~y2:(cy + ewy) - ~fill:`Black - c in - let curx = ref cx - and cury = ref cy in - bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY] - ~action:(fun e -> - let nx, ny = - let xdiff = e.ev_MouseX - cx - and ydiff = e.ev_MouseY - cy in - let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. - (float ydiff /. (float wy *. bnd)) ** 2.0) in - if diff > 1.0 then - truncate ((float xdiff) *. (1.0 /. diff)) + cx, - truncate ((float ydiff) *. (1.0 /. diff)) + cy - else - e.ev_MouseX, e.ev_MouseY - in - Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury); - curx := nx; - cury := ny) - c - in - create_eye 60 100 30 40 5 6 0.6; - create_eye 140 100 30 40 5 6 0.6; - pack [c] - -let _ = Printexc.print mainLoop () - - - diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml deleted file mode 100644 index 4a89d48062..0000000000 --- a/otherlibs/labltk/examples_labltk/hello.ml +++ /dev/null @@ -1,38 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* LablTk4 Demonstration by JPF *) - -(* First, open this modules for convenience *) -open Tk - -(* initialization of Tk --- the result is a toplevel widget *) -let top = openTk () - -(* create a button on top *) -(* Button.create : use of create function defined in button.ml *) -(* But you shouldn't open Button module for other widget class modules use *) -let b = Button.create ~text: "Hello, LablTk!" top - -(* Lack of toplevel expressions in lsl, you must use dummy let exp. *) -let _ = pack [coe b] - -(* Last, you must call mainLoop *) -(* You can write just let _ = mainLoop () *) -(* But Printexc.print will help you *) -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/hello.tcl b/otherlibs/labltk/examples_labltk/hello.tcl deleted file mode 100755 index 84ceccd6d1..0000000000 --- a/otherlibs/labltk/examples_labltk/hello.tcl +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/wish - -button .hello -text "Hello, TclTk!" - -pack .hello diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml deleted file mode 100644 index e92377ecc3..0000000000 --- a/otherlibs/labltk/examples_labltk/lang.ml +++ /dev/null @@ -1,75 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* language encoding using UTF-8 *) -open Tk - -let top = opentk () - -(* declare Tk that we use utf-8 to communicate *) -(* problem: Text display is highly dependent on your font installation - and configulation. The fonts with no-scale setting are selected - only if the point sizes are exactly same??? -*) -let _ = - Encoding.system_set "utf-8"; - let l = Label.create top ~text: "???" in - pack [l]; - let t = Text.create top in - pack [t]; - - let create_hello lang hello = - let b = Button.create t ~text: lang ~command: (fun () -> - Label.configure l ~text: hello) - in - Text.window_create t ~index: (`End,[]) ~window: b - in - List.iter (fun (lang, hello) -> create_hello lang hello) - ["Amharic(አማርኛ)", "ሠላም"; - "Arabic", "�����������"; - "Croatian (Hrvatski)", "Bog (Bok), Dobar dan"; - "Czech (česky)", "Dobrý den"; - "Danish (Dansk)", "Hej, Goddag"; - "English", "Hello"; - "Esperanto", "Saluton"; - "Estonian", "Tere, Tervist"; - "FORTRAN", "PROGRAM"; - "Finnish (Suomi)", "Hei"; - "French (Français)", "Bonjour, Salut"; - "German (Deutsch Nord)", "Guten Tag"; - "German (Deutsch Süd)", "Grüß Gott"; - "Greek (Ελληνικά)", "Γειά σας"; - "Hebrew", "שלום"; - "Italiano", "Ciao, Buon giorno"; - "Maltese", "Ciao"; - "Nederlands, Vlaams", "Hallo, Hoi, Goedendag"; - "Norwegian (Norsk)", "Hei, God dag"; - "Polish", "Cześć!"; - "Russian (Русский)", "Здравствуйте!"; - "Slovak", "Dobrý deň"; - "Spanish (Español)", "¡Hola!"; - "Swedish (Svenska)", "Hej, Goddag"; - "Thai (�������)", "�������, ������"; - "Tigrigna (ትግርኛ)", "ሰላማት"; - "Turkish (Türkçe)", "Merhaba"; - "Vietnamese (Tiếng Việt)", "Chào bạn"; - "Japanese (日本語)", "こんにちは"; - "Chinese (中文,普通话,汉语)", "你好"; - "Cantonese (粵語,廣東話)", "早晨, 你好"; - "Hangul (한글)", "안녕하세요, 안녕하십니까" ] -;; - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml deleted file mode 100644 index a3bcbb1bfb..0000000000 --- a/otherlibs/labltk/examples_labltk/taquin.ml +++ /dev/null @@ -1,143 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk;; - -let dcoupe_image img nx ny = - let l = Imagephoto.width img - and h = Imagephoto.height img in - let tx = l / nx and ty = h / ny in - let pices = ref [] in - for x = 0 to nx - 1 do - for y = 0 to ny - 1 do - let pice = Imagephoto.create ~width:tx ~height:ty () in - Imagephoto.copy ~src:img - ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pice; - pices := pice :: !pices - done - done; - (tx, ty, List.tl !pices);; - -let remplir_taquin c nx ny tx ty pices = - let trou_x = ref (nx - 1) - and trou_y = ref (ny - 1) in - let trou = - Canvas.create_rectangle - ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in - let taquin = Array.make_matrix nx ny trou in - let p = ref pices in - for x = 0 to nx - 1 do - for y = 0 to ny - 1 do - match !p with - | [] -> () - | pice :: reste -> - taquin.(x).(y) <- - Canvas.create_image - ~x:(x * tx) ~y:(y * ty) - ~image:pice ~anchor:`Nw ~tags:["pice"] c; - p := reste - done - done; - let dplacer x y = - let pice = taquin.(x).(y) in - Canvas.coords_set c pice - ~xys:[!trou_x * tx, !trou_y * ty]; - Canvas.coords_set c trou - ~xys:[x * tx, y * ty; tx, ty]; - taquin.(!trou_x).(!trou_y) <- pice; - taquin.(x).(y) <- trou; - trou_x := x; trou_y := y in - let jouer ei = - let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in - if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) - || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) - then dplacer x y in - Canvas.bind ~events:[`ButtonPress] - ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pice");; - -let rec permutation = function - | [] -> [] - | l -> let n = Random.int (List.length l) in - let (lment, reste) = partage l n in - lment :: permutation reste - -and partage l n = - match l with - | [] -> failwith "partage" - | tte :: reste -> - if n = 0 then (tte, reste) else - let (lment, reste') = partage reste (n - 1) in - (lment, tte :: reste');; - -let create_filled_text parent lines = - let lnum = List.length lines - and lwidth = - List.fold_right - (fun line max -> - let l = String.length line in - if l > max then l else max) - lines 1 in - let txtw = Text.create ~width:lwidth ~height:lnum parent in - List.iter - (fun line -> - Text.insert ~index:(`End, []) ~text:line txtw; - Text.insert ~index:(`End, []) ~text:"\n" txtw) - lines; - txtw;; - -let give_help parent lines () = - let help_window = Toplevel.create parent in - Wm.title_set help_window "Help"; - - let help_frame = Frame.create help_window in - - let help_txtw = create_filled_text help_frame lines in - - let quit_help () = destroy help_window in - let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in - - pack ~side:`Bottom [help_txtw]; - pack ~side:`Bottom [ok_button ]; - pack [help_frame];; - -let taquin nom_fichier nx ny = - let fp = openTk () in - Wm.title_set fp "Taquin"; - let img = Imagephoto.create ~file:nom_fichier () in - let c = - Canvas.create ~background:`Black - ~width:(Imagephoto.width img) - ~height:(Imagephoto.height img) fp in - let (tx, ty, pices) = dcoupe_image img nx ny in - remplir_taquin c nx ny tx ty (permutation pices); - pack [c]; - - let quit = Button.create ~text:"Quit" ~command:closeTk fp in - let help_lines = - ["Pour jouer, cliquer sur une des pices"; - "entourant le trou"; - ""; - "To play, click on a part around the hole"] in - let help = - Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in - pack ~side:`Left ~fill:`X [quit] ; - pack ~side:`Left ~fill:`X [help] ; - mainLoop ();; - -if !Sys.interactive then () else -begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml deleted file mode 100644 index 3e3f1e8a4b..0000000000 --- a/otherlibs/labltk/examples_labltk/tetris.ml +++ /dev/null @@ -1,710 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* A Tetris game for LablTk *) -(* written by Jun P. Furuse *) - -open StdLabels -open Tk - -exception Done - -type falling_block = { - mutable pattern: int array list; - mutable bcolor: int; - mutable x: int; - mutable y: int; - mutable d: int; - mutable alive: bool - } - -let stop_a_bit = 300 - -let field_width = 10 -let field_height = 20 - -let colors = [| - `Color "red"; - `Color "yellow"; - - `Color "blue"; - `Color "orange"; - - `Color "magenta"; - `Color "green"; - - `Color "cyan" -|] - -(* Put here your favorite image files *) -let backgrounds = [ - "Lambda2.back.gif" -] - -(* blocks *) -let block_size = 16 -let cell_border = 2 - -let blocks = [ - [ [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |]; - - [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |] ]; - - [ [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0111"; - "0100"; - "0000" |]; - - [|"0000"; - "0110"; - "0010"; - "0010" |]; - - [|"0000"; - "0010"; - "1110"; - "0000" |]; - - [|"0100"; - "0100"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0100"; - "0111"; - "0000" |]; - - [|"0000"; - "0110"; - "0100"; - "0100" |]; - - [|"0000"; - "1110"; - "0010"; - "0000" |]; - - [|"0010"; - "0010"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |]; - - [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |] ]; - - [ [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0100"; - "0110"; - "0010"; - "0000" |]; - - [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0010" |] ]; - - [ [|"0000"; - "0000"; - "1110"; - "0100" |]; - - [|"0000"; - "0100"; - "1100"; - "0100" |]; - - [|"0000"; - "0100"; - "1110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0100" |] ] - -] - -let line_empty = int_of_string "0b1110000000000111" -let line_full = int_of_string "0b1111111111111111" - -let decode_block dvec = - let btoi d = int_of_string ("0b"^d) in - Array.map ~f:btoi dvec - -class cell t1 t2 t3 ~canvas ~x ~y = object - val mutable color = 0 - method get = color - method set ~color:col = - if color = col then () else - if color <> 0 && col = 0 then begin - Canvas.move canvas t1 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2); - Canvas.move canvas t2 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2); - Canvas.move canvas t3 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2) - end else begin - Canvas.configure_rectangle canvas t2 - ~fill: colors.(col - 1) - ~outline: colors.(col - 1); - Canvas.configure_rectangle canvas t1 - ~fill: `Black - ~outline: `Black; - Canvas.configure_rectangle canvas t3 - ~fill: (`Color "light gray") - ~outline: (`Color "light gray"); - if color = 0 && col <> 0 then begin - Canvas.move canvas t1 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2); - Canvas.move canvas t2 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2); - Canvas.move canvas t3 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2) - end - end; - color <- col -end - -let cell_get (c, cf) x y = cf.(y).(x) #get - -let cell_set (c, cf) ~x ~y ~color = - if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then - let cur = cf.(y).(x) in - if cur#get = color then () else cur#set ~color - -let create_base_matrix ~cols ~rows = - let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in - for x = 0 to cols - 1 do for y = 0 to rows - 1 do - m.(y).(x) <- (x,y) - done done; - m - -let init fw = - let scorev = Textvariable.create () - and linev = Textvariable.create () - and levv = Textvariable.create () - and namev = Textvariable.create () - in - let f = Frame.create fw ~borderwidth: 2 in - let c = Canvas.create f ~width: (block_size * 10) - ~height: (block_size * 20) - ~borderwidth: cell_border - ~relief: `Sunken - ~background: `Black - and r = Frame.create f - and r' = Frame.create f in - - let nl = Label.create r ~text: "Next" ~font: "variable" in - let nc = Canvas.create r ~width: (block_size * 4) - ~height: (block_size * 4) - ~borderwidth: cell_border - ~relief: `Sunken - ~background: `Black in - let scl = Label.create r ~text: "Score" ~font: "variable" in - let sc = Label.create r ~textvariable: scorev ~font: "variable" in - let lnl = Label.create r ~text: "Lines" ~font: "variable" in - let ln = Label.create r ~textvariable: linev ~font: "variable" in - let levl = Label.create r ~text: "Level" ~font: "variable" in - let lev = Label.create r ~textvariable: levv ~font: "variable" in - let newg = Button.create r ~text: "New Game" ~font: "variable" in - - pack [f]; - pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y; - pack [coe nl; coe nc] ~side: `Top; - pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg] - ~side: `Top; - - let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in - let cells = - Array.map cells_src ~f: - (Array.map ~f: - begin fun (x,y) -> - let t1 = - Canvas.create_rectangle c - ~x1:(-block_size - 8) ~y1:(-block_size - 8) - ~x2:(-9) ~y2:(-9) - and t2 = - Canvas.create_rectangle c - ~x1:(-block_size - 10) ~y1:(-block_size - 10) - ~x2:(-11) ~y2:(-11) - and t3 = - Canvas.create_rectangle c - ~x1:(-block_size - 12) ~y1:(-block_size - 12) - ~x2:(-13) ~y2:(-13) - in - Canvas.raise c t1; - Canvas.raise c t2; - Canvas.lower c t3; - new cell ~canvas:c ~x ~y t1 t2 t3 - end) - in - let nexts_src = create_base_matrix ~cols:4 ~rows:4 in - let nexts = - Array.map nexts_src ~f: - (Array.map ~f: - begin fun (x,y) -> - let t1 = - Canvas.create_rectangle nc - ~x1:(-block_size - 8) ~y1:(-block_size - 8) - ~x2:(-9) ~y2:(-9) - and t2 = - Canvas.create_rectangle nc - ~x1:(-block_size - 10) ~y1:(-block_size - 10) - ~x2:(-11) ~y2:(-11) - and t3 = - Canvas.create_rectangle nc - ~x1:(-block_size - 12) ~y1:(-block_size - 12) - ~x2:(-13) ~y2:(-13) - in - Canvas.raise nc t1; - Canvas.raise nc t2; - Canvas.lower nc t3; - new cell ~canvas:nc ~x ~y t1 t2 t3 - end) - in - let game_over () = () - in - (* What a mess ! *) - [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; - coe lnl; coe ln ], - newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over - - -let draw_block field ~color ~block ~x ~y = - for iy = 0 to 3 do - let base = ref 1 in - let xd = block.(iy) in - for ix = 0 to 3 do - if xd land !base <> 0 then - cell_set field ~x:(ix + x) ~y:(iy + y) ~color; - base := !base lsl 1 - done - done - -let timer_ref = (ref None : Timer.t option ref) -(* I know, this should be timer ref, but I'm not sure what should be - the initial value ... *) - -let remove_timer () = - match !timer_ref with - None -> () - | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) - -let do_after ~ms ~callback = - timer_ref := Some (Timer.add ~ms ~callback) - -let copy_block c = - { pattern= !c.pattern; - bcolor= !c.bcolor; - x= !c.x; - y= !c.y; - d= !c.d; - alive= !c.alive } - -let _ = - let top = openTk () in - let lb = Label.create top - and fw = Frame.create top - in - let set_message s = Label.configure lb ~text:s in - pack [coe lb; coe fw] ~side: `Top; - let score = ref 0 in - let line = ref 0 in - let level = ref 0 in - let time = ref 1000 in - let blocks = List.map ~f:(List.map ~f:decode_block) blocks in - let field = Array.create 26 0 in - let widgets, button, cell_field, next_field, scorev, linev, levv, game_over - = init fw in - let canvas = fst cell_field in - - let init_field () = - for i = 0 to 25 do - field.(i) <- line_empty - done; - field.(23) <- line_full; - for i = 0 to 19 do - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:i ~color:0 - done - done; - for i = 0 to 3 do - for j = 0 to 3 do - cell_set next_field ~x:j ~y:i ~color:0 - done - done - in - - let draw_falling_block fb = - draw_block cell_field ~color: fb.bcolor - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) - ~y: (fb.y - 3) - - and erase_falling_block fb = - draw_block cell_field ~color: 0 - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) - ~y: (fb.y - 3) - in - - let stone fb = - for i=0 to 3 do - let cur = field.(i + fb.y) in - field.(i + fb.y) <- - cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) - done; - for i=0 to 2 do - field.(i) <- line_empty - done - - and clear fb = - let l = ref 0 in - for i = 0 to 3 do - if i + fb.y >= 3 && i + fb.y <= 22 then - if field.(i + fb.y) = line_full then - begin - incr l; - field.(i + fb.y) <- line_empty; - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 - done - end - done; - !l - - and fall_lines () = - let eye = ref 22 (* bottom *) - and cur = ref 22 (* bottom *) - in - try - while !eye >= 3 do - while field.(!eye) = line_empty do - decr eye; - if !eye = 2 then raise Done - done; - field.(!cur) <- field.(!eye); - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(!cur-3) - ~color:(cell_get cell_field j (!eye-3)) - done; - decr eye; - decr cur - done - with Done -> (); - for i = 3 to !cur do - field.(i) <- line_empty; - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(i-3) ~color:0 - done - done - in - - let next = ref 42 (* THE ANSWER *) - and current = - ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} - in - - let draw_next () = - draw_block next_field ~color: (!next+1) - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 - - and erase_next () = - draw_block next_field ~color: 0 - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 - in - - let set_nextblock () = - current := - { pattern= (List.nth blocks !next); - bcolor= !next+1; - x=6; y= 1; d= 0; alive= true}; - erase_next (); - next := Random.int 7; - draw_next () - in - - let death_check fb = - try - for i=0 to 3 do - let cur = field.(i + fb.y) in - if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 - then raise Done - done; - false - with - Done -> true - in - - let try_to_move m = - if !current.alive then - let sub m = - if death_check m then false - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - true - end - in - if sub m then true - else - begin - m.x <- m.x + 1; - if sub m then true - else - begin - m.x <- m.x - 2; - sub m - end - end - else false - in - - let image_load = - let i = Canvas.create_image canvas - ~x: (block_size * 5 + block_size / 2) - ~y: (block_size * 10 + block_size / 2) - ~anchor: `Center in - Canvas.lower canvas i; - let img = Imagephoto.create () in - fun file -> - try - Imagephoto.configure img ~file: file; - Canvas.configure_image canvas i ~image: img - with - _ -> - begin - Printf.eprintf "%s : No such image...\n" file; - flush stderr - end - in - - let add_score l = - let pline = !line in - if l <> 0 then - begin - line := !line + l; - score := !score + l * l; - set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) - end; - Textvariable.set linev (string_of_int !line); - Textvariable.set scorev (string_of_int !score); - - if !line /10 <> pline /10 then - (* update the background every 10 lines. *) - begin - let num_image = List.length backgrounds - 1 in - let n = !line/10 in - let n = if n > num_image then num_image else n in - let file = List.nth backgrounds n in - image_load file; - incr level; - Textvariable.set levv (string_of_int !level) - end - in - - let rec newblock () = - set_message "TETRIS"; - set_nextblock (); - draw_falling_block !current; - if death_check !current then - begin - !current.alive <- false; - set_message "GAME OVER"; - game_over () - end - else - begin - time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); - if !time < 60 - !level * 3 then time := 60 - !level * 3; - do_after ~ms:stop_a_bit ~callback:loop - end - - and loop () = - let m = copy_block current in - m.y <- m.y + 1; - if death_check m then - begin - !current.alive <- false; - stone !current; - do_after ~ms:stop_a_bit ~callback: - begin fun () -> - let l = clear !current in - if l > 0 then - do_after ~ms:stop_a_bit ~callback: - begin fun () -> - fall_lines (); - add_score l; - do_after ~ms:stop_a_bit ~callback:newblock - end - else - newblock () - end - end - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - do_after ~ms:!time ~callback:loop - end - in - - let bind_game w = - bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action: - begin fun e -> - match e.ev_KeySymString with - | "h" -> - let m = copy_block current in - m.x <- m.x - 1; - ignore (try_to_move m) - | "j" -> - let m = copy_block current in - m.d <- m.d + 1; - if m.d = List.length m.pattern then m.d <- 0; - ignore (try_to_move m) - | "k" -> - let m = copy_block current in - m.d <- m.d - 1; - if m.d < 0 then m.d <- List.length m.pattern - 1; - ignore (try_to_move m) - | "l" -> - let m = copy_block current in - m.x <- m.x + 1; - ignore (try_to_move m) - | "m" -> - remove_timer (); - loop () - | "space" -> - if !current.alive then - begin - let m = copy_block current - and n = copy_block current in - while - m.y <- m.y + 1; - if death_check m then false - else begin n.y <- m.y; true end - do () done; - erase_falling_block !current; - draw_falling_block n; - current := n; - remove_timer (); - loop () - end - | _ -> () - end - in - - let game_init () = - (* Game Initialization *) - set_message "Initializing ..."; - remove_timer (); - image_load (List.hd backgrounds); - time := 1000; - score := 0; - line := 0; - level := 1; - add_score 0; - init_field (); - next := Random.int 7; - set_message "Welcome to TETRIS"; - set_nextblock (); - draw_falling_block !current; - do_after ~ms:!time ~callback:loop - in - (* As an applet, it was required... *) - (* List.iter f: bind_game widgets; *) - bind_game top; - Button.configure button ~command: game_init; - game_init () - -let _ = Printexc.print mainLoop () |
