open Core open Graphics (* ****************** *) (* The user interface *) (* ****************** *) exception Exit_judge module UI (C : CORE) : sig val init : unit -> unit val close : unit -> unit val handle_events : unit -> unit val display : unit -> unit end = struct module G = C.G (* Graphic helpers *) let grey = rgb 112 112 112 let red = rgb 200 0 0 let green = rgb 0 150 0 let center () = size_x () / 2, size_y () / 2 let fullscreen_msg m = clear_graph(); let tx, ty = text_size m in let cx, cy = center () in let w, h = tx/2, ty/2 in set_color black; let cr d = draw_rect (cx - w - d) (cy - h - d) (2 * (w + d)) (2 * (h + d)) in cr 20; cr 22; moveto (cx - w) (cy - h); draw_string m; synchronize () let tw m = fst (text_size m) let text_l l x c m = set_color c; moveto x (size_y() - ((l+1) * 20)); draw_string m let text1 l c m = text_l l 30 c m let text2 l c m = text_l l (size_x()/2 - 30 - tw m) c m let text3 l c m = text_l l (size_x()/2 + 30) c m let text4 l c m = text_l l (size_x() - 30 - tw m) c m let hl () = draw_poly_line [| 10, size_y() - 50; size_x() - 10, size_y() - 50 |] (* Init/Close *) let init () = open_graph " 800x600"; set_font "-misc-fixed-bold-r-normal--15-120-90--c-90-iso8859-1"; auto_synchronize false; display_mode false; remember_mode true; fullscreen_msg "Starting up..." let close () = close_graph () (* View types *) type view = | ScoreBoard | MatchList of bool | ViewGame of C.game | Question of string * (unit -> unit) * view let rec handle_events () = while key_pressed () do match !curr_view, read_key() with | ScoreBoard, '\t' -> curr_view := MatchList false | MatchList _, '\t' -> curr_view := ScoreBoard | MatchList e, 'f' -> curr_view := MatchList (not e) | MatchList _, 'r' -> curr_view := Question( "Launch new round?", (fun () -> C.add_rounds(); curr_view := MatchList false), !curr_view ) | Question(_, y, n), 'y' -> y() | Question(_, y, n), 'n' -> curr_view := n | v, 'q' -> curr_view := Question( "Really quit?", (fun () -> fullscreen_msg "Exiting..."; raise Exit_judge), v) | _ -> () done and display () = clear_graph (); begin match !curr_view with | ScoreBoard -> scoreboard_disp () | MatchList f -> matchlist_disp f | ViewGame g -> game_disp g | Question (q, _, _) -> fullscreen_msg (q ^ " (y/n)") end; synchronize () and curr_view = ref ScoreBoard (* Scoreboard view *) and scoreboard_disp () = text1 1 black "score board"; text4 1 grey "match list >"; hl(); let scores = List.sort (fun (_, sc) (_, sc') -> sc' - sc) (C.scores()) in let show_sc i (n, s) = text2 (i+4) black (string_of_int (i+1)^". "); text3 (i+4) black n; text4 (i+4) black (string_of_int s) in List.iteri show_sc scores (* Match list view *) and matchlist_disp show_only_running = text1 1 black "match list"; text2 1 black "queued matches:"; text3 1 black (string_of_int (C.ql ())); text4 1 grey "score board >"; hl(); let games = if show_only_running then List.filter (fun g -> match C.p1 g, C.p2 g with Dead, Dead -> false | _ -> true) (C.games()) else C.games() in let time = Unix.gettimeofday() in let print_g i g = let cp1, cp2 = match C.s g with | TurnOf _ -> black, black | Won P1 -> green, red | Won P2 -> red, green | Tie -> grey, grey | Eliminated P1 -> red, grey | Eliminated P2 -> grey, red in let mp = function | Loading -> grey, ">>>" | Saving -> grey, "<<<" | Dead -> black, "" | StandBy t -> grey, Format.sprintf "%.2f" t | Thinking (t, tb) -> black, Format.sprintf "[ %.2f ]" (t -. (time -. tb)) in let p1n, p2n = C.pn g in let c, m = mp (C.p1 g) in text1 (i+4) c m; text2 (i+4) cp1 p1n; text3 (i+4) cp2 p2n; let c, m = mp (C.p2 g) in text4 (i+4) c m in List.iteri print_g games (* Game view *) and game_disp g = (* TODO *) () end (* ************* *) (* The main loop *) (* ************* *) module Juge (C : CORE) : sig val run : unit -> unit end = struct module UI = UI(C) let run () = C.init(); UI.init(); begin try while true do C.handle_events (); UI.handle_events (); UI.display () done with Exit_judge -> C.finish (); UI.close () end end