[Toss-devel-svn] SF.net SVN: toss:[1657] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
[Toss-devel-svn] SF.net SVN: toss:[1657] trunk/Toss
|
From: <luk...@us...> - 2012-02-01 10:17:29
|
Revision: 1657
http://toss.svn.sourceforge.net/toss/?rev=1657&view=rev
Author: lukstafi
Date: 2012-02-01 10:17:21 +0000 (Wed, 01 Feb 2012)
Log Message:
-----------
Standalone variant of JavaScript interface.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Play/Play.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
trunk/Toss/Solver/RealQuantElim/Poly.ml
trunk/Toss/Solver/RealQuantElim/SignTable.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Play.js
trunk/Toss/WebClient/State.js
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/Server/GameSelection.ml
trunk/Toss/Server/JsHandler.ml
trunk/Toss/Solver/RealQuantElim/N.ml
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/Local.js
trunk/Toss/WebClient/local.html
trunk/Toss/www/reference/TossComponents.dot
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/Aux.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -2,10 +2,12 @@
structures and standard library-like definitions. *)
let gettimeofday () =
- IFDEF NOUNIX
- THEN 1.
- ELSE Unix.gettimeofday ()
- ENDIF
+ IFDEF JAVASCRIPT THEN (
+ let t = Js.to_float ((jsnew Js.date_now ())##getTime()) in
+ t /. 1000. (* t is in milliseconds *)
+ ) ELSE (
+ Unix.gettimeofday ()
+ ) ENDIF
exception Timeout of string
@@ -739,3 +741,34 @@
Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
}
+
+(* Replacements for basic Str functions. *)
+
+(* [split_regexp ~regexp:r s] splits [s] into substrings, taking as
+ delimiters the substrings that match [r], and returns the list of
+ substrings. For instance, [split ~regexp:"[ \t]+" s] splits [s]
+ into blank-separated words. An occurrence of the delimiter at the
+ beginning and at the end of the string is ignored. *)
+let split_regexp ~regexp s =
+ IFDEF JAVASCRIPT THEN (
+ let js_s = Js.string s in
+ let js_regex = jsnew Js.regExp (Js.string regexp) in
+ let res = js_s##split_regExp (js_regex) in
+ let res = Js.to_array (Js.str_array res) in
+ Array.to_list (Array.map Js.to_string res)
+ ) ELSE (
+ Str.split (Str.regexp regexp) s
+ ) ENDIF
+
+(* [replace_regexp ~regexp ~templ s] returns a string identical to
+ [s], except that all substrings of [s] that match [regexp] have
+ been replaced by [templ]. *)
+let replace_regexp ~regexp ~templ s =
+ IFDEF JAVASCRIPT THEN (
+ let js_s = Js.string s in
+ let js_regex = jsnew Js.regExp (Js.string regexp) in
+ let res = js_s##replace (js_regex, Js.string templ) in
+ Js.to_string res
+ ) ELSE (
+ Str.global_replace (Str.regexp regexp) templ s
+ ) ENDIF
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/Aux.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -355,3 +355,17 @@
(** Set more agressive Gc values optimized for heavier computations. *)
val set_optimized_gc : unit -> unit
+
+(** Replacements for basic Str functions. *)
+
+(** [split_regexp ~regexp:r s] splits [s] into substrings, taking as
+ delimiters the substrings that match [r], and returns the list of
+ substrings. For instance, [split ~regexp:"[ \t]+" s] splits [s]
+ into blank-separated words. An occurrence of the delimiter at the
+ beginning and at the end of the string is ignored. *)
+val split_regexp : regexp:string -> string -> string list
+
+(** [replace_regexp ~regexp ~templ s] returns a string identical to [s],
+ except that all substrings of [s] that match [regexp] have been
+ replaced by [templ]. *)
+val replace_regexp : regexp:string -> templ:string -> string -> string
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -14,12 +14,15 @@
if test_fname then f ()
let run_test_if_target target_name tests =
- let f () = ignore (OUnit.run_test_tt ~verbose:true tests) in
- (* So that the tests are not run twice while building TossTest. *)
- run_if_target target_name f
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript unit testing not implemented yet"
+ ) ELSE (
+ let f () = ignore (OUnit.run_test_tt ~verbose:true tests) in
+ (* So that the tests are not run twice while building TossTest. *)
+ run_if_target target_name f
+ ) ENDIF
-
let rec input_file file =
let buf = Buffer.create 256 in
(try
@@ -33,9 +36,14 @@
close_in f; res
let list_dir dirname =
- let files, dir_handle = (ref [], Unix.opendir dirname) in
- let rec add () = files := (Unix.readdir dir_handle) :: !files; add () in
- try add () with End_of_file -> Unix.closedir dir_handle; !files
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript file manipulation not implemented yet"
+ ) ELSE (
+ let files, dir_handle = (ref [], Unix.opendir dirname) in
+ let rec add () =
+ files := (Unix.readdir dir_handle) :: !files; add () in
+ try add () with End_of_file -> Unix.closedir dir_handle; !files
+ ) ENDIF
let rec input_http_message file =
let buf = Buffer.create 256 in
@@ -76,29 +84,38 @@
exception Host_not_found
let get_inet_addr addr_s =
- try
- Unix.inet_addr_of_string addr_s
- with Failure _ ->
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript TCP/IP manipulation not implemented yet"
+ ) ELSE (
try
- let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
- if Array.length addr_arr < 1 then raise Host_not_found else
- addr_arr.(0)
- with Not_found -> raise Host_not_found
+ Unix.inet_addr_of_string addr_s
+ with Failure _ ->
+ try
+ let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
+ if Array.length addr_arr < 1 then raise Host_not_found else
+ addr_arr.(0)
+ with Not_found -> raise Host_not_found
+ ) ENDIF
let toss_call (client_port, client_addr_s) f_in x =
- try
- let client_addr = get_inet_addr client_addr_s in
- let client_sock = Unix.ADDR_INET (client_addr, client_port) in
- let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
- output_string cl_out_ch "COMP\n";
- flush cl_out_ch;
- let f a = try `Res (f_in a) with exn -> `Exn exn in
- Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
- flush cl_out_ch;
- (fun () ->
- let res = Marshal.from_channel cl_in_ch in
- Unix.shutdown_connection cl_in_ch;
- match res with `Res r -> r | `Exn e -> raise e)
- with Unix.Unix_error (e, f, s) ->
- Printf.printf "Toss call failed: %s; %s %s\n%!" (Unix.error_message e) f s;
- (fun () -> f_in x)
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript TCP/IP manipulation not implemented yet"
+ ) ELSE (
+ try
+ let client_addr = get_inet_addr client_addr_s in
+ let client_sock = Unix.ADDR_INET (client_addr, client_port) in
+ let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
+ output_string cl_out_ch "COMP\n";
+ flush cl_out_ch;
+ let f a = try `Res (f_in a) with exn -> `Exn exn in
+ Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
+ flush cl_out_ch;
+ (fun () ->
+ let res = Marshal.from_channel cl_in_ch in
+ Unix.shutdown_connection cl_in_ch;
+ match res with `Res r -> r | `Exn e -> raise e)
+ with Unix.Unix_error (e, f, s) ->
+ Printf.printf "Toss call failed: %s; %s %s\n%!"
+ (Unix.error_message e) f s;
+ (fun () -> f_in x)
+ ) ENDIF
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -945,7 +945,7 @@
!clause in
let list_int line =
- let split = Str.split (Str.regexp "[ \t]+") line in
+ let split = Aux.split_regexp ~regexp:"[ \t]+" line in
List.rev (List.tl (List.rev_map
(fun s -> int_of_string s) (List.tl split))) in
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -84,7 +84,8 @@
let get_strucs s =
let split_list ?(bound=None) pat s =
let r = Str.regexp_string pat in
- match bound with None-> Str.split r s | Some b-> Str.bounded_split r s b in
+ match bound with None-> Str.split r s
+ | Some b-> Str.bounded_split r s b in
let cl = String.index s '\n' in
let pref, st_s = String.sub s 0 cl, String.sub s cl ((String.length s)-cl) in
let strucstr s = pref ^ " \n\"" ^ s ^ "\n\"" in
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Makefile 2012-02-01 10:17:21 UTC (rev 1657)
@@ -3,9 +3,13 @@
TossServer: Server/Server.native
cp _build/Server/Server.native TossServer
-js_of_ocaml_test.js: js_of_ocaml_test.byte
- js_of_ocaml js_of_ocaml_test.byte
+WebClient/JsHandler.js: Server/JsHandler.byte
+ js_of_ocaml _build/$<
+ cp _build/Server/JsHandler.js WebClient/JsHandler.js
+%.js: %.byte
+ js_of_ocaml _build/$<
+
RELEASE=0.6
Release: TossServer doc
rm -f *~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
@@ -41,7 +45,7 @@
OCB_LIB=-libs str,nums,unix,oUnit,sqlite3
OCB_LIBJS=-libs str,js_of_ocaml
OCB_PP=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 ../caml_extensions/pa_let_try.cmo pa_macro.cmo js_of_ocaml/pa_js.cmo"
-OCB_PPJS=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 ../caml_extensions/pa_let_try.cmo pa_macro.cmo -DNOREALQE -DNOUNIX js_of_ocaml/pa_js.cmo"
+OCB_PPJS=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 ../caml_extensions/pa_let_try.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo"
OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
OCAMLBUILDJS=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PPJS) \
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/GameTree.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -39,7 +39,7 @@
player state.Arena.cur_loc state.Arena.time in
let res = "\n" ^ msg ^ head_s ^ struc_s ^ "\n" ^ info_s in
let prefix = if depth=0 then "" else (String.make depth '|') ^ " " in
- Str.global_replace (Str.regexp "\n") ("\n" ^ prefix) res in
+ Aux.replace_regexp ~regexp:"\n" ~templ:("\n" ^ prefix) res in
if upto < 0 then " Cut;" else
match tree with
| Terminal (state, player, info) ->
Modified: trunk/Toss/Play/Move.mli
===================================================================
--- trunk/Toss/Play/Move.mli 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/Move.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -12,12 +12,18 @@
TODO: fixed for now. *)
val cGRID_SIZE : int
-(** Generate moves available from a state, as an array, in fixed order. *)
+(** Generate moves available from a state, as an array, in fixed
+ order. Does not check postconditions. *)
val gen_moves : int -> (string * ContinuousRule.rule) list ->
Structure.structure -> Arena.player_loc -> Arena.move array
+(** Given moves available from a state, keep those for which
+ postconditions pass, and return the respective resulting game states. *)
val gen_models : (string * ContinuousRule.rule) list -> Arena.game_state ->
float -> Arena.move array -> Arena.move array * Arena.game_state array
+(** Get moves and resulting game states, like {!Move.gen_models}, but for
+ all rules the players can apply in the given game state. Returns
+ the player together with a move. *)
val list_moves : Arena.game -> Arena.game_state ->
(int * Arena.move * Arena.game_state) array
Modified: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/Play.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -6,9 +6,9 @@
let set_debug_level i = debug_level := i
let timeout = ref 0.
-let set_timeout t = timeout := Unix.gettimeofday() +. t
+let set_timeout t = timeout := Aux.gettimeofday() +. t
let cancel_timeout () = timeout := 0.
-let timed_out () = !timeout > 1. && Unix.gettimeofday() +. 0.01 > !timeout
+let timed_out () = !timeout > 1. && Aux.gettimeofday() +. 0.01 > !timeout
(* ------------ MAXIMAX BY DEPTH ------------- *)
@@ -63,9 +63,11 @@
| Aux.Timeout msg ->
if !debug_level > 0 then
Printf.printf "Timeout %f (%s)%!"
- (Unix.gettimeofday() -. !timeout) msg;
+ (Aux.gettimeofday() -. !timeout) msg;
(t, mvs)
+let latest_gametree_size = ref 0
+
(* Maximax unfold upto depth and choose move. *)
let maximax_unfold_choose ?(check_stable=3) count game state heur =
let ab = Heuristic.is_constant_sum heur in (* TODO: payoffs as well! *)
@@ -75,6 +77,7 @@
let t = init game state (fun _ _ _ -> 0) heur in
try
let (u, mvs) = unfold_maximax_upto ~ab count game heur (t, []) in
+ latest_gametree_size := GameTree.size u;
let nbr_to_check = min (2*check_stable + 1) (List.length mvs / 3) in
let last_mvs = Aux.take_n (max 1 nbr_to_check) mvs in
if !debug_level = 2 then
Modified: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/Play.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -23,3 +23,7 @@
val maximax_unfold_choose : ?check_stable:int -> int -> Arena.game ->
Arena.game_state -> Formula.real_expr array array ->
(Arena.move * Arena.game_state) list
+
+(** Size of the game-tree produced by the latest call of
+ {!Play.maximax_unfold_choose}. *)
+val latest_gametree_size : int ref
Added: trunk/Toss/Server/GameSelection.ml
===================================================================
--- trunk/Toss/Server/GameSelection.ml (rev 0)
+++ trunk/Toss/Server/GameSelection.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,654 @@
+type game_state_data = {
+ heuristic : Formula.real_expr array array; (** heuristic *)
+ game_state : (Arena.game * Arena.game_state); (** game and state *)
+ playclock : int; (** playclock *)
+ game_str : string; (** game representation *)
+}
+
+let compute_heuristic advr (game, state) =
+ let pat_arr = Array.of_list game.Arena.patterns in
+ let pl_heur l =
+ let len = List.length l.Arena.heur in
+ if len = 0 || len > Array.length pat_arr then raise Not_found else
+ let add_pat (i, h) pw =
+ let pat = Formula.Times (Formula.Const pw, pat_arr.(i)) in
+ (i+1, Formula.Plus (pat, h)) in
+ snd (List.fold_left add_pat (0, Formula.Const 0.) l.Arena.heur) in
+ try
+ let res = Array.map (fun a-> Array.map pl_heur a) game.Arena.graph in
+ res
+ with Not_found ->
+ Heuristic.default_heuristic ~struc:state.Arena.struc ?advr game
+
+let compile_game_data game_str =
+ let (game, game_state as game_with_state) =
+ ArenaParser.parse_game_state Lexer.lex (Lexing.from_string game_str) in
+ let adv_ratio =
+ try Some (float_of_string (List.assoc "adv_ratio" game.Arena.data))
+ with Not_found -> None in
+ {heuristic = compute_heuristic adv_ratio game_with_state;
+ game_state = game_with_state;
+ playclock = 30; (* game clock from where? *)
+ game_str = game_str;
+ }
+
+(* Maximum call stack size exceeded in JS (pbbly parsing Chess)
+let chess_str =
+*)
+
+let connect4_str = ("PLAYERS 1, 2
+DATA r1: circle, r2: line, adv_ratio: 4, depth: 6
+REL Row4 (x, y, z, v) = R(x, y) and R(y, z) and R(z, v)
+REL Col4 (x, y, z, v) = C(x, y) and C(y, z) and C(z, v)
+REL DiagA4 (x, y, z, v) = DiagA(x, y) and DiagA(y, z) and DiagA(z, v)
+REL DiagB4 (x, y, z, v) = DiagB(x, y) and DiagB(y, z) and DiagB(z, v)
+REL Conn4 (x, y, z, v) =
+ Row4(x,y,z,v) or Col4(x,y,z,v) or DiagA4(x,y,z,v) or DiagB4(x,y,z,v)
+REL WinQ() =
+ ex x,y,z,v (Q(x) and Q(y) and Q(z) and Q(v) and Conn4(x, y, z, v))
+REL WinP() =
+ ex x,y,z,v (P(x) and P(y) and P(z) and P(v) and Conn4(x, y, z, v))
+REL EmptyUnder (x) = ex y (C(y, x) and not P(y) and not Q(y))
+RULE Cross:
+ [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P
+ pre not EmptyUnder (a) and not WinQ()
+RULE Circle:
+ [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P
+ pre not EmptyUnder (a) and not WinP()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
+ }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ }
+}
+LOC 1 {
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))
+")
+
+let pawn_whopping_str = ("
+PLAYERS 1, 2
+DATA depth: 4, adv_ratio: 2
+REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
+REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
+REL IsFirst(x) = not ex z C(z, x)
+REL IsSecond(x) = ex y (C(y, x) and IsFirst(y))
+REL IsEight(x) = not ex z C(x, z)
+REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
+REL WhiteEnds() = (ex x (wP(x) and not ex y C(x, y))) or (not ex z bP(z))
+REL BlackEnds() = (ex x (bP(x) and not ex y C(y, x))) or (not ex z wP(z))
+RULE WhiteBeat:
+ [ a, b | wP { a }; bP { b } | - ] -> [ a, b | wP { b } | - ] emb wP, bP
+ pre DiagW(a, b) and not BlackEnds()
+RULE WhiteMove:
+ [ | bP:1 {}; R:2 {} | ] \"
+
+ .
+
+ wP
+\" -> [ | bP:1 {}; R:2 {} | ] \"
+
+ wP
+
+ .
+\" emb wP, bP pre not BlackEnds()
+RULE WhiteMoveTwo:
+ [ | bP:1 {}; R:2 {} | ] \"
+
+ .
+
+ .
+
+ wP
+\" -> [ | bP:1 {}; R:2 {} | ] \"
+
+ wP
+
+ .
+
+ .
+\" emb wP, bP pre IsSecond(a1) and not BlackEnds()
+RULE WhiteRightPassant:
+ [ | | ] \"
+ ...
+ ?..-bP
+ ...
+ ? ...
+ ...
+ wP.bP
+\" -> [ | | ] \"
+ ...
+ ?...
+ ...
+ ? wP.
+ ...
+ ....
+\" emb wP, bP pre not BlackEnds()
+RULE WhiteLeftPassant:
+ [ | | ] \"
+ ...
+ -bP?
+ ...
+ . ?..
+ ...
+ bP.wP
+\" -> [ | | ] \"
+ ...
+ ...?
+ ...
+ wP ?..
+ ...
+ ....
+\" emb wP, bP pre not BlackEnds()
+RULE BlackBeat:
+ [ a, b | bP { a }; wP { b } | - ] -> [ a, b | bP { b } | - ] emb wP, bP
+ pre DiagB(a, b) and not WhiteEnds()
+RULE BlackMove:
+ [ | R:2 {}; wP:1 {} | ] \"
+
+ bP
+
+ .
+\" -> [ | R:2 {}; wP:1 {} | ] \"
+
+ .
+
+ bP
+\" emb wP, bP pre not WhiteEnds()
+RULE BlackMoveTwo:
+ [ | R:2 {}; wP:1 {} | ] \"
+
+ bP
+
+ .
+
+ .
+\" -> [ | R:2 {}; wP:1 {} | ] \"
+
+ .
+
+ .
+
+ bP
+\" emb wP, bP pre IsSeventh(a3) and not WhiteEnds()
+RULE BlackRightPassant:
+ [ | | ] \"
+ ...
+ bP.wP
+ ...
+ ? ...
+ ...
+ ?..-wP
+\" -> [ | | ] \"
+ ...
+ ....
+ ...
+ ? bP.
+ ...
+ ?...
+\" emb wP, bP pre not WhiteEnds()
+RULE BlackLeftPassant:
+ [ | | ] \"
+ ...
+ wP.bP
+ ...
+ . ?..
+ ...
+ -wP?
+\" -> [ | | ] \"
+ ...
+ ....
+ ...
+ bP ?..
+ ...
+ ...?
+\" emb wP, bP pre not WhiteEnds()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WhiteEnds()) - :(BlackEnds())
+ MOVES
+ [WhiteBeat -> 1]; [WhiteMove -> 1]; [WhiteMoveTwo -> 1];
+ [WhiteRightPassant -> 1]; [WhiteLeftPassant -> 1]
+ }
+ PLAYER 2 { PAYOFF :(BlackEnds()) - :(WhiteEnds()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(WhiteEnds()) - :(BlackEnds()) }
+ PLAYER 2 {
+ PAYOFF :(BlackEnds()) - :(WhiteEnds())
+ MOVES
+ [BlackBeat -> 0]; [BlackMove -> 0]; [BlackMoveTwo -> 0];
+ [BlackRightPassant -> 0]; [BlackLeftPassant -> 0]
+ }
+}
+MODEL [ | | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ bP.bP bP.bP bP.bP bP.bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ wP wP.wP wP.wP wP.wP wP.
+ ... ... ... ...
+ ... ... ... ...
+\"
+")
+
+let breakthrough_str = ("
+PLAYERS 1, 2
+DATA depth: 2, adv_ratio: 2
+REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
+REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
+RULE WhiteDiag:
+ [ a, b | W { a }; _opt_B { b } | - ]
+ ->
+ [ a, b | W { b } | - ]
+ emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
+RULE WhiteStraight:
+ [ | B:1 {}; R:2 {} | ] \"
+
+ .
+
+ W
+\" -> [ | B:1 {}; R:2 {} |
+ ] \"
+
+ W
+
+ .
+\" emb W, B pre not ex x (B(x) and not ex y C(y, x))
+RULE BlackDiag:
+ [ a, b | B { a }; _opt_W { b } | - ]
+ ->
+ [ a, b | B { b } | - ]
+ emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
+RULE BlackStraight:
+ [ | R:2 {}; W:1 {} | ] \"
+
+ B
+
+ .
+\" -> [ | R:2 {}; W:1 {} |
+ ] \"
+
+ .
+
+ B
+\" emb W, B pre not ex x (W(x) and not ex y C(x, y))
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ MOVES
+ [WhiteDiag -> 1]; [WhiteStraight -> 1]
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ }
+}
+LOC 1 {
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ MOVES
+ [BlackDiag -> 0]; [BlackStraight -> 0]
+ }
+}
+MODEL [ | | ] \"
+ ... ... ... ...
+ B B..B B..B B..B B..
+ ... ... ... ...
+ B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W W..W W..W W..W W..
+ ... ... ... ...
+ W..W W..W W..W W..W
+\"
+")
+
+let checkers_str = ("
+PLAYERS 1, 2
+DATA depth: 4, adv_ratio: 2
+REL IsFirst(x) = not ex z C(z, x)
+REL IsEight(x) = not ex z C(x, z)
+REL w(x) = W(x) or Wq(x)
+REL b(x) = B(x) or Bq(x)
+REL DiagWa (x, y) = ex z (C(x, z) and R(y, z))
+REL DiagBa (x, y) = ex z (C(z, x) and R(z, y))
+REL DiagWb (x, y) = ex z (C(x, z) and R(z, y))
+REL DiagBb (x, y) = ex z (C(z, x) and R(y, z))
+REL AnyDiag (x, y) =
+ DiagWa (x, y) or DiagWb (x, y) or DiagBa (x, y) or DiagBb (x, y)
+REL DiagW2 (x, y, z) =
+ (DiagWa (x, y) and DiagWa (y, z)) or (DiagWb (x, y) and DiagWb (y, z))
+REL DiagB2 (x, y, z) =
+ (DiagBa (x, y) and DiagBa (y, z)) or (DiagBb (x, y) and DiagBb (y, z))
+REL Diag2 (x, y, z) = DiagW2 (x, y, z) or DiagB2 (x, y, z)
+REL BeatsW (x, y) = ex z (b(z) and not b(y) and not w(y) and DiagW2 (x, z, y))
+REL BeatsWX (x, y) = ex z (b(z) and not b(y) and not w(y) and Diag2 (x, z, y))
+REL BeatsB (x, y) = ex z (w(z) and not b(y) and not w(y) and DiagB2 (x, z, y))
+REL BeatsBX (x, y) = ex z (w(z) and not b(y) and not w(y) and Diag2 (x, z, y))
+REL BJumps() = ex x, y ((B(x) and BeatsB (x, y)) or (Bq(x) and BeatsBX (x, y)))
+REL WJumps() = ex x, y ((W(x) and BeatsW (x, y)) or (Wq(x) and BeatsWX (x, y)))
+RULE RedMove:
+ [ a, b | W { a } | - ] -> [ a, b | W { b } | - ] emb w, b
+ pre (not IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps()
+RULE WhiteMove:
+ [ a, b | B { a } | - ] -> [ a, b | B { b } | - ] emb w, b
+ pre (not IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps()
+RULE RedPromote:
+ [ a, b | W { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b
+ pre (IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps()
+RULE WhitePromote:
+ [ a, b | B { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b
+ pre (IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps()
+RULE RedQMove:
+ [ a, b | Wq { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b
+ pre AnyDiag (a, b) and not WJumps()
+RULE WhiteQMove:
+ [ a, b | Bq { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b
+ pre AnyDiag (a, b) and not BJumps()
+RULE RedBeat:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and not IsEight(c)
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeat:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and not IsFirst(c)
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatBoth:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatBoth:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatPromote:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and IsEight(c)
+RULE WhiteBeatPromote:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and IsFirst(c)
+RULE RedBeatCont:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatCont:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatBothCont:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatBothCont:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedQBeat:
+ [ a, b, c | Wq { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b
+ pre Diag2 (a, b, c)
+RULE WhiteQBeat:
+ [ a, b, c | Bq { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
+ pre Diag2 (a, b, c)
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES
+ [RedMove -> 1]; [RedPromote -> 1]; [RedQMove -> 1];
+ [RedBeat -> 1]; [RedBeatPromote -> 1]; [RedQBeat -> 1];
+ [RedBeatCont -> 2]
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
+}
+LOC 1 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteMove -> 0]; [WhitePromote -> 0]; [WhiteQMove -> 0];
+ [WhiteBeat -> 0]; [WhiteBeatPromote -> 0]; [WhiteQBeat -> 0];
+ [WhiteBeatCont -> 3]
+ }
+}
+LOC 2 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES [RedBeatBoth -> 1]; [RedBeatPromote -> 1]; [RedBeatBothCont -> 2]
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
+}
+LOC 3 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteBeatBoth -> 0]; [WhiteBeatPromote -> 0]; [WhiteBeatBothCont -> 3]
+ }
+}
+MODEL [ | Wq:1 { }; Bq:1 { } |
+ ] \"
+ ... ... ... ...
+ B.. B.. B.. B..
+ ... ... ... ...
+ B.. B.. B.. B..
+ ... ... ... ...
+ B.. B.. B.. B..
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W.. W.. W.. W..
+ ... ... ... ...
+ W.. W.. W.. W..
+ ... ... ... ...
+ W.. W.. W.. W..
+\"
+")
+
+let gomoku_str = ("
+PLAYERS 1, 2
+DATA rCircle: circle, rCross: line, adv_ratio: 5, depth: 2
+REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w)
+REL Col5 (x, y, z, v, w) = C(x, y) and C(y, z) and C(z, v) and C(v, w)
+REL DiagA5 (x, y, z, v, w) =
+ DiagA(x, y) and DiagA(y, z) and DiagA(z, v) and DiagA(v, w)
+REL DiagB5 (x, y, z, v, w) =
+ DiagB(x, y) and DiagB(y, z) and DiagB(z, v) and DiagB(v, w)
+REL Conn5 (x, y, z, v, w) =
+ Row5(x,y,z,v,w) or Col5(x,y,z,v,w) or DiagA5(x,y,z,v,w) or DiagB5(x,y,z,v,w)
+REL WinQ() =
+ ex x,y,z,v,w (Q(x) and Q(y) and Q(z) and Q(v) and Q(w) and Conn5(x,y,z,v,w))
+REL WinP() =
+ ex x,y,z,v,w (P(x) and P(y) and P(z) and P(v) and P(w) and Conn5(x,y,z,v,w))
+RULE Cross:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P (a1); Q:1 {} | - ]
+ emb Q, P pre not WinQ()
+RULE Circle:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P:1 {}; Q (a1) | - ]
+ emb Q, P pre not WinP()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
+ }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))
+")
+
+let entanglement_str = ("
+PLAYERS 1, 2
+RULE Follow:
+ [ a1, a2 | C { (a2) }; R { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ]
+ ->
+ [ a1, a2 | C { (a1) }; R { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ]
+emb R, C
+RULE Wait:
+ [ a1 | R { (a1) } |
+ vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ]
+ ->
+ [ a1 | R { (a1) } |
+ vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ]
+emb R, C
+RULE Run:
+ [ a1, a2 | C:1 { }; E { (a1, a2) }; R { (a1) }; _opt_C { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ]
+ ->
+ [ a1, a2 | C:1 { }; E { (a1, a2) }; R { (a2) }; _opt_C { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ]
+emb R, C
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF 0.
+ MOVES [Follow -> 1]; [Wait -> 1]
+ }
+ PLAYER 2 { PAYOFF 0. }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF 1. }
+ PLAYER 2 {
+ PAYOFF -1.
+ MOVES [Run -> 0]
+ }
+ }
+MODEL [ d4, a2, a1, b1, b2, e4, c2, c1, f4, d2, d1, f1, f2, g1, g2, h1, h2, e1, e2, i1, i2 | C { (d4); (e4); (f4) }; E { (a2, a1); (a2, b2); (a1, a2); (a1, b1); (b1, a1); (b1, b2); (b1, c1); (b2, a2); (b2, b1); (b2, c2); (c2, b2); (c2, c1); (c2, d2); (c1, b1); (c1, c2); (c1, d1); (d2, c2); (d2, d1); (d2, e1); (d1, c1); (d1, d2); (d1, e2); (f1, f2); (f1, g1); (f1, e1); (f2, f1); (f2, g2); (f2, e2); (g1, f1); (g1, g2); (g1, h1); (g2, f2); (g2, g1); (g2, h2); (h1, g1); (h1, h2); (h1, i1); (h2, g2); (h2, h1); (h2, i2); (e1, d2); (e1, f1); (e1, e2); (e2, d1); (e2, f2); (e2, e1); (i1, h1); (i1, i2); (i2, h2); (i2, i1) }; R { (e1) }; _opt_C:1 { } | vx { d4->0., a2->0., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; vy { d4->0., a2->0., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; x { d4->100., a2->-50., a1->-50., b1->0., b2->0., e4->150., c2->50., c1->50., f4->200., d2->100., d1->100., f1->200., f2->200., g1->250., g2->250., h1->300., h2->300., e1->150., e2->150., i1->350., i2->350. }; y { d4->-150., a2->-100., a1->-50., b1->-50., b2->-100., e4->0., c2->-100., c1->-50., f4->-150., d2->-100., d1->-50., f1->-100., f2->-50., g1->-100., g2->-50., h1->-100., h2->-50., e1->-100., e2->-50., i1->-100., i2->-50. } ]
+")
+
+let tictactoe_str = ("
+PLAYERS 1, 2
+DATA r1: circle, r2: line, adv_ratio: 5, depth: 3
+REL DiagA (x, y) = ex u (R(x, u) and C(u, y))
+REL DiagB (x, y) = ex u (R(x, u) and C(y, u))
+REL Row3 (x, y, z) = R(x, y) and R(y, z)
+REL Col3 (x, y, z) = C(x, y) and C(y, z)
+REL DiagA3 (x, y, z) = DiagA(x, y) and DiagA(y, z)
+REL DiagB3 (x, y, z) = DiagB(x, y) and DiagB(y, z)
+REL Conn3 (x, y, z) =
+ Row3(x, y, z) or Col3(x, y, z) or DiagA3(x, y, z) or DiagB3(x, y, z)
+REL WinQ() = ex x, y, z (Q(x) and Q(y) and Q(z) and Conn3(x, y, z))
+REL WinP() = ex x, y, z (P(x) and P(y) and P(z) and Conn3(x, y, z))
+RULE Cross:
+ [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P pre not WinQ()
+RULE Circle:
+ [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P pre not WinP()
+LOC 0 {
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1] }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0] }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] \"
+
+ . . .
+
+ . . .
+
+ . . .
+\"
+")
+
+let games = ref
+ [
+ "Breakthrough", compile_game_data breakthrough_str;
+ "Checkers", compile_game_data checkers_str;
+ (* "Chess", compile_game_data chess_str; *)
+ "Connect4", compile_game_data connect4_str;
+ "Entanglement", compile_game_data entanglement_str;
+ "Gomoku", compile_game_data gomoku_str;
+ "Pawn-Whopping", compile_game_data pawn_whopping_str;
+ "Tic-Tac-Toe", compile_game_data tictactoe_str;
+ ]
Added: trunk/Toss/Server/JsHandler.ml
===================================================================
--- trunk/Toss/Server/JsHandler.ml (rev 0)
+++ trunk/Toss/Server/JsHandler.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,184 @@
+(* JavaScript Handler for a subset of ReqHandler.handle_http_post requests. *)
+
+
+(* ---------- Basic request type and internal handler ---------- *)
+
+open GameSelection
+
+(* History of states in last-in-first-out order. *)
+let play_states = ref []
+(* Arbitrarily initialized -- [cur_game] only has effect with
+ non-empty [play_states]. The game state in any [game_data] is only
+ the initial state, not the current state of a game. *)
+let cur_game = ref (snd (List.hd !GameSelection.games))
+let cur_move = ref 0
+let cur_all_moves = ref [| |]
+
+(* TODO; FIXME; remove the function below. *)
+let select_moving a = (* temporary func - accept just one player w/ moves *)
+ let locs = Aux.array_find_all (fun l -> l.Arena.moves <> []) a in
+ if List.length locs <> 1 then failwith "too many moves" else
+ if locs = [] then a.(0) else List.hd locs
+
+
+(* ------------ The Handler ------------ *)
+let js = Js.string
+let of_js = Js.to_string
+let js_object = Js.Unsafe.variable "Object"
+let js_any = Js.Unsafe.inject
+
+let js_handler = Js.Unsafe.variable "LOCAL"
+let set_handle name f =
+ Js.Unsafe.set js_handler (js name) (Js.wrap_callback f)
+
+
+let js_of_move game state move_id (player, move, _) =
+ let struc = state.Arena.struc in
+ let matched = Js.array
+ (Aux.array_map_of_list (fun (_, e) ->
+ js (Structure.elem_name struc e)) move.Arena.matching) in
+ let js_move = jsnew js_object () in
+ let player_name = Aux.rev_assoc game.Arena.player_names player in
+ Js.Unsafe.set js_move (js"matched") matched;
+ Js.Unsafe.set js_move (js"rule") (js (move.Arena.rule));
+ Js.Unsafe.set js_move (js"player") (js player_name);
+ Js.Unsafe.set js_move (js"id") (Js.float (float_of_int move_id));
+ js_move
+
+(* Translate current structure into an "info_obj" format. *)
+let js_of_game_state game state =
+ let struc = state.Arena.struc in
+ let get_pos e =
+ Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
+ let elems = Structure.elements struc in
+ let (posx, posy) = List.split (List.map get_pos elems) in
+ let mkfl f l = List.fold_left f (List.hd l) (List.tl l) in
+ let (minl, maxl, suml) = (mkfl min, mkfl max, mkfl (+.)) in
+ let minx, maxx, miny, maxy = minl posx, maxl posx, minl posy, maxl posy in
+ (* elems are arrays of element name and position *)
+ let elems = Array.of_list
+ (List.map
+ (fun e ->
+ let e0 = js (Structure.elem_name struc e) in
+ let x, y = get_pos e in
+ Js.array [|js_any e0; js_any (Js.float x); js_any (Js.float y)|])
+ elems) in
+ (* rels are arrays of element names, with additional "name" field *)
+ let num = Js.number_of_float in
+ let rels = Array.of_list
+ (Aux.concat_map
+ (fun (rel, _) ->
+ let tups = Structure.Tuples.elements
+ (Structure.rel_graph rel struc) in
+ let tups = List.map
+ (fun args -> Js.array
+ (Array.map (fun e -> js (Structure.elem_name struc e)) args))
+ tups in
+ List.iter
+ (fun args -> Js.Unsafe.set args (js"name") (js rel)) tups;
+ tups)
+ (Structure.rel_signature struc)) in
+ let info_obj = jsnew js_object () in
+ Js.Unsafe.set info_obj (js"maxx") (num maxx);
+ Js.Unsafe.set info_obj (js"minx") (num minx);
+ Js.Unsafe.set info_obj (js"maxy") (num maxy);
+ Js.Unsafe.set info_obj (js"miny") (num miny);
+ Js.Unsafe.set info_obj (js"elems") (Js.array elems);
+ Js.Unsafe.set info_obj (js"rels") (Js.array rels);
+ if !cur_all_moves <> [||] then
+ Js.Unsafe.set info_obj (js"moves")
+ (Js.array (Array.mapi (js_of_move game state) !cur_all_moves))
+ else ( (* find payoffs *)
+ let payoffs = Array.mapi
+ (fun i v -> i, Solver.M.get_real_val v.Arena.payoff struc)
+ game.Arena.graph.(state.Arena.cur_loc) in
+ let result = jsnew js_object () in
+ Array.iter
+ (fun (i, payoff) ->
+ (* Players use their names on the JS side, not numbers! *)
+ let player_name = Aux.rev_assoc game.Arena.player_names i in
+ Js.Unsafe.set result (js player_name) (Js.float payoff))
+ payoffs;
+ Js.Unsafe.set info_obj (js"result") result);
+ info_obj
+
+let new_play game_name pl1 pl2 =
+ (* players are currently not used by [JsHandler] *)
+ let game_data = List.assoc (of_js game_name) !GameSelection.games in
+ let game, state = game_data.game_state in
+ cur_game := game_data;
+ play_states := [state];
+ cur_all_moves := Move.list_moves game state;
+ cur_move := 0;
+ js_of_game_state game state
+
+let _ = set_handle "new_play" new_play
+
+let preview_move move_nbr =
+ let n = List.length !play_states - (move_nbr + 1) in
+ if n < 0 then Js.null
+ else
+ let game, _ = !cur_game.game_state in
+ let state = List.nth !play_states n in
+ Js.some (js_of_game_state game state)
+
+let _ = set_handle "prev_move" preview_move
+
+let make_move move_id cont =
+ if !play_states = [] then Js.null
+ else
+ let (p, m, n_state) =
+ !cur_all_moves.(int_of_float (Js.to_float move_id)) in
+ let game, _ = !cur_game.game_state in
+ play_states := n_state :: !play_states;
+ cur_all_moves := Move.list_moves game n_state;
+ cur_move := 0;
+ Js.Unsafe.fun_call cont
+ [|js_any (js_of_game_state game n_state)|]
+
+let _ = set_handle "make_move" make_move
+
+let suggest player_name time cont =
+ (* We do not use the player name. *)
+ Random.self_init ();
+ let time = Js.to_float time in
+ Play.set_timeout time;
+ let comp_started = Aux.gettimeofday () in
+ let game, _ = !cur_game.game_state in
+ let state = List.hd !play_states in
+ try
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose 100000
+ game state !cur_game.heuristic) in
+ Play.cancel_timeout ();
+ let algo_iters = !Play.latest_gametree_size in
+ let move_id = Aux.array_argfind
+ (fun (_, m, _) -> m = move) !cur_all_moves in
+ let result =
+ js_of_move game state move_id (!cur_all_moves.(move_id)) in
+ Js.Unsafe.set result (js"comp_tree_size")
+ (Js.number_of_float (float_of_int algo_iters));
+ Js.Unsafe.set result (js"comp_started")
+ (Js.number_of_float comp_started);
+ Js.Unsafe.set result (js"comp_ended")
+ (Js.number_of_float (Aux.gettimeofday ()));
+ Js.Unsafe.fun_call cont [|js_any result|]
+ with Not_found -> Js.null
+
+let _ = set_handle "suggest" suggest
+
+let get_game game_name =
+ let game_data = List.assoc (of_js game_name) !GameSelection.games in
+ js game_data.game_str
+
+let _ = set_handle "get_game" get_game
+
+let set_game game_name game_str =
+ let game_name = of_js game_name and game_str = of_js game_str in
+ try
+ games := (game_name, compile_game_data game_str) :: !games;
+ js ("Game "^game_name^" set.")
+ with Lexer.Parsing_error s ->
+ js ("Game "^game_name^" ERROR: "^s)
+
+let _ = set_handle "set_game" set_game
Added: trunk/Toss/Solver/RealQuantElim/N.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/N.ml (rev 0)
+++ trunk/Toss/Solver/RealQuantElim/N.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,37 @@
+(* A proxy to the [Num] module from the [nums] library. *)
+
+module LocalNum = (struct
+ type num = int * int
+ let sign_num n = failwith "Local Num not implemented yet"
+ let mod_num m n = failwith "Local Num not implemented yet"
+ let div_num m n = failwith "Local Num not implemented yet"
+ let ( // ) = div_num
+ let num_of_int n = failwith "Local Num not implemented yet"
+ let ( +/ ) m n = failwith "Local Num not implemented yet"
+ let ( -/ ) m n = failwith "Local Num not implemented yet"
+ let ( */ ) m n = failwith "Local Num not implemented yet"
+ let float_of_num n = failwith "Local Num not implemented yet"
+ let num_of_string s = failwith "Local Num not implemented yet"
+ let string_of_num n = failwith "Local Num not implemented yet"
+ let abs_num n = failwith "Local Num not implemented yet"
+end : sig
+ type num
+ val sign_num : num -> int
+ val mod_num : num -> num -> num
+ val div_num : num -> num -> num
+ val ( // ) : num -> num -> num
+ val num_of_int : int -> num
+ val ( +/ ) : num -> num -> num
+ val ( -/ ) : num -> num -> num
+ val ( */ ) : num -> num -> num
+ val float_of_num : num -> float
+ val num_of_string : string -> num
+ val string_of_num : num -> string
+ val abs_num : num -> num
+end)
+
+IFDEF JAVASCRIPT THEN
+module Q = LocalNum
+ ELSE
+module Q = Num
+ ENDIF
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -1,6 +1,6 @@
(* Polynomials with ordered variables, integer coefficients.*)
-open Num
+open N.Q
(* ----------------------- BASIC TYPE DEFINITIONS --------------------------- *)
@@ -219,7 +219,7 @@
match (p, q) with
(Const n, Const m) ->
if allow_frac then Const (n // m) else
- if Num.sign_num (Num.mod_num n m) = 0 then Const (n // m) else
+ if N.Q.sign_num (N.Q.mod_num n m) = 0 then Const (n // m) else
raise Not_found
| (Poly (v, _), Poly (w, _)) ->
if v <> w then raise Unmatched_variables else
@@ -232,8 +232,8 @@
| Const n -> (
match u with
Const m ->
- if allow_frac then (Const (n // m), Const (Num.num_of_int 0)) else
- let r = Num.mod_num n m in (Const ((n -/ r) // m), Const r)
+ if allow_frac then (Const (n // m), Const (N.Q.num_of_int 0)) else
+ let r = N.Q.mod_num n m in (Const ((n -/ r) // m), Const r)
| Poly (_, _) -> raise Unmatched_variables
)
| Poly (v, (p, d) :: ps) ->
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -3,7 +3,7 @@
(** {2 Basic Type Definitions} *)
-type polynomial = Const of Num.num | Poly of string * (polynomial * int) list
+type polynomial = Const of N.Q.num | Poly of string * (polynomial * int) list
type t = polynomial (** to be compatible with OrderedType signature *)
@@ -29,14 +29,15 @@
val var : polynomial -> string
val lower : polynomial -> polynomial
-val constant_value : polynomial -> Num.num option
+val constant_value : polynomial -> N.Q.num option
val deg : polynomial -> int
val leading_coeff : int -> polynomial -> polynomial
val const_coeff : polynomial -> polynomial option
val omit_leading : polynomial -> polynomial
val multiple : int -> polynomial -> polynomial
-val multiple_num : Num.num -> polynomial -> polynomial
-val constant_factors : polynomial -> polynomial -> (Num.num * Num.num) option
+val multiple_num : N.Q.num -> polynomial -> polynomial
+val constant_factors :
+ polynomial -> polynomial -> (N.Q.num * N.Q.num) option
(** {2 Arithmetic Functions} *)
Modified: trunk/Toss/Solver/RealQuantElim/Poly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -49,7 +49,7 @@
(* ----------------- CONVERTION TO UNORDERED POLYNOMIALS -------------------- *)
let rec make_unordered = function
- OrderedPoly.Const n -> Const (Num.float_of_num n)
+ OrderedPoly.Const n -> Const (N.Q.float_of_num n)
| OrderedPoly.Poly (v, lst) -> make_unordered_list v lst
and make_unordered_list v = function
@@ -74,11 +74,11 @@
let scale = 1000000 in
let f_scaled = Printf.sprintf "%.0f" (f *. (float_of_int scale)) in
if f_scaled = "nan" || f_scaled = "inf" || f_scaled = "-inf"
- then Num.num_of_int (-1) (* unlikely number *)
+ then N.Q.num_of_int (-1) (* unlikely number *)
else
- let num_scale = Num.num_of_int scale in
- let num_f_scaled = Num.num_of_string f_scaled in
- Num.div_num num_f_scaled num_scale
+ let num_scale = N.Q.num_of_int scale in
+ let num_f_scaled = N.Q.num_of_string f_scaled in
+ N.Q.div_num num_f_scaled num_scale
(* List variables in the given polynomial. *)
let rec vars = function
Modified: trunk/Toss/Solver/RealQuantElim/SignTable.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/SignTable.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/SignTable.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -72,7 +72,7 @@
let int_case_str case =
let psgn_str (p, i) =
match constant_value p with
- Some n -> if Num.sign_num n <> sign i then "wrong" else "ok"
+ Some n -> if N.Q.sign_num n <> sign i then "wrong" else "ok"
| None ->
if i > 0 then (str p) ^ " > 0" else
if i = 0 then (str p) ^ " = 0" else (str p) ^ " < 0"
@@ -104,7 +104,7 @@
| (r, _) :: rs ->
let mulr = match q with None -> r | Some qp -> mul qp r in
match constant_factors p mulr with
- Some (c1, c2) -> ((-2, i), (Num.sign_num c1) * (Num.sign_num c2))
+ Some (c1, c2) -> ((-2, i), (N.Q.sign_num c1) * (N.Q.sign_num c2))
| None -> find_const_factor ~i:(i+1) ~q:q p rs
(* Helper function: find if p = q1 * q2 * c for some q1, q2 in [acc]. *)
@@ -120,7 +120,8 @@
[] -> acc
| p :: ps ->
match constant_value p with
- Some n -> determine_vals (acc @ [(p, ((-2, -2), Num.sign_num n))]) ps
+ Some n ->
+ determine_vals (acc @ [(p, ((-2, -2), N.Q.sign_num n))]) ps
| None ->
match find_const_factor p acc with
((-1, _), _) ->
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/Structure.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -1253,19 +1253,19 @@
find_unique (StringMap.fold (fun rel _ acc -> rel::acc)
!struc.rel_signature []) in
let uniq = uniq1 @ uniq2 @ uniq3 in
- let lines = Str.split (Str.regexp "[\r\n]+\t*") board in
+ let lines = Aux.split_regexp ~regexp:"[\r\n]+\t*" board in
let lines = List.filter (fun s->String.length s > 2) lines in
- let rec split_line line =
- let is_ok c = c = ' ' || c = '.' || Aux.is_alphanum c || c = '_' ||
+ let rec split_line line =
+ let is_ok c = c = ' ' || c = '.' || Aux.is_alphanum c || c = '_' ||
c = '*' || c = '?' || c = '#' || c = '+' || c = '-' in
let error txt = raise (Board_parse_error
- ("Unrecognized field line: \"" ^ txt ^
- "\" of board line: \"" ^ line ^"\"")) in
+ ("Unrecognized field line: \"" ^ txt ^
+ "\" of board line: \"" ^ line ^"\"")) in
if line = "" then [] else if String.length line < 3 then error line else
- if (is_ok line.[0] && is_ok line.[1] && is_ok line.[2]) then
- let rest = String.sub line 3 ((String.length line) - 3) in
- (String.sub line 0 3) :: (split_line rest)
- else error (String.sub line 0 3) in
+ if (is_ok line.[0] && is_ok line.[1] && is_ok line.[2]) then
+ let rest = String.sub line 3 ((String.length line) - 3) in
+ (String.sub line 0 3) :: (split_line rest)
+ else error (String.sub line 0 3) in
let rec rev_combine_pairs acc = function
| [] -> acc
| [hd] ->
@@ -1296,12 +1296,12 @@
else if s.[0] = '*' then ["*"] (* treated specially *)
else if sl = 0 && s.[sl] = '?' then ["_any_"]
else if s.[0] = '+' then
- let p = unabbrev (omit 1 s) in ["_new_" ^ p; p]
+ let p = unabbrev (omit 1 s) in ["_new_"^p; p]
else if s.[0] = '-' then ["_del_"^unabbrev (omit 1 s)]
else if s.[sl] = '?' then [unabbrev (String.sub s 0 sl); "_any_"]
else if s.[0] = '?' then ["_opt_"^unabbrev (omit 1 s)]
else if s.[sl] = '#' then
- ["_diffthan_" ^ unabbrev (String.sub s 0 sl); "_any_"]
+ ["_diffthan_"^unabbrev (String.sub s 0 sl); "_any_"]
else if s.[0] = '#' then ["_diffthan_"^unabbrev (omit 1 s)]
else [unabbrev s] in
let board_els =
@@ -1346,8 +1346,8 @@
done;
if List.hd !fields <> [] then
raise (Board_parse_error
- (Printf.sprintf
- "Row %d is too long, expected %d columns" r c_max));
+ (Printf.sprintf
+ "Row %d is too long, expected %d columns" r c_max));
fields := List.tl !fields;
done;
!struc
Added: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js (rev 0)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,895 @@
+// This program was compiled from OCaml by js_of_ocaml 1.0
+function caml_raise_with_arg (tag, arg) { throw [0, tag, arg]; }
+function caml_raise_with_string (tag, msg) {
+ caml_raise_with_arg (tag, new MlWrappedString (msg));
+}
+function caml_invalid_argument (msg) {
+ caml_raise_with_string(caml_global_data[4], msg);
+}
+function caml_array_bound_error () {
+ caml_invalid_argument("index out of bounds");
+}
+function caml_str_repeat(n, s) {
+ if (!n) { return ""; }
+ if (n & 1) { return caml_str_repeat(n - 1, s) + s; }
+ var r = caml_str_repeat(n >> 1, s);
+ return r + r;
+}
+function MlString(param) {
+ if (param != null) {
+ this.bytes = this.fullBytes = param;
+ this.last = this.len = param.length;
+ }
+}
+MlString.prototype = {
+ string:null,
+ bytes:null,
+ fullBytes:null,
+ array:null,
+ len:null,
+ last:0,
+ toJsString:function() {
+ return this.string = decodeURIComponent (escape(this.getFullBytes()));
+ },
+ toBytes:function() {
+ if (this.string != null)
+ var b = unescape (encodeURIComponent (this.string));
+ else {
+ var b = "", a = this.array, l = a.length;
+ for (var i = 0; i < l; i ++) b += String.fromCharCode (a[i]);
+ }
+ this.bytes = this.fullBytes = b;
+ this.last = this.len = b.length;
+ return b;
+ },
+ getBytes:function() {
+ var b = this.bytes;
+ if (b == null) b = this.toBytes();
+ return b;
+ },
+ getFullBytes:function() {
+ var b = this.fullBytes;
+ if (b !== null) return b;
+ b = this.bytes;
+ if (b == null) b = this.toBytes ();
+ if (this.last < this.len) {
+ this.bytes = (b += caml_str_repeat(this.len - this.last, '\0'));
+ this.last = this.len;
+ }
+ this.fullBytes = b;
+ return b;
+ },
+ toArray:function() {
+ var b = this.bytes;
+ if (b == null) b = this.toBytes ();
+ var a = [], l = this.last;
+ for (var i = 0; i < l; i++) a[i] = b.charCodeAt(i);
+ for (l = this.len; i < l; i++) a[i] = 0;
+ this.string = this.bytes = this.fullBytes = null;
+ this.last = this.len;
+ this.array = a;
+ return a;
+ },
+ getArray:function() {
+ var a = this.array;
+ if (!a) a = this.toArray();
+ return a;
+ },
+ getLen:function() {
+ var len = this.len;
+ if (len !== null) return len;
+ this.toBytes();
+ return this.len;
+ },
+ toString:function() { var s = this.string; return s?s:this.toJsString(); },
+ valueOf:function() { var s = this.string; return s?s:this.toJsString(); },
+ blitToArray:function(i1, a2, i2, l) {
+ var a1 = this.array;
+ if (a1)
+ for (var i = 0; i < l; i++) a2 [i2 + i] = a1 [i1 + i];
+ else {
+ var b = this.bytes;
+ if (b == null) b = this.toBytes();
+ var l1 = this.last - i1;
+ if (l <= l1)
+ for (var i = 0; i < l; i++) a2 [i2 + i] = b.charCodeAt(i1 + i);
+ else {
+ for (var i = 0; i < l1; i++) a2 [i2 + i] = b.charCodeAt(i1 + i);
+ for (; i < l; i++) a2 [i2 + i] = 0;
+ }
+ }
+ },
+ get:function (i) {
+ var a = this.array;
+ if (a) return a[i];
+ var b = this.bytes;
+ if (b == null) b = this.toBytes();
+ return (i<this.last)?b.charCodeAt(i):0;
+ },
+ safeGet:function (i) {
+ if (!this.len) this.toBytes();
+ if ((i < 0) || (i >= this.len)) caml_array_bound_error ();
+ return this.get(i);
+ },
+ set:function (i, c) {
+ var a = this.array;
+ if (!a) {
+ if (this.last == i) {
+ this.bytes += String.fromCharCode (c & 0xff);
+ this.last ++;
+ return 0;
+ }
+ a = this.toArray();
+ } else if (this.bytes != null) {
+ this.bytes = this.fullBytes = this.string = null;
+ }
+ a[i] = c & 0xff;
+ return 0;
+ },
+ safeSet:function (i, c) {
+ if (this.len == null) this.toBytes ();
+ if ((i < 0) || (i >= this.len)) caml_array_bound_error ();
+ this.set(i, c);
+ },
+ fill:function (ofs, len, c) {
+ if (ofs >= this.last && this.last && c == 0) return;
+ var a = this.array;
+ if (!a) a = this.toArray();
+ else if (this.bytes != null) {
+ this.bytes = this.fullBytes = this.string = null;
+ }
+ var l = ofs + len;
+ for (var i = ofs; i < l; i++) a[i] = c;
+ },
+ compare:function (s2) {
+ if (this.string != null && s2.string != null) {
+ if (this.string < s2.string) return -1;
+ if (this.string > s2.string) return 1;
+ return 0;
+ }
+ var b1 = this.getFullBytes ();
+ var b2 = s2.getFullBytes ();
+ if (b1 < b2) return -1;
+ if (b1 > b2) return 1;
+ return 0;
+ },
+ equal:function (s2) {
+ if (this.string != null && s2.string != null)
+ return this.string == s2.string;
+ return this.getFullBytes () == s2.getFullBytes ();
+ },
+ lessThan:function (s2) {
+ if (this.string != null && s2.string != null)
+ return this.string < s2.string;
+ return this.getFullBytes () < s2.getFullBytes ();
+ },
+ lessEqual:function (s2) {
+ if (this.string != null && s2.string != null)
+ return this.string <= s2.string;
+ return this.getFullBytes () <= s2.getFullBytes ();
+ }
+}
+function MlWrappedString (s) { this.string = s; }
+MlWrappedString.prototype = new MlString();
+function MlMakeString (l) { this.bytes = ""; this.len = l; }
+MlMakeString.prototype = new MlString ();
+function caml_array_get (array, index) {
+ if ((index < 0) || (index >= array.length - 1)) caml_array_bound_error();
+ return array[index+1];
+}
+function caml_array_set (array, index, newval) {
+ if ((index < 0) || (index >= array.length - 1)) caml_array_bound_error();
+ array[index+1]=newval; return 0;
+}
+function caml_blit_string(s1, i1, s2, i2, len) {
+ if (len === 0) return;
+ if (i2 === s2.last && i1 === 0 && s1.last == len) {
+ var s = s1.bytes;
+ if (s !== null)
+ s2.bytes += s1.bytes;
+ else
+ s2.bytes += s1.getBytes();
+ s2.last += len;
+ return;
+ }
+ var a = s2.array;
+ if (!a) a = s2.toArray(); else { s2.bytes = s2.string = null; }
+ s1.blitToArray (i1, a, i2, len);
+}
+function caml_call_gen(f, args) {
+ if(f.fun)
+ return caml_call_gen(f.fun, args);
+ var n = f.length;
+ var d = n - args.length;
+ if (d == 0)
+ return f.apply(null, args);
+ else if (d < 0)
+ return caml_call_gen(f.apply(null, args.slice(0,n)), args.slice(n));
+ else
+ return function (x){ return caml_call_gen(f, args.concat([x])); };
+}
+function caml_classify_float (x) {
+ if (isFinite (x)) {
+ if (Math.abs(x) >= 2.2250738585072014e-308) return 0;
+ if (x != 0) return 1;
+ return 2;
+ }
+ return isNaN(x)?4:3;
+}
+function caml_int64_compare(x,y) {
+ var x3 = x[3] << 16;
+ var y3 = y[3] << 16;
+ if (x3 > y3) return 1;
+ if (x3 < y3) return -1;
+ if (x[2] > y[2]) return 1;
+ if (x[2] < y[2]) return -1;
+ if (x[1] > y[1]) return 1;
+ if (x[1] < y[1]) return -1;
+ return 0;
+}
+function caml_int_compare (a, b) {
+ if (a < b) return (-1); if (a == b) return 0; return 1;
+}
+function caml_compare_val (a, b, total) {
+ var stack = [];
+ for(;;) {
+ if (!(total && a === b)) {
+ if (a instanceof MlString) {
+ if (b instanceof MlString) {
+ if (a != b) {
+ var x = a.compare(b);
+ if (x != 0) return x;
+ }
+ } else
+ return 1;
+ } else if (a instanceof Array && a[0] == (a[0]|0)) {
+ var ta = a[0];
+ if (ta === 250) {
+ a = a[1];
+ continue;
+ } else if (b instanceof Array && b[0] == (b[0]|0)) {
+ var tb = b[0];
+ if (tb === 250) {
+ b = b[1];
+ continue;
+ } else if (ta != tb) {
+ return (ta < tb)?-1:1;
+ } else {
+ switch (ta) {
+ case 248: {
+ var x = caml_int_compare(a[2], b[2]);
+ if (x != 0) return x;
+ break;
+ }
+ case 255: {
+ var x = caml_int64_compare(a, b);
+ if (x != 0) return x;
+ break;
+ }
+ default:
+ if (a.length != b.length) return (a.length < b.length)?-1:1;
+ if (a.length > 1) stack.push(a, b, 1);
+ }
+ }
+ } else
+ return 1;
+ } else if (b instanceof MlString ||
+ (b instanceof Array && b[0] == (b[0]|0))) {
+ return -1;
+ } else {
+ if (a < b) return -1;
+ if (a > b) retur...
[truncated message content] |
