commit 0a31ab85e0ab61dd6a77b2c7d77a550e6145990f Author: cqc Date: Tue Jul 6 21:43:50 2021 -0500 yea bitches diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..57ab87b --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "kommpile"] + path = kommpile + url = ./bin/kommpile diff --git a/bin/NotoEmoji-Regular.ttf b/bin/NotoEmoji-Regular.ttf new file mode 100644 index 0000000..19b7bad Binary files /dev/null and b/bin/NotoEmoji-Regular.ttf differ diff --git a/bin/Roboto-Bold.ttf b/bin/Roboto-Bold.ttf new file mode 100755 index 0000000..aaf374d Binary files /dev/null and b/bin/Roboto-Bold.ttf differ diff --git a/bin/Roboto-Light.ttf b/bin/Roboto-Light.ttf new file mode 100755 index 0000000..664e1b2 Binary files /dev/null and b/bin/Roboto-Light.ttf differ diff --git a/bin/Roboto-Regular.ttf b/bin/Roboto-Regular.ttf new file mode 100644 index 0000000..3e6e2e7 Binary files /dev/null and b/bin/Roboto-Regular.ttf differ diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..0e027ab --- /dev/null +++ b/bin/dune @@ -0,0 +1,6 @@ +(executables + (names main example lumppile) + (flags :standard -w -3-6-27-33) + (libraries komm tsdl tgls.tgles2 wall irmin-unix)) + + diff --git a/bin/entypo.ttf b/bin/entypo.ttf new file mode 100644 index 0000000..fc305d2 Binary files /dev/null and b/bin/entypo.ttf differ diff --git a/bin/example.ml b/bin/example.ml new file mode 100644 index 0000000..63a6c5c --- /dev/null +++ b/bin/example.ml @@ -0,0 +1,119 @@ +open Tsdl + +open Wall +module I = Image +module P = Path +module Text = Wall_text + +let gray ?(a=1.0) v = Color.v v v v a + +let load_font name = + 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 + +let font_icons = lazy (load_font "entypo.ttf") +let font_sans = lazy (load_font "Roboto-Regular.ttf") +let font_sans_bold = lazy (load_font "Roboto-Bold.ttf") +let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf") + +let w = 1000 +let h = 600 +let f = (try float_of_string Sys.argv.(1) with _ -> 1.0) +let fw = int_of_float (f *. float w) +let fh = int_of_float (f *. float h) + +let draw_label text x y h = + I.paint (Paint.color (gray ~a:0.5 1.0)) + Text.(simple_text + (Font.make ~size:18.0 (Lazy.force font_sans)) + ~valign:`MIDDLE ~halign:`LEFT + ~x ~y:(y+.h*.0.5) text) + +let draw_demo mx my w t = + let node = ref I.empty in + let push n = node := I.stack !node n in + let x = 0.0 and y = 0.0 in + push @@ draw_label "hello world" x y 20.0; + !node + +let counter = Performance_counter.make () +let dump_perf = + let t0 = ref 0 in + fun t -> + let t = int_of_float t in + if t <> !t0 then ( + t0 := t; + prerr_endline (Performance_counter.report counter); + Performance_counter.reset counter + ) + +let render context sw sh t = + let lw = float w in + let lh = float h in + let width = lw *. f *. sw in + let height = lh *. f *. sh in + let _, (x, y) = Sdl.get_mouse_state () in + let x = float x /. f and y = float y /. f in + Renderer.render context ~width ~height ~performance_counter:counter + (I.seq [ + draw_demo x y lw t; + ]); + dump_perf t + +open Tgles2 + +let main () = + Printexc.record_backtrace true; + match Sdl.init Sdl.Init.video with + | Error (`Msg e) -> Sdl.log "Init error: %s" e; exit 1 + | Ok () -> + ignore (Sdl.gl_set_attribute Sdl.Gl.depth_size 24 : _ result); + ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 8 : _ result); + match + Sdl.create_window ~w:fw ~h:fh "SDL OpenGL" + Sdl.Window.(opengl + allow_highdpi) + with + | Error (`Msg e) -> Sdl.log "Create window error: %s" e; exit 1 + | Ok w -> + ignore (Sdl.gl_set_swap_interval (-1)); + let ow, oh = Sdl.gl_get_drawable_size w in + Sdl.log "window size: %d,%d\topengl drawable size: %d,%d" fw fh ow oh; + let sw = float ow /. float fw and sh = float oh /. float fh in + ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); + match Sdl.gl_create_context w with + | Error (`Msg e) -> Sdl.log "Create context error: %s" e; exit 1 + | Ok ctx -> + let context = Renderer.create ~antialias:true () in + let quit = ref false in + let event = Sdl.Event.create () in + while not !quit do + while Sdl.poll_event (Some event) do + match Sdl.Event.enum (Sdl.Event.get event Sdl.Event.typ) with + | `Quit -> quit := true + | _ -> () + done; + Gl.viewport 0 0 ow oh; + Gl.clear_color 0.3 0.3 0.32 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; + render context sw sh (Int32.to_float (Sdl.get_ticks ()) /. 1000.0); + Sdl.gl_swap_window w; + done; + Sdl.gl_delete_context ctx; + Sdl.destroy_window w; + Sdl.quit (); + exit 0 + +let () = main () diff --git a/bin/kommpile b/bin/kommpile new file mode 160000 index 0000000..e82d0c8 --- /dev/null +++ b/bin/kommpile @@ -0,0 +1 @@ +Subproject commit e82d0c805f811b1072021d6399df5a946504f801 diff --git a/bin/lump.ml b/bin/lump.ml new file mode 100644 index 0000000..d4920d9 --- /dev/null +++ b/bin/lump.ml @@ -0,0 +1 @@ +(* lump is module *) diff --git a/bin/lumppile.ml b/bin/lumppile.ml new file mode 100644 index 0000000..380f9ed --- /dev/null +++ b/bin/lumppile.ml @@ -0,0 +1,30 @@ +(* pile of lumps *) + +open Lwt.Infix + +module Git_store = Irmin_unix.Git.FS.KV(Irmin.Contents.String) + +let git_config = Irmin_git.config ~bare:true "./kommpile" +let git_repo = Git_store.Repo.v git_config + + +let beginning config = + Git_store.Repo.v config >>= Git_store.master + +let branch config name = + Git_store.Repo.v config >>= fun repo -> + Git_store.of_branch repo name + + +let info message = Irmin_unix.info "%s" message + + +let main = + Git_store.Repo.v git_config >>= Git_store.master >>= fun t -> + (* Set a/b/c to "Hello, Irmin!" *) + Git_store.set_exn t ["a"; "b"; "c"] "Hello, Irmin!" ~info:(info "my first commit") >>= fun () -> + (* Get a/b/c *) + Git_store.get t ["a"; "b"; "c"] >|= fun s -> + assert (s = "Hello, Irmin!") + +let () = Lwt_main.run main diff --git a/bin/lumpstore.ml b/bin/lumpstore.ml new file mode 100644 index 0000000..90777a8 --- /dev/null +++ b/bin/lumpstore.ml @@ -0,0 +1,19 @@ +module Lump : sig + include Irmin.Type.S + val v : string -> t + val timestamp : t -> int +end = struct + type t = { names : string list; value : string } + let compare x y = compare x.names y.names + let v names value = { names ; value } + let names t = t.names + let pp ppf { names; message } = Fmt.pf ppf "%04d: %s" timestamp message + let t = + let open Irmin.Type in + record "entry" (fun t32 message -> + { timestamp = Int32.to_int t32; message }) + |+ field "timestamp" int32 (fun t -> Int32.of_int t.timestamp) + |+ field "message" string (fun t -> t.message) + |> sealr + let t = Irmin.Type.like ~cli:(pp, of_string) ~compare t +end diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000..979afe8 --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,415 @@ +[@@@ocaml.warning "-6-9-26-27"] +open Lwt.Infix +module F = Fmt + +(* komm / konsole / tafel *) +(* let f = try float_of_string Sys.argv.(1) with _ -> 1.0 *) + +module Lump = struct + module Pile = Irmin_unix.Git.FS.KV(Irmin.Contents.String) + type t = { conf : Irmin.config; + repo : Pile.Repo.t; + branch : Pile.branch; + path : string list; + } + + let branch repo_loc branch = + let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in + Lwt_main.run (Pile.of_branch repo branch) + + let get repo_loc branch path = + let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in + let branch = Lwt_main.run (Pile.of_branch repo branch) in + let node = Pile.get branch path in + Lwt_main.run node + +(* val pile_conf path = Irmin_git.config path + val pile_repo conf = Pile.Repo.v conf + val pile_branch conf name = pile_repo conf*) +end + +(*let pos = ref (Lump.get "./kommstore" "current" ["init"])*) +(* magic position [ref Lump.t]*) + + + +module Display = struct + open Wall + open Tgles2 + open Tsdl + open Gg + let (>>=) x f = match x with + | Ok a -> f a + | Error x as result -> result + + let get_result = function + | Ok x -> x + | Error (`Msg msg) -> failwith msg + + type key = int + type mouse = (int * int) + type event = [ `Key_down of key + | `Key_up of key + | `Mouse of mouse + | `Quit + | `Fullscreen of bool + | `None ] + + let event_of_sdlevent ev = + match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with + | `Key_up -> F.pr "Key_up\n"; let key = Sdl.Event.get ev Sdl.Event.keyboard_keycode in `Key_up key + | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel -> + F.pr "Mouse Event\n"; + let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in `Mouse mouse_xy + | `Quit -> F.pr "Quit Event\n"; `Quit + | _ -> `None + + (* 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; + events: event list; + wall: Wall.renderer; + } + + type image = (box2 * Wall.image) (* the box2 here is cannonically the place the returner drew + (the Wall.image extents) *) + type pane = state -> (state * image) + + type frame = { sdl_win: Sdl.window; + gl: Sdl.gl_context; + wall: Wall.renderer; + mutable quit: bool; + mutable fullscreen: bool; } + + let ticks () = (Int32.to_float (Sdl.get_ticks ())) /. 1000.0 + + let on_failure ~cleanup result = begin + match result with + | Ok _ -> () + | Error _ -> cleanup () + end; 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 + input_grabbed) + >>= fun sdl_win -> + 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 } + ) ~cleanup:(fun () -> Sdl.destroy_window sdl_win) + + let display_frame frame render = + (* create and fill event list *) + let tstart = ticks () in + let ev = Sdl.Event.create () in + let el = ref [`None] in + while Sdl.poll_event (Some ev) do + let e = event_of_sdlevent ev in + if e != `None then el := e :: !el + done; + F.pr "Receieved %d handled events" (List.length !el); + + (* Handle some of the events *) + el := List.filter_map + (function + | `Quit -> frame.quit <- true; None + | `Fullscreen -> + frame.fullscreen <- not frame.fullscreen; + 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); None + | a -> Some a) !el; + + let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in + let width = float width and height = float height in + let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height)); + time = ticks (); events = []; wall = frame.wall} in + Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () -> + let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in + 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; + F.pr "event loop took %0.2fms\n" (ticks () -. tstart); Ok () + + let run frame render () = + let frame = get_result frame in + Sdl.show_window frame.sdl_win; + while not frame.quit do + ignore (display_frame frame render) + done; + print_endline "quit"; + Sdl.hide_window frame.sdl_win; () + + let gray ?(a=1.0) v = Color.v v v v a +end + +open Wall +open Gg +module I = Image +module P = Path +module Text = Wall_text + +let load_font name = + 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 + +let font_icons = lazy (load_font "entypo.ttf") +let font_sans = lazy (load_font "Roboto-Regular.ttf") +let font_sans_bold = lazy (load_font "Roboto-Bold.ttf") +let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf") + +let str_of_pnt p = Printf.sprintf "(x:%0.1f y:%0.1f)" (P2.x p) (P2.y p) +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 = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in + ((Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b))), + (I.paint (Paint.color (Display.gray ~a:0.5 1.0)) + 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 (s:Display.state) = + (s, (b, I.paint (Paint.color c) + (I.fill_path @@ fun t -> P.rect t (Box2.ox b) (Box2.oy b) (Box2.w b) (Box2.h b)))) + +let path_box c b (s:Display.state) = + (s, (b, I.paint (Paint.color c) + (I.stroke_path + (Outline.make ()) @@ fun t -> P.rect t (Box2.ox b) (Box2.oy b) (Box2.w b) (Box2.h b)))) + +let path_circle c b (s:Display.state) = + (s, (b, I.paint (Paint.color c) + (I.stroke_path + (Outline.make ()) @@ fun t -> P.circle t (Box2.midx b) (Box2.midy b) ((Box2.w b) /. 2.)))) + +let layout_hor v () = [] + +let layout_ver v () = [] + +(* draws the second item below if there's room *) +let pane_vbox (subpanes:Display.pane list) (so:Display.state) = + let sr, (br, ir) = + List.fold_left + (fun (sp, (_, ip)) (pane:Display.pane) -> + let sr, (br, ir) = pane sp in + let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in + ({sr with box = (Box2.of_pts (Box2.tl_pt br) (Box2.max sp.box))}, + (br, Image.seq [ ip; sir; ir]))) + (so, (so.box, Image.empty)) subpanes + in + let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in + let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in + (sr, (b, (Image.stack i_redbox ir))) + +(* draws second item to right if there's room *) +let pane_hbox (subpanes:Display.pane list) (so:Display.state) = + let sr, (br, ir) = + List.fold_left + (fun (sp, (_, ip)) (pane:Display.pane) -> + let sr, (br, ir) = pane sp in + let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in + ({sr with box = (Box2.of_pts (Box2.br_pt br) (Box2.max sp.box))}, + (br, Image.seq [ ip; sir; ir]))) + (so, (so.box, Image.empty)) subpanes + in + let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in + let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in + (sr, (b, (Image.stack i_redbox ir))) + + + +let pane_label text height ~subpanes (s:Display.state) = + let label_box, label_image = draw_label text (Box2.v (Box2.o s.box) (P2.v (Box2.w s.box) height)) in + Box2.pp Format.std_formatter label_box; + (label_box, Image.seq [ + List.fold_left (fun image pane -> Image.seq [image; (pane s)]) Image.empty subpanes; + I.paint (* red box *) + (Paint.color (Color.v 0.5 0.125 0.125 1.0)) + (I.stroke_path (Outline.make ()) @@ + fun t -> P.rect t (Box2.ox s.box) (Box2.oy s.box) (Box2.w s.box) height); + label_image; ]) + + +let simple_text f text (s:Display.state) = + let fm = Text.Font.font_metrics f in + let font_height = fm.ascent -. fm.descent +. fm.line_gap in + let tm = 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.v 0.5 0.125 0.125 1.0) 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 (Display.gray ~a:0.5 1.0)) + Text.(simple_text f ~valign:`BASELINE ~halign:`LEFT + ~x:(Box2.ox s.box) ~y:((Box2.oy s.box) +. fm.ascent) text))))) + +let draw_pp height ppf (s:Display.state) = + let node, sc, box = ref I.empty, ref s, ref Box2.zero in + let push (s, (b, i)) = node := I.stack !node i; sc := s; box := b in + let f = Text.Font.make ~size:height (Lazy.force font_sans) in + let fm = Text.Font.font_metrics f in + (* Printf.printf "Font Metrics:\n\tascent:%f\n\tdescent:%f\n\tline_gap:%f\n" fm.ascent fm.descent fm.line_gap; *) + let font_height = fm.ascent -. fm.descent +. fm.line_gap in F.pr "font_height: %f\n" font_height; + let out_string text o l = + let text = String.sub text o l in + let sp = !sc in + push @@ simple_text f text !sc; + sc := {!sc with box = (Box2.of_pts (P2.v (Box2.maxx !box) (Box2.oy sp.box)) (Box2.max sp.box))}; + F.pr "out_string: (\"%s\")\n\tsp.box=%s\n\t!sc.box=%s\n\t!box=%s@." + text (str_of_box sp.box) (str_of_box !sc.box) (str_of_box !box) + in + let out_flush () = + print_endline ("out_flush: () " ^ (str_of_box !sc.box)) ; () in + let out_newline () = + let nlp = P2.v (Box2.ox s.box) ((Box2.oy !sc.box) +. font_height) in + sc := {!sc with box = Box2.of_pts nlp (Box2.max s.box)}; + Printf.printf "out_newline: (%0.1f %0.1f) %s\n" (P2.x nlp) (P2.y nlp) (str_of_box !sc.box); flush stdout + in + let out_spaces n = + let nf = float n in + let wpx = Text.Font.text_width f " " in + let nl = ((Box2.ox !sc.box) +. (nf *. wpx)) > (Box2.maxx !sc.box) in + if nl then begin (* WRAP *) + F.pr "out_spaces: ===== WRAP =======@."; + out_newline () + end; + let so = !sc in + let bo = Box2.v (Box2.o !sc.box) (P2.v (nf *. wpx) height) in + let ws = (Box2.w !box) /. nf in + for m = 0 to n-1 do + let mf = float m in + let bsp = (Box2.v (Box2.br_pt !box) (P2.v wpx height)) in + F.pr "out_space(%d): %s -> %s \n" m (str_of_box !box) (str_of_box bsp); + push @@ pane_hbox [path_circle (Color.v 0.125 1.0 0.125 0.125) bsp] !sc; + done; + box := bo; + sc := {!sc with box = Box2.of_pts (Box2.br_pt bo) (Box2.max so.box)}; + Printf.printf "out_spaces: (n=%d=%0.2fpx, nl=%b) %s\n\tbo=%s\n" n (nf *. wpx) nl (str_of_box !sc.box) + (str_of_box bo); flush stdout + in + let out_indent n = + let p = (min ((Box2.w !sc.box)-.1.) (height *. 2.0 *. (float n))) in + sc := {!sc with box = Box2.of_pts + (P2.v ((Box2.ox !sc.box) +. p) (Box2.oy !sc.box)) + (Box2.max !sc.box)}; + Printf.printf "out_indent: (n=%d=%0.2fpx) %s\n" n p (str_of_box !sc.box); flush stdout in + let pp = Format.formatter_of_out_functions {out_string; out_flush; out_newline; out_spaces; out_indent;} in + let margin = int_of_float ((Box2.w s.box) /. (Text.Font.text_width f " ")) in + let max_indent = margin in + Format.pp_safe_set_geometry pp ~max_indent ~margin; + F.pr "draw_pp-2:\n\t!sc=%s\n" (str_of_box !sc.box); + F.pr "pp_margin: %d\n" (Format.pp_get_margin pp ()); + ppf pp; + Format.pp_force_newline pp (); + F.pr "draw_pp-1:\n\t!sc=%s\n" (str_of_box !sc.box); + F.pr "pp_margin: %d\n" (Format.pp_get_margin pp ()); + let (sr, (br, ir)) = (!sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)) in + F.pr "draw_pp:\n\tso=%s\n\tbr=%s\n\tsr=%s\n" (str_of_box s.box) (str_of_box br) (str_of_box sr.box); + (sr, (br, ir)) + +let draw_sob sob s = + let sc = ref s in + let items = Format.flush_symbolic_output_buffer sob in + List.iter (fun itm -> + ()) items; + (s, Image.empty) + + +let draw_repl height (s:Display.state) = + () + +(* let draw_tree height (s:Display.state) = + * let indent = ref 0 in + * let rec draw_levels (tree:(string) list) pp = + * indent := !indent + 1; + * List.iter (fun (step, node) -> + * Format.pp_open_vbox pp 0; + * Format.pp_open_hbox pp (); + * for _ = 0 to !indent do Format.pp_print_space pp () done; + * Format.fprintf pp "%d-%s@." !indent step; + * Format.pp_close_box pp (); + * let subtree = () in + * draw_levels subtree pp; + * Format.pp_close_box pp () + * ) tree; + * indent := !indent - 1 + * in + * let root = Lwt_main.run + * Printf.printf "Lumplist length: %d\n" (List.length root); + * draw_pp height (draw_levels root) s *) + +let draw_lumptree height (s:Display.state) = + let from = [] in (* future optional arg *) + let pile = Lump.branch "./kommpile" "current" in (* future args *) + let indent = ref 0 in + let rec draw_levels (tree:(string * Lump.Pile.tree) list) pp = + indent := !indent + 1; + List.iter (fun (step, node) -> + Format.pp_open_vbox pp 0; + Format.pp_open_hbox pp (); + for _ = 0 to !indent do Format.pp_print_space pp () done; + Format.fprintf pp "%d-%s@." !indent step; + Format.pp_close_box pp (); + let subtree = Lwt_main.run (Lump.Pile.Tree.list node []) in + draw_levels subtree pp; + Format.pp_close_box pp () + ) tree; + indent := !indent - 1 + in + let root = Lwt_main.run (Lump.Pile.get_tree pile from >>= (fun n -> Lump.Pile.Tree.list n [])) in + Printf.printf "Lumplist length: %d\n" (List.length root); + draw_pp height (draw_levels root) s + +let draw_komm (s:Display.state) = + let node, state, box = ref I.empty, ref s, ref s.box in + let push (s, (b, i)) = node := I.stack !node i; state := s; box := b in + let _, (mouse_x, mouse_y) = Tsdl.Sdl.get_mouse_state () in + F.pr "\n\n\t================================================\t vvvvvvvvvvvvvvv\n"; + push @@ fill_box (Display.gray 0.125) s.box !state; (* gray bg *) + push @@ pane_vbox [ + draw_lumptree 50.; + draw_pp 30. + (fun pp -> + Box2.pp pp s.box; + Format.pp_open_box pp 0; + Format.pp_force_newline pp (); + Format.pp_print_string pp "fuck off!"; + Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]"; + Format.pp_print_newline pp (); + Format.pp_print_flush pp (); + Format.fprintf pp "%f@." 0.2; + Format.pp_print_if_newline pp (); + Format.fprintf pp "@[%s@ %d@]@." "x =" 1; + Format.pp_close_box pp (); + Format.pp_print_flush pp () + )] {s with box = (Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))}; + (!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node)) + +let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900) draw_komm) () + diff --git a/bin/old_main.ml b/bin/old_main.ml new file mode 100644 index 0000000..5a9d6c0 --- /dev/null +++ b/bin/old_main.ml @@ -0,0 +1,155 @@ +open Lwt.Infix + +(* komm / konsole / tafel *) + +module Lump = struct + module Pile = Irmin_unix.Git.FS.KV(Irmin.Contents.String) + type t = { conf : Irmin.config; + repo : Pile.Repo.t; + branch : Pile.branch; + path : string list; + } + + let branch repo_loc branch = + let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in + Lwt_main.run (Pile.of_branch repo branch) + + let get repo_loc branch path = + let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in + let branch = Lwt_main.run (Pile.of_branch repo branch) in + let node = Pile.get branch path in + Lwt_main.run node + +(* val pile_conf path = Irmin_git.config path + val pile_repo conf = Pile.Repo.v conf + val pile_branch conf name = pile_repo conf*) +end + +(*let pos = ref (Lump.get "./kommstore" "current" ["init"])*) +(* magic position [ref Lump.t]*) + + + +open Tsdl + +open Wall +module I = Image +module P = Path +module Text = Wall_text + +let gray ?(a=1.0) v = Color.v v v v a + +let load_font name = + 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 + +let font_icons = lazy (load_font "entypo.ttf") +let font_sans = lazy (load_font "Roboto-Regular.ttf") +let font_sans_bold = lazy (load_font "Roboto-Bold.ttf") +let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf") + +let w = 1000 +let h = 600 +let f = try float_of_string Sys.argv.(1) with _ -> 1.0 +let fw = int_of_float (f *. float w) +let fh = int_of_float (f *. float h) + +let draw_label text x y w h = + I.paint (Paint.color (gray ~a:0.5 1.0)) + Text.(simple_text + (Font.make ~size:18.0 (Lazy.force font_sans)) + ~valign:`MIDDLE ~halign:`LEFT + ~x ~y:(y+.h*.0.5) text) + +let draw_demo x y w h t = ( + let node = ref I.empty in + let push n = node := I.stack !node n in + push @@ draw_label "hello world" x y 280.0 20.0; + !node +) + +let draw_lumptree x y w h t = ( + let node = ref I.empty in + let push n = node := I.stack !node n in + let pile = Lump.branch "./kommpile" "current" in + let lumplist = Lwt_main.run (Lump.Pile.list pile []) in + Printf.printf "Lumplist length: %d\n" (List.length lumplist); + List.iter (fun (step, tree) -> + let path = step (*List.fold_left (fun s e -> s ^ e) "" step*) in + print_endline ("Path: " ^ path); + push @@ draw_label path x y 280.0 20.0; () + ) lumplist; + !node +) + +let render context sw sh t = + let lw = float w in + let lh = float h in + let pw = lw *. f *. sw in + let ph = lh *. f *. sh in + Renderer.render context ~width:pw ~height:ph + (Image.seq [ + draw_lumptree 100. 200. lw lh t; + draw_demo 100. 100. lw lh t; + ] + ) + +open Tgles2 + +let main () = + print_endline "komm main.ml"; + Printexc.record_backtrace true; + match Sdl.init Sdl.Init.video with + | Error (`Msg e) -> Sdl.log "Init error: %s" e; exit 1 + | Ok () -> + ignore (Sdl.gl_set_attribute Sdl.Gl.depth_size 24 : _ result); + ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 8 : _ result); + match + Sdl.create_window ~w:fw ~h:fh "SDL OpenGL" + Sdl.Window.(opengl + allow_highdpi) + with + | Error (`Msg e) -> Sdl.log "Create window error: %s" e; exit 1 + | Ok w -> + ignore (Sdl.gl_set_swap_interval (-1)); + let ow, oh = Sdl.gl_get_drawable_size w in + Sdl.log "window size: %d,%d\topengl drawable size: %d,%d" fw fh ow oh; + let sw = float ow /. float fw and sh = float oh /. float fh in + (* GL3 initialization: *) + ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); + match Sdl.gl_create_context w with + | Error (`Msg e) -> Sdl.log "Create context error: %s" e; exit 1 + | Ok ctx -> + let context = Renderer.create ~antialias:true ~stencil_strokes:true () in + let quit = ref false in + let event = Sdl.Event.create () in + while not !quit do + while Sdl.poll_event (Some event) do + match Sdl.Event.enum (Sdl.Event.get event Sdl.Event.typ) with + | `Quit -> quit := true + | _ -> () + done; + Gl.viewport 0 0 fw fh; + Gl.clear_color 0.3 0.3 0.32 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; + render context sw sh (Int32.to_float (Sdl.get_ticks ()) /. 1000.0); + Sdl.gl_swap_window w; + done; + Sdl.gl_delete_context ctx; + Sdl.destroy_window w; + Sdl.quit (); + exit 0 + +let () = () (* lol i forget *) diff --git a/bin/ui_linux_sdl.ml b/bin/ui_linux_sdl.ml new file mode 100644 index 0000000..e739170 --- /dev/null +++ b/bin/ui_linux_sdl.ml @@ -0,0 +1,202 @@ +[@@@ocaml.warning "-6-9-27"] +open Tsdl +open Tgles2 + +let (>>=) x f = match x with + | Ok a -> f a + | Error x as result -> result + +let on_failure ~cleanup result = + begin match result with + | Ok _ -> () + | Error _ -> cleanup () + end; + result + +let get_result = function + | Ok x -> x + | Error (`Msg msg) -> failwith msg + +let initialized = lazy (Sdl.init Sdl.Init.video) + +type state = { + time: float; + wall: Wall.renderer; +} + +type slide = state -> Wall.image list + +let ticks () = + Int32.to_int (Sdl.get_ticks ()) + +type window = { + win: Sdl.window; + gl: Sdl.gl_context; + wall: Wall.renderer; + event: Sdl.event; + mutable quit: bool; + mutable running_since: int option; + mutable prev_slides : slide list; + mutable next_slides : slide list; + mutable time_acc: float; + mutable fullscreen: bool; +} + +let make_window ~w ~h = + Lazy.force initialized >>= fun () -> + Sdl.create_window ~w ~h "Slideshow" + Sdl.Window.(opengl + allow_highdpi + resizable + hidden) + >>= fun win -> + ignore (Sdl.gl_set_swap_interval (-1)); + ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); + on_failure ( + Sdl.gl_create_context win >>= fun gl -> + let wall = Wall.Renderer.create ~antialias:true ~stencil_strokes:true () in + Ok { win; gl; wall; event = Sdl.Event.create (); + prev_slides = []; next_slides = []; + quit = false; running_since = None; time_acc = 0.0; fullscreen = false } + ) ~cleanup:(fun () -> Sdl.destroy_window win) + +let get_time t = + match t.running_since with + | None -> t.time_acc + | Some tick0 -> t.time_acc +. float (ticks () - tick0) /. 1000.0 + +let set_pause t pause = + if pause then ( + t.time_acc <- get_time t; + t.running_since <- None; + ) else ( + t.running_since <- Some (ticks ()) + ) + +let reset_time t = + t.time_acc <- 0.0; + set_pause t false + +let set_slides t slides = + let rec select_slides acc prevs nexts = + match prevs, nexts with + | (_ :: prevs'), (next :: nexts') -> + select_slides (next :: acc) prevs' nexts' + | _, _ -> acc, nexts + in + let prev_slides, next_slides = select_slides [] t.prev_slides slides in + t.prev_slides <- prev_slides; + t.next_slides <- next_slides + +let render_slide t slide = + Sdl.gl_make_current t.win t.gl >>= fun () -> + let (width, height) as physical_size = Sdl.gl_get_drawable_size t.win in + 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 + let transform = + let r = 1024.0 /. 768.0 in + let r' = width /. height in + let r = + if r' > r then + (height /. 768.0) + else + (width /. 1024.0) + in + let x = (width -. 1024.0 *. r) /. 2.0 in + let y = (height -. 768.0 *. r) /. 2.0 in + Wall.Transform.rescale r r + (Wall.Transform.translation x y) + (*Wall.Transform.translate ~x ~y (Wall.Transform.scale r r)*) + in + Wall.Renderer.render t.wall ~width ~height + (Wall.Image.transform transform slide); + Sdl.gl_swap_window t.win; + Ok () + +let process_events t = + while Sdl.poll_event (Some t.event) do + let run_action = function + | `Quit -> t.quit <- true + | `Prev -> + begin match t.prev_slides with + | x :: xs -> + t.next_slides <- x :: t.next_slides; + t.prev_slides <- xs; + reset_time t + | [] -> () + end + | `Next -> + begin match t.next_slides with + | x :: xs -> + t.prev_slides <- x :: t.prev_slides; + t.next_slides <- xs; + reset_time t + | [] -> () + end + | `Pause -> set_pause t (t.running_since <> None) + | `Fullscreen -> + t.fullscreen <- not t.fullscreen; + ignore (Sdl.show_cursor (not t.fullscreen) : _ result); + ignore (Sdl.set_window_fullscreen t.win + (if t.fullscreen + then Sdl.Window.fullscreen_desktop + else Sdl.Window.windowed) + : _ result) + in + let bindings = [ + (Sdl.K.[q], `Quit); + (Sdl.K.[p], `Pause); + (Sdl.K.[left; up], `Prev); + (Sdl.K.[right; down], `Next); + (Sdl.K.[f], `Fullscreen); + ] + in + match Sdl.Event.enum (Sdl.Event.get t.event Sdl.Event.typ) with + | `Key_up -> + let key = Sdl.Event.get t.event Sdl.Event.keyboard_keycode in + begin match List.find (fun (keys, _) -> List.mem key keys) bindings with + | exception Not_found -> () + | (_, action) -> run_action action + end + | `Quit -> run_action `Quit + | _ -> () + done; + let slide = match t.next_slides with + | slide :: _ -> Wall.Image.seq (slide {time = get_time t; wall = t.wall}) + | [] -> Wall.Image.empty + in + match render_slide t slide with + | Result.Ok () -> () + | Result.Error (`Msg msg) -> + prerr_endline ("Render error?: " ^ msg) + +let destroy_window { win; gl; wall } = + Wall.Renderer.delete wall; + Sdl.gl_delete_context gl; + Sdl.destroy_window win + +let window = + get_result (make_window ~w:1024 ~h:768) + +let () = (window.quit <- true) + +let unix_stat fname = + match Unix.stat fname with + | stat -> {stat with Unix.st_atime = stat.Unix.st_mtime} + | exception (Unix.Unix_error (Unix.ENOENT, _, _)) -> + raise Not_found + +let rec main () = + Sdl.show_window window.win; + if window.quit then ( + Sdl.hide_window window.win; + Lwt.return_unit + ) else ( + process_events window; + Lwt.bind (Lwt_unix.sleep 0.01) main + ) + +let () = Lwt.async main diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..d3a8bf1 --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 2.8) +(name komm) diff --git a/komm.opam b/komm.opam new file mode 100644 index 0000000..e69de29 diff --git a/kommpile b/kommpile new file mode 160000 index 0000000..e82d0c8 --- /dev/null +++ b/kommpile @@ -0,0 +1 @@ +Subproject commit e82d0c805f811b1072021d6399df5a946504f801 diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..9587f17 --- /dev/null +++ b/lib/dune @@ -0,0 +1,2 @@ +(library + (name komm))