diff --git a/assets/NotoEmoji-Regular.ttf b/assets/NotoEmoji-Regular.ttf new file mode 100644 index 0000000..19b7bad Binary files /dev/null and b/assets/NotoEmoji-Regular.ttf differ diff --git a/assets/Roboto-Bold.ttf b/assets/Roboto-Bold.ttf new file mode 100755 index 0000000..aaf374d Binary files /dev/null and b/assets/Roboto-Bold.ttf differ diff --git a/assets/Roboto-Light.ttf b/assets/Roboto-Light.ttf new file mode 100755 index 0000000..664e1b2 Binary files /dev/null and b/assets/Roboto-Light.ttf differ diff --git a/assets/Roboto-Regular.ttf b/assets/Roboto-Regular.ttf new file mode 100755 index 0000000..3e6e2e7 Binary files /dev/null and b/assets/Roboto-Regular.ttf differ diff --git a/assets/entypo.ttf b/assets/entypo.ttf new file mode 100644 index 0000000..fc305d2 Binary files /dev/null and b/assets/entypo.ttf differ diff --git a/assets/mono.ttf b/assets/mono.ttf new file mode 100644 index 0000000..c8add8e Binary files /dev/null and b/assets/mono.ttf differ diff --git a/dune b/dune index 5d41d03..265b332 100644 --- a/dune +++ b/dune @@ -15,17 +15,22 @@ (executables (names oplevel) - (modules oplevel secrets) + (modules oplevel secrets perfgraph ogui) (libraries lwt store - lablgtk3 - lablgtk3-sourceview3 - lwt_glib + memtrace + 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)) (modes byte) (preprocess (pps ppx_irmin)) diff --git a/ogui.ml b/ogui.ml new file mode 100644 index 0000000..23cf500 --- /dev/null +++ b/ogui.ml @@ -0,0 +1,1024 @@ +module Gv = Graphv_gles2_native +module F = Fmt + +type stroke = { width : float; color : Gv.Color.t } + +let stroke_none = { width = 0.; color = Gv.Color.transparent } + +module Margin = struct + open Gg + + type t = { + left : size1; + right : size1; + top : size1; + bottom : size1; + } + + 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)) +end + +type margin = Margin.t + +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 EventFilter = struct + type t = { + tab : bool; + horizontal_arrrows : bool; + vertical_arrows : bool; + escape : bool; + } + + let default = + { + tab = false; + horizontal_arrrows = false; + vertical_arrows = false; + escape = false; + } +end + +type id = int +type event_filter = EventFilter.t + +module Context = struct + type t = { derp : bool } +end + +module Response = struct + type t = { + ctx : Context.t; + (* layer_id : LayerId.t; *) + id : id; + rect : Gg.box2; + interact_rect : Gg.box2; + sense : Sense.t; + enabled : bool; + contains_pointer : bool; + hovered : bool; + highlighted : bool; + clicked : bool; + fake_primary_click : bool; + long_touched : bool; + drag_started : bool; + dragged : bool; + drag_stopped : bool; + is_pointer_button_down_on : bool; + interact_pointer_pos : Gg.p2 option; + changed : bool; + } +end + +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 + +let pp_color : Gv.Color.t Fmt.t = + F.( + record + [ + 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; + ]) + +module TextLayout = struct + open Gg + + type font_selection = Default | FontId of (string * float) + + type text_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; + } + + let pp_text_format : text_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 -> s.line_height) (option float); + field "color" (fun s -> s.color) pp_color; + field "background" (fun s -> s.background) pp_color; + ]) + + let text_format_default () = + { + font_id = FontId ("sans", 12.0); + extra_letter_spacing = 0.0; + line_height = None; + 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 text_format_simple font_id color : text_format = + { (text_format_default ()) with font_id; color } + + type text_wrapping = { + max_width : float; + max_rows : int; + break_anywhere : bool; + overflow_character : string option; + } + + 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 "…"; + } + + type layout_section = { + leading_space : float; + byte_range : int * int; + format : text_format; + } + + let pp_layout_section : Format.formatter -> 'a -> unit = + F.( + record + [ + field "leading_space" (fun s -> s.leading_space) float; + field "byte_range" + (fun s -> s.byte_range) + (pair ~sep:(any ",") int int); + field "format" (fun s -> s.format) pp_text_format; + ]) + + type layout_job = { + text : string; + sections : layout_section list; + wrap : text_wrapping; + first_row_min_height : float; + break_on_newline : bool; + halign : align; + justify : bool; + } + + let pp_layout_job = + F.( + record + [ + field "text" (fun s -> String.length s.text) int; + field "sections" + (fun s -> s.sections) + (list pp_layout_section); + field "wrap" (fun s -> s.wrap) pp_text_wrapping; + field "first_row_min_height" + (fun s -> s.first_row_min_height) + float; + field "break_on_newline" (fun s -> s.break_on_newline) bool; + field "halign" (fun s -> s.halign) Align.pp_t; + field "justify" (fun s -> s.justify) bool; + ]) + + let default_layout_job () = + { + text = ""; + sections = []; + wrap = default_text_wrapping (); + first_row_min_height = 0.0; + break_on_newline = true; + halign = Min; + justify = false; + } + + type uv_rect = { + offset : Gg.v2; + size : Gg.v2; + min : Gg.p2; (* Top left corner UV in texture *) + max : Gg.p2; (* Bottom right corner (exclusive) *) + } + + type glyph = { + chr : string; + pos : Gg.p2; + ascent : float; + size : Gg.size2; + uv_rect : uv_rect; + section_index : int; + } + + type row_visuals = { + (* mesh : mesh; *) + mesh_bounds : Gg.box2; + glyph_vertex_range : int * int; + } + + let pp_row_visuals = + F.( + record + [ + field "mesh_bounds" + (fun (s : row_visuals) -> s.mesh_bounds) + Gg.Box2.pp; + field "glyph_vertex_range" + (fun (s : row_visuals) -> s.glyph_vertex_range) + (pair ~sep:(any ",") int int); + ]) + + 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; + ]) + + type row = { + text_row : Gv.Text.text_row; + section_index_at_start : int; + glyphs : glyph list; + rect : Gg.box2; + visuals : row_visuals; + ends_with_newline : bool; + } + + let pp_row : Format.formatter -> row -> unit = + F.( + record + [ + field "text_row" (fun s -> s.text_row) pp_text_row; + field "section_index_at_start" + (fun (s : row) -> s.section_index_at_start) + int; + field "format" (fun (s : row) -> List.length s.glyphs) int; + field "rect" (fun (s : row) -> s.rect) Gg.Box2.pp; + field "visuals" (fun (s : row) -> s.visuals) pp_row_visuals; + field "ends_with_newline" + (fun (s : row) -> s.ends_with_newline) + bool; + ]) + + let row_default () = + { + text_row = + { + start_index = 0; + end_index = 0; + width = 0.; + minx = 0.; + maxx = 0.; + next = 0; + }; + section_index_at_start = 0; + glyphs = []; + rect = Box2.zero; + visuals = + { mesh_bounds = Box2.zero; glyph_vertex_range = (0, 0) }; + ends_with_newline = false; + } + + type galley = { + job : layout_job; + rows : row array; + elided : bool; + rect : Gg.box2; + mesh_bounds : Gg.box2; + num_vertices : int; + num_indices : int; + pixels_per_point : float; + } + + type rich_text = { + text : string; + size : float option; + extra_letter_spacing : float; + line_height : float option; + font : string option; + background_color : Gv.Color.t; + text_color : Gv.Color.t; + code : bool; + strong : bool; + weak : bool; + strikethrough : bool; + underline : bool; + italics : bool; + raised : bool; + } + + let rich_text_default = + { + text = ""; + size = None; + extra_letter_spacing = 0.0; + line_height = None; + font = None; + background_color = Gv.Color.transparent; + text_color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9; + code = false; + strong = false; + weak = false; + strikethrough = false; + underline = false; + italics = false; + raised = false; + } + + type widget_text = + | RichText of rich_text + | LayoutJob of layout_job + | Galley of galley + + type cursor = { + index : int; + row : int option; + prefer_next_row : bool; + } + + type cursor_range = cursor * cursor + type cursor_state = cursor_range option + + let cursor_index = ref 0 + + let new_cursor ?(loc = 0) () = + cursor_index := !cursor_index + 1; + { index = loc; row = None; prefer_next_row = false } + + let simple text (font : font_selection) color wrap_width : + layout_job = + { + (default_layout_job ()) with + text; + sections = + [ + { + leading_space = 0.0; + byte_range = (0, String.length text); + format = text_format_simple font color; + }; + ]; + wrap = + { (default_text_wrapping ()) with max_width = wrap_width }; + break_on_newline = true; + } + + let simple_singleline text (font : font_selection) color : + layout_job = + { + (default_layout_job ()) with + text; + sections = + [ + { + leading_space = 0.0; + byte_range = (0, String.length text); + format = text_format_simple font color; + }; + ]; + 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; + if job.wrap.max_rows == 0 then + { + job; + rows = Array.make 1 (row_default ()); + rect = Box2.zero; + mesh_bounds = Box2.zero; + elided = true; + num_vertices = 0; + num_indices = 0; + pixels_per_point = fonts.pixels_per_point; + } + else + let metrics = Gv.Text.metrics gv in + let lines = Gv.Text.make_empty_rows job.wrap.max_rows in + let row_count = + 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 + let max_width = ref 0. in + { + job; + rows = + Array.init row_count (fun n -> + let text_row = Array.get lines n in + height := !height +. metrics.line_height; + let rect = + Box2.v + (P2.v text_row.minx !height) + (P2.v text_row.maxx + (!height +. metrics.line_height)) + in + max_width := Float.max text_row.maxx !max_width; + { + text_row; + section_index_at_start = 0; + glyphs = [ (* TODO *) ]; + rect; + visuals = + { + mesh_bounds = rect; + glyph_vertex_range = + (text_row.start_index, text_row.end_index); + }; + ends_with_newline = false (* TODO *); + }); + rect = + Box2.v Size2.zero + (P2.v job.wrap.max_width + (Float.of_int row_count *. metrics.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 *); + num_vertices = 0 (* TODO *); + pixels_per_point = fonts.pixels_per_point; + } +end + +let rec nth_tl n = function + | hd :: tl -> if n > 0 then nth_tl (n - 1) tl else hd :: tl + | [] -> [] + +let _ = + assert (List.equal Int.equal (nth_tl 2 [ 0; 1; 2; 3 ]) [ 2; 3 ]); + assert (List.equal Int.equal (nth_tl 3 [ 0; 1; 2 ]) []); + assert (List.equal Int.equal (nth_tl 0 [ 0; 1 ]) [ 0; 1 ]) + +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 "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows;*) + Array.iteri + Gv.( + fun _n (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 *) + 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 + + 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; + + 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)) + g.rows +end + +module Style = struct + open Gg + + type text_style = unit + + type spacing = { + item_spacing : Gg.size2; + window_margin : Margin.t; + indent : Gg.size1; + interact_size : Gg.size2; + slider_width : Gg.size1; + text_edit_width : Gg.size1; + icon_width : Gg.size1; + icon_width_inner : Gg.size1; + icon_spacing : Gg.size1; + } + + type t = { + override_text_style : text_style option; + override_font : TextLayout.font_selection option; + wrap : bool option; + spacing : spacing; + (*interaction: Interaction.t; *) + animation_time : float; + } + + let default = + { + override_text_style = None; + override_font = None; + wrap = None; + spacing = + { + item_spacing = Size2.v 10. 10.; + window_margin = Margin.symmetric 5. 5.; + indent = 5.; + slider_width = 5.; + text_edit_width = 500.; + icon_width = 40.; + icon_width_inner = 35.; + icon_spacing = 50.; + interact_size = P2.v 500. 500.; + }; + animation_time = 0.1; + } +end + +module Layout = struct + open Gg + + type direction = LeftToRight | RightToLeft | TopDown | BottomUp + + type t = { + main_dir : direction; + main_wrap : bool; + main_align : align; + main_justify : bool; + cross_align : align; + cross_justify : bool; + } + + let horizontal = + { + main_dir = LeftToRight; + main_wrap = true; + main_align = Min; + main_justify = true; + cross_align = Min; + cross_justify = true; + } + + let vertical = + { + main_dir = TopDown; + main_wrap = true; + main_align = Min; + main_justify = true; + cross_align = Min; + cross_justify = true; + } + + type region = { min_rect : box2; max_rect : box2; cursor : box2 } + + let rec is_horizontal = function + | `Direction d -> ( + match d with + | LeftToRight | RightToLeft -> true + | TopDown | BottomUp -> false) + | `Layout t -> is_horizontal (`Direction t.main_dir) + + let available_from_cursor_max_rect t cursor max_rect : box2 = + (* TODO assert !cursor.any_nan() *) + (* TODO assert !max_rect.any_nan() *) + (* TODO assert !max_rect.is_finite() *) + let avail = + match t.main_dir with + | LeftToRight -> + Box2.of_pts + (V2.v (Box2.minx cursor) (Box2.miny max_rect)) + (V2.v + Float.( + max + (max (Box2.maxx max_rect) (Box2.minx cursor)) + (Box2.minx max_rect)) + Float.(max (Box2.maxy max_rect) (Box2.miny max_rect))) + | RightToLeft -> Box2.zero (* TODO *) + | TopDown | BottomUp -> Box2.zero + in + let avail = Box2.inter avail cursor in + + (* todo make sure it isn't negative (won't because Gg.maxx is maxing )*) + avail + + let available_size t r = + if t.main_wrap then + if is_horizontal (`Direction t.main_dir) then + V2.v (Box2.w r.max_rect) (Box2.h r.cursor) + else V2.v (Box2.w r.cursor) (Box2.h r.max_rect) + else + Box2.size (available_from_cursor_max_rect t r.cursor r.max_rect) + + let horizontal_justify (l : t) = + if is_horizontal (`Layout l) then l.main_justify + else l.cross_justify + + module Grid = struct + type state = { + col_widths : Gg.size1 list; + row_heights : Gg.size1 list; + } + + type t = { + id : id; + is_first_frame : bool; + prev_state : state; + initial_available : Gg.size1 option; + spacing : Gg.v2; + min_cell_size : Gg.v2; + max_cell_size : Gg.v2; + col : int; + row : int; + } + + let available_rect _t _r = Gg.Box2.zero (*TODO*) + end +end + +module Placer = struct + type t = { + grid : Layout.Grid.t option; + layout : Layout.t; + region : Layout.region; + } + + let available_size t = + match t.grid with + | Some grid -> + Gg.Box2.size (Layout.Grid.available_rect grid t.region) + | None -> Layout.available_size t.layout t.region + + let create layout region = { grid = None; layout; region } +end + +module Ui = struct + type t = { + id : id; + style : Style.t; + placer : Placer.t; + enabled : bool; + gv : Gv.t; + } + + let id = ref 0 + let spacing ui = ui.style.spacing + let available_size ui = Placer.available_size ui.placer + let available_width ui = Gg.P2.x (available_size ui) + let fonts ui (reader : Gv.t -> 'a) : 'a = reader ui + + let allocate_space (_gv : Gv.t) (size : Gg.box2) : id * Gg.box2 = + id := !id + 1; + (!id, size) + + let cursor_origin (ui : t) = Gg.Box2.o ui.placer.region.max_rect + + let window gv rect : t = + let id, rect = allocate_space gv rect in + { + id; + style = Style.default; + placer = + Placer.create Layout.vertical + Layout.{ min_rect = rect; max_rect = rect; cursor = rect }; + enabled = true; + gv; + } + + let interact (_ui : t) rect (id : id option) sense : Response.t = + let id = Option.value id ~default:(-1) in + { + ctx = { derp = false }; + id; + rect; + interact_rect = rect; + sense; + enabled = true; + contains_pointer = (*TODO*) true; + hovered = (*TODO*) true; + highlighted = (*TODO*) true; + clicked = (*TODO*) true; + fake_primary_click = (*TODO*) false; + long_touched = (*TODO*) false; + drag_started = false; + dragged = false; + drag_stopped = false; + is_pointer_button_down_on = false; + interact_pointer_pos = None; + changed = false; + } +end + +module TextBuffer = struct + type t = String of string + + let is_mutable = function String _ -> true + let as_string = function String s -> s +end + +module TextEdit = struct + open Gg + + type t = { + text : TextBuffer.t; + hint_text : TextLayout.widget_text; + id : id option; + id_source : id option; + font_selection : TextLayout.font_selection; + text_color : Gv.Color.t option; + layouter : + (Ui.t -> TextBuffer.t -> float -> TextLayout.galley) option; + password : bool; + frame : bool; + margin : margin; + multiline : bool; + interactive : bool; + desired_width : float option; + desired_height_rows : int; + event_filter : event_filter; + cursor_at_end : bool; + min_size : Gg.v2; + align : align; + clip_text : bool; + char_limit : int; (* return_key : keyboard_shortcut; *) + } + + type state = { + 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 } + + type output = { + response : Response.t; + galley : TextLayout.galley; + galley_pos : Gg.p2; + text_clip_rect : Gg.box2; + state : state; + cursor_range : TextLayout.cursor_range option; + } + + let multiline (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); + layouter = None; + password = false; + frame = true; + margin = Margin.symmetric 4.0 2.0; + multiline = true; + interactive = true; + desired_width = None; + desired_height_rows = 4; + event_filter = + { + EventFilter.default with + horizontal_arrrows = true; + vertical_arrows = true; + tab = false; + }; + cursor_at_end = true; + min_size = Gg.V2.zero; + align = Min; + clip_text = false; + char_limit = Int.max_int; + (* return_key = keyboard_shortcut; *) + } + + 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 available_width = + Ui.available_width ui -. (t.margin.left +. t.margin.right) + in + let desired_width = + Option.fold ~none:(Ui.spacing ui).text_edit_width ~some:Fun.id + t.desired_width + in + let wrap_width = + if Layout.horizontal_justify ui.placer.layout then + 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 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 + | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 } + | None -> failwith "can't font font 'sans'" + in + let layout_job = + if t.multiline then + TextLayout.simple + (TextBuffer.as_string text) + t.font_selection text_color wrap_width + else + TextLayout.simple_singleline + (TextBuffer.as_string text) + t.font_selection text_color + in + Ui.fonts ui.gv (fun f -> TextLayout.layout f font layout_job) + in + + let layouter = + Option.value ~default:default_layouter t.layouter + in + let galley = layouter ui t.text wrap_width in + let galley_size = galley.mesh_bounds in + let desired_width = + 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 + let desired_outer_size = + V2.(desired_inner_size + Margin.sum t.margin) + in + let (_auto_id, outer_rect) : id * box2 = + Ui.allocate_space ui.gv (Box2.v origin desired_outer_size) + in + 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 allow_drag_to_select = ... *) + let sense = if t.interactive then Sense.click else Sense.hover in + + let response = Ui.interact ui outer_rect t.id sense in + (* TODO *) + let text_clip_rect = rect in + (* let painter = Ui.painter_at ui text_clip_rect in *) + let cursor_range = None in + (* TODO cursor_range *) + 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; + + let _align_offset = rect in + { + response; + galley; + galley_pos = Box2.o galley_pos; + text_clip_rect; + state; + cursor_range; + } + + let show (t : t) ui : output = + let _is_mutable = TextBuffer.is_mutable t.text in + let _frame = t.frame in + + let _margin = t.margin in + let output = show_content t ui in + let _outer_rect = output.response.rect in + output +end diff --git a/oplevel.ml b/oplevel.ml index 6f6531e..d9eeaa2 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -1,201 +1,178 @@ open Lwt.Infix module F = Fmt +open Tgles2 +module Gv = Graphv_gles2_native -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 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_data 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 () = + 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.3 0.3 0.32 1.; + + Memtrace.trace_if_requested (); + + let ctx = + Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) () + in + + let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in + let _odata = load_data ctx in + 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 + Lwt_main.run - ((* Initializes GTK. *) - ignore (GMain.init ()); + ((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; - (* Install Lwt<->Glib integration. *) - Lwt_glib.install (); + let t = GLFW.getTime () |> ref in + while (not GLFW.(windowShouldClose ~window)) && !continue do + let now = GLFW.getTime () in + let dt = now -. !t in + t := now; - (* Thread which is wakeup when the main window is closed. *) - let waiter, wakener = Lwt.wait () in + Perfgraph.update graph dt; - let language_manager = - GSourceView3.source_language_manager ~default:true - in + 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 lang = - if use_mime_type then - match - language_manager#guess_language - ~content_type:lang_mime_type () - with - | Some x -> x - | None -> - failwith (F.str "no language for %s" lang_mime_type) - else - match language_manager#language lang_name with - | Some x -> x - | None -> failwith (F.str "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 () - in + let _mx, _my = GLFW.getCursorPos ~window in + let win_w, win_h = GLFW.getWindowSize ~window in - let win = GWindow.window ~title:"oplevel main" () in - (* Quit when the window is closed. *) - ignore (win#connect#destroy ~callback:(Lwt.wakeup wakener)); - (* Show the window. *) - win#show (); + Gl.viewport 0 0 win_w win_h; + Gl.clear + (Gl.color_buffer_bit lor Gl.depth_buffer_bit + lor Gl.stencil_buffer_bit); - let vbox = - GPack.vbox ~spacing:10 ~border_width:15 ~packing:win#add () - 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")); + 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; - 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.pr "oplevel.ml: Toploop.initialize_toplevel_env@."; - Toploop.initialize_toplevel_env (); - 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 win_w, win_h = (float win_w, float win_h) in + Gv.begin_frame ctx ~width:win_w ~height:win_h + ~device_ratio:1.; - ignore (GtkMain.BindingSet.make "execute"); + Perfgraph.render graph ctx (win_w -. 205.) 5.; - let module GToolbox = struct - include GToolbox - - (* mk_keys turns keys from a key_combination into a format which can be used in - * a GTK+ RC file. *) - let mk_keys (mods, c) = - let mods = - List.map - (function - | `A -> "" | `C -> "" | `S -> "") - mods + let ui = + Ogui.Ui.window ctx Gg.(Box2.v P2.o (P2.v 500. 500.)) in - String.concat "" mods - ^ String.make 1 (Char.lowercase_ascii c) + 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; - (* Signal creation for shortcuts unfortunately requires us to create an - * in-memory gtkrc file which this function do. *) - let make_gtkrc_string g_type shortcuts = - let sp = Printf.sprintf in - let b = Buffer.create 4000 in - Buffer.add_string b "binding \"Shortcuts\" {"; - StdLabels.List.iter shortcuts ~f:(fun t -> - ListLabels.iter t.keys ~f:(fun keys -> - let keys = mk_keys keys in - Buffer.add_string b - (sp " bind \"%s\" { \"%s\" () }" keys t.name))); - Buffer.add_string b "}"; - let classname = Gobject.Type.name g_type in - Buffer.add_string b - (sp "\nclass \"%s\" binding \"Shortcuts\"" classname); - Buffer.contents b + Gc.major_slice 0 |> ignore; - let create_shortcuts ~window:(win : #GWindow.window_skel) - ~shortcuts ~callback = - let win = win#as_window in - let g_type = Gobject.get_type win in - F.pr "gtkrc_string: %s@.@." - (make_gtkrc_string g_type shortcuts); - GtkMain.Rc.parse_string (make_gtkrc_string g_type shortcuts); - ListLabels.iter shortcuts ~f:(fun t -> - let sgn = - { - GtkSignal.name = t.name; - classe = `window; - marshaller = GtkSignal.marshal_unit; - } - in - GtkSignal.signal_new t.name g_type - [ `ACTION; `RUN_FIRST ]; - ignore - (GtkSignal.connect ~sgn - ~callback:(fun () -> callback t.message) - win)) - end in - GToolbox.create_shortcuts ~window:win - ~shortcuts: - [ - { - name = "Quit"; - keys = [ ([ `C ], 'q') ]; - message = `Quit; - }; - { - name = "Execute"; - keys = [ ([ `C ], 'e') ]; - message = `Execute; - }; - ] - ~callback:(function - | `Quit -> - F.pr "`Quit@."; - F.pf out_ppf "`Quit@."; - Lwt.wakeup wakener () - | `Execute -> - F.pr "`Execute@."; - F.pf out_ppf "`Execute@."; - ignore - (Toploop.use_input out_ppf - (String (source_buffer#get_text ())))); + GLFW.swapBuffers ~window; + GLFW.pollEvents () + (*continue := false;*) + done; - (* ignore - (Toploop.use_input out_ppf - (String "#use \"topfind\";;\n#list;;")); *) - output_buffer#set_text ""; - ignore (Toploop.use_input out_ppf (String text)); - (* Wait for it to be closed. *) - waiter) + 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 (); + + (* 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 ()) + ()) diff --git a/perfgraph.ml b/perfgraph.ml new file mode 100644 index 0000000..c42a4c3 --- /dev/null +++ b/perfgraph.ml @@ -0,0 +1,87 @@ +module NVG = Graphv_gles2_native + +type style = FPS | Ms | Percent + +type t = { + style : style; + name : string; + values : float array; + mutable head : int; + mutable last : float; +} + +let init style name = + { name; style; values = Array.make 100 0.; head = 0; last = 0. } + +let average t = + let avg = ref 0. in + for i = 0 to Array.length t.values - 1 do + avg := !avg +. t.values.(i) + done; + !avg /. float (Array.length t.values) + +let update t dt = + t.head <- (t.head + 1) mod Array.length t.values; + t.values.(t.head) <- dt +(* + t.last <- t.last +. dt; + if t.last > 1. then ( + t.last <- 0.; + Printf.printf "FPS %.2f\n%!" (1. /. average t); + ) + *) + +let render t (vg : NVG.t) x y = + let avg = average t in + let w = 200. in + let h = 35. in + + let open NVG in + let open FloatOps in + Path.begin_ vg; + Path.rect vg ~x ~y ~w ~h; + set_fill_color vg ~color:(Color.rgba ~r:0 ~g:0 ~b:0 ~a:128); + fill vg; + + Path.begin_ vg; + Path.move_to vg ~x ~y:(y + h); + let len = Array.length t.values in + (match t.style with + | FPS -> + for i = 0 to len -. 1 do + let v = 1. / (0.00001 + t.values.((t.head +. i) mod len)) in + let v = if v > 80. then 80. else v in + let vx = x + (float i / (float len - 1.) * w) in + let vy = y + h - (v / 80. * h) in + Path.line_to vg ~x:vx ~y:vy + done + | Percent -> () + | Ms -> ()); + Path.line_to vg ~x:(x + w) ~y:(y + h); + set_fill_color vg ~color:(Color.rgba ~r:255 ~g:192 ~b:0 ~a:128); + fill vg; + + Text.set_font_face vg ~name:"mono"; + + Text.set_size vg ~size:12.; + Text.set_align vg ~align:Align.(left lor top); + set_fill_color vg ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:192); + Text.text vg ~x:(x + 3.) ~y:(y + 3.) t.name; + + match t.style with + | FPS -> + Text.set_size vg ~size:15.; + Text.set_align vg ~align:Align.(right lor top); + set_fill_color vg + ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:255); + let s = Printf.sprintf "%.2f FPS" (1. / avg) in + Text.text vg ~x:(x + w - 3.) ~y:(y + 3.) s; + + Text.set_size vg ~size:13.; + Text.set_align vg ~align:Align.(right lor baseline); + set_fill_color vg + ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:160); + let s = Printf.sprintf "%.2f ms" (avg * 1000.) in + Text.text vg ~x:(x + w - 3.) ~y:(y + h - 3.) s + | Percent -> () + | Ms -> ()