439 lines
15 KiB
OCaml
439 lines
15 KiB
OCaml
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
|