1248 lines
35 KiB
Racket
1248 lines
35 KiB
Racket
(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))
|
|
(require (prefix-in turtle: "turtle.rkt"))
|
|
(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)
|
|
(Mesh-turtle? 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))))))
|
|
(struct
|
|
Mesh-turtle
|
|
(value)
|
|
#:transparent
|
|
#:methods
|
|
gen:preservable
|
|
((define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match preservable ((Mesh-turtle 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))
|
|
((app turtle:parse-Shape (and dest (not (== eof)))) (Mesh-turtle 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)))
|