summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/example
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/example')
-rw-r--r--otherlibs/labltk/example/Makefile2
-rw-r--r--otherlibs/labltk/example/README10
-rw-r--r--otherlibs/labltk/example/calc.ml25
-rw-r--r--otherlibs/labltk/example/clock.ml72
-rw-r--r--otherlibs/labltk/example/demo.ml8
-rw-r--r--otherlibs/labltk/example/eyes.ml15
-rw-r--r--otherlibs/labltk/example/tetris.ml72
7 files changed, 110 insertions, 94 deletions
diff --git a/otherlibs/labltk/example/Makefile b/otherlibs/labltk/example/Makefile
index ec720bc85..09ff25dde 100644
--- a/otherlibs/labltk/example/Makefile
+++ b/otherlibs/labltk/example/Makefile
@@ -1,6 +1,6 @@
include ../support/Makefile.common
-COMPFLAGS=-I ../lib -I ../support -I $(OTHERS)/unix
+COMPFLAGS=-I ../lib -I ../support -I $(OTHERS)/unix -w s
all: hello demo eyes calc clock tetris
diff --git a/otherlibs/labltk/example/README b/otherlibs/labltk/example/README
index b3f473bac..dbb038b50 100644
--- a/otherlibs/labltk/example/README
+++ b/otherlibs/labltk/example/README
@@ -1,17 +1,17 @@
$Id$
-Some examples for LablTk. They must be compiled with the -modern
-option, except for hello.ml and calc.ml.
+Some examples for LablTk.
+Only demo.ml and tetris.ml really need to be compiled with the -labels option.
hello.ml A very simple example of CamlTk
hello.tcl The same programme in Tcl/Tk
-demo.ml A demonstration using many widget classes
+demo.ml A demonstration using many widget classes (use -labels)
eyes.ml A "bind" test
calc.ml A little calculator
-clock.ml An analog clock
+clock.ml An analog clock (use unix.cma)
-tetris.ml You NEED a game also. Edit it to set a background
+tetris.ml You NEED a game also (use -labels)
diff --git a/otherlibs/labltk/example/calc.ml b/otherlibs/labltk/example/calc.ml
index c9657dfa6..18d0c7936 100644
--- a/otherlibs/labltk/example/calc.ml
+++ b/otherlibs/labltk/example/calc.ml
@@ -44,17 +44,17 @@ class calc () = object (calc)
method set = Textvariable.set variable
method get = Textvariable.get variable
- method insert s = calc#set to:(calc#get ^ s)
+ 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 to:""; displaying <- false);
+ if displaying then (calc#set ""; displaying <- false);
calc#insert s
| '.' ->
if displaying then
- (calc#set to:"0."; displaying <- false)
+ (calc#set "0."; displaying <- false)
else
if not (mem_string elt:'.' calc#get) then calc#insert s
| '+'|'-'|'*'|'/' as c ->
@@ -62,11 +62,11 @@ class calc () = object (calc)
begin match op with
None ->
x <- calc#get_float;
- op <- Some (List.assoc key:c ops)
+ op <- Some (List.assoc c ops)
| Some f ->
x <- f x (calc#get_float);
- op <- Some (List.assoc key:c ops);
- calc#set to:(string_of_float x)
+ op <- Some (List.assoc c ops);
+ calc#set (string_of_float x)
end
| '='|'\n'|'\r' ->
displaying <- true;
@@ -75,7 +75,7 @@ class calc () = object (calc)
| Some f ->
x <- f x (calc#get_float);
op <- None;
- calc#set to:(string_of_float x)
+ calc#set (string_of_float x)
end
| 'q' -> closeTk (); exit 0
| _ -> ()
@@ -99,16 +99,17 @@ class calculator :parent = object
initializer
let buttons =
- Array.map fun:
- (List.map fun:
+ 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 to:"0";
- bind parent events:[`KeyPress] fields:[`Char]
- action:(fun ev -> calc#command ev.ev_Char);
+ 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;
diff --git a/otherlibs/labltk/example/clock.ml b/otherlibs/labltk/example/clock.ml
index 37d4542eb..f1fce00db 100644
--- a/otherlibs/labltk/example/clock.ml
+++ b/otherlibs/labltk/example/clock.ml
@@ -35,7 +35,7 @@ let pi = acos (-1.)
class clock :parent = object (self)
(* Instance variables *)
- val canvas = Canvas.create parent width:100 height:100
+ val canvas = Canvas.create width:100 height:100 parent
val mutable height = 100
val mutable width = 100
val mutable rflag = -1
@@ -46,74 +46,86 @@ class clock :parent = object (self)
initializer
(* Create the oval border *)
- Canvas.create_oval canvas tags:[`Tag "cadran"]
- x1:1 y1:1 x2:(width - 2) y2:(height - 2)
- width:3 outline:`Yellow fill:`White;
+ Canvas.create_oval x1:1 y1:1 x2:(width - 2) y2:(height - 2)
+ tags:["cadran"] width:3 outline:`Yellow fill:`White
+ canvas;
(* Draw the figures *)
self#draw_figures;
(* Create the arrows with dummy position *)
- Canvas.create_line canvas tags:[`Tag "hours"] fill:`Red
- xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
- Canvas.create_line canvas tags:[`Tag "minutes"] fill:`Blue
- xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
- Canvas.create_line canvas tags:[`Tag "seconds"] fill:`Black
- xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
+ Canvas.create_line xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.]
+ tags:["hours"] fill:`Red
+ canvas;
+ Canvas.create_line xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.]
+ tags:["minutes"] fill:`Blue
+ canvas;
+ Canvas.create_line xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.]
+ tags:["seconds"] fill:`Black
+ canvas;
(* 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]
+ bind events:[`Configure]
action:(fun _ ->
width <- Winfo.width canvas;
height <- Winfo.height canvas;
- self#redraw);
+ self#redraw)
+ canvas;
(* Change direction with right button *)
- bind canvas events:[`ButtonPressDetail 3]
- action:(fun _ -> rflag <- -rflag; self#redraw);
+ bind events:[`ButtonPressDetail 3]
+ action:(fun _ -> rflag <- -rflag; self#redraw)
+ canvas;
(* Pack, expanding in both directions *)
- pack [canvas] fill:`Both expand:true
+ pack fill:`Both expand:true [canvas]
(* Redraw everything *)
method redraw =
- Canvas.coords_set canvas tag:(`Tag "cadran")
- coords:[ 1; 1; width - 2; height - 2 ];
+ Canvas.coords_set :canvas
+ coords:[ 1; 1; width - 2; height - 2 ]
+ (`Tag "cadran");
self#draw_figures;
self#draw_arrows (Unix.localtime (Unix.time ()))
(* Delete and redraw the figures *)
method draw_figures =
- Canvas.delete canvas tags:[`Tag "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 tags:[`Tag "figures"]
+ Canvas.create_text
+ x:(self#x (0.8 *. cos angle)) y:(self#y (0.8 *. sin angle))
+ tags:["figures"]
text:(string_of_int i) font:"variable"
- x:(self#x (0.8 *. cos angle))
- y:(self#y (0.8 *. sin angle))
anchor:`Center
+ canvas
done
(* Resize and reposition the arrows *)
method draw_arrows tm =
- Canvas.configure_line canvas tag:(`Tag "hours")
- width:(min width height / 40);
+ Canvas.configure_line :canvas
+ width:(min width height / 40)
+ (`Tag "hours");
let hangle =
float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180)
*. pi /. 360. in
- Canvas.coords_set canvas tag:(`Tag "hours")
+ Canvas.coords_set :canvas
coords:[ self#x 0.; self#y 0.;
- self#x (cos hangle /. 2.); self#y (sin hangle /. 2.) ];
- Canvas.configure_line canvas tag:(`Tag "minutes")
- width:(min width height / 50);
+ self#x (cos hangle /. 2.); self#y (sin hangle /. 2.) ]
+ (`Tag "hours");
+ Canvas.configure_line :canvas
+ width:(min width height / 50)
+ (`Tag "minutes");
let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in
- Canvas.coords_set canvas tag:(`Tag "minutes")
+ Canvas.coords_set :canvas
coords:[ self#x 0.; self#y 0.;
- self#x (cos mangle /. 1.5); self#y (sin mangle /. 1.5) ];
+ self#x (cos mangle /. 1.5); self#y (sin mangle /. 1.5) ]
+ (`Tag "minutes");
let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in
- Canvas.coords_set canvas tag:(`Tag "seconds")
+ Canvas.coords_set :canvas
coords:[ self#x 0.; self#y 0.;
self#x (cos sangle /. 1.25); self#y (sin sangle /. 1.25) ]
+ (`Tag "seconds")
end
(* Initialize the Tcl interpreter *)
diff --git a/otherlibs/labltk/example/demo.ml b/otherlibs/labltk/example/demo.ml
index 94d686355..70fd5e437 100644
--- a/otherlibs/labltk/example/demo.ml
+++ b/otherlibs/labltk/example/demo.ml
@@ -80,10 +80,10 @@ pack [bar] fill: `X;
(* Radio buttons *)
let tv = Textvariable.create () in
- Textvariable.set tv to: "One";
+ Textvariable.set tv "One";
let radf = Frame.create right in
let rads = List.map
- fun:(fun t -> Radiobutton.create radf text: t value: t variable: tv)
+ f:(fun t -> Radiobutton.create radf text: t value: t variable: tv)
["One"; "Two"; "Three"] in
(* Scale *)
@@ -122,7 +122,7 @@ pack [bar] fill: `X;
let defcol = `Color "#dfdfdf" in
let selcol = `Color "#ffdfdf" in
let buttons =
- List.map fun:(fun (w, t, c, a) ->
+ List.map f:(fun (w, t, c, a) ->
let b = Button.create top2 text:t command:c in
bind b events: [`Enter] action:(fun _ -> a selcol);
bind b events: [`Leave] action:(fun _ -> a defcol);
@@ -147,7 +147,7 @@ pack [bar] fill: `X;
(fun background -> Message.configure mes :background);
coe radf, "Radiobox", (fun () -> ()),
(fun background ->
- List.iter rads fun:(fun b -> Radiobutton.configure b :background));
+ List.iter rads f:(fun b -> Radiobutton.configure b :background));
coe sca, "Scale", (fun () -> ()),
(fun background -> Scale.configure sca :background);
coe tex, "Text", (fun () -> ()),
diff --git a/otherlibs/labltk/example/eyes.ml b/otherlibs/labltk/example/eyes.ml
index 021ea700c..eaa335809 100644
--- a/otherlibs/labltk/example/eyes.ml
+++ b/otherlibs/labltk/example/eyes.ml
@@ -20,20 +20,22 @@ let _ =
let top = openTk () in
let fw = Frame.create top in
pack [fw];
- let c = Canvas.create fw width: 200 height: 200 in
+ 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 c
+ let o2 = Canvas.create_oval
x1:(cx - wx) y1:(cy - wy)
x2:(cx + wx) y2:(cy + wy)
outline: `Black width: 7
fill: `White
- and o = Canvas.create_oval c
+ c
+ and o = Canvas.create_oval
x1:(cx - ewx) y1:(cy - ewy)
x2:(cx + ewx) y2:(cy + ewy)
- fill:`Black in
+ fill:`Black
+ c in
let curx = ref cx
and cury = ref cy in
- bind c events:[`Motion] extend:true fields:[`MouseX; `MouseY]
+ bind events:[`Motion] extend:true fields:[`MouseX; `MouseY]
action:(fun e ->
let nx, ny =
let xdiff = e.ev_MouseX - cx
@@ -46,9 +48,10 @@ let _ =
else
e.ev_MouseX, e.ev_MouseY
in
- Canvas.move c tag: o x: (nx - !curx) y: (ny - !cury);
+ Canvas.move canvas:c x: (nx - !curx) y: (ny - !cury) o;
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;
diff --git a/otherlibs/labltk/example/tetris.ml b/otherlibs/labltk/example/tetris.ml
index 580e7c82b..5e40c7d76 100644
--- a/otherlibs/labltk/example/tetris.ml
+++ b/otherlibs/labltk/example/tetris.ml
@@ -205,7 +205,7 @@ let line_full = int_of_string "0b1111111111111111"
let decode_block dvec =
let btoi d = int_of_string ("0b"^d) in
- Array.map fun:btoi dvec
+ Array.map f:btoi dvec
class cell t1 t2 t3 :canvas :x :y = object
val mutable color = 0
@@ -213,33 +213,33 @@ class cell t1 t2 t3 :canvas :x :y = object
method set color:col =
if color = col then () else
if color <> 0 & col = 0 then begin
- Canvas.move canvas tag: t1
+ Canvas.move t1 :canvas
x:(- block_size * (x + 1) -10 - cell_border * 2)
y:(- block_size * (y + 1) -10 - cell_border * 2);
- Canvas.move canvas tag: t2
+ Canvas.move t2 :canvas
x:(- block_size * (x + 1) -10 - cell_border * 2)
y:(- block_size * (y + 1) -10 - cell_border * 2);
- Canvas.move canvas tag: t3
+ Canvas.move t3 :canvas
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 tag: t2
+ Canvas.configure_rectangle t2 :canvas
fill: colors.(col - 1)
outline: colors.(col - 1);
- Canvas.configure_rectangle canvas tag: t1
+ Canvas.configure_rectangle t1 :canvas
fill: `Black
outline: `Black;
- Canvas.configure_rectangle canvas tag: t3
+ Canvas.configure_rectangle t3 :canvas
fill: (`Color "light gray")
outline: (`Color "light gray");
if color = 0 & col <> 0 then begin
- Canvas.move canvas tag: t1
+ Canvas.move t1 :canvas
x: (block_size * (x+1)+10+ cell_border*2)
y: (block_size * (y+1)+10+ cell_border*2);
- Canvas.move canvas tag: t2
+ Canvas.move t2 :canvas
x: (block_size * (x+1)+10+ cell_border*2)
y: (block_size * (y+1)+10+ cell_border*2);
- Canvas.move canvas tag: t3
+ Canvas.move t3 :canvas
x: (block_size * (x+1)+10+ cell_border*2)
y: (block_size * (y+1)+10+ cell_border*2)
end
@@ -298,8 +298,8 @@ let init fw =
let cells_src = create_base_matrix cols:field_width rows:field_height in
let cells =
- Array.map cells_src fun:
- (Array.map fun:
+ Array.map cells_src f:
+ (Array.map f:
begin fun (x,y) ->
let t1 =
Canvas.create_rectangle c
@@ -314,16 +314,16 @@ let init fw =
x1:(-block_size - 12) y1:(-block_size - 12)
x2:(-13) y2:(-13)
in
- Canvas.raise c tag: t1;
- Canvas.raise c tag: t2;
- Canvas.lower c tag: t3;
+ Canvas.raise canvas:c t1;
+ Canvas.raise canvas:c t2;
+ Canvas.lower canvas: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 fun:
- (Array.map fun:
+ Array.map nexts_src f:
+ (Array.map f:
begin fun (x,y) ->
let t1 =
Canvas.create_rectangle nc
@@ -338,9 +338,9 @@ let init fw =
x1:(-block_size - 12) y1:(-block_size - 12)
x2:(-13) y2:(-13)
in
- Canvas.raise nc tag: t1;
- Canvas.raise nc tag: t2;
- Canvas.lower nc tag: t3;
+ Canvas.raise canvas:nc t1;
+ Canvas.raise canvas:nc t2;
+ Canvas.lower canvas:nc t3;
new cell canvas:nc :x :y t1 t2 t3
end)
in
@@ -394,8 +394,8 @@ let _ =
let line = ref 0 in
let level = ref 0 in
let time = ref 1000 in
- let blocks = List.map fun:(List.map fun:decode_block) blocks in
- let field = Array.create len:26 0 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
@@ -419,13 +419,13 @@ let _ =
let draw_falling_block fb =
draw_block cell_field color: fb.bcolor
- block: (List.nth fb.pattern pos: fb.d)
+ 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 pos: fb.d)
+ block: (List.nth fb.pattern fb.d)
x: (fb.x - 3)
y: (fb.y - 3)
in
@@ -434,7 +434,7 @@ let _ =
for i=0 to 3 do
let cur = field.(i + fb.y) in
field.(i + fb.y) <-
- cur lor ((List.nth fb.pattern pos: fb.d).(i) lsl fb.x)
+ cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
done;
for i=0 to 2 do
field.(i) <- line_empty
@@ -489,18 +489,18 @@ let _ =
let draw_next () =
draw_block next_field color: (!next+1)
- block: (List.hd (List.nth blocks pos: !next))
+ 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 pos: !next))
+ block: (List.hd (List.nth blocks !next))
x: 0 y: 0
in
let set_nextblock () =
current :=
- { pattern= (List.nth blocks pos: !next);
+ { pattern= (List.nth blocks !next);
bcolor= !next+1;
x=6; y= 1; d= 0; alive= true};
erase_next ();
@@ -512,7 +512,7 @@ let _ =
try
for i=0 to 3 do
let cur = field.(i + fb.y) in
- if cur land ((List.nth fb.pattern pos: fb.d).(i) lsl fb.x) <> 0
+ if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0
then raise Done
done;
false
@@ -551,12 +551,12 @@ let _ =
x: (block_size * 5 + block_size / 2)
y: (block_size * 10 + block_size / 2)
anchor: `Center in
- Canvas.lower canvas tag: i;
+ Canvas.lower :canvas i;
let img = Imagephoto.create () in
fun file ->
try
Imagephoto.configure img file: file;
- Canvas.configure_image canvas tag: i image: img
+ Canvas.configure_image :canvas i image: img
with
_ ->
begin
@@ -573,8 +573,8 @@ let _ =
score := !score + l * l;
set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2)))
end;
- Textvariable.set linev to: (string_of_int !line);
- Textvariable.set scorev to: (string_of_int !score);
+ Textvariable.set linev (string_of_int !line);
+ Textvariable.set scorev (string_of_int !score);
if !line /10 <> pline /10 then
(* undate the background every 10 lines. *)
@@ -582,10 +582,10 @@ let _ =
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 pos: n in
+ let file = List.nth backgrounds n in
image_load file;
incr level;
- Textvariable.set levv to: (string_of_int !level)
+ Textvariable.set levv (string_of_int !level)
end
in
@@ -699,7 +699,7 @@ let _ =
do_after ms:!time do:loop
in
(* As an applet, it was required... *)
- (* List.iter fun: bind_game widgets; *)
+ (* List.iter f: bind_game widgets; *)
bind_game top;
Button.configure button command: game_init;
game_init ()
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 16:49:30 +0000