From ba42e06196fb580144189447ada7b4a31252dca8 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@member.fsf.org>
Date: Mon, 31 Mar 2014 16:48:08 -0400
Subject: 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.
---
 2d/font.scm    |  2 +-
 2d/texture.scm | 32 ++++++++++++++++++++++----------
 2 files changed, 23 insertions(+), 11 deletions(-)

(limited to '2d')

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
-- 
cgit v1.2.3