halfway to graphv_webgl replacing wall
This commit is contained in:
cqc
438
backend_sdl.ml
Normal file
438
backend_sdl.ml
Normal file
@ -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
|
||||
Reference in New Issue
Block a user