From 54e9cc90d38bc383a28d8385761c99a17acf1a82 Mon Sep 17 00:00:00 2001 From: cqc Date: Sat, 20 Apr 2024 13:58:47 -0500 Subject: [PATCH] basic cursor forward back --- dune | 6 +- ogui.ml | 373 +++++++++++++++++++++++++++++++++++++---------------- oplevel.ml | 286 ++++++++++++++++++++++++++++++---------- 3 files changed, 489 insertions(+), 176 deletions(-) diff --git a/dune b/dune index 265b332..0f25300 100644 --- a/dune +++ b/dune @@ -20,17 +20,17 @@ lwt store memtrace + glfw-ocaml tgls tgls.tgles2 graphv_gles2_native - stb_image - glfw-ocaml gg irmin-git compiler-libs.toplevel ) (link_flags (-linkall)) - (ocamlopt_flags (:standard -O3 -unboxed-types)) + ; (ocamlopt_flags (:standard -O3 -unboxed-types)) + (ocamlc_flags (:standard -verbose)) (modes byte) (preprocess (pps ppx_irmin)) diff --git a/ogui.ml b/ogui.ml index 23cf500..e1a683f 100644 --- a/ogui.ml +++ b/ogui.ml @@ -181,11 +181,11 @@ module TextLayout = struct field "background" (fun s -> s.background) pp_color; ]) - let text_format_default () = + let text_format_default = { - font_id = FontId ("sans", 12.0); + font_id = FontId ("mono", 18.0); extra_letter_spacing = 0.0; - line_height = None; + line_height = Some 19.; color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9; background = Gv.Color.transparent; italics = false; @@ -195,7 +195,7 @@ module TextLayout = struct } let text_format_simple font_id color : text_format = - { (text_format_default ()) with font_id; color } + { text_format_default with font_id; color } type text_wrapping = { max_width : float; @@ -242,14 +242,22 @@ module TextLayout = struct field "format" (fun s -> s.format) pp_text_format; ]) + let layout_section_default = + { + leading_space = 0.0; + byte_range = (0, 0); + format = text_format_default; + } + type layout_job = { text : string; - sections : layout_section list; + sections : layout_section array; wrap : text_wrapping; first_row_min_height : float; break_on_newline : bool; halign : align; justify : bool; + line_height : float option; } let pp_layout_job = @@ -259,7 +267,7 @@ module TextLayout = struct field "text" (fun s -> String.length s.text) int; field "sections" (fun s -> s.sections) - (list pp_layout_section); + (array pp_layout_section); field "wrap" (fun s -> s.wrap) pp_text_wrapping; field "first_row_min_height" (fun s -> s.first_row_min_height) @@ -272,12 +280,13 @@ module TextLayout = struct let default_layout_job () = { text = ""; - sections = []; + sections = Array.make 0 layout_section_default; wrap = default_text_wrapping (); first_row_min_height = 0.0; break_on_newline = true; halign = Min; justify = false; + line_height = Some 18.; } type uv_rect = { @@ -430,60 +439,141 @@ module TextLayout = struct prefer_next_row : bool; } + let cursor_default = + { index = 0; row = None; prefer_next_row = false } + type cursor_range = cursor * cursor type cursor_state = cursor_range option let cursor_index = ref 0 + let cursor_range c = ((fst c).index, (snd c).index) - let new_cursor ?(loc = 0) () = + let new_cursor ?(loc = 0) () : cursor = cursor_index := !cursor_index + 1; { index = loc; row = None; prefer_next_row = false } - let simple text (font : font_selection) color wrap_width : + let new_cursor_range (s, e) : cursor_range = + ( { cursor_default with index = s }, + { cursor_default with index = e } ) + + let cursor_state_update ~(f : int -> int -> int * int) + (c : cursor_state) : cursor_state = + match c with + | Some (a, b) -> + let a', b' = f a.index b.index in + Some (new_cursor_range (max a' 0, max b' 0)) + | None -> None + + let layout_job text ?(format = text_format_default) wrap_width : layout_job = { (default_layout_job ()) with text; sections = - [ + Array.make 1 { leading_space = 0.0; byte_range = (0, String.length text); - format = text_format_simple font color; + format; }; - ]; wrap = { (default_text_wrapping ()) with max_width = wrap_width }; break_on_newline = true; } - let simple_singleline text (font : font_selection) color : - layout_job = + let simple text (format : text_format) wrap_width : layout_job = { (default_layout_job ()) with text; sections = - [ + Array.make 1 { leading_space = 0.0; byte_range = (0, String.length text); - format = text_format_simple font color; + format; + }; + wrap = + { (default_text_wrapping ()) with max_width = wrap_width }; + break_on_newline = true; + } + + let simple_singleline text (format : text_format) : layout_job = + { + (default_layout_job ()) with + text; + sections = + Array.make 1 + { + leading_space = 0.0; + byte_range = (0, String.length text); + format; }; - ]; wrap = default_text_wrapping (); break_on_newline = true; } - let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job) : galley - = - F.epr "TextLayout.layout@."; - F.epr "job.wrap.max_width=%f@." job.wrap.max_width; - F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; + let cursor_color = ref (Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.) + + let default_cursor_formatter (f : text_format) = + { f with background = !cursor_color } + + let with_cursor (cur : cursor_range) + ?(cursor_format = default_cursor_formatter) layout_job : + layout_job = + let cs, ce = ((fst cur).index, (snd cur).index) in + { + layout_job with + sections = + Array.of_list + (* Lol maybe this is inefficient? (or maybe not) *) + (List.fold_left + (fun (l : layout_section list) sec -> + let s, e = sec.byte_range in + + if e < cs || ce < s then l @ [ sec ] + else + l + @ (if s = cs then + [ + { + sec with + byte_range = (s, if ce > e then e else ce); + format = cursor_format sec.format; + }; + ] + else if s < cs && cs <= e then + (* cursor start in section *) + [ + { sec with byte_range = (s, cs) }; + { + sec with + byte_range = (cs, if ce > e then e else ce); + format = cursor_format sec.format; + }; + ] + else if cs < s && e < ce then + [ + { sec with format = cursor_format sec.format }; + ] + else []) + @ + if ce > s && ce < e then + [ { sec with byte_range = (ce, e) } ] + else []) + [] + (Array.to_list layout_job.sections)); + } + + let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job) + (pos : v2) : galley = + (* F.epr "TextLayout.layout@."; + F.epr "job.wrap.max_width=%f@." job.wrap.max_widtha; + F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; *) if job.wrap.max_rows == 0 then { job; rows = Array.make 1 (row_default ()); - rect = Box2.zero; + rect = Box2.move pos Box2.zero; mesh_bounds = Box2.zero; elided = true; num_vertices = 0; @@ -497,20 +587,24 @@ module TextLayout = struct Gv.Text.break_lines gv ~break_width:job.wrap.max_width ~max_rows:job.wrap.max_rows ~lines job.text in - F.epr "row_count=%d@." row_count; - let height = ref 0. in + (* F.epr "row_count=%d@." row_count; *) + let height = ref (V2.y pos) in let max_width = ref 0. in + let line_height = + Option.value ~default:metrics.line_height job.line_height + in { job; rows = Array.init row_count (fun n -> let text_row = Array.get lines n in - height := !height +. metrics.line_height; + height := !height +. line_height; let rect = Box2.v - (P2.v text_row.minx !height) - (P2.v text_row.maxx - (!height +. metrics.line_height)) + (P2.v (V2.x pos) !height) + (P2.v + (text_row.width +. V2.x pos) + (!height +. line_height)) in max_width := Float.max text_row.maxx !max_width; { @@ -529,7 +623,7 @@ module TextLayout = struct rect = Box2.v Size2.zero (P2.v job.wrap.max_width - (Float.of_int row_count *. metrics.line_height)); + (Float.of_int row_count *. line_height)); elided = row_count > job.wrap.max_rows (* TODO *); mesh_bounds = Box2.v Size2.zero (P2.v !max_width !height); num_indices = 0 (* TODO *); @@ -551,69 +645,71 @@ module Painter = struct type t = Gv.t let galley (t : t) (g : TextLayout.galley) : unit = - F.epr - "Painter.galley (String.length g.job.text)=%d (Array.length \ - g.rows)=%d @." - (String.length g.job.text) - (Array.length g.rows); - F.epr "g.rect=%a@." Gg.Box2.pp g.rect; - F.epr "g.job=%a@." F.(braces TextLayout.pp_layout_job) g.job; + (* F.epr + "Painter.galley (String.length g.job.text)=%d (Array.length \ + g.rows)=%d @." + (String.length g.job.text) + (Array.length g.rows); + F.epr "g.rect=%a@." Gg.Box2.pp g.rect; *) + (* F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows;*) - Array.iteri + Array.iter Gv.( - fun _n (row : TextLayout.row) -> + fun (row : TextLayout.row) -> let sections = List.filter (fun (r : TextLayout.layout_section) -> - row.text_row.start_index <= snd r.byte_range) - (nth_tl row.section_index_at_start g.job.sections) - (* TODO don't need to iterate the whole list *) + fst r.byte_range <= row.text_row.end_index + && snd r.byte_range > row.text_row.start_index) + (Array.to_list + @@ Array.sub g.job.sections row.section_index_at_start + (Array.length g.job.sections + - row.section_index_at_start)) in assert (List.length sections > 0); ignore - (List.fold_left - Gg.( - fun x (sec : TextLayout.layout_section) -> - let start, end_ = - ( min - (String.length g.job.text - 1) - (max 0 - (max (fst sec.byte_range) - row.text_row.start_index)), - min - (String.length g.job.text - 1) - (max 0 - (min (snd sec.byte_range) - row.text_row.end_index)) ) - in + Gg.( + List.fold_left + (fun x (sec : TextLayout.layout_section) -> + let start, end_ = + ( min + (String.length g.job.text - 1) + (max 0 + (max (fst sec.byte_range) + row.text_row.start_index)), + min + (String.length g.job.text - 1) + (max 0 + (min (snd sec.byte_range) + row.text_row.end_index)) ) + in - let font_name, font_size = - match sec.format.font_id with - | Default -> ("mono", 12.) - | FontId (s, size) -> (s, size) - 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 metrics = Gv.Text.metrics t in - let bounds = - Gv.Text.bounds t ~x:0. ~y:0. ~start ~end_ - g.job.text - in - Path.begin_ t; - Path.rect t ~x ~y:(Box2.miny row.rect) - ~w:bounds.advance ~h:metrics.line_height; - set_fill_color t ~color:sec.format.background; - fill t; + let font_name, font_size = + match sec.format.font_id with + | Default -> ("mono", 18.) + | FontId (s, size) -> (s, size) + 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 metrics = Gv.Text.metrics t in + let bounds = + Gv.Text.bounds t ~x ~y:0. ~start ~end_ g.job.text + in + Path.begin_ t; + Path.rect t ~x ~y:(Box2.miny row.rect) + ~w:bounds.advance ~h:metrics.line_height; + set_fill_color t ~color:sec.format.background; + fill t; - set_fill_color t ~color:sec.format.color; - let w = - Text.text_w t ~x:(Box2.minx row.rect) - ~y:(Box2.miny row.rect) ~start ~end_ g.job.text - in - x +. w) - 0. sections)) + set_fill_color t ~color:sec.format.color; + let w = + Text.text_w t ~x ~y:(Box2.miny row.rect) ~start + ~end_ g.job.text + in + w) + (Box2.minx row.rect) sections)) g.rows end @@ -781,12 +877,23 @@ module Placer = struct end module Ui = struct - type t = { + type key_callback = + t -> + GLFW.window -> + GLFW.key -> + int -> + GLFW.key_action -> + GLFW.key_mod list -> + unit + + and t = { id : id; style : Style.t; placer : Placer.t; enabled : bool; gv : Gv.t; + glfw_window : GLFW.window option; + mutable key : key_callback; } let id = ref 0 @@ -800,8 +907,9 @@ module Ui = struct (!id, size) let cursor_origin (ui : t) = Gg.Box2.o ui.placer.region.max_rect + let key_callback_default _ _ _ _ _ _ = () - let window gv rect : t = + let window gv ?(window : GLFW.window option) rect : t = let id, rect = allocate_space gv rect in { id; @@ -811,8 +919,20 @@ module Ui = struct Layout.{ min_rect = rect; max_rect = rect; cursor = rect }; enabled = true; gv; + glfw_window = window; + key = key_callback_default; } + let keycallback t window key int state mods : unit = + t.key t window key int state mods + + let add_key_callback (t : t) ~(f : key_callback) : unit = + let g = t.key in + t.key <- + (fun a1 a2 a3 a4 a5 a6 -> + f a1 a2 a3 a4 a5 a6; + g a1 a2 a3 a4 a5 a6) + let interact (_ui : t) rect (id : id option) sense : Response.t = let id = Option.value id ~default:(-1) in { @@ -852,8 +972,7 @@ module TextEdit = struct hint_text : TextLayout.widget_text; id : id option; id_source : id option; - font_selection : TextLayout.font_selection; - text_color : Gv.Color.t option; + text_format : TextLayout.text_format; layouter : (Ui.t -> TextBuffer.t -> float -> TextLayout.galley) option; password : bool; @@ -872,14 +991,51 @@ module TextEdit = struct } type state = { - cursor : TextLayout.cursor_state; + mutable cursor : TextLayout.cursor_state; (* undoer : undoer; *) singleline_offset : float; last_edit_time : float; } - let load_state _ui _id = - { cursor = None; singleline_offset = 0.0; last_edit_time = 0.0 } + let state_mem : (int * state) list ref = ref [] + + let process_key (state : state) (key : GLFW.key) + (action : GLFW.key_action) (mods : GLFW.key_mod list) : unit = + let open GLFW in + match (action, key, mods) with + | Press, F, [ Control ] | Press, Right, [] -> + state.cursor <- + TextLayout.cursor_state_update + ~f:(fun a b -> + F.epr "cursor_state_update %d %d@." a b; + (a + 1, b + 1)) + state.cursor + | Press, B, [ Control ] | Press, Left, [] -> + state.cursor <- + TextLayout.cursor_state_update + ~f:(fun a b -> + F.epr "cursor_state_update %d %d@." a b; + (a - 1, b - 1)) + state.cursor + | _ -> () + + let load_state ui id = + match List.assoc_opt id !state_mem with + | Some state -> state + | None -> + let state = + { + cursor = Some (TextLayout.new_cursor_range (12, 13)); + singleline_offset = 0.0; + last_edit_time = 0.0; + } + in + state_mem := (id, state) :: !state_mem; + (* We use this as the one shot for registering keyboard shortcuts + since they just operate on the state *) + Ui.add_key_callback ui ~f:(fun _ _ key _ action mods -> + process_key state key action mods); + state type output = { response : Response.t; @@ -890,14 +1046,14 @@ module TextEdit = struct cursor_range : TextLayout.cursor_range option; } - let multiline (text : TextBuffer.t) : t = + let multiline ?(text_format = TextLayout.text_format_default) + (text : TextBuffer.t) : t = { text; hint_text = RichText TextLayout.rich_text_default; id = None; id_source = None; - font_selection = Default; - text_color = Some (Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9); + text_format; layouter = None; password = false; frame = true; @@ -923,9 +1079,8 @@ module TextEdit = struct let show_content (t : t) (ui : Ui.t) : output = let origin = Ui.cursor_origin ui in - let text_color = t.text_color in (* TODO .or(ui.visuals().override_text_color) *) - let row_height = (Gv.Text.metrics ui.gv).line_height in + (* let row_height = (Gv.Text.metrics ui.gv).line_height in *) let available_width = Ui.available_width ui -. (t.margin.left +. t.margin.right) in @@ -938,29 +1093,33 @@ module TextEdit = struct available_width else Float.min desired_width available_width in - let text_color = - Option.value - ~default:(Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.5) - text_color - in + let state = load_state ui (Option.value ~default:(-1) t.id) in let default_layouter (ui : Ui.t) (text : TextBuffer.t) (wrap_width : size1) : TextLayout.galley = let font = - match Gv.Text.find_font ui.gv ~name:"sans" with + match Gv.Text.find_font ui.gv ~name:"mono" with | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 } - | None -> failwith "can't font font 'sans'" + | None -> failwith "can't font font 'mono'" in let layout_job = if t.multiline then TextLayout.simple (TextBuffer.as_string text) - t.font_selection text_color wrap_width + t.text_format wrap_width else TextLayout.simple_singleline (TextBuffer.as_string text) - t.font_selection text_color + t.text_format in - Ui.fonts ui.gv (fun f -> TextLayout.layout f font layout_job) + let layout_job = + TextLayout.with_cursor + (Option.value + ~default:(TextLayout.new_cursor_range (0, 0)) + state.cursor) + layout_job + in + Ui.fonts ui.gv (fun f -> + TextLayout.layout f font layout_job origin) in let layouter = @@ -972,9 +1131,6 @@ module TextEdit = struct if t.clip_text then wrap_width else Float.max (Size2.w (Box2.size galley_size)) wrap_width in - let _desired_height = - Float.min (Int.to_float t.desired_height_rows) 1.0 *. row_height - in let desired_inner_size = V2.v desired_width (Box2.maxy galley_size) in @@ -987,7 +1143,7 @@ module TextEdit = struct let rect = Margin.inner t.margin outer_rect in (* TODO id = ui.make_persistent_id(id_source) else auto_id *) (* TODO state = TextEditState::load(ui.ctx(), id)... *) - let state = load_state ui.gv t.id in + (* TODO moved up let state = load_state (Option.value ~default:(-1) t.id) in *) (* TODO allow_drag_to_select = ... *) let sense = if t.interactive then Sense.click else Sense.hover in @@ -1000,6 +1156,7 @@ module TextEdit = struct let galley_pos = Align.size_within_rect (Box2.size galley_size) rect in + (* if Ui.is_rect_visible ui rect then *) Painter.galley ui.gv galley; diff --git a/oplevel.ml b/oplevel.ml index d9eeaa2..3c00358 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -37,6 +37,153 @@ let load_data vg = Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji"; Gv.Text.set_font_face vg ~name:"mono" +let pp_glfw_key : GLFW.key F.t = + fun ppf k -> + F.pf ppf + GLFW.( + match k with + | Unknown -> "Unknown" + | Space -> "Space" + | Apostrophe -> "Apostrophe" + | Comma -> "Comma" + | Minus -> "Minus" + | Period -> "Period" + | Slash -> "Slash" + | Num0 -> "Num0" + | Num1 -> "Num1" + | Num2 -> "Num2" + | Num3 -> "Num3" + | Num4 -> "Num4" + | Num5 -> "Num5" + | Num6 -> "Num6" + | Num7 -> "Num7" + | Num8 -> "Num8" + | Num9 -> "Num9" + | Semicolon -> "Semicolon" + | Equal -> "Equal" + | A -> "A" + | B -> "B" + | C -> "C" + | D -> "D" + | E -> "E" + | F -> "F" + | G -> "G" + | H -> "H" + | I -> "I" + | J -> "J" + | K -> "K" + | L -> "L" + | M -> "M" + | N -> "N" + | O -> "O" + | P -> "P" + | Q -> "Q" + | R -> "R" + | S -> "S" + | T -> "T" + | U -> "U" + | V -> "V" + | W -> "W" + | X -> "X" + | Y -> "Y" + | Z -> "Z" + | LeftBracket -> "LeftBracket" + | Backslash -> "Backslash" + | RightBracket -> "RightBracket" + | GraveAccent -> "GraveAccent" + | World1 -> "World1" + | World2 -> "World2" + | Escape -> "Escape" + | Enter -> "Enter" + | Tab -> "Tab" + | Backspace -> "Backspace" + | Insert -> "Insert" + | Delete -> "Delete" + | Right -> "Right" + | Left -> "Left" + | Down -> "Down" + | Up -> "Up" + | PageUp -> "PageUp" + | PageDown -> "PageDown" + | Home -> "Home" + | End -> "End" + | CapsLock -> "CapsLock" + | ScrollLock -> "ScrollLock" + | NumLock -> "NumLock" + | PrintScreen -> "PrintScreen" + | Pause -> "Pause" + | F1 -> "F1" + | F2 -> "F2" + | F3 -> "F3" + | F4 -> "F4" + | F5 -> "F5" + | F6 -> "F6" + | F7 -> "F7" + | F8 -> "F8" + | F9 -> "F9" + | F10 -> "F10" + | F11 -> "F11" + | F12 -> "F12" + | F13 -> "F13" + | F14 -> "F14" + | F15 -> "F15" + | F16 -> "F16" + | F17 -> "F17" + | F18 -> "F18" + | F19 -> "F19" + | F20 -> "F20" + | F21 -> "F21" + | F22 -> "F22" + | F23 -> "F23" + | F24 -> "F24" + | F25 -> "F25" + | Kp0 -> "Kp0" + | Kp1 -> "Kp1" + | Kp2 -> "Kp2" + | Kp3 -> "Kp3" + | Kp4 -> "Kp4" + | Kp5 -> "Kp5" + | Kp6 -> "Kp6" + | Kp7 -> "Kp7" + | Kp8 -> "Kp8" + | Kp9 -> "Kp9" + | KpDecimal -> "KpDecimal" + | KpDivide -> "KpDivide" + | KpMultiply -> "KpMultiply" + | KpSubtract -> "KpSubtract" + | KpAdd -> "KpAdd" + | KpEnter -> "KpEnter" + | KpEqual -> "KpEqual" + | LeftShift -> "LeftShift" + | LeftControl -> "LeftControl" + | LeftAlt -> "LeftAlt" + | LeftSuper -> "LeftSuper" + | RightShift -> "RightShift" + | RightControl -> "RightControl" + | RightAlt -> "RightAlt" + | RightSuper -> "RightSuper" + | Menu -> "Menu") + +let pp_glfw_key_action : GLFW.key_action F.t = + fun ppf s -> + F.pf ppf + GLFW.( + match s with + | Release -> "Release" + | Press -> "Press" + | Repeat -> "Repeat") + +let pp_glfw_mods = + F.( + list (fun ppf s -> + pf ppf + GLFW.( + match s with + | Shift -> "Shift" + | Control -> "Control" + | Alt -> "Alt" + | Super -> "Super"))) + let () = GLFW.init (); at_exit GLFW.terminate; @@ -65,38 +212,53 @@ let () = let continue = ref true in let min_fps = ref Float.max_float in let max_fps = ref Float.min_float in - let blowup = ref false 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 (); - Lwt_main.run - ((fun () -> - 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 -> - GLFW.setKeyCallback ~window - ~f: - (Some - (fun _ key _ state _ -> - match (key, state) with - | GLFW.Space, GLFW.Release -> blowup := not !blowup - | _ -> ())) - |> ignore; + let text = + Lwt_main.run + ((fun () -> + 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 -> Lwt.return text) + ()) + in - let t = GLFW.getTime () |> ref in - while (not GLFW.(windowShouldClose ~window)) && !continue do + let ui = + Ogui.Ui.window ctx ~window Gg.(Box2.v P2.o (P2.v 500. 500.)) + in + + GLFW.setKeyCallback ~window + ~f: + (Some + (fun window key int state mods -> + F.epr + "GLFW.setKeyCallback ~f: _win key=%a int=%d state=%a \ + mods=%a@." + pp_glfw_key key int pp_glfw_key_action state pp_glfw_mods + mods; + Ogui.Ui.keycallback ui window key int state mods)) + |> ignore; + + let t = GLFW.getTime () |> ref in + + while (not GLFW.(windowShouldClose ~window)) && !continue do + Lwt_main.run + ((fun () -> let now = GLFW.getTime () in let dt = now -. !t in t := now; @@ -127,9 +289,6 @@ let () = Perfgraph.render graph ctx (win_w -. 205.) 5.; - let ui = - Ogui.Ui.window ctx Gg.(Box2.v P2.o (P2.v 500. 500.)) - in ignore Ogui.TextEdit.(show (multiline (String text)) ui); (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *) Gv.end_frame ctx; @@ -137,42 +296,39 @@ let () = Gc.major_slice 0 |> ignore; GLFW.swapBuffers ~window; - GLFW.pollEvents () - (*continue := false;*) - done; + GLFW.pollEvents (); + Lwt.return_unit) + ()) + done; - Printf.printf "MIN %.2f\n" !min_fps; - Printf.printf "MAX %.2f\n%!" !max_fps; + Printf.printf "MIN %.2f\n" !min_fps; + Printf.printf "MAX %.2f\n%!" !max_fps; - if Array.length Sys.argv = 1 then - while not GLFW.(windowShouldClose ~window) do - GLFW.pollEvents (); - Unix.sleepf 0.25 - done; - F.pr "oplevel.ml: Toploop.initialize_toplevel_env@."; - Toploop.initialize_toplevel_env (); + if Array.length Sys.argv = 1 then + while not GLFW.(windowShouldClose ~window) do + GLFW.pollEvents (); + Unix.sleepf 0.25 + done - (* let out_ppf = - Format.formatter_of_out_functions - Format. - { - out_string = (fun s _ _ -> output_buffer#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 ' ')); - } - in *) +(* let out_ppf = + Format.formatter_of_out_functions + Format. + { + out_string = (fun s _ _ -> output_buffer#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 ' ')); + } + in *) - (* ignore - (Toploop.use_input out_ppf - (String "#use \"topfind\";;\n#list;;")); *) - (* ignore (Toploop.use_input Format.std_formatter (String text)); *) - (* Wait for it to be closed. *) - Lwt.return ()) - ()) +(* ignore + (Toploop.use_input out_ppf + (String "#use \"topfind\";;\n#list;;")); *) +(* ignore (Toploop.use_input Format.std_formatter (String text)); *) +(* Wait for it to be closed. *)