154 lines
4.4 KiB
Racket
154 lines
4.4 KiB
Racket
(module scene racket/base
|
|
(provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
|
|
(rename-out
|
|
(:decode-embedded decode-embedded:scene)
|
|
(:encode-embedded encode-embedded:scene)))
|
|
(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 gatekeeper: syndicate/schemas/gatekeeper))
|
|
(require (prefix-in shapes: "shapes.rkt"))
|
|
(define :decode-embedded values)
|
|
(define :encode-embedded values)
|
|
(struct
|
|
AmbientSound
|
|
(name spec)
|
|
#:transparent
|
|
#:methods
|
|
gen:preservable
|
|
((define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match
|
|
preservable
|
|
((AmbientSound ?name ?spec)
|
|
(record
|
|
'ambient-sound
|
|
(list (*->preserve ?name) (*->preserve ?spec))))))))
|
|
(define (parse-AmbientSound input)
|
|
(match
|
|
input
|
|
((and dest
|
|
(record
|
|
'ambient-sound
|
|
(list
|
|
(and ?name (? string?))
|
|
(app shapes:parse-SoundSpec (and ?spec (not (== eof)))))))
|
|
(AmbientSound ?name ?spec))
|
|
(_ eof)))
|
|
(define parse-AmbientSound!
|
|
(parse-success-or-error 'parse-AmbientSound parse-AmbientSound))
|
|
(struct
|
|
Gravity
|
|
(direction)
|
|
#:transparent
|
|
#:methods
|
|
gen:preservable
|
|
((define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match
|
|
preservable
|
|
((Gravity ?direction)
|
|
(record 'gravity (list (*->preserve ?direction))))))))
|
|
(define (parse-Gravity input)
|
|
(match
|
|
input
|
|
((and dest
|
|
(record
|
|
'gravity
|
|
(list
|
|
(app
|
|
shapes:parse-LiteralVector3
|
|
(and ?direction (not (== eof)))))))
|
|
(Gravity ?direction))
|
|
(_ eof)))
|
|
(define parse-Gravity! (parse-success-or-error 'parse-Gravity parse-Gravity))
|
|
(struct
|
|
Portal
|
|
(name destination position)
|
|
#:transparent
|
|
#:methods
|
|
gen:preservable
|
|
((define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match
|
|
preservable
|
|
((Portal ?name ?destination ?position)
|
|
(record
|
|
'portal
|
|
(list
|
|
(*->preserve ?name)
|
|
(*->preserve ?destination)
|
|
(*->preserve ?position))))))))
|
|
(define (parse-Portal input)
|
|
(match
|
|
input
|
|
((and dest
|
|
(record
|
|
'portal
|
|
(list
|
|
(and ?name (? string?))
|
|
(app parse-PortalDestination (and ?destination (not (== eof))))
|
|
(app
|
|
shapes:parse-LiteralVector3
|
|
(and ?position (not (== eof)))))))
|
|
(Portal ?name ?destination ?position))
|
|
(_ eof)))
|
|
(define parse-Portal! (parse-success-or-error 'parse-Portal parse-Portal))
|
|
(define (PortalDestination? p)
|
|
(or (PortalDestination-local? p) (PortalDestination-remote? p)))
|
|
(struct
|
|
PortalDestination-local
|
|
(value)
|
|
#:transparent
|
|
#:methods
|
|
gen:preservable
|
|
((define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match preservable ((PortalDestination-local src) (embedded src))))))
|
|
(struct
|
|
PortalDestination-remote
|
|
(value)
|
|
#:transparent
|
|
#:methods
|
|
gen:preservable
|
|
((define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match preservable ((PortalDestination-remote src) (*->preserve src))))))
|
|
(define (parse-PortalDestination input)
|
|
(match
|
|
input
|
|
((embedded dest) (PortalDestination-local dest))
|
|
((app gatekeeper:parse-Route (and dest (not (== eof))))
|
|
(PortalDestination-remote dest))
|
|
(_ eof)))
|
|
(define parse-PortalDestination!
|
|
(parse-success-or-error 'parse-PortalDestination parse-PortalDestination))
|
|
(struct
|
|
Touch
|
|
(subject object)
|
|
#:transparent
|
|
#:methods
|
|
gen:preservable
|
|
((define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match
|
|
preservable
|
|
((Touch ?subject ?object)
|
|
(record
|
|
'touch
|
|
(list (*->preserve ?subject) (*->preserve ?object))))))))
|
|
(define (parse-Touch input)
|
|
(match
|
|
input
|
|
((and dest
|
|
(record
|
|
'touch
|
|
(list (and ?subject (? string?)) (and ?object (? string?)))))
|
|
(Touch ?subject ?object))
|
|
(_ eof)))
|
|
(define parse-Touch! (parse-success-or-error 'parse-Touch parse-Touch)))
|