add label nodes to scene

assets/main.scene

@@ -23,9 +23,26 @@
    (transform (tx -172) (ty 320))
    (sprite hud pps (pos -12 -148))
    (sprite hud kpp (pos -12 -116))
+
+   (sprite hud num (pos 0 -73))
+   (object "pcnt"
+    (label mono-sm "0")
+    (transform (ty -50) (sx 24) (sy 24)
+     ; TODO: text align right
+     (tx -14)))
+
    (sprite hud time (pos 0 -25))
-   (sprite hud num (pos 0 -73)))
+   (object "time"
+    (label mono-sm "0:00.00")
+    (transform (ty -2) (sx 24) (sy 24)
+     ; TODO: text align right
+     (tx -100))))
 
   (object "right_labels"
    (transform (tx 272) (ty 320))
-   (sprite hud lines_rem (pos 0 -20)))))
+   (sprite hud lines_rem (pos 0 -20))
+   (object "goal"
+    (label roman-md "40")
+    (transform (ty -56) (sx 80) (sy 80)
+     ; TODO: text align center
+     (tx -39))))))

scripts/gen_fonts.sh

@@ -30,7 +30,7 @@ function gen() {
              | exit 1)
 }
 
-gen liberation.128 "Liberation Mono:style=regular" 128
-gen liberation.32 "Liberation Mono:style=regular" 32
-gen p052-roman.96 "P052:style=roman" 96
-gen p052-roman.32 "P052:style=roman" 32
+#gen liberation-lg "Liberation Mono:style=regular" 128
+gen mono-sm "Liberation Mono:style=regular" 24
+gen roman-md "P052:style=roman" 80
+#gen p052-roman.32 "P052:style=roman" 32

src/main.ml

@@ -13,22 +13,12 @@ let main () =
   let ren = Renderer.make ~wnd in
   info (fun m -> m "renderer initialized");
 
-  let font1 = Asset.load_font "p052-roman.96" in
-  let text1 = "39" in
-  let text1_fg = rgb24 0xffffff in
-  let text1_tf = mat2a 50.0 100.0 48.0 48.0 in
-
-  let font2 = Asset.load_font "liberation.32" in
-  let text2 = "Hello, world" in
-  let text2_fg = rgb24 0xffffff in
-  let text2_tf = mat2a 50.0 200.0 24.0 24.0 in
-
   let sg = SG.make () in
-  SG.register_sprite_map sg "blocks"
-    (Asset.load_sprite_map "blocks" ~dpi:192);
-  SG.register_sprite_map sg "hud"
-    (Asset.load_sprite_map "hud");
-  debug (fun m -> m "loaded sprites");
+  SG.register_sprite_map sg "blocks" (Asset.load_sprite_map "blocks" ~dpi:192);
+  SG.register_sprite_map sg "hud" (Asset.load_sprite_map "hud");
+  SG.register_font sg "roman-md" (Asset.load_font "roman-md");
+  SG.register_font sg "mono-sm" (Asset.load_font "mono-sm");
+  debug (fun m -> m "loaded assets");
 
   let tg = TG.make () in
   let scene = Scene.load "main" ~tg ~sg in
@@ -47,10 +37,7 @@ let main () =
       Renderer.clear ren (rgb24 0x131321);
 
       TG.update tg;
-      if false then SG.render sg ~ren;
-
-      Renderer.draw_text ren font1 text1 ~tf:text1_tf ~fg:text1_fg;
-      Renderer.draw_text ren font2 text2 ~tf:text2_tf ~fg:text2_fg;
+      SG.render sg ~ren;
 
       Renderer.post_draw ren;
 

src/n2/n2.ml

@@ -1,4 +1,5 @@
 open Adam
+open S2
 
 include (val Ohlog.logs "N2")
 
@@ -75,21 +76,29 @@ module Sprite_graph = struct
   include (val Ohlog.sublogs logger "SG")
 
   type t = {
-    sprite_maps : (string, S2.Sprite.map) Hashtbl.t;
+    sprite_maps : (string, Sprite.map) Hashtbl.t;
+    fonts : (string, Font.t) Hashtbl.t;
     mutable list_rev : node list;
     mutable list : node list;
   }
 
-  and node = {
-    tf : mat2a;
-    pos : vec2;
-    sprite : S2.Sprite.t;
-    (* tint : color; *)
-    (* mutable remove : bool; *)
-  }
+  and node =
+    | Sprite of {
+        tf : mat2a;
+        pos : vec2;
+        sprite : Sprite.t;
+        (* tint : color *)
+      }
+    | Label of {
+        tf : mat2a;
+        font : Font.t;
+        (* mutable *)text : string;
+        fg : color;
+      }
 
   let make () = {
-    sprite_maps = Hashtbl.create 128;
+    sprite_maps = Hashtbl.create 32;
+    fonts = Hashtbl.create 32;
     list_rev = [];
     list = [];
   }
@@ -97,11 +106,18 @@ module Sprite_graph = struct
   let register_sprite_map t name map =
     Hashtbl.replace t.sprite_maps name map
 
+  let register_font t name font =
+    Hashtbl.replace t.fonts name font
+
   let get_sprite t map_name sprite_name =
     let map = try Hashtbl.find t.sprite_maps map_name
       with Not_found -> Format.kasprintf failwith "no sprite map %S" map_name
     in
-    S2.Sprite.get map sprite_name
+    Sprite.get map sprite_name
+
+  let get_font t name =
+    try Hashtbl.find t.fonts name
+    with Not_found -> Format.kasprintf failwith "no font %S" name
 
   let push t node =
     begin
@@ -109,15 +125,23 @@ module Sprite_graph = struct
       t.list <- [];
     end
 
-  let add t ~tf ~pos ~sprite =
-    let node = { tf; pos; sprite } in
+  let add_sprite t ~tf ~pos ~sprite =
+    let node = Sprite { tf; pos; sprite } in
+    push t node;
+    node
+
+  let add_label t ~tf ~font ~text ~fg =
+    let node = Label { tf; font; text; fg } in
     push t node;
     node
 
   let rec render_rec ren = function
     | [] -> ()
-    | { tf; pos; sprite } :: nodes ->
-      S2.Renderer.draw_sprite ren sprite ~tf ~pos;
+    | Sprite { tf; pos; sprite } :: nodes ->
+      Renderer.draw_sprite ren sprite ~tf ~pos;
+      render_rec ren nodes
+    | Label { tf; font; text; fg } :: nodes ->
+      Renderer.draw_text ren font text ~tf ~fg;
       render_rec ren nodes
 
   let render t ~ren =
@@ -204,10 +228,25 @@ module Scene = struct
       let sprite = Sprite_graph.get_sprite sg map sprite in
       let pos = vec2 0.0 0.0 in
       List.iter (parse_sprite_arg ~pos) args;
-      Sprite_graph.add sg ~tf ~pos ~sprite
+      Sprite_graph.add_sprite sg ~tf ~pos ~sprite
     | sexp ->
       of_sexp_error "invalid sprite" sexp
 
+  let parse_label_arg ~(fg : color) = function
+    | Sexp.List [Atom "fg"; rgb] ->
+      Color.set_rgb24 fg (int_of_sexp rgb)
+    | sexp ->
+      of_sexp_error "bad argument to label" sexp
+
+  let parse_label ~sg ~tf = function
+    | Sexp.List (Atom "label" :: Atom font :: Atom text :: args) ->
+      let font = Sprite_graph.get_font sg font in
+      let fg = rgb24 0xffffff in
+      List.iter (parse_label_arg ~fg) args;
+      Sprite_graph.add_label sg ~tf ~font ~text ~fg
+    | sexp ->
+      of_sexp_error "invalid label" sexp
+
   let rec parse_obj t ~tg ~sg ~parent = function
     | Sexp.List (Atom "object" :: args) ->
       trace (fun m -> m "parse_obj");
@@ -233,21 +272,31 @@ module Scene = struct
         trace (fun m -> m "parse_obj_args: name=%S" name);
         let obj = { obj with name = Some name } in
         parse_obj_args t obj args ~tg ~sg
+
       | Sexp.List (Atom "transform" :: tf_args) ->
         let tf = Transform_graph.model obj.transform in
         List.iter (parse_transform_arg ~tf) tf_args;
         trace (fun m -> m "parse_obj_args: tf=%a" Mat2A.pp tf);
         parse_obj_args t obj args ~tg ~sg
+
       | Sexp.List (Atom "sprite" :: _) ->
         let tf = Transform_graph.world obj.transform in
         let spr = parse_sprite arg ~sg ~tf in
         let obj = { obj with sprites = spr :: obj.sprites } in
         parse_obj_args t obj args ~tg ~sg
+
+      | Sexp.List (Atom "label" :: _) ->
+        let tf = Transform_graph.world obj.transform in
+        let lab = parse_label arg ~sg ~tf in
+        let obj = { obj with sprites = lab :: obj.sprites } in
+        parse_obj_args t obj args ~tg ~sg
+
       | Sexp.List (Atom "object" :: _) ->
         trace (fun m -> m "parse_obj_args: begin object");
         let _child = parse_obj t arg ~tg ~sg ~parent:(Some obj) in
         trace (fun m -> m "parse_obj_args: end object");
         parse_obj_args t obj args ~tg ~sg
+
       | sexp ->
         of_sexp_error "bad argument to object" sexp
 

src/n2/n2.mli

@@ -20,9 +20,8 @@ module Sprite_graph : sig
 
   val make : unit -> t
   val register_sprite_map : t -> string -> Sprite.map -> unit
+  val register_font : t -> string -> Font.t -> unit
   val render : t -> ren:Renderer.t -> unit
-
-  (* val add_rect : t -> tf:mat2a -> bb:aabb -> fill:color -> node *)
 end
 
 module Scene : sig

src/s2/asset.ml

@@ -8,23 +8,38 @@ let absolute_path path =
   with Unix.Unix_error (ENOENT, _, _) ->
     raise (Error (path, "not found"))
 
-let load_file path =
-  trace (fun m -> m "open text file %S" path);
+let load_file path of_bigstring =
+  trace (fun m -> m "reading file %S" path);
   let fd = Unix.openfile (absolute_path path) [O_RDONLY] 0 in
-  let len = (Unix.fstat fd).st_size in
-  let buf = Bytes.create len in
-  trace (fun m -> m "length=%d" len);
-  let rec read i =
-    match Unix.read fd buf i (len - i) with
-    | 0 -> Unix.close fd; i
-    | n -> read (i + n)
+  try
+    let mmap = Unix.map_file fd Char C_layout false [|-1|] in
+    let res = of_bigstring (array1_of_genarray mmap) in
+    Unix.close fd; res
+  with exn ->
+    Unix.close fd; raise exn
+
+let load_image path of_surface =
+  trace (fun m -> m "reading image %S" path);
+  let srf = match Sdl.Image.load (absolute_path path) with
+    | Ok srf -> srf
+    | Error (`Msg msg) -> raise (Error (path, msg))
   in
-  Bytes.sub_string buf 0 (read 0)
+  try
+    let res = of_surface srf in
+    Sdl.free_surface srf; res
+  with exn ->
+    Sdl.free_surface srf; raise exn
+
+let string_of_bigarray ba =
+  let len = Array1.dim ba in
+  let str = Bytes.create len in
+  for i = 0 to len - 1 do Bytes.unsafe_set str i ba.{i} done;
+  Bytes.unsafe_to_string str
+
+let load_string path =
+  load_file path string_of_bigarray
 
 let load_sexp_conv path of_sexp =
-  try
-    load_file path
-    |> Sexplib.Sexp.of_string
-    |> of_sexp
-  with Sexplib.Conv.Of_sexp_error (Failure msg, _) ->
-    raise (Error (path, "parse error: " ^ msg))
+  try of_sexp (load_file path Sexp.of_bigstring)
+  with Failure msg | Sexp_conv.Of_sexp_error (Failure msg, _) ->
+    raise (Error (path, msg))

src/s2/font.ml

@@ -1,6 +1,4 @@
 open! Import
-module Sexp = Sexplib.Sexp
-module Sexp_conv = Sexplib.Conv
 include (val Ohlog.sublogs logger "Font")
 
 type glyph = {

src/s2/import.ml

@@ -1,4 +1,6 @@
 include Adam
 include Bigarray
+module Sexp = Sexplib.Sexp
+module Sexp_conv = Sexplib.Conv
 
 include (val Ohlog.logs "S2")

src/s2/renderer.ml

@@ -110,8 +110,8 @@ let compile_shader ~vert ~frag =
 let load_shader ~name =
   let shd =
     compile_shader
-      ~vert:(Printf.ksprintf Asset.load_file "shaders/%s.vert" name)
-      ~frag:(Printf.ksprintf Asset.load_file "shaders/%s.frag" name)
+      ~vert:(Printf.ksprintf Asset.load_string "shaders/%s.vert" name)
+      ~frag:(Printf.ksprintf Asset.load_string "shaders/%s.frag" name)
   in
   debug (fun m -> m "loaded shader %S" name); shd
 

src/s2/s2.mli

@@ -41,10 +41,13 @@ end
 
 module Asset : sig
   open Sexplib
+  open Bigarray
+  type bigstring := (char, int8_unsigned_elt, c_layout) Array1.t
 
   exception Error of string * string
 
-  val load_file : string -> string
+  val load_string : string -> string
+  val load_file : string -> (bigstring -> 'a) -> 'a
   val load_sexp_conv : string -> (Sexp.t -> 'a) -> 'a
   val load_sprite_map : ?dpi:int -> string -> Sprite.map
   val load_font : string -> Font.t

src/s2/sprite.ml

@@ -1,6 +1,4 @@
 open! Import
-module Sexp = Sexplib.Sexp
-module Sexp_conv = Sexplib.Conv
 include (val Ohlog.sublogs logger "Sprite")
 
 (* TODO: spritemap has one texture shared by all the sprites *)
@@ -80,12 +78,8 @@ module Asset = struct
     let texture = Texture.Asset.load_texture tex_path in
     let spritemap = Asset.load_sexp_conv map_path (of_sexp ~texture ?dpi) in
     debug (fun m -> m "loaded sprite map %S" name);
-    trace (fun m ->
-            Hashtbl.iter
-              (fun name s ->
-                 m "  %S %a %a" name
-                   AABB.pp s.clip
-                   AABB.pp s.offs)
-              spritemap);
+    trace (fun m -> Hashtbl.iter
+                      (fun name s -> m "  %S %a %a" name AABB.pp s.clip AABB.pp s.offs)
+                      spritemap);
     spritemap
 end

src/s2/texture.ml

@@ -73,20 +73,8 @@ let of_surface ?(premultiply_alpha = true) srf =
   let dst, fmt = conv src width height in
   Renderer.make_texture width height fmt dst
 
-let of_surface_free ?premultiply_alpha srf =
-  try
-    let tex = of_surface srf ?premultiply_alpha in
-    Sdl.free_surface srf; tex
-  with e ->
-    Sdl.free_surface srf; raise e
-
 module Asset = struct
   let load_texture ?premultiply_alpha path =
-    trace (fun m -> m "open image %S" path);
-    try
-      match Sdl.Image.load (Asset.absolute_path path) with
-      | Ok srf -> of_surface_free ?premultiply_alpha srf
-      | Error (`Msg msg) -> failwith msg
-    with
-      Failure msg -> raise (Asset.Error (path, msg))
+    Asset.load_image path
+      (of_surface ?premultiply_alpha)
 end