summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson@member.fsf.org>2014-03-31 16:48:08 -0400
committerDavid Thompson <dthompson@member.fsf.org>2014-03-31 16:48:08 -0400
commitba42e06196fb580144189447ada7b4a31252dca8 (patch)
treee934ec05faa48c8fadfbbddb904dd3ee3d477933
parent686d5fdf3d9ab2763839e47a1fec5aa7e70170f6 (diff)
Add more texture anchor types.
* 2d/texture.scm (anchor-texture): Add top-right, bottom-left, bottom-right, top-center, and bottom-center anchor types. * 2d/font.scm (make-label): Don't call anchor-texture when there is no texture.
-rw-r--r--2d/font.scm2
-rw-r--r--2d/texture.scm32
2 files changed, 23 insertions, 11 deletions
diff --git a/2d/font.scm b/2d/font.scm
index a9e178f..0917e66 100644
--- a/2d/font.scm
+++ b/2d/font.scm
@@ -143,7 +143,7 @@ the given position. Optional arguments are COLOR with a default of
white and ANCHOR with a default of 'top-left."
(let* ((texture (render-text font text))
(vertices (and texture (make-label-vertices texture)))
- (anchor (anchor-texture texture anchor)))
+ (anchor (if texture (anchor-texture texture anchor) null-vector2)))
(%make-label font text position anchor color texture vertices)))
(define (draw-label label)
diff --git a/2d/texture.scm b/2d/texture.scm
index 1ac3f05..8dcbf95 100644
--- a/2d/texture.scm
+++ b/2d/texture.scm
@@ -158,16 +158,28 @@ that will be rendered, in pixels."
(define (anchor-texture texture anchor)
"Return a vector2 of the coordinates for the center point of a
texture."
- (cond
- ((vector2? anchor)
- anchor)
- ((eq? anchor 'top-left)
- null-vector2)
- ((eq? anchor 'center)
- (vector2 (/ (texture-width texture) 2)
- (/ (texture-height texture) 2)))
- (else
- (error "Invalid anchor type!" anchor))))
+ (let ((w (texture-width texture))
+ (h (texture-height texture)))
+ (cond
+ ((vector2? anchor)
+ anchor)
+ ((eq? anchor 'center)
+ (vector2 (/ w 2)
+ (/ h 2)))
+ ((eq? anchor 'top-left)
+ null-vector2)
+ ((eq? anchor 'top-right)
+ (vector2 w 0))
+ ((eq? anchor 'bottom-left)
+ (vector2 0 h))
+ ((eq? anchor 'bottom-right)
+ (vector2 w h))
+ ((eq? anchor 'top-center)
+ (vector2 (/ w 2) 0))
+ ((eq? anchor 'bottom-center)
+ (vector2 (/ w 2) h))
+ (else
+ (error "Invalid anchor type!" anchor)))))
;;;
;;; Texture Vertices