(module shapes racket/base (provide (except-out (all-defined-out) :decode-embedded :encode-embedded) (rename-out (:decode-embedded decode-embedded:shapes) (:encode-embedded encode-embedded:shapes))) (require preserves) (require preserves-schema/methods) (require preserves-schema/support) (require racket/match) (require racket/set) (require racket/dict) (require (only-in racket/generic define/generic)) (define :decode-embedded values) (define :encode-embedded values) (struct Box () #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Box) (record 'box (list))))))) (define (parse-Box input) (match input ((and dest (record 'box (list))) (Box)) (_ eof))) (define parse-Box! (parse-success-or-error 'parse-Box parse-Box)) (struct CSG (expr) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSG ?expr) (record 'csg (list (*->preserve ?expr)))))))) (define (parse-CSG input) (match input ((and dest (record 'csg (list (app parse-CSGExpr (and ?expr (not (== eof))))))) (CSG ?expr)) (_ eof))) (define parse-CSG! (parse-success-or-error 'parse-CSG parse-CSG)) (define (CSGExpr? p) (or (CSGExpr-mesh? p) (CSGExpr-scale? p) (CSGExpr-move? p) (CSGExpr-rotate? p) (CSGExpr-subtract? p) (CSGExpr-union? p) (CSGExpr-intersect? p) (CSGExpr-invert? p))) (struct CSGExpr-mesh (shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-mesh ?shape) (record 'mesh (list (*->preserve ?shape)))))))) (struct CSGExpr-scale (v shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-scale ?v ?shape) (record 'scale (list (*->preserve ?v) (*->preserve ?shape)))))))) (struct CSGExpr-move (v shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-move ?v ?shape) (record 'move (list (*->preserve ?v) (*->preserve ?shape)))))))) (struct CSGExpr-rotate (v shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-rotate ?v ?shape) (record 'rotate (list (*->preserve ?v) (*->preserve ?shape)))))))) (struct CSGExpr-subtract (base more) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-subtract ?base ?more) (record 'subtract (list (list* (*->preserve ?base) (for/list ((item (in-list ?more))) (*->preserve item)))))))))) (struct CSGExpr-union (base more) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-union ?base ?more) (record 'union (list (list* (*->preserve ?base) (for/list ((item (in-list ?more))) (*->preserve item)))))))))) (struct CSGExpr-intersect (base more) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-intersect ?base ?more) (record 'intersect (list (list* (*->preserve ?base) (for/list ((item (in-list ?more))) (*->preserve item)))))))))) (struct CSGExpr-invert (shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CSGExpr-invert ?shape) (record 'invert (list (*->preserve ?shape)))))))) (define (parse-CSGExpr input) (match input ((and dest (record 'mesh (list (app parse-Mesh (and ?shape (not (== eof))))))) (CSGExpr-mesh ?shape)) ((and dest (record 'scale (list (app parse-LiteralVector3 (and ?v (not (== eof)))) (app parse-CSGExpr (and ?shape (not (== eof))))))) (CSGExpr-scale ?v ?shape)) ((and dest (record 'move (list (app parse-LiteralVector3 (and ?v (not (== eof)))) (app parse-CSGExpr (and ?shape (not (== eof))))))) (CSGExpr-move ?v ?shape)) ((and dest (record 'rotate (list (app parse-LiteralVector3 (and ?v (not (== eof)))) (app parse-CSGExpr (and ?shape (not (== eof))))))) (CSGExpr-rotate ?v ?shape)) ((and dest (record 'subtract (list (list* (app parse-CSGExpr (and ?base (not (== eof)))) (list (app parse-CSGExpr (and ?more (not (== eof)))) ...))))) (CSGExpr-subtract ?base ?more)) ((and dest (record 'union (list (list* (app parse-CSGExpr (and ?base (not (== eof)))) (list (app parse-CSGExpr (and ?more (not (== eof)))) ...))))) (CSGExpr-union ?base ?more)) ((and dest (record 'intersect (list (list* (app parse-CSGExpr (and ?base (not (== eof)))) (list (app parse-CSGExpr (and ?more (not (== eof)))) ...))))) (CSGExpr-intersect ?base ?more)) ((and dest (record 'invert (list (app parse-CSGExpr (and ?shape (not (== eof))))))) (CSGExpr-invert ?shape)) (_ eof))) (define parse-CSGExpr! (parse-success-or-error 'parse-CSGExpr parse-CSGExpr)) (define (Color? p) (or (Color-opaque? p) (Color-transparent? p))) (struct Color-opaque (r g b shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Color-opaque ?r ?g ?b ?shape) (record 'color (list (*->preserve ?r) (*->preserve ?g) (*->preserve ?b) (*->preserve ?shape)))))))) (struct Color-transparent (r g b alpha shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Color-transparent ?r ?g ?b ?alpha ?shape) (record 'color (list (*->preserve ?r) (*->preserve ?g) (*->preserve ?b) (*->preserve ?alpha) (*->preserve ?shape)))))))) (define (parse-Color input) (match input ((and dest (record 'color (list (app parse-DoubleValue (and ?r (not (== eof)))) (app parse-DoubleValue (and ?g (not (== eof)))) (app parse-DoubleValue (and ?b (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Color-opaque ?r ?g ?b ?shape)) ((and dest (record 'color (list (app parse-DoubleValue (and ?r (not (== eof)))) (app parse-DoubleValue (and ?g (not (== eof)))) (app parse-DoubleValue (and ?b (not (== eof)))) (app parse-DoubleValue (and ?alpha (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Color-transparent ?r ?g ?b ?alpha ?shape)) (_ eof))) (define parse-Color! (parse-success-or-error 'parse-Color parse-Color)) (define (DoubleValue? p) (or (DoubleValue-immediate? p) (DoubleValue-reference? p))) (struct DoubleValue-immediate (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((DoubleValue-immediate src) (exact->inexact (*->preserve src))))))) (struct DoubleValue-reference (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((DoubleValue-reference src) (*->preserve src)))))) (define (parse-DoubleValue input) (match input ((and dest (? flonum?)) (DoubleValue-immediate dest)) ((and dest (? symbol?)) (DoubleValue-reference dest)) (_ eof))) (define parse-DoubleValue! (parse-success-or-error 'parse-DoubleValue parse-DoubleValue)) (struct External (path) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((External ?path) (record 'external (list (*->preserve ?path)))))))) (define (parse-External input) (match input ((and dest (record 'external (list (and ?path (? string?))))) (External ?path)) (_ eof))) (define parse-External! (parse-success-or-error 'parse-External parse-External)) (struct Floor (shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Floor ?shape) (record 'floor (list (*->preserve ?shape)))))))) (define (parse-Floor input) (match input ((and dest (record 'floor (list (app parse-Shape (and ?shape (not (== eof))))))) (Floor ?shape)) (_ eof))) (define parse-Floor! (parse-success-or-error 'parse-Floor parse-Floor)) (struct Ground () #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Ground) (record 'ground (list))))))) (define (parse-Ground input) (match input ((and dest (record 'ground (list))) (Ground)) (_ eof))) (define parse-Ground! (parse-success-or-error 'parse-Ground parse-Ground)) (struct ImmediateQuaternion (a b c d) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((ImmediateQuaternion ?a ?b ?c ?d) (record 'q (list (*->preserve ?a) (*->preserve ?b) (*->preserve ?c) (*->preserve ?d)))))))) (define (parse-ImmediateQuaternion input) (match input ((and dest (record 'q (list (app parse-DoubleValue (and ?a (not (== eof)))) (app parse-DoubleValue (and ?b (not (== eof)))) (app parse-DoubleValue (and ?c (not (== eof)))) (app parse-DoubleValue (and ?d (not (== eof))))))) (ImmediateQuaternion ?a ?b ?c ?d)) (_ eof))) (define parse-ImmediateQuaternion! (parse-success-or-error 'parse-ImmediateQuaternion parse-ImmediateQuaternion)) (struct ImmediateVector2 (x y) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((ImmediateVector2 ?x ?y) (record 'v (list (*->preserve ?x) (*->preserve ?y)))))))) (define (parse-ImmediateVector2 input) (match input ((and dest (record 'v (list (app parse-DoubleValue (and ?x (not (== eof)))) (app parse-DoubleValue (and ?y (not (== eof))))))) (ImmediateVector2 ?x ?y)) (_ eof))) (define parse-ImmediateVector2! (parse-success-or-error 'parse-ImmediateVector2 parse-ImmediateVector2)) (struct ImmediateVector3 (x y z) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((ImmediateVector3 ?x ?y ?z) (record 'v (list (*->preserve ?x) (*->preserve ?y) (*->preserve ?z)))))))) (define (parse-ImmediateVector3 input) (match input ((and dest (record 'v (list (app parse-DoubleValue (and ?x (not (== eof)))) (app parse-DoubleValue (and ?y (not (== eof)))) (app parse-DoubleValue (and ?z (not (== eof))))))) (ImmediateVector3 ?x ?y ?z)) (_ eof))) (define parse-ImmediateVector3! (parse-success-or-error 'parse-ImmediateVector3 parse-ImmediateVector3)) (struct Light (v) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Light ?v) (record 'hemispheric-light (list (*->preserve ?v)))))))) (define (parse-Light input) (match input ((and dest (record 'hemispheric-light (list (app parse-Vector3 (and ?v (not (== eof))))))) (Light ?v)) (_ eof))) (define parse-Light! (parse-success-or-error 'parse-Light parse-Light)) (struct LiteralVector3 (x y z) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((LiteralVector3 ?x ?y ?z) (record 'v (list (exact->inexact (*->preserve ?x)) (exact->inexact (*->preserve ?y)) (exact->inexact (*->preserve ?z))))))))) (define (parse-LiteralVector3 input) (match input ((and dest (record 'v (list (and ?x (? flonum?)) (and ?y (? flonum?)) (and ?z (? flonum?))))) (LiteralVector3 ?x ?y ?z)) (_ eof))) (define parse-LiteralVector3! (parse-success-or-error 'parse-LiteralVector3 parse-LiteralVector3)) (define (Mesh? p) (or (Mesh-Sphere? p) (Mesh-Box? p) (Mesh-Ground? p) (Mesh-Plane? p) (Mesh-External? p))) (struct Mesh-Sphere (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Mesh-Sphere src) (*->preserve src)))))) (struct Mesh-Box (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Mesh-Box src) (*->preserve src)))))) (struct Mesh-Ground (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Mesh-Ground src) (*->preserve src)))))) (struct Mesh-Plane (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Mesh-Plane src) (*->preserve src)))))) (struct Mesh-External (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Mesh-External src) (*->preserve src)))))) (define (parse-Mesh input) (match input ((app parse-Sphere (and dest (not (== eof)))) (Mesh-Sphere dest)) ((app parse-Box (and dest (not (== eof)))) (Mesh-Box dest)) ((app parse-Ground (and dest (not (== eof)))) (Mesh-Ground dest)) ((app parse-Plane (and dest (not (== eof)))) (Mesh-Plane dest)) ((app parse-External (and dest (not (== eof)))) (Mesh-External dest)) (_ eof))) (define parse-Mesh! (parse-success-or-error 'parse-Mesh parse-Mesh)) (struct Move (v shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Move ?v ?shape) (record 'move (list (*->preserve ?v) (*->preserve ?shape)))))))) (define (parse-Move input) (match input ((and dest (record 'move (list (app parse-Vector3 (and ?v (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Move ?v ?shape)) (_ eof))) (define parse-Move! (parse-success-or-error 'parse-Move parse-Move)) (struct Name (base shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Name ?base ?shape) (record 'name (list (*->preserve ?base) (*->preserve ?shape)))))))) (define (parse-Name input) (match input ((and dest (record 'name (list (and ?base (? string?)) (app parse-Shape (and ?shape (not (== eof))))))) (Name ?base ?shape)) (_ eof))) (define parse-Name! (parse-success-or-error 'parse-Name parse-Name)) (struct Nonphysical (shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Nonphysical ?shape) (record 'nonphysical (list (*->preserve ?shape)))))))) (define (parse-Nonphysical input) (match input ((and dest (record 'nonphysical (list (app parse-Shape (and ?shape (not (== eof))))))) (Nonphysical ?shape)) (_ eof))) (define parse-Nonphysical! (parse-success-or-error 'parse-Nonphysical parse-Nonphysical)) (struct Plane () #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Plane) (record 'plane (list))))))) (define (parse-Plane input) (match input ((and dest (record 'plane (list))) (Plane)) (_ eof))) (define parse-Plane! (parse-success-or-error 'parse-Plane parse-Plane)) (define (Quaternion? p) (or (Quaternion-immediate? p) (Quaternion-reference? p))) (struct Quaternion-immediate (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Quaternion-immediate src) (*->preserve src)))))) (struct Quaternion-reference (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Quaternion-reference src) (*->preserve src)))))) (define (parse-Quaternion input) (match input ((app parse-ImmediateQuaternion (and dest (not (== eof)))) (Quaternion-immediate dest)) ((and dest (? symbol?)) (Quaternion-reference dest)) (_ eof))) (define parse-Quaternion! (parse-success-or-error 'parse-Quaternion parse-Quaternion)) (define (Rotate? p) (or (Rotate-euler? p) (Rotate-quaternion? p))) (struct Rotate-euler (v shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Rotate-euler ?v ?shape) (record 'rotate (list (*->preserve ?v) (*->preserve ?shape)))))))) (struct Rotate-quaternion (q shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Rotate-quaternion ?q ?shape) (record 'rotate (list (*->preserve ?q) (*->preserve ?shape)))))))) (define (parse-Rotate input) (match input ((and dest (record 'rotate (list (app parse-Vector3 (and ?v (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Rotate-euler ?v ?shape)) ((and dest (record 'rotate (list (app parse-Quaternion (and ?q (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Rotate-quaternion ?q ?shape)) (_ eof))) (define parse-Rotate! (parse-success-or-error 'parse-Rotate parse-Rotate)) (struct Scale (v shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Scale ?v ?shape) (record 'scale (list (*->preserve ?v) (*->preserve ?shape)))))))) (define (parse-Scale input) (match input ((and dest (record 'scale (list (app parse-Vector3 (and ?v (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Scale ?v ?shape)) (_ eof))) (define parse-Scale! (parse-success-or-error 'parse-Scale parse-Scale)) (define (Shape? p) (or (Shape-Mesh? p) (Shape-Light? p) (Shape-Scale? p) (Shape-Move? p) (Shape-Rotate? p) (Shape-many? p) (Shape-Texture? p) (Shape-Color? p) (Shape-Sound? p) (Shape-Name? p) (Shape-Floor? p) (Shape-Nonphysical? p) (Shape-Touchable? p) (Shape-CSG? p) (Shape-Skybox? p))) (struct Shape-Mesh (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Mesh src) (*->preserve src)))))) (struct Shape-Light (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Light src) (*->preserve src)))))) (struct Shape-Scale (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Scale src) (*->preserve src)))))) (struct Shape-Move (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Move src) (*->preserve src)))))) (struct Shape-Rotate (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Rotate src) (*->preserve src)))))) (struct Shape-many (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-many src) (for/list ((item (in-list src))) (*->preserve item))))))) (struct Shape-Texture (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Texture src) (*->preserve src)))))) (struct Shape-Color (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Color src) (*->preserve src)))))) (struct Shape-Sound (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Sound src) (*->preserve src)))))) (struct Shape-Name (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Name src) (*->preserve src)))))) (struct Shape-Floor (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Floor src) (*->preserve src)))))) (struct Shape-Nonphysical (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Nonphysical src) (*->preserve src)))))) (struct Shape-Touchable (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Touchable src) (*->preserve src)))))) (struct Shape-CSG (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-CSG src) (*->preserve src)))))) (struct Shape-Skybox (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Shape-Skybox src) (*->preserve src)))))) (define (parse-Shape input) (match input ((app parse-Mesh (and dest (not (== eof)))) (Shape-Mesh dest)) ((app parse-Light (and dest (not (== eof)))) (Shape-Light dest)) ((app parse-Scale (and dest (not (== eof)))) (Shape-Scale dest)) ((app parse-Move (and dest (not (== eof)))) (Shape-Move dest)) ((app parse-Rotate (and dest (not (== eof)))) (Shape-Rotate dest)) ((list (app parse-Shape (and dest (not (== eof)))) ...) (Shape-many dest)) ((app parse-Texture (and dest (not (== eof)))) (Shape-Texture dest)) ((app parse-Color (and dest (not (== eof)))) (Shape-Color dest)) ((app parse-Sound (and dest (not (== eof)))) (Shape-Sound dest)) ((app parse-Name (and dest (not (== eof)))) (Shape-Name dest)) ((app parse-Floor (and dest (not (== eof)))) (Shape-Floor dest)) ((app parse-Nonphysical (and dest (not (== eof)))) (Shape-Nonphysical dest)) ((app parse-Touchable (and dest (not (== eof)))) (Shape-Touchable dest)) ((app parse-CSG (and dest (not (== eof)))) (Shape-CSG dest)) ((app parse-Skybox (and dest (not (== eof)))) (Shape-Skybox dest)) (_ eof))) (define parse-Shape! (parse-success-or-error 'parse-Shape parse-Shape)) (struct Skybox (path) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Skybox ?path) (record 'skybox (list (*->preserve ?path)))))))) (define (parse-Skybox input) (match input ((and dest (record 'skybox (list (and ?path (? string?))))) (Skybox ?path)) (_ eof))) (define parse-Skybox! (parse-success-or-error 'parse-Skybox parse-Skybox)) (struct Sound (spec shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Sound ?spec ?shape) (record 'sound (list (*->preserve ?spec) (*->preserve ?shape)))))))) (define (parse-Sound input) (match input ((and dest (record 'sound (list (app parse-SoundSpec (and ?spec (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Sound ?spec ?shape)) (_ eof))) (define parse-Sound! (parse-success-or-error 'parse-Sound parse-Sound)) (define (SoundSpec? p) (or (SoundSpec-stream? p) (SoundSpec-loop? p))) (struct SoundSpec-stream (url) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((SoundSpec-stream ?url) (record 'stream (list (*->preserve ?url)))))))) (struct SoundSpec-loop (url) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((SoundSpec-loop ?url) (record 'loop (list (*->preserve ?url)))))))) (define (parse-SoundSpec input) (match input ((and dest (record 'stream (list (and ?url (? string?))))) (SoundSpec-stream ?url)) ((and dest (record 'loop (list (and ?url (? string?))))) (SoundSpec-loop ?url)) (_ eof))) (define parse-SoundSpec! (parse-success-or-error 'parse-SoundSpec parse-SoundSpec)) (struct Sphere () #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Sphere) (record 'sphere (list))))))) (define (parse-Sphere input) (match input ((and dest (record 'sphere (list))) (Sphere)) (_ eof))) (define parse-Sphere! (parse-success-or-error 'parse-Sphere parse-Sphere)) (struct Sprite (name formals shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Sprite ?name ?formals ?shape) (record 'sprite (list (*->preserve ?name) (for/list ((item (in-list ?formals))) (*->preserve item)) (*->preserve ?shape)))))))) (define (parse-Sprite input) (match input ((and dest (record 'sprite (list (and ?name (? string?)) (list (and ?formals (? symbol?)) ...) (app parse-Shape (and ?shape (not (== eof))))))) (Sprite ?name ?formals ?shape)) (_ eof))) (define parse-Sprite! (parse-success-or-error 'parse-Sprite parse-Sprite)) (struct Texture (spec shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Texture ?spec ?shape) (record 'texture (list (*->preserve ?spec) (*->preserve ?shape)))))))) (define (parse-Texture input) (match input ((and dest (record 'texture (list (app parse-TextureSpec (and ?spec (not (== eof)))) (app parse-Shape (and ?shape (not (== eof))))))) (Texture ?spec ?shape)) (_ eof))) (define parse-Texture! (parse-success-or-error 'parse-Texture parse-Texture)) (define (TextureSpec? p) (or (TextureSpec-simple? p) (TextureSpec-uv? p) (TextureSpec-uvAlpha? p))) (struct TextureSpec-simple (path) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((TextureSpec-simple ?path) (list (*->preserve ?path))))))) (struct TextureSpec-uv (path scale offset) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((TextureSpec-uv ?path ?scale ?offset) (list (*->preserve ?path) (*->preserve ?scale) (*->preserve ?offset))))))) (struct TextureSpec-uvAlpha (path scale offset alpha) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((TextureSpec-uvAlpha ?path ?scale ?offset ?alpha) (list (*->preserve ?path) (*->preserve ?scale) (*->preserve ?offset) (*->preserve ?alpha))))))) (define (parse-TextureSpec input) (match input ((and dest (list (and ?path (? string?)))) (TextureSpec-simple ?path)) ((and dest (list (and ?path (? string?)) (app parse-Vector2 (and ?scale (not (== eof)))) (app parse-Vector2 (and ?offset (not (== eof)))))) (TextureSpec-uv ?path ?scale ?offset)) ((and dest (list (and ?path (? string?)) (app parse-Vector2 (and ?scale (not (== eof)))) (app parse-Vector2 (and ?offset (not (== eof)))) (app parse-DoubleValue (and ?alpha (not (== eof)))))) (TextureSpec-uvAlpha ?path ?scale ?offset ?alpha)) (_ eof))) (define parse-TextureSpec! (parse-success-or-error 'parse-TextureSpec parse-TextureSpec)) (struct Touchable (shape) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Touchable ?shape) (record 'touchable (list (*->preserve ?shape)))))))) (define (parse-Touchable input) (match input ((and dest (record 'touchable (list (app parse-Shape (and ?shape (not (== eof))))))) (Touchable ?shape)) (_ eof))) (define parse-Touchable! (parse-success-or-error 'parse-Touchable parse-Touchable)) (struct Variable (spriteName variable value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Variable ?spriteName ?variable ?value) (record 'variable (list (*->preserve ?spriteName) (*->preserve ?variable) (*->preserve ?value)))))))) (define (parse-Variable input) (match input ((and dest (record 'variable (list (and ?spriteName (? string?)) (and ?variable (? symbol?)) ?value))) (Variable ?spriteName ?variable ?value)) (_ eof))) (define parse-Variable! (parse-success-or-error 'parse-Variable parse-Variable)) (define (Vector2? p) (or (Vector2-immediate? p) (Vector2-reference? p))) (struct Vector2-immediate (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Vector2-immediate src) (*->preserve src)))))) (struct Vector2-reference (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Vector2-reference src) (*->preserve src)))))) (define (parse-Vector2 input) (match input ((app parse-ImmediateVector2 (and dest (not (== eof)))) (Vector2-immediate dest)) ((and dest (? symbol?)) (Vector2-reference dest)) (_ eof))) (define parse-Vector2! (parse-success-or-error 'parse-Vector2 parse-Vector2)) (define (Vector3? p) (or (Vector3-immediate? p) (Vector3-reference? p))) (struct Vector3-immediate (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Vector3-immediate src) (*->preserve src)))))) (struct Vector3-reference (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Vector3-reference src) (*->preserve src)))))) (define (parse-Vector3 input) (match input ((app parse-ImmediateVector3 (and dest (not (== eof)))) (Vector3-immediate dest)) ((and dest (? symbol?)) (Vector3-reference dest)) (_ eof))) (define parse-Vector3! (parse-success-or-error 'parse-Vector3 parse-Vector3)))