New Upstream Release - labltk
Ready changes
Summary
Merged new upstream version: 8.06.13 (was: 8.06.11).
Resulting package
Built on 2022-12-18T07:25 (took 4m9s)
The resulting binary packages can be installed (if you have the apt repository enabled) by running one of:
apt install -t fresh-releases labltkapt install -t fresh-releases liblabltk-ocaml-dbgsymapt install -t fresh-releases liblabltk-ocaml-devapt install -t fresh-releases liblabltk-ocaml
Lintian Result
Diff
diff --git a/Changes b/Changes
index 45ba7c8..e2e1494 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,20 @@
+2022-11-01:
+-----------
+* Release labltk-8.06.13 for OCaml 5.0
+
+2022-10-13:
+-----------
+* Fix compatibility with OCaml 5.0
+
+2022-10-06:
+-----------
+* Update OCamlBrowser for OCaml 5.0
+
+2022-03-30:
+-----------
+* Release labltk-8.06.12 for OCaml 4.14
+* Update OCamlBrowser
+
2021-09-17:
-----------
* Release labltk-8.06.11 for ocaml 4.13
diff --git a/INSTALL b/INSTALL
index 6f68868..47e383c 100644
--- a/INSTALL
+++ b/INSTALL
@@ -3,7 +3,7 @@
PREREQUISITES
-* OCaml (>= 4.08) should be installed (4.13 for ocamlbrowser)
+* OCaml (>= 4.08) should be installed (5.0 for ocamlbrowser)
* Tcl/Tk (>= 8.03) should be installed
diff --git a/browser/Makefile.shared b/browser/Makefile.shared
index 2cea45f..004b256 100644
--- a/browser/Makefile.shared
+++ b/browser/Makefile.shared
@@ -14,8 +14,8 @@ include ../support/Makefile.common
# #
#########################################################################
-LABLTKLIB=-I ../labltk -I ../lib -I ../support -I +compiler-libs
-INCLUDES=$(LABLTKLIB)
+LABLTKLIB=-I ../labltk -I ../lib -I ../support -I +compiler-libs -I +str -I +unix
+INCLUDES=$(LABLTKLIB) -I +unix -I +str
OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \
fileselect.cmo searchid.cmo searchpos.cmo \
diff --git a/browser/main.ml b/browser/main.ml
index aca631c..e8e830a 100644
--- a/browser/main.ml
+++ b/browser/main.ml
@@ -83,8 +83,6 @@ let _ =
"<command> Pipe sources through preprocessor <command>";
"-rectypes", Arg.Set Clflags.recursive_types,
" Allow arbitrary recursive types";
- "-safe-string", Arg.Clear Clflags.unsafe_string,
- " Make strings immutable";
"-short-paths", Arg.Clear Clflags.real_paths, " Shorten paths in types";
"-version", Arg.Unit print_version,
" Print version and exit";
@@ -96,7 +94,7 @@ let _ =
Arg.parse spec
(fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
errmsg;
- Load_path.init
+ Load_path.init ~auto_include:Load_path.no_auto_include
(Sys.getcwd ()
:: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
@ [Config.standard_library]);
diff --git a/browser/searchid.ml b/browser/searchid.ml
index e87852b..ebbf363 100644
--- a/browser/searchid.ml
+++ b/browser/searchid.ml
@@ -95,27 +95,25 @@ let rec arr p ~card:n =
if p = 0 then 1 else n * arr (p-1) ~card:(n-1)
let rec all_args ty =
- let ty = repr ty in
- match ty.desc with
+ match get_desc ty with
Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty)
| _ -> ([], ty)
let rec equal ~prefix t1 t2 =
- match (repr t1).desc, (repr t2).desc with
+ match get_desc t1, get_desc t2 with
Tvar _, Tvar _ -> true
| Tvariant row1, Tvariant row2 ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let fields1 = filter_row_fields false row1.row_fields
- and fields2 = filter_row_fields false row1.row_fields
+ let fields1 = filter_row_fields false (row_fields row1)
+ and fields2 = filter_row_fields false (row_fields row1)
in
let r1, r2, pairs = merge_row_fields fields1 fields2 in
- row1.row_closed = row2.row_closed && r1 = [] && r2 = [] &&
+ row_closed row1 = row_closed row2 && r1 = [] && r2 = [] &&
List.for_all pairs ~f:
begin fun (_,f1,f2) ->
match row_field_repr f1, row_field_repr f2 with
Rpresent None, Rpresent None -> true
| Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix
- | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
+ | Reither(c1, tl1, _), Reither(c2, tl2, _) ->
c1 = c2 && List.length tl1 = List.length tl2 &&
List.for_all2 tl1 tl2 ~f:(equal ~prefix)
| _ -> false
@@ -143,12 +141,11 @@ let rec equal ~prefix t1 t2 =
let get_options = List.filter ~f:Btype.is_optional
let rec included ~prefix t1 t2 =
- match (repr t1).desc, (repr t2).desc with
+ match get_desc t1, get_desc t2 with
Tvar _, _ -> true
| Tvariant row1, Tvariant row2 ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let fields1 = filter_row_fields false row1.row_fields
- and fields2 = filter_row_fields false row2.row_fields
+ let fields1 = filter_row_fields false (row_fields row1)
+ and fields2 = filter_row_fields false (row_fields row2)
in
let r1, r2, pairs = merge_row_fields fields1 fields2 in
r1 = [] &&
@@ -157,7 +154,7 @@ let rec included ~prefix t1 t2 =
match row_field_repr f1, row_field_repr f2 with
Rpresent None, Rpresent None -> true
| Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix
- | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
+ | Reither(c1, tl1, _), Reither(c2, tl2, _) ->
c1 = c2 && List.length tl1 = List.length tl2 &&
List.for_all2 tl1 tl2 ~f:(included ~prefix)
| _ -> false
@@ -207,7 +204,7 @@ let mkpath = function
let get_fields ~prefix ~sign self =
(*let env = open_signature Fresh (mkpath prefix) sign !start_env in*)
let env = add_signature sign !start_env in
- match (expand_head env self).desc with
+ match get_desc (expand_head env self) with
Tobject (ty_obj, _) ->
let l,_ = flatten_fields ty_obj in l
| _ -> []
@@ -270,12 +267,12 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
end
let search_all_types t ~mode =
- let tl = match mode, t.desc with
+ let tl = match mode, get_desc t with
`Exact, _ -> [t]
| `Included, Tarrow _ -> [t]
| `Included, _ ->
- [t; newty(Tarrow(Nolabel,t,newvar(),Cok));
- newty(Tarrow(Nolabel,newvar(),t,Cok))]
+ [t; newty(Tarrow(Nolabel,t,newvar(),commu_ok));
+ newty(Tarrow(Nolabel,newvar(),t,commu_ok))]
in List2.flat_map !module_list ~f:
begin fun modname ->
let mlid = Lident modname in
diff --git a/browser/searchpos.ml b/browser/searchpos.ml
index 564e164..2755cdc 100644
--- a/browser/searchpos.ml
+++ b/browser/searchpos.ml
@@ -195,7 +195,7 @@ let search_pos_type_decl td ~pos ~env =
let search_pos_extension ext ~pos ~env =
begin match ext.pext_kind with
- Pext_decl (l, _) -> search_pos_arguments l ~pos ~env
+ Pext_decl (_, l, _) -> search_pos_arguments l ~pos ~env
| Pext_rebind _ -> ()
end
@@ -502,16 +502,18 @@ and view_module_id id ~env =
and view_type_decl path ~env =
let td = find_type path env in
try match td.type_manifest with None -> raise Not_found
- | Some ty -> match (Ctype.repr ty).desc with
+ | Some ty -> match get_desc ty with
Tobject _ ->
let clt = find_cltype path env in
view_signature_item ~path ~env
[Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first,
Exported);
dummy_item; dummy_item]
- | Tvariant ({row_name = Some _} as row) ->
- let td = {td with type_manifest = Some(
- Btype.newgenty (Tvariant {row with row_name = None}))} in
+ | Tvariant row when row_name row <> None ->
+ let Row {fields; more; closed; fixed} = row_repr row in
+ let row = create_row ~fields ~more ~closed ~fixed ~name:None in
+ let td =
+ {td with type_manifest = Some(Btype.newgenty (Tvariant row))} in
view_signature_item ~path ~env
[Sig_type(ident_of_path path ~default:"t", td, Trec_first,
Exported)]
@@ -697,8 +699,7 @@ let view_type_menu kind ~env ~parent =
Format.set_formatter_output_functions buf#out ignore;
Format.set_margin 60;
Format.open_hbox ();
- Printtyp.reset ();
- Printtyp.mark_loops ty;
+ Printtyp.prepare_for_printing [ty];
Printtyp.wrap_printing_env ~error:false env
(fun () -> Printtyp.type_expr Format.std_formatter ty);
Format.close_box (); Format.print_flush ();
@@ -712,11 +713,12 @@ let view_type_menu kind ~env ~parent =
in
(* Menu.add_separator menu; *)
List.iter l ~f:
- begin fun label -> match (Ctype.repr ty).desc with
+ begin fun label -> match get_desc ty with
Tconstr (path,_,_) ->
Menu.add_command menu ~label ~font
~command:(fun () -> view_type_decl path ~env)
- | Tvariant {row_name = Some (path, _)} ->
+ | Tvariant row when row_name row <> None ->
+ let path, _ = Stdlib.Option.get (row_name row) in
Menu.add_command menu ~label ~font
~command:(fun () -> view_type_decl path ~env)
| _ ->
@@ -864,7 +866,7 @@ and search_pos_expr ~pos exp =
search_pos_expr a ~pos; search_pos_expr b ~pos
| Texp_for (_, _, a, b, _, c) ->
List.iter [a;b;c] ~f:(search_pos_expr ~pos)
- | Texp_send (exp, _, _) -> search_pos_expr exp ~pos
+ | Texp_send (exp, _) -> search_pos_expr exp ~pos
| Texp_new (path, _, _) ->
add_found_str (`Exp(`New path, exp.exp_type))
~env:exp.exp_env ~loc:exp.exp_loc
diff --git a/browser/setpath.ml b/browser/setpath.ml
index fad9eea..3278b16 100644
--- a/browser/setpath.ml
+++ b/browser/setpath.ml
@@ -31,7 +31,7 @@ let exec_update_hooks () =
end
let set_load_path l =
- Load_path.init l;
+ Load_path.init l ~auto_include:Load_path.no_auto_include;
exec_update_hooks ();
Env.reset_cache ()
diff --git a/browser/shell.ml b/browser/shell.ml
index c5672a0..c87e651 100644
--- a/browser/shell.ml
+++ b/browser/shell.ml
@@ -45,7 +45,7 @@ let dump_handle (h : Unix.file_descr) =
let obj = Obj.repr h in
if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then
invalid_arg "Shell.dump_handle";
- Nativeint.format "%x" (Obj.obj obj)
+ Printf.sprintf "%nx" (Obj.obj obj)
(* The shell class. Now encapsulated *)
diff --git a/browser/typecheck.ml b/browser/typecheck.ml
index 99ef48a..e6c4261 100644
--- a/browser/typecheck.ml
+++ b/browser/typecheck.ml
@@ -116,7 +116,7 @@ let f txt =
List.iter psl ~f:
begin function
Ptop_def pstr ->
- let str, sign, _names, env' = Typemod.type_structure !env pstr in
+ let str, sign, _names, _, env' = Typemod.type_structure !env pstr in
txt.structure <- txt.structure @ str.str_items;
txt.signature <- txt.signature @ sign;
env := env'
diff --git a/browser/viewer.ml b/browser/viewer.ml
index 590da6f..7c96707 100644
--- a/browser/viewer.ml
+++ b/browser/viewer.ml
@@ -65,13 +65,13 @@ let view_symbol ~kind ~env ?path id =
[Sig_value (Ident.create_local name, vd, Exported)]
| Ptype -> view_type_id id ~env
| Plabel -> let ld = find_label_by_name id env in
- begin match ld.lbl_res.desc with
+ begin match get_desc ld.lbl_res with
Tconstr (path, _, _) -> view_type_decl path ~env
| _ -> ()
end
| Pconstructor ->
let cd = find_constructor_by_name id env in
- begin match cd.cstr_tag, cd.cstr_res.desc with
+ begin match cd.cstr_tag, get_desc cd.cstr_res with
Cstr_extension _, Tconstr (cpath, args, _) ->
view_signature ~title:(string_of_longident id) ~env ?path
[Sig_typext (Ident.create_local name,
diff --git a/camltk/Makefile b/camltk/Makefile
index ed4b3a0..29e3a81 100644
--- a/camltk/Makefile
+++ b/camltk/Makefile
@@ -16,7 +16,7 @@
include ../support/Makefile.common
-COMPFLAGS= -I ../support -no-alias-deps
+COMPFLAGS= -I ../support -no-alias-deps -I +unix
all: camltkobjs
diff --git a/debian/changelog b/debian/changelog
index 1f40ede..b913c22 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+labltk (8.06.13-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- Debian Janitor <janitor@jelmer.uk> Sun, 18 Dec 2022 07:22:12 -0000
+
labltk (8.06.11-2) unstable; urgency=medium
* Fix paths in labltk script (Closes: #1023867)
diff --git a/examples_camltk/Makefile b/examples_camltk/Makefile
index e9c4c6a..3eeee08 100644
--- a/examples_camltk/Makefile
+++ b/examples_camltk/Makefile
@@ -17,8 +17,9 @@
include ../support/Makefile.common
# We are using the non-installed library !
-BYT_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -dllpath ../support
-BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s
+BYT_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -dllpath ../support \
+ -I +unix
+BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -I +unix
WITH_BYT_CAMLTK=labltk.cma camltk.cmo
WITH_BIN_CAMLTK=labltk.cmxa camltk.cmx
diff --git a/examples_camltk/taquin.ml b/examples_camltk/taquin.ml
new file mode 100644
index 0000000..70ac934
--- /dev/null
+++ b/examples_camltk/taquin.ml
@@ -0,0 +1,146 @@
+(***********************************************************************)
+(* *)
+(* Caml examples *)
+(* *)
+(* Pierre Weis *)
+(* *)
+(* INRIA Rocquencourt *)
+(* *)
+(* Copyright (c) 1994-2011, INRIA *)
+(* All rights reserved. *)
+(* *)
+(* Distributed under the BSD license. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: taquin.ml,v 1.4 2011-08-08 19:31:17 weis Exp $ *)
+
+open Camltk;;
+
+let d�coupe_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 pi�ces = ref [] in
+ for x = 0 to nx - 1 do
+ for y = 0 to ny - 1 do
+ let pi�ce =
+ Imagephoto.create [Width (Pixels tx); Height (Pixels ty)] in
+ Imagephoto.copy pi�ce img
+ [ImgFrom(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty)];
+ pi�ces := pi�ce :: !pi�ces
+ done
+ done;
+ (tx, ty, List.tl !pi�ces)
+;;
+
+let remplir_taquin c nx ny tx ty pi�ces =
+ let trou_x = ref (nx - 1)
+ and trou_y = ref (ny - 1) in
+ let trou =
+ Canvas.create_rectangle c
+ (Pixels (!trou_x * tx)) (Pixels (!trou_y * ty))
+ (Pixels tx) (Pixels ty) [] in
+ let taquin = Array.make_matrix nx ny trou in
+ let p = ref pi�ces in
+ for x = 0 to nx - 1 do
+ for y = 0 to ny - 1 do
+ match !p with
+ | [] -> ()
+ | pi�ce :: reste ->
+ taquin.(x).(y) <-
+ Canvas.create_image c
+ (Pixels (x * tx)) (Pixels (y * ty))
+ [ImagePhoto pi�ce; Anchor NW; Tags [Tag "pi�ce"]];
+ p := reste
+ done
+ done;
+ let d�placer x y =
+ let pi�ce = taquin.(x).(y) in
+ Canvas.coords_set c pi�ce
+ [Pixels (!trou_x * tx); Pixels(!trou_y * ty)];
+ Canvas.coords_set c trou
+ [Pixels (x * tx); Pixels(y * ty); Pixels tx; Pixels ty];
+ taquin.(!trou_x).(!trou_y) <- pi�ce;
+ 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 d�placer x y in
+ Canvas.bind c (Tag "pi�ce") [[], ButtonPress]
+ (BindSet ([Ev_MouseX; Ev_MouseY], jouer));;
+
+let rec permutation = function
+ | [] -> []
+ | l -> let n = Random.int (List.length l) in
+ let (�l�ment, reste) = partage l n in
+ �l�ment :: permutation reste
+
+and partage l n =
+ match l with
+ | [] -> failwith "partage"
+ | t�te :: reste ->
+ if n = 0 then (t�te, reste) else
+ let (�l�ment, reste') = partage reste (n - 1) in
+ (�l�ment, t�te :: 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 parent [TextWidth lwidth; TextHeight lnum] in
+ List.iter
+ (fun line ->
+ Text.insert txtw (TextIndex (End, [])) line [];
+ Text.insert txtw (TextIndex (End, [])) "\n" [])
+ 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 help_frame [Text "Ok"; Command quit_help] in
+
+ pack [help_txtw; ok_button ] [Side Side_Bottom];
+ 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 fp
+ [Width(Pixels(Imagephoto.width img));
+ Height(Pixels(Imagephoto.height img))] in
+ let (tx, ty, pi�ces) = d�coupe_image img nx ny in
+ remplir_taquin c nx ny tx ty (permutation pi�ces);
+ pack [c] [];
+
+ let quit = Button.create fp [Text "Quit"; Command closeTk] in
+ let help_lines =
+ ["Pour jouer, cliquer sur une des pi�ces";
+ "entourant le trou";
+ "";
+ "To play, click on a part around the hole"] in
+ let help =
+ Button.create fp [Text "Help"; Command (give_help fp help_lines)] in
+ pack [quit; help] [Side Side_Left; Fill Fill_X];
+ mainLoop ()
+;;
+
+if !Sys.interactive then () else begin taquin "joconde.gif" 3 5; exit 0 end;;
diff --git a/examples_camltk/tetris.ml b/examples_camltk/tetris.ml
new file mode 100644
index 0000000..a46de60
--- /dev/null
+++ b/examples_camltk/tetris.ml
@@ -0,0 +1,542 @@
+(***********************************************************************)
+(* *)
+(* Caml examples *)
+(* *)
+(* Pierre Weis *)
+(* *)
+(* INRIA Rocquencourt *)
+(* *)
+(* Copyright (c) 1994-2011, INRIA *)
+(* All rights reserved. *)
+(* *)
+(* Distributed under the BSD license. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: tetris.ml,v 1.6 2011-08-08 19:31:17 weis Exp $ *)
+
+(* A Tetris game for CamlTk.
+ Written by Jun P. Furuse.
+ Adapted to the oc examples repository by P. Weis *)
+
+open Camltk;;
+
+(* The directory where images will be found. *)
+let baseurl = "images/";;
+
+exception Done;;
+
+type cell = {
+ mutable color : int;
+ tag : tagOrId * tagOrId * tagOrId;
+}
+;;
+
+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 colors = [|
+ NamedColor "red"; NamedColor "yellow"; NamedColor "blue";
+ NamedColor "orange"; NamedColor "magenta"; NamedColor "green";
+ NamedColor "cyan";
+|]
+;;
+
+let backgrounds =
+ List.map (fun s -> baseurl ^ s)
+ [ "dojoji.back.gif"; "Lambda2.back.gif"; "CamlBook.gif"; ];;
+
+(* blocks *)
+let block_size = 16
+and 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"
+and line_full = int_of_string "0b1111111111111111"
+;;
+
+let decode_block dvec =
+ let btoi d = int_of_string ("0b" ^ d) in
+ Array.map btoi dvec
+;;
+
+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 (Pixels 2)] in
+ let c =
+ Canvas.create f
+ [Width (Pixels (block_size * 10));
+ Height (Pixels (block_size * 20));
+ BorderWidth (Pixels 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 (Pixels (block_size * 4));
+ Height (Pixels (block_size * 4));
+ BorderWidth (Pixels 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
+ let exitg = Button.create r [Text "Quit"; Font "variable"] in
+
+ pack [f] [];
+ pack [c; r; r'] [Side Side_Left; Fill Fill_Y];
+ pack [nl; nc] [Side Side_Top];
+ pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top];
+
+ let cells_src = Array.make_matrix 20 10 () in
+ let cells = Array.map (Array.map (fun () ->
+ {tag =
+ (let t1, t2, t3 =
+ Canvas.create_rectangle c
+ (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+ (Pixels (-9)) (Pixels (-9)) [],
+ Canvas.create_rectangle c
+ (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+ (Pixels (-11)) (Pixels (-11)) [],
+ Canvas.create_rectangle c
+ (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+ (Pixels (-13)) (Pixels (-13)) [] in
+ Canvas.raise_top c t1;
+ Canvas.raise_top c t2;
+ Canvas.lower_bot c t3;
+ t1, t2, t3);
+ color = 0})) cells_src in
+ let nexts_src = Array.make_matrix 4 4 () in
+ let nexts =
+ Array.map (Array.map (fun () ->
+ {tag =
+ (let t1, t2, t3 =
+ Canvas.create_rectangle nc
+ (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+ (Pixels (-9)) (Pixels (-9)) [],
+ Canvas.create_rectangle nc
+ (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+ (Pixels (-11)) (Pixels (-11)) [],
+ Canvas.create_rectangle nc
+ (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+ (Pixels (-13)) (Pixels (-13)) [] in
+ Canvas.raise_top nc t1;
+ Canvas.raise_top nc t2;
+ Canvas.lower_bot nc t3;
+ t1, t2, t3);
+ color = 0})) nexts_src in
+ let game_over () = ()
+ in
+ [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
+ (c, cells), (nc, nexts), scorev, linev, levv, game_over
+;;
+
+let cell_get (c, cf) x y = cf.(y).(x).color;;
+
+let cell_set (c, cf) x y col =
+ let cur = cf.(y).(x) in
+ let t1, t2, t3 = cur.tag in
+ if cur.color = col then () else
+ if cur.color <> 0 && col = 0 then begin
+ Canvas.move c t1
+ (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+ (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+ Canvas.move c t2
+ (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+ (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+ Canvas.move c t3
+ (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+ (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
+
+ end else begin
+ Canvas.configure_rectangle c t2
+ [FillColor (Array.get colors (col - 1));
+ Outline (Array.get colors (col - 1))];
+ Canvas.configure_rectangle c t1
+ [FillColor Black;
+ Outline Black];
+ Canvas.configure_rectangle c t3
+ [FillColor (NamedColor "light gray");
+ Outline (NamedColor "light gray")];
+ if cur.color = 0 && col <> 0 then begin
+ Canvas.move c t1
+ (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+ (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
+ Canvas.move c t2
+ (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+ (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
+ Canvas.move c t3
+ (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+ (Pixels (block_size * (y + 1) + 10 + cell_border * 2))
+ end
+ end;
+ cur.color <- col
+;;
+
+let draw_block field col d x y =
+ for iy = 0 to 3 do
+ let base = ref 1 in
+ let xd = Array.get d iy in
+ for ix = 0 to 3 do
+ if xd land !base <> 0 then begin
+ try cell_set field (ix + x) (iy + y) col with _ -> ()
+ end;
+ base := !base lsl 1
+ done
+ done
+;;
+
+let timer_ref = (ref None : Timer.t option ref);;
+
+let remove_timer () =
+ match !timer_ref with
+ | None -> ()
+ | Some t -> Timer.remove t
+;;
+
+let do_after milli f = timer_ref := Some (Timer.add milli f);;
+
+let copy_block c =
+ { pattern = !c.pattern;
+ bcolor = !c.bcolor;
+ x = !c.x;
+ y = !c.y;
+ d = !c.d;
+ alive = !c.alive }
+;;
+
+let start_game () =
+ let top = openTk () in
+ Wm.title_set top "";
+ let lb = Label.create top []
+ and fw = Frame.create top [] in
+ let set_message s = Label.configure lb [Text s] in
+ pack [lb; fw] [Side 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 (List.map decode_block) blocks in
+ let field = Array.make 26 0 in
+ let widgets, newg, exitg, 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 j i 0
+ done
+ done;
+ for i = 0 to 3 do
+ for j = 0 to 3 do
+ cell_set next_field j i 0
+ done
+ done in
+
+ let draw_falling_block fb =
+ draw_block cell_field fb.bcolor
+ (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
+ and erase_falling_block fb =
+ draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (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 &&
+ 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 j (i + fb.y - 3) 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 j (!cur-3) (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 j (i - 3) 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 (!next + 1) (List.hd (List.nth blocks !next)) 0 0
+
+ and erase_next () =
+ draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 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 () else begin
+ m.x <- m.x + 1;
+ if sub m then () else begin
+ m.x <- m.x - 2;
+ ignore (sub m)
+ end
+ end
+ else () in
+
+ let image_load =
+ let i =
+ Canvas.create_image canvas
+ (Pixels (block_size * 5 + block_size / 2))
+ (Pixels (block_size * 10 + block_size / 2))
+ [Anchor Center] in
+ Canvas.lower_bot canvas i;
+ let img = Imagephoto.create [] in
+ fun file ->
+ try
+ Imagephoto.configure img [File file];
+ Canvas.configure_image canvas i [ImagePhoto img]
+ with _ -> Printf.eprintf "%s : No such image...\n" file; flush stderr 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;
+ (* Future work: We should gain level after an image is put... *)
+ 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 stop_a_bit 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 stop_a_bit (fun () ->
+ let l = clear !current in
+ if l > 0 then
+ do_after stop_a_bit (fun () ->
+ fall_lines ();
+ add_score l;
+ do_after stop_a_bit newblock)
+ else newblock ())
+ end else begin
+ erase_falling_block !current;
+ draw_falling_block m;
+ current := m;
+ do_after !time loop
+ end in
+
+ let bind_game w =
+ bind w [([], KeyPress)] (BindSet ([Ev_KeySymString],
+ fun e ->
+ match e.ev_KeySymString with
+ | "h" ->
+ let m = copy_block current in
+ m.x <- m.x - 1;
+ 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;
+ 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;
+ try_to_move m
+ | "l" ->
+ let m = copy_block current in
+ m.x <- m.x + 1;
+ 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
+ | _ -> ()
+ )) 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 !time loop in
+
+ bind_game top;
+ Button.configure newg [Command game_init];
+ Button.configure exitg [Command (fun () -> exit 0)];
+ game_init ()
+;;
+
+let tetris () =
+ start_game ();
+ Printexc.print mainLoop ()
+;;
+
+if !Sys.interactive then () else begin tetris (); exit 0 end;;
diff --git a/examples_labltk/Makefile b/examples_labltk/Makefile
index 798d363..b363c4a 100644
--- a/examples_labltk/Makefile
+++ b/examples_labltk/Makefile
@@ -35,11 +35,12 @@ calc: calc.cmo
$(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo
clock: clock.cmo
- $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo
+ $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma \
+ -I +unix unix.cma clock.cmo
clock.opt: clock.cmx
$(CAMLOPT) $(COMPFLAGS) -o clock.opt \
- $(LIBNAME).cmxa unix.cmxa clock.cmx
+ $(LIBNAME).cmxa -I +unix unix.cmxa clock.cmx
tetris: tetris.cmo
$(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo
diff --git a/jpf/Makefile b/jpf/Makefile
index 4ba354d..dccf9db 100644
--- a/jpf/Makefile
+++ b/jpf/Makefile
@@ -16,7 +16,7 @@
include ../support/Makefile.common
-COMPFLAGS=-I ../labltk -I ../support
+COMPFLAGS=-I ../labltk -I ../support -I +str -I +unix
OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo
diff --git a/labltk/Makefile b/labltk/Makefile
index 8fb58db..1d22c0a 100644
--- a/labltk/Makefile
+++ b/labltk/Makefile
@@ -16,7 +16,7 @@
include ../support/Makefile.common
-COMPFLAGS= -I ../support -no-alias-deps
+COMPFLAGS= -I ../support -no-alias-deps -I +unix
all: labltkobjs
diff --git a/lib/Makefile b/lib/Makefile
index db46b7f..d4a1f65 100644
--- a/lib/Makefile
+++ b/lib/Makefile
@@ -67,9 +67,8 @@ $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src
$(LIBNAME)top$(EXE) : $(LIBNAME).cma ../support/lib$(LIBNAME).$(A)
$(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \
$(TOPLEVELLIBS) \
- -I +compiler-libs unix.cma \
+ -I +compiler-libs -I +unix -I +str unix.cma str.cma \
-I ../labltk -I ../camltk $(LIBNAME).cma \
- str.cma \
$(TOPLEVELSTART)
$(LIBNAME): Makefile
@@ -114,4 +113,4 @@ installopt:
cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A)
chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa
chmod 644 $(INSTALLDIR)/$(LIBNAME).$(A)
-endif
\ No newline at end of file
+endif
diff --git a/support/Makefile b/support/Makefile
index 75ccdc1..5915418 100644
--- a/support/Makefile
+++ b/support/Makefile
@@ -30,7 +30,7 @@ COBJS=cltkCaml.$(O) cltkUtf.$(O) cltkEval.$(O) cltkEvent.$(O) \
CCFLAGS=-I$(LIBDIR)/caml $(TK_DEFS) $(SHAREDCCCOMPOPTS)
-COMPFLAGS=
+COMPFLAGS=-I +unix
THFLAGS=-I +threads -I vmthreads
TKLDOPTS=$(TK_LINK:%=-ldopt "%")
diff --git a/support/Makefile.common b/support/Makefile.common
index 7aac0a2..f3b818d 100644
--- a/support/Makefile.common
+++ b/support/Makefile.common
@@ -35,3 +35,6 @@ LINKFLAGS=
CAMLOPTLIBR=$(CAMLOPT) -a
MKLIB=$(BINDIR)/ocamlmklib
CAMLRUNGEN=$(BINDIR)/ocamlrun
+ifeq (x$(RANLIB),x)
+RANLIB=":"
+endif