115 lines
4.1 KiB
Scheme
115 lines
4.1 KiB
Scheme
(module (engine components core) ()
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken module)
|
|
(engine core)
|
|
(engine guards)
|
|
(engine math)
|
|
(srfi 1)
|
|
(srfi 99))
|
|
|
|
;; Screen transform record and exports
|
|
(export make-screen-transform screen-transform?)
|
|
|
|
;; The screen transform is for representing transformations in screen-space, that is
|
|
;; in UI and not in 2D/3D
|
|
(define-record-type <screen-transform>
|
|
(int:make-screen-transform position pivot rotation scale anchor parent)
|
|
screen-transform?
|
|
(position screen-transform-position int:set-screen-transform-position!)
|
|
(pivot screen-transform-pivot int:set-screen-transform-pivot!)
|
|
(rotation screen-transform-rotation int:set-screen-transform-rotation!)
|
|
(scale screen-transform-scale int:set-screen-transform-scale!)
|
|
(anchor screen-transform-anchor int:set-screen-transform-anchor!)
|
|
(parent screen-transform-parent int:set-screen-transform-parent!))
|
|
|
|
;; Type safe constructor
|
|
(define (make-screen-transform position pivot rotation scale anchor parent)
|
|
(assert (vec2? position))
|
|
(assert (real? rotation))
|
|
(assert (vec2? scale))
|
|
(assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right
|
|
center-left center center-right
|
|
bottom-left bottom-middle bottom-right))))
|
|
(assert (or (null? parent) (screen-transform? parent)))
|
|
(int:make-screen-transform position pivot rotation scale anchor parent))
|
|
|
|
;; Generic accessors and mutators for position, rotation, scale, anchor, and parent
|
|
;; This allows us to abstract across different transform types - (position) will work for
|
|
;; screen-transform and 2D-transform, with type checking
|
|
(export global-position position set-position! rotation
|
|
set-rotation! scale set-scale! anchor set-anchor!
|
|
parent set-parent!)
|
|
|
|
(define (global-position component)
|
|
(assert (record? component))
|
|
(if (null? (parent component))
|
|
((rtd-accessor (record-rtd component) 'position) component)
|
|
(v+ ((rtd-accessor (record-rtd component) 'position) component)
|
|
(global-position (parent component)))))
|
|
|
|
(define (position component)
|
|
(assert (record? component))
|
|
((rtd-accessor (record-rtd component) 'position) component))
|
|
|
|
(define (set-position! component position)
|
|
(assert (record? component))
|
|
(cond
|
|
((screen-transform? component) (assert (vec2? position))))
|
|
((rtd-mutator (record-rtd component) 'position) component position))
|
|
|
|
(define (pivot component)
|
|
(assert (record? component))
|
|
((rtd-accessor (record-rtd component) 'pivot) component))
|
|
|
|
(define (set-pivot! component pivot)
|
|
(assert (record? component))
|
|
(cond
|
|
((screen-transform? component) (assert (vec2? pivot))))
|
|
((rtd-mutator (record-rtd component) 'pivot) component pivot))
|
|
|
|
(define (rotation component)
|
|
(assert (record? component))
|
|
((rtd-accessor (record-rtd component) 'rotation) component))
|
|
|
|
(define (set-rotation! component rotation)
|
|
(assert (record? component))
|
|
(cond
|
|
((screen-transform? component) (assert (real? rotation))))
|
|
((rtd-mutator (record-rtd component) 'rotation) component rotation))
|
|
|
|
(define (scale component)
|
|
(assert (record? component))
|
|
((rtd-accessor (record-rtd component) 'scale) component))
|
|
|
|
(define (set-scale! component scale)
|
|
(assert (record? component))
|
|
(cond
|
|
((screen-transform? component) (assert (vec2? scale))))
|
|
((rtd-mutator (record-rtd component) 'scale) component scale))
|
|
|
|
(define (anchor component)
|
|
(assert (record? component))
|
|
((rtd-accessor (record-rtd component) 'anchor) component))
|
|
|
|
(define (set-anchor! component anchor)
|
|
(assert (record? component))
|
|
(cond
|
|
((screen-transform? component)
|
|
(assert (and (symbol? anchor)
|
|
(member anchor '(top-left top-middle top-right
|
|
center-left center center-right
|
|
bottom-left bottom-middle bottom-right))))))
|
|
((rtd-mutator (record-rtd component) 'anchor) component anchor))
|
|
|
|
(define (parent component)
|
|
(assert (record? component))
|
|
((rtd-accessor (record-rtd component) 'parent) component))
|
|
|
|
(define (set-parent! component parent)
|
|
(assert (record? component))
|
|
(cond
|
|
((screen-transform? component)
|
|
(assert (symbol? anchor))))
|
|
((rtd-mutator (record-rtd component) 'parent) component parent))
|
|
)
|