diff --git a/.config/init.ml b/.config/init.ml index 81f9a79..91314da 100644 --- a/.config/init.ml +++ b/.config/init.ml @@ -1,95 +1,1621 @@ +[@@@ocamlformat "disable"] +#use "topfind";; + +#require "lwt";; +(* #list;; *) +[@@@ocamlformat "enable"] + +module Store = struct + open Lwt.Infix + module F = Fmt + module S = Irmin_git_unix.FS.KV (Irmin.Contents.String) + module Sync = Irmin.Sync.Make (S) + + type t = S.tree + type tree = t + type step = S.step + type path = step list + + let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree + let info = Irmin_git_unix.info + + let test_populate () : t Lwt.t = + let add p s t = S.Tree.add t p s in + add [ "hello" ] "world" (S.Tree.empty ()) + >>= add [ "hello"; "daddy" ] "ily" + >>= add [ "beep"; "beep" ] "motherfucker" + + let init_default upstream_url : Sync.db Lwt.t = + S.Repo.v (Irmin_git.Conf.init "../rootstore") >>= fun repo -> + S.of_branch repo "lablgtk" >>= fun t -> + S.remote upstream_url >>= fun upstream -> + (* (try Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return_unit + with Invalid_argument a -> + F.epr "Sync.pull_exn raised Invalid_argument(%s)" a; + Lwt.return_unit) + >>= fun () -> *) + Lwt.return t +end + +module Ogui = struct + open Lwt.Infix + module Gv = Graphv_gles2_native + module F = Fmt + module Str = Re.Str + + type stroke = { width : float; color : Gv.Color.t } + + let stroke_none = { width = 0.; color = Gv.Color.transparent } + + let pp_text_row : Gv.Text.text_row F.t = + F.( + record + [ + field "start_index" (fun r -> Gv.Text.(r.start_index)) int; + field "end_index" (fun r -> Gv.Text.(r.end_index)) int; + field "width" (fun r -> Gv.Text.(r.width)) float; + field "minx" (fun r -> Gv.Text.(r.minx)) float; + field "maxx" (fun r -> Gv.Text.(r.maxx)) float; + field "next" (fun r -> Gv.Text.(r.next)) int; + ]) + + let pp_color : Gv.Color.t Fmt.t = + F.( + hbox + @@ record ~sep:sp + [ + field "r" (fun (s : Gv.Color.t) -> s.r) float; + field "g" (fun (s : Gv.Color.t) -> s.g) float; + field "b" (fun (s : Gv.Color.t) -> s.b) float; + field "a" (fun (s : Gv.Color.t) -> s.a) float; + ]) + + let lwt_lwd (t : 'a Lwt.t Lwd.t) : 'a Lwd.t Lwt.t = + let root = Lwd.observe t in + Lwd.quick_sample root >>= fun root' -> + let var = Lwd.var root' in + Lwd.set_on_invalidate root (fun _t' -> + Lwt.async (fun () -> + Lwd.quick_sample root >>= fun root' -> + Lwt.return @@ Lwd.set var root')); + Lwt.return (Lwd.get var) + + module Margin = struct + open Gg + + type t = { + left : size1; + right : size1; + top : size1; + bottom : size1; + } + + let empty = { left = 0.; right = 0.; top = 0.; bottom = 0. } + let symmetric h w = { left = w; right = w; top = h; bottom = h } + let sum t : size2 = Size2.v (t.left +. t.right) (t.top +. t.bottom) + + let inner t b : box2 = + Box2.v + (V2.v (Box2.minx b +. t.left) (Box2.miny b +. t.top)) + (V2.v (Box2.maxx b -. t.right) (Box2.maxy b -. t.bottom)) + + let outer t b = + Box2.( + v + (V2.v (minx b -. t.left) (miny b -. t.top)) + (V2.v (maxx b +. t.right) (maxy b +. t.bottom))) + + let pp ppf t = + F.pf ppf "l=%f@;r=%f@;t=%f@;b=%f" t.left t.right t.top t.bottom + end + + type margin = Margin.t + + let string_of_utf_8_uchar uc = + Buffer.( + let b = create 4 in + add_utf_8_uchar b uc; + contents b) + + let pp_uchar : Uchar.t F.t = + fun ppf u -> F.pf ppf "%S" (string_of_utf_8_uchar u) + + module Sense = struct + type t = { + click : bool; + drag : bool; + focusable : bool; + edit : bool; + } + + let click = + { click = true; drag = false; focusable = true; edit = false } + + let hover = + { click = false; drag = false; focusable = true; edit = false } + end + + module TextBuffer = struct + type t = { + path : string list Lwd.var; + tree : Store.S.tree Lwd.var; + repo : Store.Sync.db Lwt.t; + } + + let of_repo ~initial_path ~(repo : Store.Sync.db Lwt.t) : t Lwt.t + = + repo >>= Store.S.tree >>= fun tree -> + Lwt.return + { path = Lwd.var initial_path; tree = Lwd.var tree; repo } + + let of_string ~path ?(repo : Store.Sync.db Lwt.t option) str = + { + path = Lwd.var path; + tree = Lwd.var @@ Store.S.Tree.singleton path str; + repo = + ( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' -> + Option.value ~default:Store.S.(empty repo') repo ); + } + + let insert_uchar { path; tree; _ } n uc : unit Lwt.t = + F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc; + let ucbuf = Bytes.create 8 in + let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in + Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function + | Some src -> + let sn = String.length src in + assert (n <= sn); + let dst = Bytes.create (sn + uclen) in + BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0 + ~len:n; + BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n + ~len:uclen; + if sn > n + uclen then + BytesLabels.blit_string ~src ~src_pos:n ~dst + ~dst_pos:(n + uclen) + ~len:(sn - (n + uclen)); + Some (Bytes.to_string dst) + | None -> + F.epr "TextBuffer.insert_uchar Tree.update -> Nonep@."; + Some (String.sub (Bytes.to_string ucbuf) 0 uclen)) + >>= fun t -> + Lwd.set tree t; + Lwt.return_unit + + let insert { path; tree; _ } n str = + Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function + | Some src -> + let srcn = String.length src in + assert (n <= srcn); + Some + String.( + cat (cat (sub src 0 n) str) (sub src n (srcn - n))) + | None -> + F.epr "TextBuffer.insert Tree.update -> Nonep@."; + Some str) + >>= fun t -> + Lwd.set tree t; + Lwt.return_unit + + let remove { path; tree; _ } (a, b) : unit Lwt.t = + let a, b = (min a b, max a b) in + (* F.epr "TextBuffer.remove (%d, %d)@." a b; *) + Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function + | Some src -> + let srcn = String.length src in + assert (max a b <= srcn); + let dst = Bytes.create (srcn - (b - a)) in + Bytes.blit_string src 0 dst 0 a; + Bytes.blit_string src b dst a (srcn - b); + Some (Bytes.to_string dst) + | v -> v) + >>= fun t -> + Lwd.set tree t; + Lwt.return_unit + + let remove_uchar { path; tree; _ } n : unit Lwt.t = + (* F.epr "TextBuffer.remove_subset n=%d @." n; *) + Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function + | Some src -> + let srcn = String.length src in + assert (n < srcn); + let ucn = + Uchar.utf_decode_length (String.get_utf_8_uchar src n) + in + let dst = Bytes.create (srcn - ucn) in + Bytes.blit_string src 0 dst 0 n; + Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn); + Some (Bytes.to_string dst) + | None -> + F.epr "TextBuffer.remove_uchar None"; + None) + >>= fun t -> + Lwd.set tree t; + Lwt.return_unit + + let fold_string t (f : string -> 'a) : 'a Lwt.t = + match t with + | { path; tree; _ } -> + Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) + >>= fun text -> Lwt.return (f text) + + let contents { path; tree; _ } : string Lwt.t = + (try Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) + with e -> + F.epr "TextBuffer.contents %s: %s" + (String.concat "/" (Lwd.peek path)) + (match e with + | Not_found -> "Not_found" + | Invalid_argument a -> F.str "Invalid_argument %s" a + | exc -> F.str "Exception: %s" (Printexc.to_string exc)); + Lwt.return "") + >>= fun text -> Lwt.return text + + let get { tree; path; _ } = + Lwd.map2 (Lwd.get tree) (Lwd.get path) ~f:(fun tree path -> + Store.S.Tree.get tree path) + |> lwt_lwd + + let peek { tree; path; _ } = + Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) + + let length { path; tree; _ } = + Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) >>= fun text -> + Lwt.return (String.length text) + end + + module Event = struct + type key_action = GLFW.key_action + type key = GLFW.key + type key_mod = GLFW.key_mod + type event = Key of key_action * key * key_mod list + + (* Stolen from zed_input.ml *) + module EventMap = Map.Make (struct + type t = event + + let compare = compare + end) + + type 'a t = 'a node EventMap.t + and 'a node = Set of 'a t | Val of 'a + + let empty = EventMap.empty + + let rec add (events : event list) value set = + match events with + | [] -> invalid_arg "Event.add" + | [ event ] -> EventMap.add event (Val value) set + | event :: events -> ( + match + try Some (EventMap.find event set) + with Not_found -> None + with + | None | Some (Val _) -> + EventMap.add event (Set (add events value empty)) set + | Some (Set s) -> + EventMap.add event (Set (add events value s)) set) + + let adds (events : event list list) value set = + List.fold_left (fun s e -> add e value s) set events + + let rec remove events set = + match events with + | [] -> invalid_arg "Event.remove" + | [ event ] -> EventMap.remove event set + | event :: events -> ( + match + try Some (EventMap.find event set) + with Not_found -> None + with + | None | Some (Val _) -> set + | Some (Set s) -> + let s = remove events s in + if EventMap.is_empty s then EventMap.remove event set + else EventMap.add event (Set s) set) + + let fold f set acc = + let rec loop prefix set acc = + EventMap.fold + (fun event node acc -> + match node with + | Val v -> f (List.rev (event :: prefix)) v acc + | Set s -> loop (event :: prefix) s acc) + set acc + in + loop [] set acc + + let bindings set = + List.rev + (fold (fun events action l -> (events, action) :: l) set []) + + module type Pack = sig + type a + type b + + val set : a t + val map : a -> b + end + + type 'a pack = (module Pack with type b = 'a) + type 'a resolver = 'a pack list + + let pack (type u v) map set = + let module Pack = struct + type a = u + type b = v + + let set = set + let map = map + end in + (module Pack : Pack with type b = v) + + let resolver l = l + + type 'a result = + | Accepted of 'a + | Continue of 'a resolver + | Rejected + + let rec resolve_rec : + 'a. event -> 'a pack list -> 'a pack list -> 'a result = + fun (type u) event acc packs -> + match packs with + | [] -> if acc = [] then Rejected else Continue (List.rev acc) + | p :: packs -> ( + let module Pack = (val p : Pack with type b = u) in + match + try Some (EventMap.find event Pack.set) + with Not_found -> None + with + | Some (Set set) -> + resolve_rec event (pack Pack.map set :: acc) packs + | Some (Val v) -> Accepted (Pack.map v) + | None -> resolve_rec event acc packs) + + let resolve event sets = resolve_rec event [] sets + + include Glfw_types + + let pp_event : event F.t = + fun ppf e -> + let open Glfw_types in + match e with + | Key (a, k, m) -> + F.pf ppf "Key %a, %a, %a" pp_key_action a pp_key k pp_mods m + end + + type event = Event.event + + module Align = struct + open Gg + + type range = size1 * size1 + + type t = + | Min (* Left or top. *) + | Center (* Horizontal or vertical center *) + | Max (* Right or bottom *) + + let pp_t ppf = + F.( + function + | Min -> pf ppf "Min" + | Center -> pf ppf "Center" + | Max -> pf ppf "Max") + + let size_within_rect (size : size2) (frame : box2) : box2 = + let size_within_range (size : size1) (range : range) : range = + let min, max = range in + if max -. min == Float.infinity && size == Float.infinity then + range + else range + in + let x_range = + size_within_range (P2.x size) + (Box2.minx frame, Box2.maxx frame) + in + let y_range = + size_within_range (P2.y size) + (Box2.miny frame, Box2.maxy frame) + in + Box2.v + (P2.v (fst x_range) (fst y_range)) + (P2.v (snd x_range) (snd y_range)) + end + + type align = Align.t + + module Fonts = struct + open Gg + + let pixels_per_point = ref 1.0 + + type t = { gv : Gv.Text.font; pixels_per_point : size1 } + + let find_font gv name : t option = + Option.fold + ~some:(fun gv -> + Some { gv; pixels_per_point = !pixels_per_point }) + ~none:None + (Gv.Text.find_font gv ~name) + end + + module TextLayout = struct + open Gg + + type font_selection = Default | FontId of (string * float) + + type format = { + font_id : font_selection; + extra_letter_spacing : float; + line_height : float option; + color : Gv.Color.t; + background : Gv.Color.t; + italics : bool; + underline : stroke; + strikethrough : stroke; + valign : align; + } + + type text_wrapping = { + max_width : float; + max_rows : int; + break_anywhere : bool; + overflow_character : string option; + } + + type section = { byte_range : int * int; format : format } + + type layout = { + text : TextBuffer.t; + sections : section list; + wrap : text_wrapping; + halign : align; + justify : bool; + line_height : float option; + } + + type cursor = { index : int; last_col : int } + + let pp_format : format F.t = + F.( + record + [ + field "font_id" (fun _ -> "...") string; + field "extra_letter_spacing" + (fun s -> s.extra_letter_spacing) + float; + field "line_height" + (fun (s : format) -> s.line_height) + (option float); + field "color" (fun s -> s.color) pp_color; + field "background" (fun s -> s.background) pp_color; + ]) + + let format_default = + { + font_id = FontId ("mono", 18.0); + extra_letter_spacing = 0.0; + line_height = Some 19.; + color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9; + background = Gv.Color.transparent; + italics = false; + underline = stroke_none; + strikethrough = stroke_none; + valign = Max; + } + + let format_simple font_id color : format = + { format_default with font_id; color } + + let pp_text_wrapping = + F.( + record + [ + field "max_width" (fun s -> s.max_width) float; + field "max_rows" (fun s -> s.max_rows) int; + field "break_anywhere" (fun s -> s.break_anywhere) bool; + field "overflow_character" + (fun s -> s.overflow_character) + (option string); + ]) + + let default_text_wrapping () = + { + max_width = Float.infinity; + max_rows = 100; + (* TODO *) + break_anywhere = false; + overflow_character = Some "…"; + } + + let pp_section : Format.formatter -> 'a -> unit = + F.( + record + [ + field "byte_range" + (fun s -> s.byte_range) + (pair ~sep:(any ",") int int); + (* field "format" (fun s -> s.format) pp_format; *) + ]) + + let section_default = + { byte_range = (0, 0); format = format_default } + + let pp_layout = + F.( + record + [ + field "text" + (fun s -> + str "path=%s" + (String.concat "/" (Lwd.peek s.text.path))) + string; + field "sections" + (fun s -> s.sections) + (brackets @@ list pp_section); + field "wrap" (fun s -> s.wrap) pp_text_wrapping; + field "halign" (fun s -> s.halign) Align.pp_t; + field "justify" (fun s -> s.justify) bool; + ]) + + let layout_default = + { + text = TextBuffer.of_string ~path:[] ""; + sections = [ section_default ]; + wrap = default_text_wrapping (); + halign = Min; + justify = false; + line_height = Some 20.; + } + + let pp_text_row : Format.formatter -> Gv.Text.text_row -> unit = + F.( + record + [ + field "start_index" + (fun (s : Gv.Text.text_row) -> s.start_index) + int; + field "end_index" + (fun (s : Gv.Text.text_row) -> s.end_index) + int; + field "width" + (fun (s : Gv.Text.text_row) -> s.width) + float; + field "minx" (fun (s : Gv.Text.text_row) -> s.minx) float; + field "maxx" (fun (s : Gv.Text.text_row) -> s.maxx) float; + ]) + + let cursor_default = { index = 0; last_col = 0 } + let cursor ?(last_col = 0) index : cursor = { index; last_col } + + let simple (text : TextBuffer.t) ?(start = Lwd.pure 0) + ?(format = format_default) wrap_width : layout Lwd.t Lwt.t = + TextBuffer.get text >>= fun str -> + Lwd.map2 start str ~f:(fun start str -> + { + layout_default with + text; + sections = + [ { byte_range = (start, String.length str); format } ]; + wrap = + { + (default_text_wrapping ()) with + max_width = wrap_width; + }; + }) + |> Lwt.return + + let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.) + + let default_cursor_formatter (f : format) = + { f with background = !cursor_color } + + let default_mark_formatter (f : format) = + { f with background = Gv.Color.rgbf ~r:0.3 ~g:0.3 ~b:0.3 } + + let with_range ((cs, ce) : int * int) + ?(format = default_cursor_formatter) layout : layout = + { + layout with + sections = + List.fold_left + (fun (l : section list) sec -> + let s, e = sec.byte_range in + l + @ (if e < cs || ce < s then [ sec ] else []) + @ (if cs > s && cs <= e then + [ { sec with byte_range = (s, cs) } ] + else []) + @ (if cs <= e && ce >= s then + [ + { + format = format sec.format; + byte_range = (max cs s, min ce e); + }; + ] + else []) + @ + if ce > s && ce <= e then + [ { sec with byte_range = (ce, e) } ] + else []) + [] layout.sections; + } + + let with_cursor (cursor : cursor Lwd.t) + ?(format = default_cursor_formatter) layout : layout Lwd.t = + Lwd.map2 cursor layout ~f:(fun c l -> + with_range (c.index, c.index + 1) ~format l) + + let with_mark (mark : int option Lwd.t) (cursor : cursor Lwd.t) + ?(format = default_mark_formatter) layout : layout Lwd.t = + Lwd.bind layout ~f:(fun l -> + Lwd.map2 mark cursor ~f:(fun m c -> + match m with + | Some m' -> + F.epr "TextLayout.with_mark inside Lwd.map@."; + + with_range ~format + (min m' c.index, max m' c.index) + l + | None -> l)) + end + + let rec nth_tl n = function + | hd :: tl -> if n > 0 then nth_tl (n - 1) tl else hd :: tl + | [] -> [] + + module Ui = struct + type t = { + rect : Gg.box2 Lwd.var; + enabled : bool; + gv : Gv.t; + glfw_window : GLFW.window option; + bindings : action list Event.t Lwd.var; + } + + and action = Custom of (unit -> unit Lwt.t) + + let id = ref 0 + + let window gv ?(window : GLFW.window option) rect : t = + { + rect; + enabled = true; + gv; + glfw_window = window; + bindings = Lwd.var Event.empty; + } + + let callback_resolver : action list Event.resolver option ref = + ref Option.None + + let keycallback t (state : Event.key_action) (key : Event.key) + (mods : Event.key_mod list) : bool Lwt.t = + let res = + match !callback_resolver with + | Some res -> res + | None -> + Event.resolver + [ + Event.pack Fun.id + (t.bindings |> Lwd.get |> Lwd.observe + |> Lwd.quick_sample); + ] + in + + Event.( + F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action + state pp_mods mods); + match Event.resolve (Key (state, key, mods)) res with + | Event.Accepted actions -> + callback_resolver := None; + let rec exec : action list -> bool Lwt.t = function + | Custom f :: actions -> f () >>= fun () -> exec actions + | [] -> Lwt.return false + in + exec actions + | Event.Continue res -> + callback_resolver := Some res; + Lwt.return true + | Event.Rejected -> + callback_resolver := None; + Lwt.return false + + let update_bindings ui + (f : action list Event.t -> action list Event.t) = + Lwd.set ui.bindings (f (Lwd.peek ui.bindings)) + + let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref = + ref (fun _c -> + F.epr "chrcallback: '%a'@." pp_uchar _c; + Lwt.return_unit) + + let chrcallback _t (chr : int) : unit Lwt.t = + !chrcallback_ref @@ Uchar.of_int chr + + module Style = struct + type t = { + stroke : float option * Gv.Color.t; + fill : Gv.Color.t; + margin : Margin.t; + } + + let default = + { + stroke = (None, Gv.Color.transparent); + fill = Gv.Color.transparent; + margin = Margin.empty; + } + + let pp ppf t = + F.pf ppf "%a" + F.( + record + [ + field "stroke" + (fun t -> t.stroke) + (hbox + @@ pair ~sep:comma + (option ~none:(any "None") float) + pp_color); + field "fill" (fun t -> t.fill) pp_color; + field "margin" (fun t -> t.margin) Margin.pp; + ]) + t + end + end + + module TextEdit = struct + open Gg + + type t = { + text : TextBuffer.t; + cursor : TextLayout.cursor Lwd.var; + mark : int option Lwd.var; + scroll : int Lwd.var; + rows : int Lwd.var; + text_format : TextLayout.format; + formatter : + (Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option; + password : bool; + frame : bool; + margin : margin; + multiline : bool; + interactive : bool; + desired_width : float option; + desired_height_rows : int; + cursor_at_end : bool; + min_size : v2; + align : align; + clip_text : bool; + char_limit : int; (* return_key : keyboard_shortcut; *) + } + + let col t = + TextBuffer.fold_string t.text (fun s -> + let c = Lwd.peek t.cursor in + c.index - Str.search_backward (Str.regexp "^") s c.index) + + let rec newlines (s : string) (i : int) : int list = + match String.index_from_opt s i '\n' with + | Some i' -> i :: newlines s i' + | None -> [] + + let rec index_rows_from (s : string) (start : int) (rows : int) : + int option = + match String.index_from_opt s start '\n' with + | Some start' -> + if rows - 1 > 0 then + index_rows_from s (start' + 1) (rows - 1) + else Some (start' + 1) + | None -> None (* eof *) + + let rec rindex_rows_from (s : string) (start : int) (rows : int) : + int option = + match String.rindex_from_opt s start '\n' with + | Some start' -> + if start' - 1 <= 0 then None + else if rows - 1 > 0 then + rindex_rows_from s (start' - 1) (rows - 1) + else Some (start' + 1) + | None -> None (* eof *) + + let scroll_update ({ text; cursor; scroll; rows; _ } as t : t) : + unit Lwt.t = + TextBuffer.fold_string text (fun s -> + let cursor = Lwd.peek cursor in + let rows = Lwd.peek rows in + let slen = String.length s in + if cursor.index < Lwd.peek scroll then + match + String.rindex_from_opt s + (min (slen - 1) (cursor.index - 1)) + '\n' + with + | Some i' -> Lwd.set t.scroll (i' + 1) + | None -> Lwd.set t.scroll 0 + else + match index_rows_from s (Lwd.peek scroll) rows with + | None -> () + | Some eow -> ( + if cursor.index >= eow then + match + rindex_rows_from s + (min (slen - 1) cursor.index) + rows + with + | None -> () + | Some i' -> Lwd.set t.scroll i')) + + let cursor_update (t : t) (f : int -> int) : unit Lwt.t = + col t >>= fun last_col -> + TextBuffer.fold_string t.text (fun s -> + Lwd.set t.cursor + (TextLayout.cursor ~last_col + (f (Lwd.peek t.cursor).index + |> max 0 + |> min (String.length s)))) + >>= fun () -> scroll_update t + + let cursor_move (t : t) (amt : int) : unit Lwt.t = + cursor_update t (( + ) amt) + + let cursor_set (t : t) (index : int) : unit Lwt.t = + cursor_update t (Fun.const index) + + let default_bindings (t : t) (ui : Ui.t) : unit = + let open GLFW in + let open Event in + let open Ui in + Ui.update_bindings ui (fun a -> + a + |> adds + [ + [ Key (Press, F, [ Control ]) ]; + [ Key (Repeat, F, [ Control ]) ]; + [ Key (Press, Right, []) ]; + [ Key (Repeat, Right, []) ]; + ] + [ Custom (fun () -> cursor_move t 1) ] + |> adds + [ + [ Key (Press, B, [ Control ]) ]; + [ Key (Repeat, B, [ Control ]) ]; + [ Key (Press, Left, []) ]; + [ Key (Repeat, Left, []) ]; + ] + [ Custom (fun () -> cursor_move t (-1)) ] + |> adds + [ + [ Key (Press, N, [ Control ]) ]; + [ Key (Repeat, N, [ Control ]) ]; + [ Key (Press, Down, []) ]; + [ Key (Repeat, Down, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + let sn = String.length s in + let seol = + Str.search_forward (Str.regexp "$") + in + let next_bol = + min sn + (seol s (Lwd.peek t.cursor).index + 1) + in + let next_line_len = + seol s next_bol - next_bol + in + next_bol + + + if + (Lwd.peek t.cursor).last_col + > next_line_len + then next_line_len + else + min next_line_len + (Lwd.peek t.cursor).last_col) + >>= cursor_set t); + ] + |> adds + [ + [ Key (Press, P, [ Control ]) ]; + [ Key (Repeat, P, [ Control ]) ]; + [ Key (Press, Up, []) ]; + [ Key (Repeat, Up, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + let sbol = + Str.search_backward (Str.regexp "^") s + in + let bol = sbol (Lwd.peek t.cursor).index in + if bol > 0 then + let prev_bol = sbol (max 0 (bol - 1)) in + let prev_line_len = bol - 1 - prev_bol in + + (*F.epr + "up: index=%d bol=%d prev_bol=%d \ + prev_line_len=%d @." + t.cursor.index bol prev_bol prev_line_len; *) + prev_bol + + + if + (Lwd.peek t.cursor).last_col + > prev_line_len + then prev_line_len + else + min prev_line_len + (Lwd.peek t.cursor).last_col + else (Lwd.peek t.cursor).index) + >>= cursor_set t); + ] + |> adds (* EOL *) + [ + [ Key (Press, E, [ Control ]) ]; + [ Key (Press, End, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + let bol = + Str.search_backward (Str.regexp "^") s + (Lwd.peek t.cursor).index + in + let eol = + Str.search_forward (Str.regexp "$") s + (Lwd.peek t.cursor).index + in + Lwd.set t.cursor + @@ TextLayout.cursor ~last_col:(eol - bol) + eol)); + ] + |> adds (* BOL *) + [ + [ Key (Press, A, [ Control ]) ]; + [ Key (Press, Home, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + Lwd.set t.cursor + @@ TextLayout.cursor ~last_col:0 + (Str.search_backward (Str.regexp "^") s + (Lwd.peek t.cursor).index))); + ] + |> adds + [ + [ Key (Press, Backspace, []) ]; + [ Key (Repeat, Backspace, []) ]; + ] + [ + Custom + (fun () -> + match Lwd.peek t.mark with + | Some mark -> + TextBuffer.remove t.text + (mark, (Lwd.peek t.cursor).index) + >>= fun _ -> + Lwd.set t.mark None; + cursor_set t + (min mark (Lwd.peek t.cursor).index) + | None -> + if (Lwd.peek t.cursor).index > 0 then + TextBuffer.remove_uchar t.text + ((Lwd.peek t.cursor).index - 1) + >>= fun _ -> cursor_move t (-1) + else Lwt.return_unit); + ] + |> adds + [ [ Key (Press, K, [ Control ]) ] ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + TextBuffer.remove t.text + ( (Lwd.peek t.cursor).index, + let eol = + Str.search_forward (Str.regexp "$") s + (Lwd.peek t.cursor).index + in + if + eol == (Lwd.peek t.cursor).index + && String.length s > eol + then eol + 1 + else eol ) + >>= fun _ -> + Lwd.set t.mark None; + cursor_set t (Lwd.peek t.cursor).index) + >>= fun u -> u); + ] + |> adds + [ + [ Key (Press, Enter, []) ]; + [ Key (Repeat, Enter, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.insert_uchar t.text + (Lwd.peek t.cursor).index (Uchar.of_char '\n') + >>= fun _ -> cursor_move t 1); + ] + |> adds + [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *) + [ + Custom + (fun () -> + Lwd.set t.mark + (match Lwd.peek t.mark with + | Some _ -> None + | None -> Some (Lwd.peek t.cursor).index); + Lwt.return_unit); + ]); + Ui.chrcallback_ref := + fun c -> + TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c + >>= fun _ -> cursor_move t 1 + (* This creates a giant stack of calls lol + >>= fun () -> !Ui.chrcallback_ref c *) + + let multiline ui ?(text_format = TextLayout.format_default) + (text : TextBuffer.t) : t = + let t = + { + text; + cursor = Lwd.var (TextLayout.cursor 0); + mark = Lwd.var None; + scroll = Lwd.var 0; + rows = Lwd.var 0; + text_format; + formatter = None; + password = false; + frame = true; + margin = Margin.symmetric 4.0 4.0; + multiline = true; + interactive = true; + desired_width = None; + desired_height_rows = 4; + cursor_at_end = true; + min_size = Gg.V2.zero; + align = Min; + clip_text = false; + char_limit = Int.max_int; + (* return_key = keyboard_shortcut; *) + } + in + default_bindings t ui; + t + end + + module Layout = struct + module Style = Ui.Style + + type frame = { t : t; mutable size : size; style : Style.t } + + and t = + [ `Join of [ `X | `Y | `Z ] * (frame * frame) + | `String of string + | `Buffer of TextBuffer.t + | `TextEdit of TextEdit.t * TextLayout.layout + | `None ] + + and dim = [ `Ratio of float | `Pixels of float ] + and size = dim * dim + + let ratio x y = (`Ratio x, `Ratio y) + + let pixels x y = + (`Pixels (Int.of_float x), `Pixels (Int.of_float y)) + + let frame ?(size = ratio 1. 1.) ?(style = Style.default) t : frame + = + { t; size; style } + + let none = frame `None + let join d ?style a b = frame ?style (`Join (d, (a, b))) + + (* let hbox, vbox, zbox = (box `X, box `Y, box `Z) *) + let pack ?style d = (none, join d ?style) + let pack_x ?style () = pack `X ?style + let pack_y ?style () = pack `Y ?style + let pack_z ?style () = pack `Z ?style + let cat ?style d = Lwd_utils.reduce (pack ?style d) + let hcat ?style = cat ?style `X + let vcat ?style = Lwd_utils.reduce (pack_y ?style ()) + let zcat ?style = Lwd_utils.reduce (pack_z ?style ()) + let box ?style d = Lwd_utils.pack (pack ?style d) + let hbox, vbox, zbox = (box `X, box `Y, box `Z) + + let textedit_style = + Style. + { + default with + stroke = (Some 1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9); + margin = Margin.symmetric 10. 10.; + } + + let textedit ?size ?(style = textedit_style) (t : TextEdit.t) : + frame Lwd.t Lwt.t = + let open TextLayout in + F.epr "Layout.textedit@."; + simple t.text ~start:(Lwd.get t.scroll) ~format:t.text_format + (Option.value ~default:80. t.desired_width) + >>= fun layout -> + with_cursor (Lwd.get t.cursor) layout + |> with_mark (Lwd.get t.mark) (Lwd.get t.cursor) + |> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl))) + |> Lwt.return + + let tiling ui ?(style = textedit_style) d + (telist : TextEdit.t list) = + let cursor = Lwd.var 0 in + let len = List.length telist in + Ui.update_bindings ui (fun a -> + a + |> Event.adds + [ + (*[ Key (Press, X, [Control])]; + [ Key (Release, X, [Control])];*) + [ Key (Press, O, [ Control ]) ]; + ] + [ + Ui.Custom + (fun () -> + Lwd.set cursor + (if Lwd.peek cursor < len - 1 then + Lwd.peek cursor + 1 + else 0); + TextEdit.default_bindings + (List.nth telist (Lwd.peek cursor)) + ui; + Lwt.return_unit); + ]); + let teln = List.length telist in + let ratio n = `Ratio (1. /. float (teln - (n + 1))) in + Lwt_list.mapi_s + (fun n te -> + textedit + ~size: + (match d with + | `X -> (`Ratio 0.5, `Ratio 1.) + | `Y -> (`Ratio 1., `Ratio 0.5) + | `Z -> (`Ratio 1., `Ratio 1.)) + te + >>= fun tl -> + Lwd.map2 tl (Lwd.get cursor) ~f:(fun tl cursor -> + { + tl with + style = + { + tl.style with + stroke = + ( fst style.stroke, + if n == cursor then + Gv.Color.(transf (snd style.stroke) 0.5) + else snd style.stroke ); + }; + }) + |> Lwt.return) + telist + >>= fun framelist -> box ~style d framelist |> Lwt.return + + let pp_dir ppf (t : [ `X | `Y | `Z ]) = + F.pf ppf "%s" + (match t with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z") + + let pp_t ppf (t : t) = + F.pf ppf "%s" + (match t with + | `Join (d, _) -> F.str "`Join %a" pp_dir d + | `Buffer _ -> "`Buffer" + | `TextEdit _ -> "`TextEdit" + | `String s -> F.str "`String %s" s + | `None -> "`None") + + let pp_size ppf (x, y) = + (match x with + | `Pixels p -> F.pf ppf "`Pixels %f.2, " p + | `Ratio p -> F.pf ppf "`Ratio %f.2, " p); + match y with + | `Pixels p -> F.pf ppf "`Pixels %f.2" p + | `Ratio p -> F.pf ppf "`Ratio %f.2" p + + let pp_frame = + F.( + record + [ + field "t" (fun t -> t.t) pp_t; + field "size" (fun t -> t.size) pp_size; + field "style" (fun t -> t.style) Style.pp; + ]) + + let parse_t_frame s = + match s with + | "`Box" -> `Vbox + | "`Buffer" -> `Buffer + | "`TextEdit" -> `TextEdit + | "`None" -> `None + | s -> `S s + end + + module Painter = struct + open Layout + open Gg + + let draw_box (t : Gv.t) ~(box : Gg.box2) ~(style : Layout.Style.t) + = + let open Gv in + let open Box2 in + Path.begin_ t; + Path.rect t ~x:(minx box) ~y:(miny box) ~w:(w box) ~h:(h box); + set_fill_color t ~color:style.fill; + set_stroke_color t ~color:(snd style.stroke); + (match style.stroke with + | None, _ -> () + | Some width, _ -> + set_stroke_width t ~width; + stroke t); + fill t + + let set_text_format (t : Gv.t) (format : TextLayout.format) = + let font_name, font_size = + match format.font_id with + | Default -> ("mono", 18.) + | FontId (s, size) -> (s, size) + in + let open Gv in + Text.set_font_face t ~name:font_name; + Text.set_size t ~size:font_size; + Text.set_align t ~align:Align.(left lor top) + + let text_layout (t : Gv.t) (rect : box2) + ((te, layout) : TextEdit.t * TextLayout.layout) : box2 Lwt.t = + let g = layout in + let line_height = + Option.value ~default:(Gv.Text.metrics t).line_height + g.line_height + in + let max_rows = Int.of_float (Box2.h rect /. line_height) in + Lwd.set te.rows max_rows; + let lines = Gv.Text.make_empty_rows max_rows in + Store.S.Tree.get (Lwd.peek te.text.tree) (Lwd.peek te.text.path) + >>= fun contents -> + let contents_len = String.length contents in + let row_count = + Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows + ~lines ~start:(Lwd.peek te.scroll) contents + in + Seq.fold_left + (fun ((cur, start) : p2 * int) (row : Gv.Text.text_row) -> + let sections = + List.filter + (fun (r : TextLayout.section) -> + fst r.byte_range <= row.end_index + && snd r.byte_range > start) + g.sections + in + List.fold_left + (fun (cur' : p2) (sec : TextLayout.section) -> + let start, end_ = + ( start |> max (fst sec.byte_range) |> min contents_len, + row.end_index |> min contents_len + |> min (snd sec.byte_range) ) + in + let width = + if start == row.end_index then + (* hack to display cursor at end of row *) + (Gv.Text.bounds t ~x:(P2.x cur') ~y:0. " ").advance + else + (Gv.Text.bounds t ~x:(P2.x cur') ~y:0. ~start ~end_ + contents) + .advance + in + draw_box t + ~box: + (Box2.v + (V2.v (P2.x cur') (P2.y cur)) + (V2.v width line_height)) + ~style: + Layout.Style. + { default with fill = sec.format.background }; + set_text_format t sec.format; + Gv.set_fill_color t ~color:sec.format.color; + V2.v + (Gv.Text.text_w t ~x:(P2.x cur') ~y:(P2.y cur) ~start + ~end_ contents) + (P2.y cur')) + P2.(v (Box2.minx rect) (y cur)) + sections + |> fun cur'' -> + ( V2.(v (max (x cur) (x cur'')) (y cur'' +. line_height)), + row.next )) + (Box2.o rect, Lwd.peek te.scroll) + (Seq.take row_count (Array.to_seq lines)) + |> fst + |> (fun cur''' -> V2.(cur''' - v 0. line_height)) + |> Box2.(of_pts (o rect)) + |> Lwt.return + + let rec layout (box : box2) (ui : Ui.t) + ({ t; style; size = sx, sy } : frame) : box2 Lwt.t = + let box = + Box2.v (Box2.o box) + (V2.v + (match sx with + | `Ratio r -> Box2.w box *. r + | `Pixels p -> p) + (match sy with + | `Ratio r -> Box2.h box *. r + | `Pixels p -> p)) + in + let box' = Margin.inner style.margin box in + (match t with + | `Join (dir, (a, b)) -> + Lwt_list.fold_left_s + (fun (c : box2) f -> + layout c ui f >>= fun r -> + let c' = + Box2.( + match dir with + | `X -> of_pts (V2.v (maxx r) (miny c)) (max c) + | `Y -> of_pts (V2.v (minx c) (maxy r)) (max c) + | `Z -> box) + in + Lwt.return c') + box' [ a; b ] + | `TextEdit tt -> text_layout ui.gv box' tt + | _ -> Lwt.return box) + >>= fun r -> + let r' = + Box2.add_pt r + V2.(Box2.max r + v style.margin.right style.margin.bottom) + |> Margin.outer style.margin + in + draw_box ui.gv ~box:r' ~style; + Lwt.return r' + end +end + open Lwt.Infix -open Store module F = Fmt +open Tgles2 +module Gv = Graphv_gles2_native +open Ogui -let lang_mime_type = "text/x-ocaml" -let lang_name = "ocaml" -let use_mime_type = true -let font_name = "Monospace 12" +module GLFWExtras = struct + open Ctypes + open Foreign -let _ = - let language_manager = - GSourceView3.source_language_manager ~default:true + let glfwSetErrorCallback : + (int -> string -> unit) -> int -> string -> unit = + let errorfun = int @-> string @-> returning void in + foreign "glfwSetErrorCallback" + (funptr errorfun @-> returning (funptr errorfun)) +end + +let errorcb error desc = + Printf.printf "GLFW error %d: %s\n%!" error desc + +let load_fonts vg = + let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in + let _ = + Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf" + in + let _ = + Gv.Text.create vg ~name:"sans" ~file:"./assets/Roboto-Regular.ttf" + in + let _ = + Gv.Text.create vg ~name:"sans-bold" + ~file:"./assets/Roboto-Bold.ttf" + in + let _ = + Gv.Text.create vg ~name:"emoji" + ~file:"./assets/NotoEmoji-Regular.ttf" + in + Gv.Text.add_fallback vg ~name:"sans" ~fallback:"emoji"; + Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji"; + Gv.Text.set_font_face vg ~name:"mono" + +let main = + GLFW.init (); + at_exit GLFW.terminate; + let _res = GLFWExtras.glfwSetErrorCallback errorcb in + GLFW.windowHint ~hint:GLFW.ClientApi ~value:GLFW.OpenGLESApi; + GLFW.windowHint ~hint:GLFW.ContextVersionMajor ~value:2; + GLFW.windowHint ~hint:GLFW.ContextVersionMinor ~value:0; + + let window = + GLFW.createWindow ~width:1000 ~height:600 ~title:"window" () + in + (* Make the window's context current *) + GLFW.makeContextCurrent ~window:(Some window); + GLFW.swapInterval ~interval:0; + + Gl.clear_color 0.1 0.2 0.2 1.; + + (*Memtrace.trace_if_requested (); *) + let ctx = + Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) () in - let lang = - if use_mime_type then - match - language_manager#guess_language ~content_type:lang_mime_type - () - with - | Some x -> x - | None -> failwith (sprintf "no language for %s" lang_mime_type) - else - match language_manager#language lang_name with - | Some x -> x - | None -> failwith (sprintf "can't load %s" lang_name) - in - Store.init_default (F.str "%s/console/rootstore.git" Secrets.giturl) - >>= fun t -> - Store.S.tree t >>= fun rootstore -> - (try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with - | Not_found | Invalid_argument _ -> - Lwt.return - "print_newline \"rootstore://.config/init.ml not found\";;" - | exc -> - Lwt.return - (F.str ".config/init.ml load exception: %s" - (Printexc.to_string exc))) - >>= fun text -> - let source_buffer = - GSourceView3.source_buffer ~language:lang ~text - ?style_scheme: - ((GSourceView3.source_style_scheme_manager ~default:true) - #style_scheme "solarized-dark") - ~highlight_matching_brackets:true ~highlight_syntax:true () + let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in + let min_fps = ref Float.max_float in + let max_fps = ref Float.min_float in + + (* Thread which is woken up when the main window is closed. *) + let _waiter, _wakener = Lwt.wait () in + + (* F.pr "oplevel.ml: Toploop.initialize_toplevel_env@."; + Toploop.initialize_toplevel_env (); *) + let rootrepo = + Store.init_default + (F.str "%s/console/rootstore.git" Secrets.giturl) in - let win = GWindow.window ~title:"oplevel main" () in - let vbox = - GPack.vbox ~spacing:10 ~border_width:15 ~packing:win#add () + let ui = + Ogui.Ui.window ctx ~window + (Lwd.var Gg.(Box2.v P2.o (P2.v 500. 500.))) in - let scroll_edit = - GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC - ~packing:vbox#add () - in - let edit = - GSourceView3.source_view ~source_buffer ~auto_indent:true - ~insert_spaces_instead_of_tabs:true ~tab_width:2 - ~show_line_numbers:true ~right_margin_position:80 - ~show_right_margin:true (* ~smart_home_end:true *) - ~packing:scroll_edit#add ~height:500 ~width:650 () - in - edit#misc#modify_font_by_name font_name; - edit#set_smart_home_end `AFTER; - if edit#smart_home_end <> `AFTER then failwith "regret"; - ignore (edit#connect#undo ~callback:(fun _ -> prerr_endline "undo")); - let scroll_output = - GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC - ~packing:vbox#add () - in - let output_buffer = GText.buffer ~text:"loading..." () in - let _output_win = - GText.view ~buffer:output_buffer ~editable:false - ~cursor_visible:true ~packing:scroll_output#add () - in - F.pf "Toploop.initialize_toplevel_env"; - Toploop.initialize_toplevel_env (); + load_fonts ui.gv; + GLFW.setKeyCallback ~window + ~f: + (Some + (fun _window key _int state mods -> + Lwt.async (fun () -> + Ogui.Ui.keycallback ui state key mods >>= fun _ -> + Lwt.return_unit))) + |> ignore; + + GLFW.setCharCallback ~window + ~f: + (Some + (fun _window ch -> + Lwt.async (fun () -> + Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit))) + |> ignore; + + GLFW.setWindowSizeCallback ~window + ~f: + (Some + Gg.( + fun _window x y -> + Lwd.set ui.rect + (Box2.v V2.zero (V2.v (float x) (float y))))) + |> ignore; + + F.pr "oplevel.ml: building initial page@."; + let initial_path = [ ".config"; "init.ml" ] in + TextBuffer.of_repo ~initial_path ~repo:rootrepo >>= fun tb_init -> + TextBuffer.of_string ~repo:rootrepo + ~path: + (List.fold_right + (fun a (acc : string list) -> + match acc with + | [] -> [ F.str "%s.output" a ] + | a' -> a :: a') + [] initial_path) + (F.str "(* --- output:%s --- *)\n\n" + (String.concat "/" initial_path)) + |> Lwt.return + >>= fun to_init -> let out_ppf = + let insert s = + Lwt.async (fun () -> + TextBuffer.length to_init >>= fun len -> + (* TKTK if buffer is modified here during yield from >>= it could be weird *) + TextBuffer.insert to_init len s) + in Format.formatter_of_out_functions Format. { - out_string = (fun s _ _ -> output_buffer#insert s); + out_string = (fun s _ _ -> insert s); out_flush = (fun () -> ()); - out_indent = - (fun n -> - for _ = 0 to n do - output_buffer#insert " " - done); - out_newline = (fun () -> output_buffer#insert "\n"); - out_spaces = - (fun n -> output_buffer#insert (String.make n ' ')); + out_indent = (fun n -> insert (String.make (n * 2) ' ')); + out_newline = (fun () -> insert "\n"); + out_spaces = (fun n -> insert (String.make n ' ')); } in - ignore (Toploop.use_input out_ppf (String text)) + + (* toplevel execution binding *) + Ui.( + update_bindings ui + Event.( + fun a -> + a + |> adds + [ + [ + Key (Press, X, [ Control ]); + Key (Release, X, [ Control ]); + Key (Press, E, [ Control ]); + ]; + ] + [ + Custom + (fun () -> + F.epr "Ctrl-X Ctrl-E@."; + TextBuffer.peek tb_init >>= fun str -> + Toploop.use_input out_ppf (String str) + |> F.epr "Toploop.use_input=%b@."; + Lwt.return_unit); + ])); + + Layout.( + tiling ui `Y + ~style: + Style.{ default with margin = Margin.symmetric 10.0 10.0 } + [ TextEdit.multiline ui tb_init; TextEdit.multiline ui to_init ]) + >>= fun page -> + let page_root = Lwd.observe page in + + let open GLFW in + let open Event in + Ui.update_bindings ui + Ui.( + adds + [ + [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ]; + ] + [ Custom (fun () -> Lwt.return ()) ]); + F.pr "oplevel.ml: entering drawing loop@."; + let period_min = 1.0 /. 30. in + let t = GLFW.getTime () |> ref in + + let render root = + let page = Lwd.quick_sample root in + let win_w, win_h = GLFW.getWindowSize ~window in + let width, height = (float win_w, float win_h) in + let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in + Gv.begin_frame ctx ~width ~height ~device_ratio:1.; + Perfgraph.render graph ctx (width -. 205.) 5.; + (* F.epr "box=%a@." Gg.Box2.pp box; + F.epr "Painter.layout=%a@." Gg.Box2.pp *) + Painter.layout box ui page >>= fun _ -> + (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *) + Gv.end_frame ctx; + + Lwt.return_unit + in + + while not GLFW.(windowShouldClose ~window) do + let now = GLFW.getTime () in + let dt = now -. !t in + t := now; + + Perfgraph.update graph dt; + + if now > 2. then ( + let avg = 1. /. Perfgraph.average graph in + min_fps := Float.min avg !min_fps; + max_fps := Float.max avg !max_fps); + + let win_w, win_h = GLFW.getWindowSize ~window in + Gl.viewport 0 0 win_w win_h; + Gl.clear + (Gl.color_buffer_bit lor Gl.depth_buffer_bit + lor Gl.stencil_buffer_bit); + Gl.enable Gl.blend; + Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha; + Gl.enable Gl.cull_face_enum; + Gl.disable Gl.depth_test; + Lwt.async (fun () -> render page_root); + Gc.major_slice 0 |> ignore; + GLFW.swapBuffers ~window; + GLFW.pollEvents (); + Unix.sleepf Float.(max 0. (period_min -. GLFW.getTime () +. !t)) + done; + + Printf.printf "MIN %.2f\n" !min_fps; + Printf.printf "MAX %.2f\n%!" !max_fps; + Lwt.return_unit + +let () = Lwt_main.run main diff --git a/.gitignore b/.gitignore index e4e5f6c..cdd8678 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,4 @@ -*~ \ No newline at end of file +*~ + +*/.merlin +*/_build \ No newline at end of file diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..75b374d --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,3 @@ +profile = default +version = 0.26.2 +no-parse-toplevel-phrases \ No newline at end of file