summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--catbird.scm5
-rw-r--r--catbird/camera.scm16
-rw-r--r--catbird/kernel.scm26
-rw-r--r--catbird/mixins.scm8
-rw-r--r--catbird/node-2d.scm1
-rw-r--r--catbird/overlay.scm5
-rw-r--r--catbird/region.scm74
-rw-r--r--catbird/scene.scm4
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)