diff --git a/backend.ml b/backend.ml new file mode 100644 index 0000000..05b17e7 --- /dev/null +++ b/backend.ml @@ -0,0 +1,205 @@ +module F = Fmt + +module Key = struct + type special = + [ `Enter + | `Escape + | `Tab + | `Arrow of [`Up | `Down | `Left | `Right] + | `Function of int + | `Page of [`Up | `Down] + | `Home + | `End + | `Insert + | `Delete + | `Backspace ] + + (** Type of key code. *) + type code = + [`Uchar of Uchar.t (** A unicode character. *) | special] + + type keystate = + {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} + + module KeyS = struct + type t = keystate + + let compare = compare + end + + module Bind = struct + (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) + module S = Zed_input.Make (KeyS) + + type 'a t = 'a list S.t + type 'a resolver = 'a list S.resolver + type 'a result = 'a list S.result + + type 'a state = + { mutable bindings: 'a t + ; mutable state: 'a result + ; mutable last_keyseq: keystate list + ; mutable last_actions: 'a list } + + type mods = Ctrl | Meta | Super | Shift + type key = C of char | U of code + + let keystate_of_mods ks m = + List.fold_left + (fun ks m -> + match m with + | Meta -> {ks with meta= true} + | Ctrl -> {ks with ctrl= true} + | Super -> {ks with super= true} + | Shift -> {ks with shift= true} ) + ks m + + let add events action bindings = + let events = + List.map + (fun (m, k) -> + keystate_of_mods + { meta= false + ; ctrl= false + ; super= false + ; shift= false + ; code= + ( match k with + | C c -> `Uchar (Uchar.of_char c) + | U c -> c ) } + m ) + events in + S.add events action bindings + + let default_resolver b = S.resolver [S.pack (fun x -> x) b] + + let get_resolver result default = + match result with S.Continue r -> r | _ -> default + + let init bindings = + {bindings; state= S.Rejected; last_keyseq= []; last_actions= []} + + let resolve = S.resolve + let empty = S.empty + + type action = + | Custom of (unit -> unit) + | CustomLwt of (unit -> unit Lwt.t) + | Zed of Zed_edit.action + + let resolve_events (state : 'a state) events = + List.flatten + (List.filter_map + (fun e -> + match e with + | `Key (`Press, (k : keystate)) -> ( + ( match state.state with + | Continue _ -> () + | _ -> state.last_keyseq <- [] ) ; + state.state <- + resolve k + (get_resolver state.state + (default_resolver state.bindings) ) ; + state.last_keyseq <- k :: state.last_keyseq ; + match state.state with + | Accepted a -> + state.last_actions <- a ; + Some a + | Rejected -> + state.last_actions <- [] ; + None + | _ -> None ) + | _ -> None ) + events ) + + let actions_of_events (state : action state) events = + List.flatten + (List.filter_map + (fun e -> + match e with + | `Key (`Press, (k : keystate)) -> ( + ( match state.state with + | Continue _ -> () + | _ -> state.last_keyseq <- [] ) ; + state.state <- + resolve k + (get_resolver state.state + (default_resolver state.bindings) ) ; + state.last_keyseq <- k :: state.last_keyseq ; + match state.state with + | Accepted a -> + state.last_actions <- a ; + Some a + | Rejected -> + state.last_actions <- [] ; + None + | _ -> None ) + | _ -> None ) + events ) + + let process bindstate events = + Lwt_list.iter_s + (function + | Custom f -> Lwt.return (f ()) + | CustomLwt f -> f () + | Zed _ -> Lwt.return_unit ) + (actions_of_events bindstate events) + end + + (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) + let string_of_code = function + | `Uchar ch -> + if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch) + else F.str "Char 0x%02x" (Uchar.to_int ch) + | `Enter -> "Enter" + | `Escape -> "Escape" + | `Tab -> "Tab" + | `Arrow `Up -> "Up" + | `Arrow `Down -> "Down" + | `Arrow `Left -> "Left" + | `Arrow `Right -> "Right" + | `Function i -> F.str "F%d" i + | `Page `Up -> "Page Up" + | `Page `Down -> "Page Down" + | `Home -> "Home" + | `End -> "End" + | `Insert -> "Insert" + | `Delete -> "Delete" + | `Backspace -> "Backspace" + + let to_string key = + Printf.sprintf + "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }" + key.ctrl key.meta key.shift key.super + (string_of_code key.code) + + let to_string_compact key = + let buffer = Buffer.create 32 in + if key.ctrl then Buffer.add_string buffer "Ctrl-" ; + if key.meta then Buffer.add_string buffer "Meta-" ; + if key.shift then Buffer.add_string buffer "Shift-" ; + if key.super then Buffer.add_string buffer "Super-" ; + ( match key.code with + | `Uchar ch -> + let code = Uchar.to_int ch in + if Uchar.is_char ch then + match Uchar.to_char ch with + | ( 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' + | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' + | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' + | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch -> + Buffer.add_char buffer ch + | ' ' -> Buffer.add_string buffer "space" + | _ -> Printf.bprintf buffer "U+%02x" code + else if code <= 0xffff then + Printf.bprintf buffer "U+%04x" code + else Printf.bprintf buffer "U+%06x" code + | `Page `Down -> Buffer.add_string buffer "pgup" + | `Page `Up -> Buffer.add_string buffer "pgdn" + | code -> + Buffer.add_string buffer + (String.lowercase_ascii (string_of_code code)) ) ; + Buffer.contents buffer +end diff --git a/backend_js.ml b/backend_js.ml new file mode 100644 index 0000000..700427c --- /dev/null +++ b/backend_js.ml @@ -0,0 +1,7 @@ +include Backend + +module Keycode = struct + open Js_of_ocaml + + type t = Dom_html.Keyboard_code.t +end diff --git a/backend_sdl.ml b/backend_sdl.ml new file mode 100644 index 0000000..de5ac0d --- /dev/null +++ b/backend_sdl.ml @@ -0,0 +1,438 @@ +module Key = struct + let sdlkey_map = Hashtbl.create 1024 + + let () = + let aa (x : int) (y : Key.code) = Hashtbl.add sdlkey_map x y in + aa return `Enter ; + aa escape `Escape ; + aa backspace `Backspace ; + aa tab `Tab ; + aa f1 (`Function 1) ; + aa f2 (`Function 2) ; + aa f3 (`Function 3) ; + aa f4 (`Function 4) ; + aa f5 (`Function 5) ; + aa f6 (`Function 6) ; + aa f7 (`Function 7) ; + aa f8 (`Function 8) ; + aa f9 (`Function 9) ; + aa f10 (`Function 10) ; + aa f11 (`Function 11) ; + aa f12 (`Function 12) ; + aa insert `Insert ; + aa delete `Delete ; + aa home `Home ; + aa kend `End ; + aa pageup (`Page `Up) ; + aa pagedown (`Page `Down) ; + aa right (`Arrow `Right) ; + aa left (`Arrow `Left) ; + aa down (`Arrow `Down) ; + aa up (`Arrow `Up) + + let key_of_sdlkey ev = + let (kc : Sdl.keycode) = + Sdl.Event.get ev Sdl.Event.keyboard_keycode + land lnot Sdl.K.scancode_mask in + match (Hashtbl.find_opt sdlkey_map kc, Uchar.is_valid kc) with + | Some s, _ -> Some s + | None, true -> Some (`Uchar (Uchar.of_int kc)) + | None, false -> None + + let event_of_sdlevent ev : t option = + match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with + | (`Key_down | `Key_up) as d -> ( + match key_of_sdlkey ev with + | None -> None + | Some code -> + let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in + Some + (`Key + ( ( match d with + | _ + when Sdl.Event.get ev Sdl.Event.keyboard_repeat > 1 + -> + `Repeat + | `Key_up -> `Release + | _ -> `Press ) + , { code + ; ctrl= km land Sdl.Kmod.ctrl > 0 + ; meta= km land Sdl.Kmod.alt > 0 + ; super= km land Sdl.Kmod.gui > 0 + ; shift= km land Sdl.Kmod.shift > 0 } ) ) ) + | `Mouse_motion -> + let x, y = snd (Tsdl.Sdl.get_mouse_state ()) in + Some (`Mouse (V2.v (float x) (float y))) + | `Quit -> Some `Quit + (* Unhandled events *) + | `Text_editing -> Some (`Unknown "`Text_editing") + | `Text_input -> Some (`Unknown "`Text_input") + | `App_did_enter_background -> + Some (`Unknown "`App_did_enter_background") + | `App_did_enter_foreground -> + Some (`Unknown "`App_did_enter_foreground ") + | `App_low_memory -> Some (`Unknown "`App_low_memory ") + | `App_terminating -> Some (`Unknown "`App_terminating ") + | `App_will_enter_background -> + Some (`Unknown "`App_will_enter_background ") + | `App_will_enter_foreground -> + Some (`Unknown "`App_will_enter_foreground ") + | `Clipboard_update -> Some (`Unknown "`Clipboard_update ") + | `Controller_axis_motion -> + Some (`Unknown "`Controller_axis_motion ") + | `Controller_button_down -> + Some (`Unknown "`Controller_button_down ") + | `Controller_button_up -> Some (`Unknown "`Controller_button_up ") + | `Controller_device_added -> + Some (`Unknown "`Controller_device_added ") + | `Controller_device_remapped -> + Some (`Unknown "`Controller_device_remapped ") + | `Controller_device_removed -> + Some (`Unknown "`Controller_device_removed ") + | `Dollar_gesture -> Some (`Unknown "`Dollar_gesture ") + | `Dollar_record -> Some (`Unknown "`Dollar_record ") + | `Drop_file -> Some (`Unknown "`Drop_file ") + | `Finger_down -> Some (`Unknown "`Finger_down") + | `Finger_motion -> Some (`Unknown "`Finger_motion ") + | `Finger_up -> Some (`Unknown "`Finger_up ") + | `Joy_axis_motion -> Some (`Unknown "`Joy_axis_motion ") + | `Joy_ball_motion -> Some (`Unknown "`Joy_ball_motion ") + | `Joy_button_down -> Some (`Unknown "`Joy_button_down ") + | `Joy_button_up -> Some (`Unknown "`Joy_button_up ") + | `Joy_device_added -> Some (`Unknown "`Joy_device_added ") + | `Joy_device_removed -> Some (`Unknown "`Joy_device_removed ") + | `Joy_hat_motion -> Some (`Unknown "`Joy_hat_motion ") + | `Mouse_button_down -> Some (`Unknown "`Mouse_button_down ") + | `Mouse_button_up -> Some (`Unknown "`Mouse_button_up") + | `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ") + | `Multi_gesture -> Some (`Unknown "`Multi_gesture") + | `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ") + | `Unknown e -> Some (`Unknown (Format.sprintf "`Unknown %d" e)) + | `User_event -> Some (`Unknown "`User_event ") + | `Display_event -> Some (`Unknown "`Display_event ") + | `Sensor_update -> Some (`Unknown "`Sensor_update ") + | `Window_event -> Some (`Unknown "`Window_event ") + + let key_up : Sdl.keycode = 0x40000052 + let key_down : Sdl.keycode = 0x40000051 + let key_left : Sdl.keycode = 0x40000050 + let key_right : Sdl.keycode = 0x4000004f +end + +module Display = struct + open Tgles2 + open Tsdl + open Gg + open Wall + module I = Image + module P = Path + + let ( >>>= ) x f = + match x with Ok a -> f a | Error _ as result -> result + + let get_result = function + | Ok x -> x + | Error (`Msg msg) -> failwith msg + + (* current window state to be passed to window renderer *) + type state = + { box: box2 + (* This is cannonically box within which the next element should draw *) + ; time: float + ; wall: Wall.renderer } + + (* the box2 here is cannonically the place the returner drew + (the Wall.image extents) *) + type image = box2 * Wall.image + type pane = state -> state * image + type actor = (Event.events -> pane Lwt.t) ref + + let pane_empty s = + (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) + + type frame = + { sdl_win: Sdl.window + ; gl: Sdl.gl_context + ; wall: Wall.renderer + ; mutable last_pane: pane + ; mutable quit: bool + ; mutable fullscreen: bool } + + let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000. + + let on_failure ~cleanup result = + (match result with Ok _ -> () | Error _ -> cleanup ()) ; + result + + let video_initialized = lazy (Sdl.init Sdl.Init.video) + + let make_frame ?(title = "komm") ~w ~h () = + Lazy.force video_initialized + >>>= fun () -> + Sdl.create_window ~w ~h title + Sdl.Window.( + opengl + allow_highdpi + resizable (*+ input_grabbed*)) + >>>= fun sdl_win -> + Sdl.set_window_title sdl_win title ; + ignore (Sdl.gl_set_swap_interval (-1)) ; + ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1) ; + on_failure + ( Sdl.gl_create_context sdl_win + >>>= fun gl -> + let wall = + Wall.Renderer.create ~antialias:true ~stencil_strokes:true () + in + Ok + { sdl_win + ; gl + ; wall + ; quit= false + ; fullscreen= false + ; last_pane= pane_empty } ) + ~cleanup:(fun () -> Sdl.destroy_window sdl_win) + + let handle_frame_events frame events = + List.iter + (fun (e : Event.t) -> + match e with + | `Quit -> frame.quit <- true + | `Fullscreen a -> + frame.fullscreen <- a ; + ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ; + ignore + ( Sdl.set_window_fullscreen frame.sdl_win + ( if frame.fullscreen then + Sdl.Window.fullscreen_desktop + else Sdl.Window.windowed ) + : _ result ) + | _ -> () ) + events + + let draw_pane frame pane = + let width, height = Sdl.gl_get_drawable_size frame.sdl_win in + let _, (_, image) = + pane + { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height)) + ; time= ticks () + ; wall= frame.wall } in + Sdl.gl_make_current frame.sdl_win frame.gl + >>>= fun () -> + Gl.viewport 0 0 width height ; + Gl.clear_color 0.0 0.0 0.0 1.0 ; + Gl.( + clear + (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)) ; + Gl.enable Gl.blend ; + Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one + Gl.one_minus_src_alpha ; + Gl.enable Gl.cull_face_enum ; + Gl.disable Gl.depth_test ; + let width = float width and height = float height in + Wall.Renderer.render frame.wall ~width ~height image ; + Sdl.gl_swap_window frame.sdl_win ; + Ok () + + let rec get_events () : Event.t list = + (* create and fill event list *) + let ev = Sdl.Event.create () in + if Sdl.poll_event (Some ev) then + match Event.event_of_sdlevent ev with + | Some e -> get_events () @ [e] + | None -> get_events () + else [] + + let successful_actor = ref (fun _ -> Lwt.return pane_empty) + + let display_frame frame (actor : actor) = + let events = get_events () in + handle_frame_events frame events ; + if List.length events > 0 then ( + (* recompute the actor definition with the new events to return a new pane *) + ( try + !actor events + >|= fun p -> + successful_actor := !actor ; + p + with e -> + F.epr + "Display.display_frame (!actor events) failed with:@. %s \ + @." + (Printexc.to_string e) ; + actor := !successful_actor ; + !actor events ) + >>= fun p -> + frame.last_pane <- p ; + (* call draw_pane because we should redraw now that we have updated *) + ignore (draw_pane frame frame.last_pane) ; + Lwt.return_unit ) + else Lwt.return_unit + + let run frame actor () = + let frame = get_result frame in + Sdl.show_window frame.sdl_win ; + let rec loop () = + Lwt.pause () (* seems required for the irc connection to work *) + >>= fun () -> + Lwt_unix.sleep 0.030 + >>= fun () -> + display_frame frame actor + >>= fun () -> + if not frame.quit then loop () else Lwt.return_unit in + Lwt_main.run (loop ()) ; + print_endline "quit" ; + Sdl.hide_window frame.sdl_win ; + Sdl.gl_delete_context frame.gl ; + Sdl.destroy_window frame.sdl_win ; + Sdl.quit () ; + () + + let gray ?(a = 1.0) v = Color.v v v v a + + module FontCache = Map.Make (String) + + let font_cache = ref FontCache.empty + + let load_font name = + match FontCache.find_opt name !font_cache with + | Some font -> font + | None -> ( + let ic = open_in_bin name in + let dim = in_channel_length ic in + let fd = Unix.descr_of_in_channel ic in + let buffer = + Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout + false [|dim|] + |> Bigarray.array1_of_genarray in + let offset = List.hd (Stb_truetype.enum buffer) in + match Stb_truetype.init buffer offset with + | None -> assert false + | Some font -> + font_cache := FontCache.add name font !font_cache ; + font ) + + let font_icons = lazy (load_font "fonts/entypo.ttf") + let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf") + let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf") + let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf") + let font_sans_italic = lazy (load_font "fonts/Roboto-Italic.ttf") + + let font_sans_bold_italic = + lazy (load_font "fonts/Roboto-BoldItalic.ttf") + + let font_serif = + lazy (load_font "fonts/ScheherazadeNew-Regular.ttf") + + let font_serif_bold = + lazy (load_font "fonts/ScheherazadeNew-Bold.ttf") + + let font_mono = lazy (load_font "fonts/static/RobotoMono-Regular") + + let font_mono_bold = + lazy (load_font "fonts/static/RobotoMono-Regular") + + let font_mono_light = + lazy (load_font "fonts/static/RobotoMono-Regular") + + let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf") + + let str_of_box b = + Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) + (Box2.oy b) (Box2.maxx b) (Box2.maxy b) + + let draw_label text b = + let f = + Wall_text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) + in + ( Box2.v (Box2.o b) + (P2.v (Wall_text.Font.text_width f text) (Box2.h b)) + , I.paint + (Paint.color (gray ~a:0.5 1.0)) + Wall_text.( + simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b) + ~y:(Box2.oy b +. (Box2.h b *. 0.75)) + text) ) + + let fill_box c b = + ( b + , I.paint (Paint.color c) + ( I.fill_path + @@ fun t -> + P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) + ~h:(Box2.h b) ) ) + + let draw_filled_box c (s : state) = (s, fill_box c s.box) + + let path_box c b (s : state) = + ( s + , ( b + , I.paint (Paint.color c) + ( I.stroke_path (Outline.make ()) + @@ fun t -> + P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) + ~h:(Box2.h b) ) ) ) + + let path_circle c b (s : state) = + ( s + , ( b + , I.paint (Paint.color c) + ( I.stroke_path (Outline.make ()) + @@ fun t -> + P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b) + ~r:(Box2.w b /. 2.) ) ) ) + + (** Display.state.box as supplied to a widget defines the allowed drawing area for the widget. + This way basic widgets will just expand to the full area of a box, while other widgets can have + the express purpose of limiting the size of an object in a larger system of limitations. + + Panes return a tuple: (state, (box, image)) + state is the updated state, where state.box is always + - the top left corner of the box the pane drew in, and + - the bottom right corner of the state.box that was passed in + box is the area the widget actually drew in (or wants to sort of "use") + image is the Wall.image to compose with other panes and draw to the display + *) + + let simple_text f text (s : state) = + let fm = Wall_text.Font.font_metrics f in + let font_height = fm.ascent -. fm.descent +. fm.line_gap in + let tm = Wall_text.Font.text_measure f text in + let br_pt = + P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height) + in + let bextent = Box2.of_pts (Box2.o s.box) br_pt in + (* let _, (_, redbox) = path_box Color.red bextent s in*) + ( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)} + , ( bextent + , (* I.stack redbox *) + I.paint + (Paint.color (gray ~a:0.5 1.0)) + Wall_text.( + simple_text f ~valign:`BASELINE ~halign:`LEFT + ~x:(Box2.ox s.box) + ~y:(Box2.oy s.box +. fm.ascent) + text) ) ) + + let pane_box next_point_func (subpanes : pane list) (so : state) = + let sr, (br, ir) = + List.fold_left + (fun (sp, (bp, ip)) (pane : pane) -> + (* uses br to hold max extent of boxes *) + let sr, (br, ir) = pane sp in + (* draw the pane *) + let _, (_, irb) = path_box Color.blue br sr in + (* draw the box around the pane *) + ( { sr with + box= Box2.of_pts (next_point_func br) (Box2.max sp.box) + } + , ( Box2.of_pts (Box2.o bp) + (P2.v + (max (Box2.maxx br) (Box2.maxx bp)) + (max (Box2.maxy br) (Box2.maxy bp)) ) + , Image.seq [ip; irb; ir] ) ) ) + ( so + , (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty) + ) + subpanes in + let _, (_, redbox) = path_box Color.red br sr in + (sr, (br, Image.stack redbox ir)) +end diff --git a/boot_js.ml b/boot_js.ml new file mode 100644 index 0000000..031700c --- /dev/null +++ b/boot_js.ml @@ -0,0 +1,69 @@ +open Js_of_ocaml +module NVG = Graphv_webgl + +(* This scales the canvas to match the DPI of the window, + it prevents blurriness when rendering to the canvas *) +let scale_canvas (canvas : Dom_html.canvasElement Js.t) = + let dpr = Dom_html.window##.devicePixelRatio in + let rect = canvas##getBoundingClientRect in + let width = rect##.right -. rect##.left in + let height = rect##.bottom -. rect##.top in + canvas##.width := width *. dpr |> int_of_float ; + canvas##.height := height *. dpr |> int_of_float ; + let width = + Printf.sprintf "%dpx" (int_of_float width) |> Js.string in + let height = + Printf.sprintf "%dpx" (int_of_float height) |> Js.string in + canvas##.style##.width := width ; + canvas##.style##.height := height + +let _ = + let canvas = + Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas") in + scale_canvas canvas ; + let webgl_ctx = + (* Graphv requires a stencil buffer to work properly *) + let attrs = WebGL.defaultContextAttributes in + attrs##.stencil := Js._true ; + match + WebGL.getContextWithAttributes canvas attrs |> Js.Opt.to_option + with + | None -> + print_endline "Sorry your browser does not support WebGL" ; + raise Exit + | Some ctx -> ctx in + let open NVG in + let vg = + create + ~flags:CreateFlags.(antialias lor stencil_strokes) + webgl_ctx in + (* File in this case is actually the CSS font name *) + Text.create vg ~name:"sans" ~file:"sans" |> ignore ; + webgl_ctx##clearColor 0.3 0.3 0.32 1. ; + let rec render (time : float) = + webgl_ctx##clear + ( webgl_ctx##._COLOR_BUFFER_BIT_ + lor webgl_ctx##._DEPTH_BUFFER_BIT_ + lor webgl_ctx##._STENCIL_BUFFER_BIT_ ) ; + let device_ratio = Dom_html.window##.devicePixelRatio in + begin_frame vg ~width:canvas##.width ~height:canvas##.height + ~device_ratio ; + Transform.scale vg ~x:device_ratio ~y:device_ratio ; + Human.Display.render vg canvas##.width canvas##.height ; + (* + Path.begin_ vg ; + Path.rect vg ~x:40. ~y:40. ~w:320. ~h:320. ; + set_fill_color vg ~color:Color.(rgba ~r:154 ~g:203 ~b:255 ~a:200) ; + fill vg ; + Transform.translate vg ~x:200. ~y:200. ; + Transform.rotate vg ~angle:(time *. 0.0005) ; + Text.set_font_face vg ~name:"sans" ; + Text.set_size vg ~size:48. ; + Text.set_align vg ~align:Align.(center lor middle) ; + set_fill_color vg ~color:Color.white ; + Text.text vg ~x:0. ~y:0. "Hello World!" ; *) + NVG.end_frame vg ; + Dom_html.window##requestAnimationFrame (Js.wrap_callback render) + |> ignore in + Dom_html.window##requestAnimationFrame (Js.wrap_callback render) + |> ignore diff --git a/dune b/dune index bef2838..f254a42 100644 --- a/dune +++ b/dune @@ -2,77 +2,18 @@ (dev (flags (:standard -warn-error -A)))) -(library - (name human) - (modes byte) - (modules human) - (libraries - topinf - lwt_ppx - tsdl - tgls.tgles2 - wall - zed - lambda-term - irmin-unix - nottui - nottui-pretty - uuseg.string - uutf - uucp - ocaml-compiler-libs.common - ocaml-compiler-libs.bytecomp - ocaml-compiler-libs.toplevel)) - - (executable - (name irc) - (modes byte) - (modules irc) + (name boot_js) + (modes byte js) + (preprocess (pps js_of_ocaml-ppx)) + (modules boot_js backend backend_js human) (libraries - human + graphv_webgl + js_of_ocaml lwt - fmt - topinf - lwt_ppx - irc-client - irc-client-lwt - irc-client-unix - irc-client-tls - nottui-lwt - nottui-pretty + irmin-git + irmin-indexeddb + zed + gg )) -(executable - (name boot) - (modes byte) - (modules boot) - (link_flags (-linkall)) - (libraries - lwt_ppx - lambda-term - topinf)) - -(library - (name topinf) - (modes byte) - (modules topinf) - (libraries - fmt - tsdl - tgls.tgles2 - wall - zed - lambda-term - irmin-unix - nottui - nottui-pretty - nottui-lwt - uuseg - irc-client - irc-client-lwt - irc-client-unix - irc-client-tls - ocaml-compiler-libs.common - ocaml-compiler-libs.bytecomp - ocaml-compiler-libs.toplevel)) diff --git a/human.ml b/human.ml index 1364e9d..1657e9d 100644 --- a/human.ml +++ b/human.ml @@ -22,221 +22,26 @@ some options: open Lwt.Infix module F = Fmt -module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String) -module Key = struct - type special = - [ `Enter - | `Escape - | `Tab - | `Arrow of [`Up | `Down | `Left | `Right] - | `Function of int - | `Page of [`Up | `Down] - | `Home - | `End - | `Insert - | `Delete - | `Backspace ] +(* module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)*) - (** Type of key code. *) - type code = - [`Uchar of Uchar.t (** A unicode character. *) | special] +module Istore = + Irmin_git.Generic + (Irmin_indexeddb.Content_store) + (Irmin_indexeddb.Branch_store) + (Irmin.Contents.String) + (Irmin.Path.String_list) + (Irmin.Branch.String) - type keystate = - {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} - - module KeyS = struct - type t = keystate - - let compare = compare - end - - module Bind = struct - (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) - module S = Zed_input.Make (KeyS) - - type 'a t = 'a list S.t - type 'a resolver = 'a list S.resolver - type 'a result = 'a list S.result - - type 'a state = - { mutable bindings: 'a t - ; mutable state: 'a result - ; mutable last_keyseq: keystate list - ; mutable last_actions: 'a list } - - type mods = Ctrl | Meta | Super | Shift - type key = C of char | U of code - - let keystate_of_mods ks m = - List.fold_left - (fun ks m -> - match m with - | Meta -> {ks with meta= true} - | Ctrl -> {ks with ctrl= true} - | Super -> {ks with super= true} - | Shift -> {ks with shift= true} ) - ks m - - let add events action bindings = - let events = - List.map - (fun (m, k) -> - keystate_of_mods - { meta= false - ; ctrl= false - ; super= false - ; shift= false - ; code= - ( match k with - | C c -> `Uchar (Uchar.of_char c) - | U c -> c ) } - m ) - events in - S.add events action bindings - - let default_resolver b = S.resolver [S.pack (fun x -> x) b] - - let get_resolver result default = - match result with S.Continue r -> r | _ -> default - - let init bindings = - {bindings; state= S.Rejected; last_keyseq= []; last_actions= []} - - let resolve = S.resolve - let empty = S.empty - - type action = - | Custom of (unit -> unit) - | CustomLwt of (unit -> unit Lwt.t) - | Zed of Zed_edit.action - - let resolve_events (state : 'a state) events = - List.flatten - (List.filter_map - (fun e -> - match e with - | `Key (`Press, (k : keystate)) -> ( - ( match state.state with - | Continue _ -> () - | _ -> state.last_keyseq <- [] ) ; - state.state <- - resolve k - (get_resolver state.state - (default_resolver state.bindings) ) ; - state.last_keyseq <- k :: state.last_keyseq ; - match state.state with - | Accepted a -> - state.last_actions <- a ; - Some a - | Rejected -> - state.last_actions <- [] ; - None - | _ -> None ) - | _ -> None ) - events ) - - let actions_of_events (state : action state) events = - List.flatten - (List.filter_map - (fun e -> - match e with - | `Key (`Press, (k : keystate)) -> ( - ( match state.state with - | Continue _ -> () - | _ -> state.last_keyseq <- [] ) ; - state.state <- - resolve k - (get_resolver state.state - (default_resolver state.bindings) ) ; - state.last_keyseq <- k :: state.last_keyseq ; - match state.state with - | Accepted a -> - state.last_actions <- a ; - Some a - | Rejected -> - state.last_actions <- [] ; - None - | _ -> None ) - | _ -> None ) - events ) - - let process bindstate events = - Lwt_list.iter_s - (function - | Custom f -> Lwt.return (f ()) - | CustomLwt f -> f () - | Zed _ -> Lwt.return_unit ) - (actions_of_events bindstate events) - end - - (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) - let string_of_code = function - | `Uchar ch -> - if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch) - else F.str "Char 0x%02x" (Uchar.to_int ch) - | `Enter -> "Enter" - | `Escape -> "Escape" - | `Tab -> "Tab" - | `Arrow `Up -> "Up" - | `Arrow `Down -> "Down" - | `Arrow `Left -> "Left" - | `Arrow `Right -> "Right" - | `Function i -> F.str "F%d" i - | `Page `Up -> "Page Up" - | `Page `Down -> "Page Down" - | `Home -> "Home" - | `End -> "End" - | `Insert -> "Insert" - | `Delete -> "Delete" - | `Backspace -> "Backspace" - - let to_string key = - Printf.sprintf - "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }" - key.ctrl key.meta key.shift key.super - (string_of_code key.code) - - let to_string_compact key = - let buffer = Buffer.create 32 in - if key.ctrl then Buffer.add_string buffer "Ctrl-" ; - if key.meta then Buffer.add_string buffer "Meta-" ; - if key.shift then Buffer.add_string buffer "Shift-" ; - if key.super then Buffer.add_string buffer "Super-" ; - ( match key.code with - | `Uchar ch -> - let code = Uchar.to_int ch in - if Uchar.is_char ch then - match Uchar.to_char ch with - | ( 'a' .. 'z' - | 'A' .. 'Z' - | '0' .. '9' - | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' - | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' - | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch -> - Buffer.add_char buffer ch - | ' ' -> Buffer.add_string buffer "space" - | _ -> Printf.bprintf buffer "U+%02x" code - else if code <= 0xffff then - Printf.bprintf buffer "U+%04x" code - else Printf.bprintf buffer "U+%06x" code - | `Page `Down -> Buffer.add_string buffer "pgup" - | `Page `Up -> Buffer.add_string buffer "pgdn" - | code -> - Buffer.add_string buffer - (String.lowercase_ascii (string_of_code code)) ) ; - Buffer.contents buffer -end +open Backend_js module Event = struct - open Tsdl - open Key open Gg type mouse = V2.t type t = - [ `Key of [`Press | `Release | `Repeat] * keystate + [ `Key of [`Press | `Release | `Repeat] * Key.keystate | `Mouse of mouse | `Quit | `Fullscreen of bool @@ -257,135 +62,14 @@ module Event = struct | `Fullscreen b -> F.str "`Fullscreen %b" b | `Unknown s -> F.str "`Unknown %s" s - let sdlkey_map = Hashtbl.create 1024 - - let () = - let aa (x : int) (y : Key.code) = Hashtbl.add sdlkey_map x y in - let open Sdl.K in - aa return `Enter ; - aa escape `Escape ; - aa backspace `Backspace ; - aa tab `Tab ; - aa f1 (`Function 1) ; - aa f2 (`Function 2) ; - aa f3 (`Function 3) ; - aa f4 (`Function 4) ; - aa f5 (`Function 5) ; - aa f6 (`Function 6) ; - aa f7 (`Function 7) ; - aa f8 (`Function 8) ; - aa f9 (`Function 9) ; - aa f10 (`Function 10) ; - aa f11 (`Function 11) ; - aa f12 (`Function 12) ; - aa insert `Insert ; - aa delete `Delete ; - aa home `Home ; - aa kend `End ; - aa pageup (`Page `Up) ; - aa pagedown (`Page `Down) ; - aa right (`Arrow `Right) ; - aa left (`Arrow `Left) ; - aa down (`Arrow `Down) ; - aa up (`Arrow `Up) - - let key_of_sdlkey ev = - let (kc : Sdl.keycode) = - Sdl.Event.get ev Sdl.Event.keyboard_keycode - land lnot Sdl.K.scancode_mask in - match (Hashtbl.find_opt sdlkey_map kc, Uchar.is_valid kc) with - | Some s, _ -> Some s - | None, true -> Some (`Uchar (Uchar.of_int kc)) - | None, false -> None - - let event_of_sdlevent ev : t option = - match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with - | (`Key_down | `Key_up) as d -> ( - match key_of_sdlkey ev with - | None -> None - | Some code -> - let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in - Some - (`Key - ( ( match d with - | _ - when Sdl.Event.get ev Sdl.Event.keyboard_repeat > 1 - -> - `Repeat - | `Key_up -> `Release - | _ -> `Press ) - , { code - ; ctrl= km land Sdl.Kmod.ctrl > 0 - ; meta= km land Sdl.Kmod.alt > 0 - ; super= km land Sdl.Kmod.gui > 0 - ; shift= km land Sdl.Kmod.shift > 0 } ) ) ) - | `Mouse_motion -> - let x, y = snd (Tsdl.Sdl.get_mouse_state ()) in - Some (`Mouse (V2.v (float x) (float y))) - | `Quit -> Some `Quit - (* Unhandled events *) - | `Text_editing -> Some (`Unknown "`Text_editing") - | `Text_input -> Some (`Unknown "`Text_input") - | `App_did_enter_background -> - Some (`Unknown "`App_did_enter_background") - | `App_did_enter_foreground -> - Some (`Unknown "`App_did_enter_foreground ") - | `App_low_memory -> Some (`Unknown "`App_low_memory ") - | `App_terminating -> Some (`Unknown "`App_terminating ") - | `App_will_enter_background -> - Some (`Unknown "`App_will_enter_background ") - | `App_will_enter_foreground -> - Some (`Unknown "`App_will_enter_foreground ") - | `Clipboard_update -> Some (`Unknown "`Clipboard_update ") - | `Controller_axis_motion -> - Some (`Unknown "`Controller_axis_motion ") - | `Controller_button_down -> - Some (`Unknown "`Controller_button_down ") - | `Controller_button_up -> Some (`Unknown "`Controller_button_up ") - | `Controller_device_added -> - Some (`Unknown "`Controller_device_added ") - | `Controller_device_remapped -> - Some (`Unknown "`Controller_device_remapped ") - | `Controller_device_removed -> - Some (`Unknown "`Controller_device_removed ") - | `Dollar_gesture -> Some (`Unknown "`Dollar_gesture ") - | `Dollar_record -> Some (`Unknown "`Dollar_record ") - | `Drop_file -> Some (`Unknown "`Drop_file ") - | `Finger_down -> Some (`Unknown "`Finger_down") - | `Finger_motion -> Some (`Unknown "`Finger_motion ") - | `Finger_up -> Some (`Unknown "`Finger_up ") - | `Joy_axis_motion -> Some (`Unknown "`Joy_axis_motion ") - | `Joy_ball_motion -> Some (`Unknown "`Joy_ball_motion ") - | `Joy_button_down -> Some (`Unknown "`Joy_button_down ") - | `Joy_button_up -> Some (`Unknown "`Joy_button_up ") - | `Joy_device_added -> Some (`Unknown "`Joy_device_added ") - | `Joy_device_removed -> Some (`Unknown "`Joy_device_removed ") - | `Joy_hat_motion -> Some (`Unknown "`Joy_hat_motion ") - | `Mouse_button_down -> Some (`Unknown "`Mouse_button_down ") - | `Mouse_button_up -> Some (`Unknown "`Mouse_button_up") - | `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ") - | `Multi_gesture -> Some (`Unknown "`Multi_gesture") - | `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ") - | `Unknown e -> Some (`Unknown (Format.sprintf "`Unknown %d" e)) - | `User_event -> Some (`Unknown "`User_event ") - | `Display_event -> Some (`Unknown "`Display_event ") - | `Sensor_update -> Some (`Unknown "`Sensor_update ") - | `Window_event -> Some (`Unknown "`Window_event ") - - let key_up : Sdl.keycode = 0x40000052 - let key_down : Sdl.keycode = 0x40000051 - let key_left : Sdl.keycode = 0x40000050 - let key_right : Sdl.keycode = 0x4000004f let handle_keyevents (el : events) f = List.iter f el end module Display = struct - open Tgles2 - open Tsdl open Gg - open Wall - module I = Image - module P = Path + module NVG = Graphv_webgl + module I = NVG.Image + module P = NVG.Path let ( >>>= ) x f = match x with Ok a -> f a | Error _ as result -> result @@ -398,114 +82,36 @@ module Display = struct type state = { box: box2 (* This is cannonically box within which the next element should draw *) - ; time: float - ; wall: Wall.renderer } + ; renderer: NVG.t } (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) - type image = box2 * Wall.image + type image = box2 * NVG.Image.image type pane = state -> state * image type actor = (Event.events -> pane Lwt.t) ref let pane_empty s = - (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) - - type frame = - { sdl_win: Sdl.window - ; gl: Sdl.gl_context - ; wall: Wall.renderer - ; mutable last_pane: pane - ; mutable quit: bool - ; mutable fullscreen: bool } - - let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000. + (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), I.dummy)) let on_failure ~cleanup result = (match result with Ok _ -> () | Error _ -> cleanup ()) ; result - let video_initialized = lazy (Sdl.init Sdl.Init.video) - - let make_frame ?(title = "komm") ~w ~h () = - Lazy.force video_initialized - >>>= fun () -> - Sdl.create_window ~w ~h title - Sdl.Window.( - opengl + allow_highdpi + resizable (*+ input_grabbed*)) - >>>= fun sdl_win -> - Sdl.set_window_title sdl_win title ; - ignore (Sdl.gl_set_swap_interval (-1)) ; - ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1) ; - on_failure - ( Sdl.gl_create_context sdl_win - >>>= fun gl -> - let wall = - Wall.Renderer.create ~antialias:true ~stencil_strokes:true () - in - Ok - { sdl_win - ; gl - ; wall - ; quit= false - ; fullscreen= false - ; last_pane= pane_empty } ) - ~cleanup:(fun () -> Sdl.destroy_window sdl_win) - - let handle_frame_events frame events = - List.iter - (fun (e : Event.t) -> - match e with - | `Quit -> frame.quit <- true - | `Fullscreen a -> - frame.fullscreen <- a ; - ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ; - ignore - ( Sdl.set_window_fullscreen frame.sdl_win - ( if frame.fullscreen then - Sdl.Window.fullscreen_desktop - else Sdl.Window.windowed ) - : _ result ) - | _ -> () ) - events - - let draw_pane frame pane = - let width, height = Sdl.gl_get_drawable_size frame.sdl_win in - let _, (_, image) = - pane - { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height)) - ; time= ticks () - ; wall= frame.wall } in - Sdl.gl_make_current frame.sdl_win frame.gl - >>>= fun () -> - Gl.viewport 0 0 width height ; - Gl.clear_color 0.0 0.0 0.0 1.0 ; - Gl.( - clear - (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)) ; - Gl.enable Gl.blend ; - Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one - Gl.one_minus_src_alpha ; - Gl.enable Gl.cull_face_enum ; - Gl.disable Gl.depth_test ; - let width = float width and height = float height in - Wall.Renderer.render frame.wall ~width ~height image ; - Sdl.gl_swap_window frame.sdl_win ; + let draw_pane vg pane width height = + let _, (b, image) = + pane {box= Box2.v (P2.v 0. 0.) (P2.v width height); renderer= vg} + in + let w, h = (Box2.w b, Box2.h b) in + let paint = + NVG.Paint.image_pattern vg ~cx:0. ~cy:0. ~w ~h ~angle:0. ~image + ~alpha:1. in + NVG.set_fill_paint vg ~paint ; + NVG.fill vg ; Ok () - let rec get_events () : Event.t list = - (* create and fill event list *) - let ev = Sdl.Event.create () in - if Sdl.poll_event (Some ev) then - match Event.event_of_sdlevent ev with - | Some e -> get_events () @ [e] - | None -> get_events () - else [] - let successful_actor = ref (fun _ -> Lwt.return pane_empty) - let display_frame frame (actor : actor) = - let events = get_events () in - handle_frame_events frame events ; + let render (vg : NVG.t) (w : float) (h : float) (actor : actor) = if List.length events > 0 then ( (* recompute the actor definition with the new events to return a new pane *) ( try @@ -521,31 +127,11 @@ module Display = struct actor := !successful_actor ; !actor events ) >>= fun p -> - frame.last_pane <- p ; (* call draw_pane because we should redraw now that we have updated *) - ignore (draw_pane frame frame.last_pane) ; + ignore (draw_pane vg p w h) ; Lwt.return_unit ) else Lwt.return_unit - let run frame actor () = - let frame = get_result frame in - Sdl.show_window frame.sdl_win ; - let rec loop () = - Lwt.pause () (* seems required for the irc connection to work *) - >>= fun () -> - Lwt_unix.sleep 0.030 - >>= fun () -> - display_frame frame actor - >>= fun () -> - if not frame.quit then loop () else Lwt.return_unit in - Lwt_main.run (loop ()) ; - print_endline "quit" ; - Sdl.hide_window frame.sdl_win ; - Sdl.gl_delete_context frame.gl ; - Sdl.destroy_window frame.sdl_win ; - Sdl.quit () ; - () - let gray ?(a = 1.0) v = Color.v v v v a module FontCache = Map.Make (String) @@ -600,9 +186,7 @@ module Display = struct (Box2.oy b) (Box2.maxx b) (Box2.maxy b) let draw_label text b = - let f = - Wall_text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) - in + let f = NVG.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in ( Box2.v (Box2.o b) (P2.v (Wall_text.Font.text_width f text) (Box2.h b)) , I.paint diff --git a/index.html b/index.html new file mode 100644 index 0000000..84141f3 --- /dev/null +++ b/index.html @@ -0,0 +1,35 @@ + + + + + + +
+ +
+ + +