From 59cff7602ce7438c2450da460928e6be8d43d005 Mon Sep 17 00:00:00 2001 From: cqc Date: Mon, 19 Jul 2021 17:52:20 -0500 Subject: [PATCH] rearranged files --- bin/dune | 2 +- bin/example.ml | 119 --------------- bin/{ => fonts}/NotoEmoji-Regular.ttf | Bin bin/{ => fonts}/Roboto-Bold.ttf | Bin bin/{ => fonts}/Roboto-Light.ttf | Bin bin/{ => fonts}/Roboto-Regular.ttf | Bin bin/{ => fonts}/entypo.ttf | Bin bin/lump.ml | 1 - bin/lumppile.ml | 30 ---- bin/lumpstore.ml | 19 --- bin/main.ml | 9 +- bin/old_main.ml | 155 -------------------- bin/ui_linux_sdl.ml | 202 -------------------------- 13 files changed, 6 insertions(+), 531 deletions(-) delete mode 100644 bin/example.ml rename bin/{ => fonts}/NotoEmoji-Regular.ttf (100%) rename bin/{ => fonts}/Roboto-Bold.ttf (100%) rename bin/{ => fonts}/Roboto-Light.ttf (100%) rename bin/{ => fonts}/Roboto-Regular.ttf (100%) rename bin/{ => fonts}/entypo.ttf (100%) delete mode 100644 bin/lump.ml delete mode 100644 bin/lumppile.ml delete mode 100644 bin/lumpstore.ml delete mode 100644 bin/old_main.ml delete mode 100644 bin/ui_linux_sdl.ml diff --git a/bin/dune b/bin/dune index 2de0743..f0a976c 100644 --- a/bin/dune +++ b/bin/dune @@ -1,5 +1,5 @@ (executables - (names main example lumppile) + (names main) (modes byte) (link_flags (-linkall)) (libraries komm tsdl tgls.tgles2 wall irmin-unix compiler-libs.common compiler-libs.bytecomp compiler-libs.toplevel ocaml-compiler-libs.common ocaml-compiler-libs.toplevel zed)) diff --git a/bin/example.ml b/bin/example.ml deleted file mode 100644 index 63a6c5c..0000000 --- a/bin/example.ml +++ /dev/null @@ -1,119 +0,0 @@ -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/NotoEmoji-Regular.ttf b/bin/fonts/NotoEmoji-Regular.ttf similarity index 100% rename from bin/NotoEmoji-Regular.ttf rename to bin/fonts/NotoEmoji-Regular.ttf diff --git a/bin/Roboto-Bold.ttf b/bin/fonts/Roboto-Bold.ttf similarity index 100% rename from bin/Roboto-Bold.ttf rename to bin/fonts/Roboto-Bold.ttf diff --git a/bin/Roboto-Light.ttf b/bin/fonts/Roboto-Light.ttf similarity index 100% rename from bin/Roboto-Light.ttf rename to bin/fonts/Roboto-Light.ttf diff --git a/bin/Roboto-Regular.ttf b/bin/fonts/Roboto-Regular.ttf similarity index 100% rename from bin/Roboto-Regular.ttf rename to bin/fonts/Roboto-Regular.ttf diff --git a/bin/entypo.ttf b/bin/fonts/entypo.ttf similarity index 100% rename from bin/entypo.ttf rename to bin/fonts/entypo.ttf diff --git a/bin/lump.ml b/bin/lump.ml deleted file mode 100644 index d4920d9..0000000 --- a/bin/lump.ml +++ /dev/null @@ -1 +0,0 @@ -(* lump is module *) diff --git a/bin/lumppile.ml b/bin/lumppile.ml deleted file mode 100644 index 380f9ed..0000000 --- a/bin/lumppile.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* 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 deleted file mode 100644 index 90777a8..0000000 --- a/bin/lumpstore.ml +++ /dev/null @@ -1,19 +0,0 @@ -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 index 584532e..75c8a8e 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -276,10 +276,11 @@ let load_font name = | 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 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_emoji = lazy (load_font "fonts/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) diff --git a/bin/old_main.ml b/bin/old_main.ml deleted file mode 100644 index 5a9d6c0..0000000 --- a/bin/old_main.ml +++ /dev/null @@ -1,155 +0,0 @@ -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 deleted file mode 100644 index e739170..0000000 --- a/bin/ui_linux_sdl.ml +++ /dev/null @@ -1,202 +0,0 @@ -[@@@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