158 lines
4.0 KiB
OCaml
158 lines
4.0 KiB
OCaml
open! Import
|
|
open Types
|
|
|
|
include (val Ohlog.sublogs Import.logger "Scene")
|
|
|
|
type context = {
|
|
sprite_maps : (string, Sprite_map.t) Hashtbl.t;
|
|
fonts : (string, Font.t) Hashtbl.t;
|
|
trans_parent : en option;
|
|
}
|
|
|
|
let make_context () = {
|
|
sprite_maps = Hashtbl.create 32;
|
|
fonts = Hashtbl.create 8;
|
|
trans_parent = None;
|
|
}
|
|
|
|
let register_sprite_map cx k v = Hashtbl.replace cx.sprite_maps k v
|
|
let get_sprite_map cx k = try Hashtbl.find cx.sprite_maps k
|
|
with Not_found -> Format.kasprintf failwith "no such sprite map %S" k
|
|
|
|
let register_font cx k v = Hashtbl.replace cx.fonts k v
|
|
let get_font cx k = try Hashtbl.find cx.fonts k
|
|
with Not_found -> Format.kasprintf failwith "no such font %S" k
|
|
|
|
type t =
|
|
context -> en
|
|
|
|
let build cx f = f cx
|
|
|
|
let rec each2 fs x y = match fs with
|
|
| [] -> ()
|
|
| [f] -> f x y
|
|
| f :: fs -> f x y; each2 fs x y
|
|
|
|
|
|
(* sexp conv *)
|
|
|
|
module Sexp = Sexplib0.Sexp
|
|
open Sexplib0.Sexp_conv
|
|
|
|
(* (transform <...>) *)
|
|
|
|
let parse_transform args =
|
|
let tf = mat2a () in
|
|
List.iter
|
|
(function
|
|
| Sexp.List [Atom "tx"; arg] ->
|
|
tf.a2 <- float_of_sexp arg
|
|
| Sexp.List [Atom "ty"; arg] ->
|
|
tf.a5 <- float_of_sexp arg
|
|
| Sexp.List [Atom "sx"; arg] ->
|
|
tf.a0 <- float_of_sexp arg
|
|
| Sexp.List [Atom "sy"; arg] ->
|
|
tf.a4 <- float_of_sexp arg
|
|
| sexp ->
|
|
of_sexp_error "bad argument to transform" sexp)
|
|
args;
|
|
tf
|
|
|
|
(* (sprites <map> <...>) *)
|
|
|
|
let rec parse_sprites = function
|
|
| Sexp.List (Atom "sprites" :: Atom map :: args) ->
|
|
let init cx en =
|
|
let sprite_map = get_sprite_map cx map in
|
|
Render.Sprite.init en ~sprite_map
|
|
in
|
|
init :: List.map parse_sprites_arg args
|
|
|
|
| sexp ->
|
|
of_sexp_error "invalid sprites" sexp
|
|
|
|
and parse_sprites_arg = function
|
|
| Sexp.List [Atom frame; x; y] ->
|
|
let pos = vec2 (float_of_sexp x) (float_of_sexp y) in
|
|
fun cx en -> Render.Sprite.add en ~frame ~pos
|
|
| Atom frame ->
|
|
let pos = vec2 0.0 0.0 in
|
|
fun cx en -> Render.Sprite.add en ~frame ~pos
|
|
| sexp ->
|
|
of_sexp_error "bad argument to sprites" sexp
|
|
|
|
(* (label <font> <text> <...>) *)
|
|
|
|
let rec parse_label = function
|
|
| Sexp.List (Atom "label" :: Atom font :: Atom text :: args) ->
|
|
let init cx en =
|
|
let font = get_font cx font in
|
|
Render.Label.init en ~font;
|
|
Render.Label.set_text en text
|
|
in
|
|
init :: List.map parse_label_arg args
|
|
|
|
| sexp ->
|
|
of_sexp_error "invalid label" sexp
|
|
|
|
and parse_label_arg = function
|
|
| Sexp.List [Atom "fg"; _rgb] ->
|
|
failwith "TODO: label: (fg <rgb>)"
|
|
| sexp ->
|
|
of_sexp_error "bad argument to label" sexp
|
|
|
|
(* (object [<name>] <...>) *)
|
|
|
|
let rec parse_obj = function
|
|
| Sexp.List (Atom "object" :: args) ->
|
|
let name, args = match args with
|
|
| Atom name :: args -> Some name, args
|
|
| args -> None, args
|
|
in
|
|
trace (fun m -> match name with
|
|
| Some n -> m "parse_obj %S" n
|
|
| None -> m "parse_obj %s" "(unnamed)");
|
|
let inits = flat_map parse_obj_arg args in
|
|
fun cx ->
|
|
let en = Entity.make ?name () in
|
|
Trans.init en ?parent:cx.trans_parent;
|
|
each2 inits cx en;
|
|
en
|
|
|
|
| sexp ->
|
|
of_sexp_error "invalid object" sexp
|
|
|
|
and parse_obj_arg = function
|
|
| Sexp.List (Atom "transform" :: args) ->
|
|
let tf = parse_transform args in
|
|
let init _cx en = Mat2A.copy (Trans.model en) ~src:tf in
|
|
[init]
|
|
|
|
| Sexp.List (Atom "sprites" :: _) as arg ->
|
|
parse_sprites arg
|
|
|
|
| Sexp.List (Atom "label" :: _) as arg ->
|
|
parse_label arg
|
|
|
|
| Sexp.List (Atom "object" :: _) as sexp ->
|
|
trace (fun m -> m "parse_obj_args: begin object");
|
|
let build = parse_obj sexp in
|
|
trace (fun m -> m "parse_obj_args: end object");
|
|
let init cx en = build { cx with trans_parent = Some en } |> ignore in
|
|
[init]
|
|
|
|
| sexp ->
|
|
of_sexp_error "bad argument to object" sexp
|
|
|
|
let of_sexp = function
|
|
| Sexp.List [Atom "scene"; root] ->
|
|
parse_obj root
|
|
|
|
| sexp ->
|
|
of_sexp_error "invalid scene" sexp
|
|
|
|
let load name =
|
|
S2.Asset.load_sexp_conv
|
|
(name ^ ".scene")
|
|
of_sexp
|