diff options
| -rw-r--r-- | catbird.scm | 5 | ||||
| -rw-r--r-- | catbird/camera.scm | 16 | ||||
| -rw-r--r-- | catbird/kernel.scm | 26 | ||||
| -rw-r--r-- | catbird/mixins.scm | 8 | ||||
| -rw-r--r-- | catbird/node-2d.scm | 1 | ||||
| -rw-r--r-- | catbird/overlay.scm | 5 | ||||
| -rw-r--r-- | catbird/region.scm | 74 | ||||
| -rw-r--r-- | catbird/scene.scm | 4 |
8 files changed, 109 insertions, 30 deletions
diff --git a/catbird.scm b/catbird.scm index cdb9e39..cdd3313 100644 --- a/catbird.scm +++ b/catbird.scm @@ -118,7 +118,10 @@ (on-controller-release kernel controller button)) #:controller-move (lambda (controller axis value) - (on-controller-move kernel controller axis value)))))) + (on-controller-move kernel controller axis value)) + #:window-resize + (lambda (width height) + (on-window-resize kernel width height)))))) (define (exit-catbird) "Stop the Catbird engine." diff --git a/catbird/camera.scm b/catbird/camera.scm index a3d8fd3..e4463be 100644 --- a/catbird/camera.scm +++ b/catbird/camera.scm @@ -45,8 +45,8 @@ #:re-export (width height)) (define-root-class <camera> () - (width #:accessor width #:init-keyword #:width) - (height #:accessor height #:init-keyword #:height) + (width #:accessor width #:init-keyword #:width #:init-value 0.0) + (height #:accessor height #:init-keyword #:height #:init-value 0.0) (projection-matrix #:getter projection-matrix #:init-thunk make-identity-matrix4) (view-matrix #:getter view-matrix #:init-thunk make-identity-matrix4)) @@ -58,6 +58,11 @@ (refresh-projection camera) (refresh-view camera)) +(define-method (resize (camera <camera>) w h) + (set! (width camera) w) + (set! (height camera) h) + (refresh-projection camera)) + (define current-camera (make-parameter #f)) @@ -70,6 +75,13 @@ (define-method (initialize (camera <camera-2d>) initargs) (next-method) + (refresh-bounding-box-size camera)) + +(define-method (resize (camera <camera-2d>) w h) + (next-method) + (refresh-bounding-box-size camera)) + +(define-method (refresh-bounding-box-size (camera <camera-2d>)) (let ((bb (view-bounding-box camera))) (set-rect-width! bb (width camera)) (set-rect-height! bb (height camera)))) diff --git a/catbird/kernel.scm b/catbird/kernel.scm index 6560d47..448b168 100644 --- a/catbird/kernel.scm +++ b/catbird/kernel.scm @@ -303,6 +303,15 @@ (controller-slot-id slot) axis value)))))) + +;;; +;;; Windows +;;; + +(define-method (on-window-resize (kernel <kernel>) width height) + (for-each (lambda (r) + (on-window-resize r width height)) + (regions kernel))) ;;; @@ -336,14 +345,23 @@ (gensym "region-")) (define* (create-region area #:key (rank 0) (name (unique-region-name))) - (let ((region (make-region area name rank))) + (let* ((window (current-window)) + (w (window-width window)) + (h (window-height window))) + (when (or (< (rect-left area) 0.0) + (< (rect-bottom area) 0.0) + (> (rect-right area) w) + (> (rect-top area) h)) + (raise-exception + (make-exception-with-message "region area exceeds window area")))) + (let ((region (make <region> #:area area #:name name #:rank rank))) (add-region (current-kernel) region) region)) (define* (create-full-region #:key (rank 0) (name (unique-region-name))) - (let ((w (window-width (current-window))) - (h (window-height (current-window)))) - (create-region (make-rect 0.0 0.0 w h) #:rank rank #:name name))) + (let ((region (make <full-region> #:name name #:rank rank))) + (add-region (current-kernel) region) + region)) (define (kill-region region) (let ((k (current-kernel))) diff --git a/catbird/mixins.scm b/catbird/mixins.scm index 6e1cd4a..520e12f 100644 --- a/catbird/mixins.scm +++ b/catbird/mixins.scm @@ -75,6 +75,8 @@ height depth + resize + <listener> ignore listen @@ -245,6 +247,12 @@ (define-accessor height) (define-accessor depth) + +;;; +;;; Resizable +;;; + +(define-generic resize) ;;; diff --git a/catbird/node-2d.scm b/catbird/node-2d.scm index 44a31f9..12014f1 100644 --- a/catbird/node-2d.scm +++ b/catbird/node-2d.scm @@ -88,7 +88,6 @@ place-right position-x position-y - resize rotate-by rotate-to rotation diff --git a/catbird/overlay.scm b/catbird/overlay.scm index 2833e87..1cdabd4 100644 --- a/catbird/overlay.scm +++ b/catbird/overlay.scm @@ -70,6 +70,11 @@ (lambda (exception stack) (handle-error overlay exception stack)))) +(define-method (on-region-resize (overlay <overlay>)) + (let ((repl (child-ref overlay 'repl)) + (region (car (regions overlay)))) + (when repl (resize-repl repl (width region) (height region))))) + (define-method (notify (scene <overlay>) message) (run-script scene (let* ((padding 8.0) diff --git a/catbird/region.scm b/catbird/region.scm index 7e9f9df..a117a2e 100644 --- a/catbird/region.scm +++ b/catbird/region.scm @@ -36,31 +36,32 @@ #:use-module (ice-9 exceptions) #:use-module (oop goops) #:export (<region> - make-region + <full-region> area area-x area-y area-width area-height camera + set-camera freeze frozen? scene replace-scene push-scene pop-scene - unfreeze) + unfreeze + on-window-resize) #:re-export (name rank render update)) (define-root-class <region> (<renderable> <updatable> <nameable> <rankable>) - (area #:accessor area #:init-keyword #:area) + (area #:getter area #:init-keyword #:area) (camera #:accessor camera #:init-keyword #:camera #:init-value #f) (scene-state #:accessor scene-state #:init-thunk make-pushdown-state) (framebuffer #:accessor framebuffer) - (framebuffer-rect #:accessor framebuffer-rect) ;; Regions can be frozen for debugging purposes, so that the scene ;; they contain isn't updated or rendered. (frozen? #:accessor frozen? #:init-value #f)) @@ -88,26 +89,37 @@ (define-method (initialize (region <region>) args) (next-method) + (refresh-framebuffer region) + (refresh-camera region)) + +(define-method (set-camera (region <region>) new-camera) + (set! (camera region) new-camera) + (refresh-camera region)) + +(define-method (refresh-camera (region <region>)) + (let ((c (camera region))) + (when c (resize c (width region) (height region))))) + +(define-method (refresh-framebuffer (region <region>)) (let ((r (area region))) (set! (framebuffer region) (make-framebuffer (float->int (rect-width r)) - (float->int (rect-height r)))) - (set! (framebuffer-rect region) - (make-rect 0.0 0.0 - (float->int (rect-width r)) - (float->int (rect-height r)))))) - -(define (make-region area name rank) - (let* ((window (current-window)) - (w (window-width window)) - (h (window-height window))) - (when (or (< (rect-left area) 0.0) - (< (rect-bottom area) 0.0) - (> (rect-right area) w) - (> (rect-top area) h)) - (raise-exception - (make-exception-with-message "region area exceeds window area"))) - (make <region> #:area area #:name name #:rank rank))) + (float->int (rect-height r)))))) + +(define-method (resize (region <region>) width height) + (let ((r (area region)) + (c (camera region)) + (s (scene region))) + (set-rect-width! r width) + (set-rect-height! r height) + (refresh-framebuffer region) + (refresh-camera region) + (when s (on-region-resize s)))) + +(define-method (move (region <region>) x y) + (let ((r (area region))) + (set-rect-x! r x) + (set-rect-y! r y ))) (define-method (freeze (region <region>)) (set! (frozen? region) #t)) @@ -161,5 +173,23 @@ (with-projection (projection-matrix (camera region)) (render/around s alpha)))) (draw-sprite* (framebuffer-texture fb) - (framebuffer-rect region) + (area region) %identity-matrix))))) + +(define-method (on-window-resize (region <region>) width height) + #t) + + +;;; +;;; Full region +;;; + +(define (current-window-area) + (let ((window (current-window))) + (make-rect 0.0 0.0 (window-width window) (window-height window)))) + +(define-class <full-region> (<region>) + (area #:getter area #:init-thunk current-window-area)) + +(define-method (on-window-resize (region <full-region>) width height) + (resize region width height)) diff --git a/catbird/scene.scm b/catbird/scene.scm index a1bcffa..69a0b1d 100644 --- a/catbird/scene.scm +++ b/catbird/scene.scm @@ -41,6 +41,7 @@ regions major-mode minor-modes + on-region-resize replace-major-mode push-major-mode pop-major-mode @@ -194,6 +195,9 @@ (lambda (mode) (on-controller-move mode controller-id axis value)))) +(define-method (on-region-resize (scene <scene>)) + #t) + (define-method (update (scene <scene>) dt) (with-scene scene (update (major-mode scene) dt) |