(* Js_of_ocaml examples * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2008 Benjamin Canou * * DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE * TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION * *) let (>>=) = Lwt.bind module Html = Dom_html let js = Js.string let document = Html.window##document let append_text e s = Dom.appendChild e (document##createTextNode (js s)) let replace_child p n = Js.Opt.iter (p##firstChild) (fun c -> Dom.removeChild p c); Dom.appendChild p n let box_style = js"border: 1px black solid; background-color: white ; \ display: inline ; padding-right: .5em; padding-left: .5em;" let loading_style = js"background-color: red; color: white; display:inline; \ position: absolute; top:0; right:0;" let loading parent = let div = Html.createDiv document in div##style##cssText <- loading_style; append_text div "LOADING..."; Dom.appendChild parent div; (fun () -> Dom.removeChild parent div) let clock_div () = let t0 = ref (Sys.time ()) in let div = Html.createDiv document in div##style##cssText <- box_style; append_text div "--:--:--"; let stopped = ref true in let rec update_cb () = let dt = Sys.time () -. !t0 in if not !stopped then begin let txt = document##createTextNode (let secs = int_of_float dt in js (Printf.sprintf "%02d:%02d:%02d" (secs / 3600) ((secs / 60) mod 60) (secs mod 60))) in replace_child div txt end; Lwt_js.sleep 1. >>= fun () -> update_cb () in ignore (update_cb ()) ; (div, (fun () -> t0 := Sys.time () ; stopped := false), (fun () -> stopped := true)) type cell = Empty | Grass | Diamond | Boulder | Door | End | Guy | Wall | Bam and state = { map : cell array array ; imgs : Html.imageElement Js.t array array ; mutable pos : int * int ; mutable endpos : int * int ; mutable rem : int ; mutable dead : bool ; mutable map_mutex : Lwt_mutex.t ; mutable events_mutex : bool ; mutable pending_out_cb : (unit -> unit) option ref ; } exception Death let img_assoc v = match v with | Empty -> js"sprites/empty.png" | Bam -> js"sprites/bam.png" | Grass -> js"sprites/grass.png" | Diamond -> js"sprites/diamond.png" | Boulder -> js"sprites/boulder.png" | End -> js"sprites/end.png" | Door -> js"sprites/door.png" | Guy -> js"sprites/guy.png" | Wall -> js"sprites/wall.png" let set_cell state x y v = state.map.(y).(x) <- v ; state.imgs.(y).(x)##src <- img_assoc v let walkable = function | Empty | Grass | Diamond | End -> true | _-> false let rec fall state = (* assumes wall borders *) let changed = ref false in for y = Array.length state.map - 2 downto 1 do for x = 1 to Array.length state.map.(y) - 2 do let sustaining = state.map.(y + 1).(x) = Guy && state.map.(y).(x) = Boulder in if (state.map.(y).(x) = Empty && state.map.(y - 1).(x) = Boulder) then ( set_cell state x (y - 1) Empty ; set_cell state x y Boulder ; changed := true ) ; if (state.map.(y).(x) = Empty && state.map.(y - 1).(x) = Empty && state.map.(y).(x - 1) = Boulder && state.map.(y - 1).(x - 1) = Boulder) then ( set_cell state (x - 1) (y - 1) Empty ; set_cell state x y Boulder ; changed := true ) ; if (state.map.(y).(x) = Empty && state.map.(y - 1).(x) = Empty && state.map.(y).(x + 1) = Boulder && state.map.(y - 1).(x + 1) = Boulder) then ( set_cell state (x + 1) (y - 1) Empty ; set_cell state x y Boulder ; changed := true ) ; if (not sustaining) && state.map.(y + 1).(x) = Guy && state.map.(y).(x) = Boulder then ( set_cell state x (y + 1) Bam ; raise Death ) done done ; if !changed then begin Lwt_js.sleep 0.05 >>= fun () -> fall state end else Lwt.return () let rec build_interaction state show_rem ((_,_, clock_stop) as clock) = Lwt_mutex.lock state.map_mutex >>= fun () -> for y = 0 to Array.length state.map - 1 do for x = 0 to Array.length state.map.(y) - 1 do state.imgs.(y).(x)##onmouseover <- Html.no_handler; state.imgs.(y).(x)##onmouseout <- Html.no_handler; state.imgs.(y).(x)##onclick <- Html.no_handler done done ; let inhibit f _x = if not state.events_mutex then ignore (state.events_mutex <- true; f () >>= fun () -> state.events_mutex <- false; Lwt.return ()); Js._false in let set_pending_out f out () = f () >>= fun () -> state.pending_out_cb := Some out; Lwt.return () in let with_pending_out f () = match !(state.pending_out_cb) with | None -> f () | Some out -> out () ; state.pending_out_cb := None ; f () in let rec update (x, y) next img over_cont out_cont click_cont = if walkable state.map.(y).(x) then ( let cur_img = state.imgs.(y).(x)##src in let over () = state.imgs.(y).(x)##src <- img; over_cont () and out () = state.imgs.(y).(x)##src <- cur_img; out_cont () and click' () = click_cont () >>= fun () -> if state.map.(y).(x) = Diamond then state.rem <- state.rem - 1 ; set_cell state x y Guy ; Lwt_js.sleep 0.05 >>= fun () -> fall state >>= fun () -> set_cell state x y Empty; Lwt.return () in let click () = let gx, gy = state.pos in set_cell state gx gy Empty ; (Lwt.catch (fun () -> click_cont () >>= fun () -> if state.map.(y).(x) = Diamond then state.rem <- state.rem - 1 ; set_cell state x y Guy ; state.pos <- (x,y) ; fall state) (fun e -> match e with Death -> state.dead <- true; Lwt.return () | _ -> Lwt.fail e)) >>= fun () -> build_interaction state show_rem clock in state.imgs.(y).(x)##onmouseover <- Html.handler (inhibit (set_pending_out (with_pending_out over) out)) ; state.imgs.(y).(x)##onmouseout <- Html.handler (inhibit (with_pending_out (fun () -> Lwt.return ()))) ; state.imgs.(y).(x)##onclick <- Html.handler (inhibit (with_pending_out click)) ; if state.map.(y).(x) <> End then update (next (x,y)) next img over out click' ) in let update_push ((x, y) as pos) next img img_guy= let ((x', y') as pos') = next pos in let (x'', y'') = next pos' in if (try state.map.(y').(x') = Boulder && state.map.(y'').(x'') = Empty with Invalid_argument "index out of bounds" -> false) then ( let over () = state.imgs.(y).(x)##src <- img_guy; state.imgs.(y').(x')##src <- img; Lwt.return () in let out () = state.imgs.(y).(x)##src <- js"sprites/guy.png"; state.imgs.(y').(x')##src <- js"sprites/boulder.png" in let click () = set_cell state x y Empty ; set_cell state x' y' Guy ; state.pos <- pos' ; set_cell state x'' y'' Boulder ; Lwt.catch (fun () -> fall state) (fun e -> match e with Death -> state.dead <- true; Lwt.return () | e -> Lwt.fail e) >>= fun () -> build_interaction state show_rem clock in state.imgs.(y').(x')##onmouseover <- Html.handler (inhibit (set_pending_out (with_pending_out over) out)); state.imgs.(y').(x')##onmouseout <- Html.handler (inhibit (with_pending_out (fun () -> Lwt.return ()))); state.imgs.(y').(x')##onclick <- Html.handler (inhibit (with_pending_out click)) ) in if state.pos = state.endpos then ( clock_stop () ; Html.window##alert (js"YOU WIN !") ) else if state.dead then ( clock_stop () ; Html.window##alert (js"YOU LOSE !") ) else ( if state.rem = 0 then ( let x,y = state.endpos in state.imgs.(y).(x)##src <- js"sprites/end.png"; state.map.(y).(x) <- End ) ; let r (x, y) = succ x, y and l (x, y) = pred x, y in let u (x, y) = x, pred y and d (x, y) = x, succ y in let nil_cont () = () in let nil_cont_async () = Lwt.return () in update (r state.pos) r (js"sprites/R.png") nil_cont_async nil_cont nil_cont_async ; update (l state.pos) l (js"sprites/L.png") nil_cont_async nil_cont nil_cont_async ; update (u state.pos) u (js"sprites/U.png") nil_cont_async nil_cont nil_cont_async ; update (d state.pos) d (js"sprites/D.png") nil_cont_async nil_cont nil_cont_async ; update_push state.pos r (js"sprites/bR.png") (js"sprites/push_r.png") ; update_push state.pos l (js"sprites/bL.png") (js"sprites/push_l.png") ; show_rem state.rem ) ; Lwt_mutex.unlock state.map_mutex; Lwt.return () let opt_style e style = match style with Some s -> e##style##cssText <- s | None -> () let build_table ?style ?tr_style ?td_style f t = let m = Html.createTable document in opt_style m style; for y = 0 to Array.length t - 1 do let tr = m##insertRow (-1) in opt_style tr tr_style; for x = 0 to Array.length t.(y) - 1 do let td = tr##insertCell (-1) in opt_style td td_style; Dom.appendChild td (f y x t.(y).(x)); Dom.appendChild tr td done ; Dom.appendChild m tr done; m let http_get url = XmlHttpRequest.get url >>= fun r -> let cod = r.XmlHttpRequest.code in let msg = r.XmlHttpRequest.content in if cod = 0 || cod = 200 then Lwt.return msg else fst (Lwt.wait ()) let start _ = let body = Js.Opt.get (document##getElementById(js"boulderdash")) (fun () -> assert false) in let board_div = Html.createDiv document in let (clock_div,clock_start,_) as clock = clock_div () in let load_data name process = let loading_end = loading body in http_get name >>= fun data -> process data >>= fun res -> loading_end (); Lwt.return res in let rem_div, show_rem = let div = Html.createDiv document in div##style##cssText <- box_style; append_text div "--"; (div, fun v -> replace_child div (document##createTextNode (Js.string (string_of_int v)))) in load_data "maps.txt" (fun txt -> let find_string st = let sz = String.length txt in let rec find_string_start s = if s >= sz then failwith "eos" else if txt.[s] == '"' then find_string_end (s + 1) (s + 2) else find_string_start (s + 1) and find_string_end s e = if s >= sz then failwith "eos" else if txt.[e] == '"' then (String.sub txt s (e - s), e + 1) else find_string_end s (e + 1) in find_string_start st in let rec scan_pairs st acc = match try let fst, st = find_string st in let snd, st = find_string st in Some ((fst, snd), st) with Failure "eos" -> None with | Some (elt, st) -> scan_pairs st (elt :: acc) | None -> acc in Lwt.return (List.rev (scan_pairs 0 []))) >>= fun levels -> let load_level file = load_data file (fun data -> let map, cells = let res = ref [] and row = ref [] in for i = 0 to String.length data - 1 do match data.[i] with | '\n' -> res := List.rev (!row) :: !res ; row := [] | '#' -> row := Wall :: !row | '.' -> row := Grass :: !row | ' ' -> row := Empty :: !row | '+' -> row := Diamond :: !row | 'X' -> row := Boulder :: !row | 'W' -> row := Guy :: !row | 'E' -> row := Door :: !row | 'S' -> row := Guy :: !row | _ -> failwith "malformed level" done ; let map = Array.of_list (List.map Array.of_list (List.rev !res)) in map, Array.map (Array.map (fun c -> let img = Html.createImg document in img##src <- img_assoc c; img)) map in let gx = ref 0 and gy = ref 0 and ex = ref 0 and ey = ref 0 and rem = ref 0 in let style = js"border-collapse:collapse;line-height: 0; opacity: 0; \ margin-left:auto; margin-right:auto" in let td_style = js"padding: 0; width: 20px; height: 20px;" in let table = build_table ~style ~td_style (fun y x cell -> begin match map.(y).(x) with | Guy -> gx := x ; gy := y | Diamond -> incr rem | Door -> ex := x ; ey := y | _ -> () end; cell) cells in replace_child board_div table; build_interaction { map = map; imgs = cells ; pos = (!gx, !gy) ; endpos = (!ex, !ey) ; map_mutex = Lwt_mutex.create () ; events_mutex = false ; dead = false ; rem = !rem ; pending_out_cb = ref None } show_rem clock >>= fun () -> let t0 = Sys.time () in let rec fade () = let t = Sys.time () in if t -. t0 >= 1. then ( table##style##opacity <- Js.def (js"1"); Lwt.return () ) else ( Lwt_js.sleep 0.05 >>= fun () -> table##style##opacity <- Js.def (js (Printf.sprintf "%g" (t -. t0))) ; fade () ) in fade () >>= fun () -> clock_start (); Lwt.return () ) in body##style##cssText <- js"font-family: sans-serif; text-align: center; \ background-color: #e8e8e8;" ; let h1 = Html.createH1 document in append_text h1 "Boulder Dash in Ocaml"; Dom.appendChild body h1; let div = Html.createDiv document in append_text div "Elapsed time: "; Dom.appendChild div clock_div; append_text div " Remaining diamonds: "; Dom.appendChild div rem_div; append_text div " "; let select = Html.createSelect document in let option = Html.createOption document in append_text option "Choose a level"; Dom.appendChild select option; List.iter (fun (f, n) -> let option = Html.createOption document in append_text option n; (* option##onclick <- some (fun _ -> ignore (load_level f); Js._false); *) Dom.appendChild select option) levels; select##onchange <- Html.handler (fun _ -> let i = select##selectedIndex - 1 in if i >= 0 && i < List.length levels then ignore (load_level (fst (List.nth levels i))); Js._false); Dom.appendChild div select; Dom.appendChild div (Html.createBr document); Dom.appendChild div (Html.createBr document); Dom.appendChild div board_div; Dom.appendChild body div; Lwt.return () let _ = Html.window##onload <- Html.handler (fun _ -> ignore (start ()); Js._false)