console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

halfway to graphv_webgl replacing wall

Browse Source
This commit is contained in:
cqc
2022-08-31 12:32:44 -05:00
parent c40e725978
commit 7460b8f793
7 changed files with 793 additions and 514 deletions
Download Patch File Download Diff File Expand all files Collapse all files

474
human.ml
View File

@ -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