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

rearranged files

Browse Source
This commit is contained in:
cqc
2021-07-19 17:52:20 -05:00
parent c091f951f4
commit 59cff7602c
13 changed files with 6 additions and 531 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
bin/dune
View File

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

119
bin/example.ml
View File

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

0
bin/NotoEmoji-Regular.ttf → bin/fonts/NotoEmoji-Regular.ttf
View File

0
bin/Roboto-Bold.ttf → bin/fonts/Roboto-Bold.ttf
View File

0
bin/Roboto-Light.ttf → bin/fonts/Roboto-Light.ttf
View File

0
bin/Roboto-Regular.ttf → bin/fonts/Roboto-Regular.ttf
View File

0
bin/entypo.ttf → bin/fonts/entypo.ttf
View File

1
bin/lump.ml
View File

@ -1 +0,0 @@
(* lump is module *)

30
bin/lumppile.ml
View File

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

19
bin/lumpstore.ml
View File

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

9
bin/main.ml
View File

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

155
bin/old_main.ml
View File

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

202
bin/ui_linux_sdl.ml
View File

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