change Canvas, pour des labels/ordre plus naturels
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3029 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Jacques Garrigue
parent
ed84ab0c2c
commit
151d346646
|
|
@ -272,7 +272,7 @@ subtype option(arc) {
|
|||
Start ["-start"; float]
|
||||
Stipple ["-stipple"; Bitmap]
|
||||
ArcStyle ["-style"; ArcStyle]
|
||||
Tags ["-tags"; [TagOrId list]]
|
||||
Tags ["-tags"; [string list]]
|
||||
Width
|
||||
}
|
||||
|
||||
|
|
@ -399,10 +399,10 @@ widget canvas {
|
|||
option YScrollIncrement ["-yscrollincrement"; int]
|
||||
|
||||
|
||||
function () addtag [widget(canvas); "addtag"; tag: TagOrId; specs: SearchSpec list] # Tag only
|
||||
function () addtag [widget(canvas); "addtag"; tag: string; specs: SearchSpec list] # Tag only
|
||||
# bbox not fully supported. should be builtin because of ambiguous result
|
||||
# will raise protocol__TkError if no items match TagOrId
|
||||
function (int,int,int,int) bbox [widget(canvas); "bbox"; tags: TagOrId list]
|
||||
function (int,int,int,int) bbox [canvas: widget(canvas); "bbox"; TagOrId list]
|
||||
external bind "builtin/canvas_bind"
|
||||
function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]]
|
||||
# function (float) canvasx [widget(canvas); "canvasx"; x:int]
|
||||
|
|
@ -413,43 +413,38 @@ widget canvas {
|
|||
function () configure [widget(canvas); "configure"; option(canvas) list]
|
||||
function (string) configure_get [widget(canvas); "configure"]
|
||||
# TODO: check result
|
||||
function (float list) coords_get [widget(canvas); "coords"; tag: TagOrId]
|
||||
function () coords_set [widget(canvas); "coords"; tag: TagOrId; coords: int list]
|
||||
function (float list) coords_get [canvas: widget(canvas); "coords"; TagOrId]
|
||||
function () coords_set [canvas: widget(canvas); "coords"; TagOrId; coords: int list]
|
||||
# create variations (see below)
|
||||
function () dchars [widget(canvas); "dchars"; tag: TagOrId; first: Index(canvas); last: Index(canvas)]
|
||||
function () delete [widget(canvas); "delete"; tags: TagOrId list]
|
||||
function () dtag [widget(canvas); "dtag"; tag: TagOrId; tagtodelete: TagOrId] # 2d arg is tag only
|
||||
function () dchars [canvas: widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)]
|
||||
function () delete [canvas: widget(canvas); "delete"; TagOrId list]
|
||||
function () dtag [canvas: widget(canvas); "dtag"; TagOrId; tag: string]
|
||||
function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list]
|
||||
# focus variations
|
||||
function () focus_reset [widget(canvas); "focus"; ""]
|
||||
function (TagOrId) focus_get [widget(canvas); "focus"]
|
||||
function () focus [widget(canvas); "focus"; tag: TagOrId]
|
||||
function (TagOrId list) gettags [widget(canvas); "gettags"; tag: TagOrId]
|
||||
function () icursor [widget(canvas); "icursor"; tag: TagOrId; index: Index(canvas)]
|
||||
function (int) index [widget(canvas); "index"; tag: TagOrId; index: Index(canvas)]
|
||||
function () insert [widget(canvas); "insert"; tag: TagOrId; before: Index(canvas); text: string]
|
||||
function () lower [widget(canvas); "lower"; tag: TagOrId; ?below: [TagOrId]]
|
||||
# configure variations, see below
|
||||
# function () lower_below [widget(canvas); "lower"; tag: TagOrId; below: TagOrId]
|
||||
# function () lower_bot [widget(canvas); "lower"; tag: TagOrId]
|
||||
function () move [widget(canvas); "move"; tag: TagOrId; x: int; y: int]
|
||||
function () focus [canvas: widget(canvas); "focus"; TagOrId]
|
||||
function (string list) gettags [canvas: widget(canvas); "gettags"; TagOrId]
|
||||
function () icursor [canvas: widget(canvas); "icursor"; TagOrId; index: Index(canvas)]
|
||||
function (int) index [canvas: widget(canvas); "index"; TagOrId; index: Index(canvas)]
|
||||
function () insert [canvas: widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string]
|
||||
function () lower [canvas: widget(canvas); "lower"; TagOrId; ?below: [TagOrId]]
|
||||
function () move [canvas: widget(canvas); "move"; TagOrId; x: int; y: int]
|
||||
unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list]
|
||||
# We use raise... with Module name
|
||||
function () raise [widget(canvas); "raise"; tag: TagOrId; ?above:[TagOrId]]
|
||||
# function () raise_above [widget(canvas); "raise"; tag: TagOrId; above: TagOrId]
|
||||
# function () raise_top [widget(canvas); "raise"; tag: TagOrId]
|
||||
function () scale [widget(canvas); "scale"; tag: TagOrId; xorigin: int; yorigin: int; xscale: float; yscale: float]
|
||||
function () raise [canvas: widget(canvas); "raise"; TagOrId; ?above:[TagOrId]]
|
||||
function () scale [canvas: widget(canvas); "scale"; TagOrId; xorigin: int; yorigin: int; xscale: float; yscale: float]
|
||||
# For scan, use x:int and y:int since common usage is with mouse coordinates
|
||||
function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int]
|
||||
function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int]
|
||||
# select variations
|
||||
function () select_adjust [widget(canvas); "select"; "adjust"; tag: TagOrId; index: Index(canvas)]
|
||||
function () select_adjust [canvas: widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)]
|
||||
function () select_clear [widget(canvas); "select"; "clear"]
|
||||
function () select_from [widget(canvas); "select"; "from"; tag: TagOrId; index: Index(canvas)]
|
||||
function () select_from [canvas: widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)]
|
||||
function (TagOrId) select_item [widget(canvas); "select"; "item"]
|
||||
function () select_to [widget(canvas); "select"; "to"; tag: TagOrId; index: Index(canvas)]
|
||||
function () select_to [canvas: widget(canvas); "select"; "to"; TagOrId; index: Index(canvas)]
|
||||
|
||||
function (CanvasItem) typeof [widget(canvas); "type"; tag: TagOrId]
|
||||
function (CanvasItem) typeof [canvas: widget(canvas); "type"; TagOrId]
|
||||
function (float,float) xview_get [widget(canvas); "xview"]
|
||||
function (float,float) yview_get [widget(canvas); "yview"]
|
||||
function () xview [widget(canvas); "xview"; scroll: ScrollValue]
|
||||
|
|
@ -466,17 +461,17 @@ widget canvas {
|
|||
function (TagOrId) create_text [widget(canvas); "create"; "text"; x: int; y: int; option(canvastext) list]
|
||||
function (TagOrId) create_window [widget(canvas); "create"; "window"; x: int; y: int; option(window) list]
|
||||
|
||||
function (string) itemconfigure_get [widget(canvas); "itemconfigure"; tag: TagOrId]
|
||||
function (string) itemconfigure_get [canvas: widget(canvas); "itemconfigure"; TagOrId]
|
||||
|
||||
function () configure_arc [widget(canvas); "itemconfigure"; tag: TagOrId; option(arc) list]
|
||||
function () configure_bitmap [widget(canvas); "itemconfigure"; tag: TagOrId; option(bitmap) list]
|
||||
function () configure_image [widget(canvas); "itemconfigure"; tag: TagOrId; option(image) list]
|
||||
function () configure_line [widget(canvas); "itemconfigure"; tag: TagOrId; option(line) list]
|
||||
function () configure_oval [widget(canvas); "itemconfigure"; tag: TagOrId; option(oval) list]
|
||||
function () configure_polygon [widget(canvas); "itemconfigure"; tag: TagOrId; option(polygon) list]
|
||||
function () configure_rectangle [widget(canvas); "itemconfigure"; tag: TagOrId; option(rectangle) list]
|
||||
function () configure_text [widget(canvas); "itemconfigure"; tag: TagOrId; option(canvastext) list]
|
||||
function () configure_window [widget(canvas); "itemconfigure"; tag: TagOrId; option(window) list]
|
||||
function () configure_arc [canvas: widget(canvas); "itemconfigure"; TagOrId; option(arc) list]
|
||||
function () configure_bitmap [canvas: widget(canvas); "itemconfigure"; TagOrId; option(bitmap) list]
|
||||
function () configure_image [canvas: widget(canvas); "itemconfigure"; TagOrId; option(image) list]
|
||||
function () configure_line [canvas: widget(canvas); "itemconfigure"; TagOrId; option(line) list]
|
||||
function () configure_oval [canvas: widget(canvas); "itemconfigure"; TagOrId; option(oval) list]
|
||||
function () configure_polygon [canvas: widget(canvas); "itemconfigure"; TagOrId; option(polygon) list]
|
||||
function () configure_rectangle [canvas: widget(canvas); "itemconfigure"; TagOrId; option(rectangle) list]
|
||||
function () configure_text [canvas: widget(canvas); "itemconfigure"; TagOrId; option(canvastext) list]
|
||||
function () configure_window [canvas: widget(canvas); "itemconfigure"; TagOrId; option(window) list]
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
let bind :tag :events ?(:extend = false) ?(:breakable = false) ?(:fields = [])
|
||||
?:action widget =
|
||||
let bind canvas:widget :events
|
||||
?(:extend = false) ?(:breakable = false) ?(:fields = [])
|
||||
?:action tag =
|
||||
tkCommand
|
||||
[| cCAMLtoTKwidget widget;
|
||||
TkToken "bind";
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
val bind :
|
||||
tag: tagOrId -> events: event list ->
|
||||
canvas: canvas widget -> events: event list ->
|
||||
?extend: bool -> ?breakable: bool -> ?fields: eventField list ->
|
||||
?action: (eventInfo -> unit) -> canvas widget -> unit
|
||||
?action: (eventInfo -> unit) -> tagOrId -> unit
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 *)
|
||||
|
|
|
|||
|
|
@ -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 () -> ()),
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue