├── README.md ├── calc ├── README.md ├── back │ ├── dune │ └── server.ml ├── calc.html ├── compile.sh ├── front │ ├── calc.ml │ └── dune └── proto │ ├── dune │ └── protocol.atd ├── count ├── compile.sh ├── count.html ├── count.ml └── dune ├── counter ├── compile.sh ├── counter.html ├── counter.ml └── dune ├── counters ├── compile.sh ├── counters.html ├── counters.ml └── dune ├── login ├── compile.sh ├── dune ├── login.html └── login.ml ├── signup ├── compile.sh ├── dune ├── signup.html └── signup.ml ├── tic-tac-toe ├── README.md ├── compile.sh ├── dune ├── ttt.css ├── ttt.html ├── ttt.ml ├── ttt_history.html ├── ttt_history.ml └── util.ml └── timer ├── compile.sh ├── dune ├── timer.html └── timer.ml /README.md: -------------------------------------------------------------------------------- 1 | Experiments with [Daniel Bünzli](https://erratique.ch/profile)'s 2 | [Brr](https://github.com/dbuenzli/brr). 3 | -------------------------------------------------------------------------------- /calc/README.md: -------------------------------------------------------------------------------- 1 | Talk to an http server to add two integers. 2 | -------------------------------------------------------------------------------- /calc/back/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name server) 3 | (preprocess (pps lwt_ppx)) 4 | (libraries cohttp-lwt-unix atdgen proto) 5 | ) 6 | -------------------------------------------------------------------------------- /calc/back/server.ml: -------------------------------------------------------------------------------- 1 | open Cohttp 2 | open Cohttp_lwt_unix 3 | 4 | module P = Proto.Protocol_j 5 | module SS = Set.Make(String) 6 | type state = SS.t 7 | 8 | (* deal with CORS, if we have to *) 9 | let add_access_control request response_headers = 10 | let request_headers = Request.headers request in 11 | match Header.get request_headers "Origin" with 12 | | Some origin -> 13 | let h = [ 14 | (* allow the origin, in lieu of responding with just 15 | wildcard "*" *) 16 | "Access-Control-Allow-Origin", origin; 17 | 18 | (* also allow credentials, in case request was made with 19 | "withCredentials = true" *) 20 | "Access-Control-Allow-Credentials", "true" 21 | ] in 22 | 23 | Header.add_list response_headers h 24 | 25 | | _ -> response_headers 26 | 27 | let server () = 28 | let mode = `TCP (`Port 8888) in 29 | let state_0 = SS.empty in 30 | let state_mvar = Lwt_mvar.create state_0 in 31 | 32 | let callback _conn req body = 33 | let headers = Header.init () in 34 | let not_found = `Not_found, "", headers in 35 | 36 | let%lwt (status, body, headers) = 37 | match Request.meth req with 38 | | `POST -> ( 39 | let%lwt body_s = Cohttp_lwt.Body.to_string body in 40 | try 41 | let f2b = P.front_to_back_of_string body_s in 42 | let%lwt state = Lwt_mvar.take state_mvar in 43 | let state, response = 44 | match f2b with 45 | | `NewSession -> 46 | let session = Int64.to_string (Random.int64 Int64.max_int) in 47 | let state = SS.add session state in 48 | state, `NewSession session 49 | 50 | | `Add (session, (a, b)) -> 51 | match SS.find_opt session state with 52 | | None -> state, `InvalidSession 53 | | Some _ -> state, `Add (a + b) 54 | in 55 | let%lwt () = Lwt_mvar.put state_mvar state in 56 | let b2f = P.string_of_back_to_front response in 57 | let headers = add_access_control req headers in 58 | Lwt.return (`OK, b2f, headers) 59 | 60 | with 61 | | Yojson.Json_error err_msg 62 | | Atdgen_runtime__Oj_run.Error err_msg -> 63 | let response_headers = Header.add headers 64 | "content-type" "text/plain" in 65 | let body = "Error: " ^ err_msg in 66 | Lwt.return (`OK, body, response_headers) 67 | ) 68 | 69 | | _ -> 70 | Lwt.return not_found 71 | in 72 | 73 | Server.respond_string ~headers ~status ~body () 74 | in 75 | 76 | Server.create ~mode (Server.make ~callback ()) 77 | 78 | let _ = 79 | (* see https://github.com/mirage/ocaml-cohttp/issues/511 *) 80 | Lwt.async_exception_hook := ignore; 81 | ignore (Lwt_main.run (server ())) 82 | 83 | -------------------------------------------------------------------------------- /calc/calc.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /calc/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build front/calc.bc.js 4 | dune build back/server.exe 5 | -------------------------------------------------------------------------------- /calc/front/calc.ml: -------------------------------------------------------------------------------- 1 | module Http = struct 2 | open Js_of_ocaml 3 | 4 | (* request are in the payload of body of a HTTP POST; replies are in 5 | the body of a POST's response *) 6 | let do_post ~url ~request send = 7 | let req = XmlHttpRequest.create() in 8 | req##_open (Js.string "post") (Js.string url) Js._true; 9 | 10 | let callback _ = 11 | match req##.readyState with 12 | | XmlHttpRequest.DONE -> ( 13 | match Js.Opt.to_option req##.responseText with 14 | | None -> () 15 | | Some s -> send (Js.to_string s) 16 | ) 17 | | _ -> () 18 | in 19 | req##.onreadystatechange := Js.wrap_callback callback; 20 | req##send (Js.some (Js.string request)) 21 | 22 | open Note 23 | 24 | let req url request = 25 | let response, send = E.create () in 26 | do_post ~url ~request send; 27 | response 28 | 29 | end 30 | 31 | open Note 32 | 33 | module P = Proto.Protocol_j 34 | 35 | module Protocol = struct 36 | 37 | let url = "http://localhost:8888/" 38 | 39 | let req : P.front_to_back -> P.back_to_front event = 40 | fun request -> 41 | let request_p = P.string_of_front_to_back request in 42 | let response_p = Http.req url request_p in 43 | E.map P.back_to_front_of_string response_p 44 | 45 | end 46 | 47 | module Adder : sig 48 | val create : (int * int) event -> int event 49 | end = 50 | struct 51 | type state = { 52 | session : P.session option; 53 | adds : (int * int) list 54 | } 55 | 56 | let add_add add adds = List.rev (add :: List.rev adds) 57 | let rem_add adds = match adds with [] -> [] | _ :: adds -> adds 58 | 59 | let do_add_add : state -> int * int -> state = 60 | fun s add -> { s with adds = add_add add s.adds} 61 | 62 | let do_req : state -> state * P.back_to_front event = 63 | fun s -> match s.session with 64 | | None -> s, (Protocol.req `NewSession) 65 | | Some _ when s.adds = [] -> s, E.never 66 | | Some session -> s, Protocol.req (`Add (session, List.hd s.adds)) 67 | 68 | let do_resp : state -> P.back_to_front -> state * int option = 69 | fun s resp -> match resp with 70 | | `Add i -> { s with adds = rem_add s.adds}, Some i 71 | | `NewSession session -> { s with session = Some session }, None 72 | | `InvalidSession -> { s with session = None }, None 73 | 74 | let create add_ev = 75 | let init = { session = None; adds = [] } in 76 | let def s = 77 | let do_req = E.map do_req (S.changes s) in 78 | let resp = E.join (E.Pair.snd do_req) in 79 | let do_resp = S.sample s ~on:resp do_resp in 80 | let result = E.Option.on_some @@ E.Pair.snd do_resp in 81 | let s'0 = E.Pair.fst do_req in 82 | let s'1 = E.Pair.fst do_resp in 83 | let s'2 = S.sample s ~on:add_ev do_add_add in 84 | let s' = S.hold init (E.select [s'0; s'1; s'2]) in 85 | s', (s', result) 86 | in 87 | let s, result = S.fix init def in 88 | Logr.hold (S.log s (fun _ -> ())); 89 | result 90 | end 91 | 92 | open Brr 93 | open Brr_note 94 | 95 | let v = Jstr.v 96 | 97 | let main root = 98 | let arg1 = El.input () in 99 | let arg2 = El.input () in 100 | let sum_el = El.span [] in 101 | let sum_button = El.(button [txt' "sum"]) in 102 | let table = El.table [ 103 | El.tr [El.(td [txt' "arg 1:"; arg1 ])]; 104 | El.tr [El.(td [txt' "arg 2:"; arg2 ])]; 105 | El.tr [El.td [sum_button; sum_el]]; 106 | ] in 107 | El.set_children root [table]; 108 | 109 | let int_of_value el = 110 | int_of_string (Jstr.to_string (El.prop El.Prop.value el)) 111 | in 112 | 113 | let get_args _ = 114 | try 115 | let arg1_i = int_of_value arg1 in 116 | let arg2_i = int_of_value arg2 in 117 | Some (arg1_i, arg2_i) 118 | with Failure _ -> 119 | None 120 | in 121 | 122 | let add_opt_ev = Evr.on_el Ev.click get_args sum_button in 123 | let add_ev = E.Option.on_some add_opt_ev in 124 | 125 | let sum_e = Adder.create add_ev in 126 | let sum_txt = E.map (fun i -> [El.txt' (string_of_int i)]) sum_e in 127 | Elr.set_children sum_el ~on:sum_txt 128 | 129 | 130 | let () = 131 | let id = "root" in 132 | match Document.find_el_by_id G.document (v id) with 133 | | None -> Console.(info [str (Printf.sprintf "element %S not found" id)]) 134 | | Some root -> 135 | main root 136 | -------------------------------------------------------------------------------- /calc/front/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name calc) 3 | (libraries js_of_ocaml brr.note proto) 4 | (preprocess (pps js_of_ocaml-ppx)) 5 | ) 6 | 7 | -------------------------------------------------------------------------------- /calc/proto/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name proto) 3 | (libraries atdgen) 4 | ) 5 | 6 | (rule 7 | (targets protocol_j.ml protocol_j.mli) 8 | (deps protocol.atd) 9 | (action (run atdgen -j -j-std %{deps}))) 10 | 11 | (rule 12 | (targets protocol_t.ml protocol_t.mli) 13 | (deps protocol.atd) 14 | (action (run atdgen -t %{deps}))) 15 | -------------------------------------------------------------------------------- /calc/proto/protocol.atd: -------------------------------------------------------------------------------- 1 | type session = string 2 | 3 | type front_to_back = [ 4 | | NewSession 5 | | Add of (session * (int * int)) 6 | ] 7 | 8 | type back_to_front = [ 9 | | NewSession of session 10 | | Add of int 11 | | InvalidSession 12 | ] 13 | -------------------------------------------------------------------------------- /count/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build count.bc.js 4 | -------------------------------------------------------------------------------- /count/count.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |
7 | 8 | 9 | -------------------------------------------------------------------------------- /count/count.ml: -------------------------------------------------------------------------------- 1 | open Note 2 | open Brr 3 | open Brr_note 4 | 5 | let v = Jstr.v 6 | 7 | let main id = 8 | match Document.find_el_by_id G.document (v id) with 9 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 10 | | Some root -> 11 | let incr_button = El.(button [txt' "click me"]) in 12 | 13 | let incr x = x + 1 in 14 | let incr_e = Evr.on_el Ev.click (fun _ -> incr) incr_button in 15 | let counter_s = S.accum 0 incr_e in 16 | let message_s = S.map ( 17 | fun count -> 18 | [El.txt' (Printf.sprintf "you clicked %d times" count)] 19 | ) counter_s in 20 | 21 | let p = El.p [] in 22 | Elr.def_children p message_s; 23 | 24 | let d = El.div [p; incr_button] in 25 | El.set_children root [d] 26 | 27 | let () = main "root" 28 | -------------------------------------------------------------------------------- /count/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name count) 3 | (libraries js_of_ocaml brr.note) 4 | ) 5 | 6 | -------------------------------------------------------------------------------- /counter/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build counter.bc.js 4 | -------------------------------------------------------------------------------- /counter/counter.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |
7 | 8 | 9 | -------------------------------------------------------------------------------- /counter/counter.ml: -------------------------------------------------------------------------------- 1 | open Note 2 | open Brr 3 | open Brr_note 4 | 5 | let v = Jstr.v 6 | 7 | let main id = 8 | match Document.find_el_by_id G.document (v id) with 9 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 10 | | Some el -> 11 | let decr_button = El.(button [txt' "-"]) in 12 | let incr_button = El.(button [txt' "+"]) in 13 | 14 | let incr x = x + 1 in 15 | let decr x = x - 1 in 16 | 17 | let decr_e = Evr.on_el Ev.click (fun _ -> decr) decr_button in 18 | let incr_e = Evr.on_el Ev.click (fun _ -> incr) incr_button in 19 | 20 | let decr_incr_e = E.select [decr_e; incr_e] in 21 | let counter_s = S.accum 0 decr_incr_e in 22 | 23 | let children_s = S.map ( 24 | fun count -> [ 25 | decr_button; 26 | El.txt' (string_of_int count); 27 | incr_button 28 | ] 29 | ) counter_s in 30 | 31 | Elr.def_children el children_s 32 | 33 | let () = main "root" 34 | -------------------------------------------------------------------------------- /counter/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name counter) 3 | (libraries js_of_ocaml brr.note) 4 | ) 5 | 6 | -------------------------------------------------------------------------------- /counters/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build counters.bc.js 4 | -------------------------------------------------------------------------------- /counters/counters.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 |
8 | 9 | 10 | -------------------------------------------------------------------------------- /counters/counters.ml: -------------------------------------------------------------------------------- 1 | open Note 2 | open Brr 3 | open Brr_note 4 | 5 | module Counter : sig 6 | type t 7 | val create : unit -> t 8 | val incr : t -> t 9 | val decr : t -> t 10 | val value : t -> int 11 | end = struct 12 | type t = int 13 | let create () = 0 14 | let incr = succ 15 | let decr = pred 16 | let value x = x 17 | end 18 | 19 | module Counters : sig 20 | type t 21 | 22 | type idx = int 23 | val empty : t 24 | val count : t -> int 25 | val add : Counter.t -> t -> t 26 | val update : int -> by:(Counter.t -> Counter.t option) -> t -> t 27 | val foldi : (int -> Counter.t -> 'a -> 'a) -> t -> 'a -> 'a 28 | end = struct 29 | type t = Counter.t list 30 | type idx = int 31 | let empty = [] 32 | let count = List.length 33 | let add c cs = c :: cs 34 | let update i ~by cs = 35 | let rec loop k left = function 36 | | [] -> invalid_arg (Printf.sprintf "No counter identified by %d" i) 37 | | c :: cs when i <> k -> loop (k + 1) (c :: left) cs 38 | | c :: cs -> 39 | match by c with 40 | | None -> List.rev_append left cs 41 | | Some c -> List.rev_append (c :: left) cs 42 | in 43 | loop 0 [] cs 44 | 45 | let foldi f cs acc = 46 | let rec loop f i acc = function 47 | | [] -> acc 48 | | c :: cs -> loop f (i + 1) (f i c acc) cs 49 | in 50 | loop f 0 acc cs 51 | end 52 | 53 | type counter_action = [ 54 | | `Incr 55 | | `Decr 56 | | `Delete 57 | ] 58 | 59 | let counter_ui : 60 | label:Jstr.t -> Counter.t -> counter_action event * El.t = 61 | fun ~label counter -> 62 | let label = El.span [El.txt label] in 63 | let decr_button = El.button [El.txt' "-"] in 64 | let incr_button = El.button [El.txt' "+"] in 65 | let delete_button = El.button [El.txt' "x"] in 66 | let value = El.span [El.txt' (string_of_int (Counter.value counter))] in 67 | let el = El.div [label; decr_button; value; incr_button; delete_button] in 68 | let decr = Evr.on_el Ev.click (Evr.stamp `Decr) decr_button in 69 | let incr = Evr.on_el Ev.click (Evr.stamp `Incr) incr_button in 70 | let delete = Evr.on_el Ev.click (Evr.stamp `Delete) delete_button in 71 | let action = E.select [decr; incr; delete] in 72 | action, el 73 | 74 | type counters_action = [ 75 | | `Add 76 | | `Update of Counters.idx * counter_action 77 | ] 78 | 79 | let counters_ui : Counters.t -> counters_action event * El.t = 80 | fun cs -> 81 | let cs_count = Counters.count cs in 82 | let counter_ui i c (actions, els) = 83 | let action, el = counter_ui ~label:(Jstr.of_int (cs_count - i)) c in 84 | let action = E.map (fun act -> i, act) action (* remember index *) in 85 | (action :: actions, el :: els) 86 | in 87 | let actions, els = Counters.foldi counter_ui cs ([], []) in 88 | let update = E.map (fun act -> `Update act) (E.select actions) in 89 | let add_button = El.button [El.txt' "Add counter"] in 90 | let add = Evr.on_el Ev.click (Evr.stamp `Add) add_button in 91 | E.select [add; update], El.div [add_button; El.div (List.rev els)] 92 | 93 | let update_counters : counters_action -> Counters.t -> Counters.t = 94 | fun action cs -> match action with 95 | | `Add -> Counters.add (Counter.create ()) cs 96 | | `Update (idx, action) -> 97 | let action c = match action with 98 | | `Incr -> Some (Counter.incr c) 99 | | `Decr -> Some (Counter.decr c) 100 | | `Delete -> None 101 | in 102 | Counters.update idx ~by:action cs 103 | 104 | let ui cs = 105 | let def cs = 106 | let counters_ui = S.map ~eq:( == ) counters_ui cs in 107 | let action = S.Pair.fst ~eq:( == ) counters_ui in 108 | let el = S.Pair.snd ~eq:( == ) counters_ui in 109 | let update = E.swap action in 110 | let do_action = E.map update_counters update in 111 | let cs' = S.accum (S.value cs) do_action in 112 | cs', (cs', el) 113 | in 114 | S.fix cs def 115 | 116 | let v = Jstr.v 117 | 118 | let main id = 119 | match Document.find_el_by_id G.document (v id) with 120 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 121 | | Some el -> 122 | let cs, ui_el = ui Counters.empty in 123 | Logr.hold (S.log cs (fun _ -> ())); 124 | Elr.def_children el (S.map (fun el -> [el]) ui_el) 125 | 126 | let () = main "root" 127 | -------------------------------------------------------------------------------- /counters/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name counters) 3 | (libraries js_of_ocaml brr.note) 4 | ) 5 | 6 | -------------------------------------------------------------------------------- /login/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build login.bc.js 4 | -------------------------------------------------------------------------------- /login/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name login) 3 | (libraries js_of_ocaml brr) 4 | ) 5 | 6 | -------------------------------------------------------------------------------- /login/login.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |
7 | 8 | 9 | -------------------------------------------------------------------------------- /login/login.ml: -------------------------------------------------------------------------------- 1 | open Brr 2 | 3 | let v = Jstr.v 4 | 5 | let main id = 6 | match Document.find_el_by_id G.document (v id) with 7 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 8 | | Some el -> 9 | let email = El.input ~at:[At.placeholder (v "email")] () in 10 | 11 | let password = 12 | let at = [At.type' (v "password"); At.placeholder (v "password")] in 13 | El.input ~at () 14 | in 15 | 16 | let submit_button = 17 | let at = [At.type' (v "submit")] in 18 | El.input ~at () 19 | in 20 | 21 | let table = El.table [ 22 | El.tr [El.td [email]]; 23 | El.tr [El.td [password]]; 24 | El.tr [El.td [submit_button]] 25 | 26 | ] in 27 | 28 | El.set_children el [table] 29 | 30 | let () = main "root" 31 | -------------------------------------------------------------------------------- /signup/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build signup.bc.js 4 | -------------------------------------------------------------------------------- /signup/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name signup) 3 | (libraries js_of_ocaml brr.note) 4 | ) 5 | 6 | -------------------------------------------------------------------------------- /signup/signup.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |
7 | 8 | 9 | -------------------------------------------------------------------------------- /signup/signup.ml: -------------------------------------------------------------------------------- 1 | (* allow user to choose between logging in and resetting password *) 2 | 3 | open Brr 4 | open Brr_note 5 | 6 | let v = Jstr.v 7 | 8 | let login = 9 | let email = El.input ~at:[At.placeholder (v "email")] () in 10 | 11 | let password = 12 | let at = [At.type' (v "password"); At.placeholder (v "password")] in 13 | El.input ~at () 14 | in 15 | 16 | let submit_button = 17 | let at = [At.type' (v "submit"); At.value (v "login")] in 18 | El.input ~at () 19 | in 20 | 21 | let reset_link = El.a ~at:[At.href (v "#")] [El.txt' "forgot password?"] in 22 | let click_reset = Evr.on_el Ev.click (fun _ -> `Reset) reset_link in 23 | 24 | let table = El.table [ 25 | El.tr [El.td [email]]; 26 | El.tr [El.td [password]]; 27 | El.tr [El.td [submit_button; reset_link]] 28 | 29 | ] in 30 | table, click_reset 31 | 32 | let reset = 33 | let email = El.input ~at:[At.placeholder (v "email")] () in 34 | 35 | let submit_button = 36 | let at = [At.type' (v "submit"); At.value (v "reset")] in 37 | El.input ~at () 38 | in 39 | 40 | let login_link = El.a ~at:[At.href (v "#")] [El.txt' "login"] in 41 | let click_login = Evr.on_el Ev.click (fun _ -> `Login) login_link in 42 | 43 | let table = El.table [ 44 | El.tr [El.td [email]]; 45 | El.tr [El.td [submit_button; login_link]] 46 | 47 | ] in 48 | table, click_login 49 | 50 | 51 | let main id = 52 | match Document.find_el_by_id G.document (v id) with 53 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 54 | | Some el -> 55 | let login_el, click_reset = login in 56 | let reset_el, click_login = reset in 57 | 58 | let open Note in 59 | let reset_or_login_s = S.hold `Login (E.select [click_reset; click_login]) in 60 | let children_s = S.map ( 61 | function 62 | | `Reset -> [reset_el] 63 | | `Login -> [login_el] 64 | ) reset_or_login_s in 65 | 66 | Elr.def_children el children_s 67 | 68 | 69 | let () = main "root" 70 | -------------------------------------------------------------------------------- /tic-tac-toe/README.md: -------------------------------------------------------------------------------- 1 | Implementation of tic-tac-toe game using 2 | [Brr](https://github.com/dbuenzli/brr). Actually, two implementations: 3 | 4 | * ttt.ml: simple 5 | * ttt_history.ml: with support for time traveling 6 | -------------------------------------------------------------------------------- /tic-tac-toe/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build ttt.bc.js 4 | dune build ttt_history.bc.js 5 | -------------------------------------------------------------------------------- /tic-tac-toe/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names ttt ttt_history) 3 | (libraries js_of_ocaml brr.note) 4 | ) 5 | 6 | -------------------------------------------------------------------------------- /tic-tac-toe/ttt.css: -------------------------------------------------------------------------------- 1 | /* copied from https://codepen.io/gaearon/pen/gWWZgR */ 2 | body { 3 | font: 14px "Century Gothic", Futura, sans-serif; 4 | margin: 20px; 5 | } 6 | 7 | ol, ul { 8 | padding-left: 30px; 9 | } 10 | 11 | .board-row:after { 12 | clear: both; 13 | content: ""; 14 | display: table; 15 | } 16 | 17 | .status { 18 | margin-bottom: 10px; 19 | } 20 | 21 | .square { 22 | background: #fff; 23 | border: 1px solid #999; 24 | float: left; 25 | font-size: 24px; 26 | font-weight: bold; 27 | line-height: 34px; 28 | height: 34px; 29 | margin-right: -1px; 30 | margin-top: -1px; 31 | padding: 0; 32 | text-align: center; 33 | width: 34px; 34 | } 35 | 36 | .square:focus { 37 | outline: none; 38 | } 39 | 40 | .kbd-navigation .square:focus { 41 | background: #ddd; 42 | } 43 | 44 | .game { 45 | display: flex; 46 | flex-direction: row; 47 | } 48 | 49 | .game-info { 50 | margin-left: 20px; 51 | } 52 | -------------------------------------------------------------------------------- /tic-tac-toe/ttt.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 |
8 | 9 | 10 | -------------------------------------------------------------------------------- /tic-tac-toe/ttt.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type player = X | O 4 | 5 | type field = 6 | | Empty 7 | | Marked of player 8 | 9 | type turn = 10 | | Playing of player 11 | | Winner of player 12 | | Draw 13 | 14 | type t = { 15 | board : field IntMap.t; 16 | turn : turn; 17 | } 18 | 19 | let empty = { 20 | board = Seq.fold_left (fun board i -> IntMap.add i Empty board) IntMap.empty (range 9); 21 | turn = Playing X; 22 | } 23 | 24 | let winning_combinations = [ 25 | 0, 1, 2; 26 | 3, 4, 5; 27 | 6, 7, 8; 28 | 0, 3, 6; 29 | 1, 4, 7; 30 | 2, 5, 8; 31 | 0, 4, 8; 32 | 2, 4, 6; 33 | ] 34 | 35 | let winner board = 36 | try 37 | let i, _j, _k = List.find ( 38 | fun (i, j, k) -> 39 | match get board i, get board j, get board k with 40 | | Marked X, Marked X, Marked X 41 | | Marked O, Marked O, Marked O -> true 42 | | _ -> false 43 | ) winning_combinations in 44 | match get board i with 45 | | Marked player -> Some player 46 | | _ -> assert false 47 | with Not_found -> 48 | None 49 | 50 | let is_draw board = 51 | IntMap.fold ( 52 | fun _ field all -> 53 | all && (match field with Marked _ -> true | Empty -> false) 54 | ) board true 55 | 56 | 57 | let next_player = function 58 | | X -> O 59 | | O -> X 60 | 61 | let string_of_turn = function 62 | | Playing X -> "next player: X" 63 | | Playing O -> "next player: O" 64 | | Winner X -> "winner: X" 65 | | Winner O -> "winner: O" 66 | | Draw -> "draw" 67 | 68 | open Note 69 | open Brr 70 | open Brr_note 71 | 72 | let at1 c = 73 | [At.class' (v c)] 74 | 75 | let txt_of_turn gs = 76 | [El.txt' (string_of_turn gs)] 77 | 78 | let cell idx = 79 | let el = El.button ~at:(at1 "square") [] in 80 | let ev = Evr.on_el Ev.click (fun _ -> idx) el in 81 | el, ev 82 | 83 | let row start_idx = 84 | let b0, e0 = cell (start_idx ) in 85 | let b1, e1 = cell (start_idx + 1) in 86 | let b2, e2 = cell (start_idx + 2) in 87 | let el = El.div ~at:(at1 "board-row") [b0; b1; b2] in 88 | el, b0, b1, b2, E.select [e0; e1; e2] 89 | 90 | let square () = 91 | let r0, b0, b1, b2, ev012 = row 0 in 92 | let r1, b3, b4, b5, ev345 = row 3 in 93 | let r2, b6, b7, b8, ev678 = row 6 in 94 | let el = El.div ~at:(at1 "game-board") [r0; r1; r2] in 95 | let ev = E.select [ev012; ev345; ev678] in 96 | let ev_w = E.map (fun idx -> `Mark idx) ev in 97 | let cells = [| b0; b1; b2; b3; b4; b5; b6; b7; b8 |] in 98 | el, ev_w, cells 99 | 100 | let update msg t = 101 | match msg with 102 | | `NewGame -> empty 103 | | `Mark idx -> 104 | match get t.board idx with 105 | | Empty -> ( 106 | match t.turn with 107 | | Playing player -> 108 | let board = IntMap.add idx (Marked player) t.board in 109 | let turn = 110 | if is_draw board then 111 | Draw 112 | else 113 | match winner board with 114 | | None -> Playing (next_player player) 115 | | Some winner -> Winner winner 116 | in 117 | { turn; board } 118 | | Draw 119 | | Winner _ -> t 120 | ) 121 | | Marked _ -> t 122 | 123 | let cell_txt = function 124 | | Empty -> [ ] 125 | | Marked X -> [El.txt' "X"] 126 | | Marked O -> [El.txt' "O"] 127 | 128 | let ui () = 129 | let new_game = El.button [El.txt' "new game"] in 130 | let new_game_ev = Evr.on_el Ev.click (fun _ -> `NewGame) new_game in 131 | let sq, ev_idx, cells = square () in 132 | let ev = E.select [new_game_ev; ev_idx] in 133 | 134 | let update_idx = E.map update ev in 135 | let t_ev = E.accum empty update_idx in 136 | let t_s = S.hold empty t_ev in 137 | let board_s = S.map (fun { board; _ } -> board) t_s in 138 | let turn_s = S.map (fun { turn; _} -> turn) t_s in 139 | let cell_s i = S.map (fun board -> get board i) board_s in 140 | let cell_s_seq = Seq.map cell_s (range 9) in 141 | let cell_s_arr = Array.of_seq cell_s_seq in 142 | Array.iteri ( 143 | fun i cell_s -> 144 | let cell_txt_s = S.map cell_txt cell_s in 145 | Elr.def_children cells.(i) cell_txt_s 146 | ) cell_s_arr; 147 | 148 | let turn_txt_s = S.map txt_of_turn turn_s in 149 | let game_outcome = El.div [] in 150 | Elr.def_children game_outcome turn_txt_s; 151 | 152 | let game_board = El.div ~at:(at1 "game-board") [sq] in 153 | let game_info = El.div ~at:(at1 "game-info") [game_outcome; new_game] in 154 | El.div ~at:(at1 "game") [game_board; game_info] 155 | 156 | let main id = 157 | match Document.find_el_by_id G.document (v id) with 158 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 159 | | Some el -> 160 | let game = ui () in 161 | El.set_children el [game] 162 | 163 | let () = main "root" 164 | -------------------------------------------------------------------------------- /tic-tac-toe/ttt_history.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 |
8 | 9 | 10 | -------------------------------------------------------------------------------- /tic-tac-toe/ttt_history.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type player = X | O 4 | 5 | type field = 6 | | Empty 7 | | Marked of player 8 | 9 | type turn = 10 | | Playing of player 11 | | Winner of player 12 | | Draw 13 | 14 | type state = { 15 | board : field IntMap.t; 16 | turn : turn; 17 | } 18 | 19 | open Note 20 | open Brr 21 | 22 | type msg = [ `JumpTo of int | `Mark of int ] 23 | 24 | type snapshot = { 25 | state : state; 26 | button : El.t; 27 | jump : msg event; 28 | } 29 | 30 | type t = { 31 | history : snapshot list; 32 | current : int; (* index into history list *) 33 | } 34 | 35 | let empty_state = 36 | let empty_board = Seq.fold_left ( 37 | fun board i -> 38 | IntMap.add i Empty board 39 | ) IntMap.empty (range 9) in 40 | { board = empty_board; turn = Playing X } 41 | 42 | let winning_combinations = [ 43 | 0, 1, 2; 44 | 3, 4, 5; 45 | 6, 7, 8; 46 | 0, 3, 6; 47 | 1, 4, 7; 48 | 2, 5, 8; 49 | 0, 4, 8; 50 | 2, 4, 6; 51 | ] 52 | 53 | let winner board = 54 | try 55 | let i, _j, _k = List.find ( 56 | fun (i, j, k) -> 57 | match get board i, get board j, get board k with 58 | | Marked X, Marked X, Marked X 59 | | Marked O, Marked O, Marked O -> true 60 | | _ -> false 61 | ) winning_combinations in 62 | match get board i with 63 | | Marked player -> Some player 64 | | _ -> assert false 65 | with Not_found -> 66 | None 67 | 68 | let is_draw board = 69 | IntMap.fold ( 70 | fun _ field all -> 71 | all && (match field with Marked _ -> true | Empty -> false) 72 | ) board true 73 | 74 | let next_player = function 75 | | X -> O 76 | | O -> X 77 | 78 | let string_of_turn = function 79 | | Playing X -> "next player: X" 80 | | Playing O -> "next player: O" 81 | | Winner X -> "winner: X" 82 | | Winner O -> "winner: O" 83 | | Draw -> "draw" 84 | 85 | open Brr_note 86 | 87 | let jump_button idx = 88 | let txt = 89 | if idx = 0 then 90 | [El.txt' "new game"] 91 | else 92 | [El.txt' (sp "go to move #%d" idx)] 93 | in 94 | let button = El.button txt in 95 | let ev = Evr.on_el Ev.click (fun _ -> `JumpTo idx) button in 96 | El.li [button], ev 97 | 98 | let empty = 99 | let button, jump = jump_button 0 in 100 | let snapshot_0 = { state = empty_state; button; jump } in 101 | { history = [snapshot_0]; current = 0 } 102 | 103 | let at1 c = 104 | [At.class' (v c)] 105 | 106 | let txt_of_turn gs = 107 | [El.txt' (string_of_turn gs)] 108 | 109 | let cell idx = 110 | let el = El.button ~at:(at1 "square") [] in 111 | let ev = Evr.on_el Ev.click (fun _ -> idx) el in 112 | el, ev 113 | 114 | let row start_idx = 115 | let b0, e0 = cell (start_idx ) in 116 | let b1, e1 = cell (start_idx + 1) in 117 | let b2, e2 = cell (start_idx + 2) in 118 | let el = El.div ~at:(at1 "board-row") [b0; b1; b2] in 119 | el, b0, b1, b2, E.select [e0; e1; e2] 120 | 121 | let square () = 122 | let r0, b0, b1, b2, ev012 = row 0 in 123 | let r1, b3, b4, b5, ev345 = row 3 in 124 | let r2, b6, b7, b8, ev678 = row 6 in 125 | let el = El.div ~at:(at1 "game-board") [r0; r1; r2] in 126 | let ev = E.select [ev012; ev345; ev678] in 127 | let ev_w = E.map (fun idx -> `Mark idx) ev in 128 | let cells = [| b0; b1; b2; b3; b4; b5; b6; b7; b8 |] in 129 | el, ev_w, cells 130 | 131 | let update t msg = 132 | match msg with 133 | | `JumpTo move -> { t with current = move } 134 | | `Mark idx -> 135 | let depth = List.length t.history in 136 | let snap , history_rest = 137 | if depth = t.current + 1 then 138 | match t.history with 139 | | hd :: tl -> hd, tl 140 | | [] -> assert false 141 | else 142 | match decapitate_list (depth - t.current - 1) t.history with 143 | | hd :: tl -> hd, tl 144 | | [] -> assert false 145 | in 146 | match get snap.state.board idx with 147 | | Empty -> ( 148 | match snap.state.turn with 149 | | Playing player -> 150 | let board = IntMap.add idx (Marked player) snap.state.board in 151 | let turn = 152 | if is_draw board then 153 | Draw 154 | else 155 | match winner board with 156 | | None -> Playing (next_player player) 157 | | Some winner -> Winner winner 158 | in 159 | let state' = { turn; board } in 160 | let current = List.length history_rest + 1 in 161 | let button, jump = jump_button current in 162 | let snap' = { state = state'; button; jump } in 163 | let history = snap' :: snap :: history_rest in 164 | { history; current } 165 | | Draw 166 | | Winner _ -> t 167 | ) 168 | | Marked _ -> t 169 | 170 | 171 | let buttons_jumps t = 172 | let events, jumps = List.fold_left ( 173 | fun (buttons, jumps) { button; jump; _ } -> 174 | button :: buttons, jump :: jumps 175 | ) ([], []) t.history in 176 | events, E.select jumps 177 | 178 | 179 | let cell_txt = function 180 | | Empty -> [ ] 181 | | Marked X -> [El.txt' "X"] 182 | | Marked O -> [El.txt' "O"] 183 | 184 | let ui () = 185 | let sq, cell_ev, cells = square () in 186 | let turn_div = El.div [] in 187 | let game_board = El.div ~at:(at1 "game-board") [sq] in 188 | let jump_button_list = El.ol [] in 189 | let game_info = El.div ~at:(at1 "game-info") 190 | [turn_div; jump_button_list] in 191 | let game = El.div ~at:(at1 "game") [game_board; game_info] in 192 | let eq = ( == ) in 193 | 194 | let def t_s = 195 | let buttons_jumps_s = S.map ~eq buttons_jumps t_s in 196 | let buttons_s = S.Pair.fst ~eq buttons_jumps_s in 197 | let jumps_s = S.Pair.snd ~eq buttons_jumps_s in 198 | let jump_e = E.swap jumps_s in 199 | 200 | let ev = E.select [cell_ev; jump_e] in 201 | Elr.def_children jump_button_list buttons_s; 202 | 203 | let state_s = S.map ~eq ( 204 | fun { history; current } -> 205 | let hlen = List.length history in 206 | let { state; _ } = List.nth history (hlen - current - 1) in 207 | state 208 | ) t_s in 209 | 210 | let board_s = S.map ~eq (fun { board; _ } -> board) state_s in 211 | let turn_s = S.map ~eq (fun { turn; _} -> turn) state_s in 212 | 213 | let cell_s i = S.map ~eq (fun board -> get board i) board_s in 214 | let cell_s_seq = Seq.map cell_s (range 9) in 215 | let cell_s_arr = Array.of_seq cell_s_seq in 216 | Array.iteri ( 217 | fun i cell_s -> 218 | let cell_txt_s = S.map ~eq cell_txt cell_s in 219 | Elr.def_children cells.(i) cell_txt_s 220 | ) cell_s_arr; 221 | 222 | let turn_txt_s = S.map ~eq txt_of_turn turn_s in 223 | Elr.def_children turn_div turn_txt_s; 224 | 225 | let t_ev = S.sample t_s ~on:ev update in 226 | let t_s' = S.hold ~eq empty t_ev in 227 | t_s', t_s' 228 | in 229 | S.fix ~eq empty def, game 230 | 231 | let main id = 232 | match Document.find_el_by_id G.document (v id) with 233 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 234 | | Some root -> 235 | let t_s, game = ui () in 236 | Logr.hold (S.log t_s (fun _ -> ())); 237 | El.set_children root [game] 238 | 239 | 240 | let () = main "root" 241 | -------------------------------------------------------------------------------- /tic-tac-toe/util.ml: -------------------------------------------------------------------------------- 1 | (* utilities *) 2 | module IntMap = Map.Make(struct type t = int let compare = compare end) 3 | 4 | let range = 5 | fun n -> 6 | let open Seq in 7 | let rec gen x () = 8 | if x = n then 9 | Nil 10 | else 11 | Cons (x, gen (x + 1)) 12 | in 13 | gen 0 14 | 15 | let get map i = 16 | IntMap.find i map 17 | 18 | let sp = Printf.sprintf 19 | let v = Jstr.v 20 | 21 | (* remove the first n elements of the list *) 22 | let decapitate_list = 23 | let rec loop n i = function 24 | | [] -> [] 25 | | (_ :: t) as list -> 26 | if i = n then 27 | list 28 | else 29 | loop n (i + 1) t 30 | in 31 | fun n list -> 32 | loop n 0 list 33 | 34 | -------------------------------------------------------------------------------- /timer/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | dune build timer.bc.js 4 | -------------------------------------------------------------------------------- /timer/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name timer) 3 | (libraries js_of_ocaml brr.note) 4 | ) 5 | 6 | -------------------------------------------------------------------------------- /timer/timer.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |

7 | 8 | 9 | -------------------------------------------------------------------------------- /timer/timer.ml: -------------------------------------------------------------------------------- 1 | open Note 2 | open Brr 3 | open Brr_note 4 | open Brr_note_kit 5 | 6 | let v = Jstr.v 7 | 8 | (* [every secs] creates a unit event which fires every [secs] seconds *) 9 | let every secs = 10 | let e, send_e = E.create () in 11 | let rec loop () = 12 | Time.delay secs (fun () -> loop ()); 13 | send_e () 14 | in 15 | loop (); 16 | e 17 | 18 | 19 | let main id = 20 | match Document.find_el_by_id G.document (v id) with 21 | | None -> Console.(debug [str (Printf.sprintf "element %S not found" id)]) 22 | | Some root -> 23 | 24 | let delta_secs = 1.0 in 25 | let add x y = x +. y in 26 | let e = every delta_secs in 27 | let incr_e = E.map (fun () -> add delta_secs) e in 28 | let sum_e = E.accum 0.0 incr_e in 29 | let sum_s = S.hold 0.0 sum_e in 30 | 31 | let sum_txt f = [El.txt' (Printf.sprintf "%0.1f" f)] in 32 | let sum_txt_s = S.map sum_txt sum_s in 33 | Elr.def_children root sum_txt_s 34 | 35 | let () = main "root" 36 | --------------------------------------------------------------------------------