From 2bdb665cffff93721bbd38b3809a7c420dff2f1c Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sun, 12 Apr 2020 21:59:35 -0400
Subject: Day 3 progress.

---
 lisparuga/node-2d.scm | 26 +++++++++++++++++++++++++-
 1 file changed, 25 insertions(+), 1 deletion(-)

(limited to 'lisparuga/node-2d.scm')

diff --git a/lisparuga/node-2d.scm b/lisparuga/node-2d.scm
index 0baef54..b6753ef 100644
--- a/lisparuga/node-2d.scm
+++ b/lisparuga/node-2d.scm
@@ -605,7 +605,31 @@
 
 (define-class <label> (<node-2d>)
   (font #:accessor font #:init-keyword #:font #:init-thunk default-font)
-  (text #:accessor text #:init-form "" #:init-keyword #:text))
+  (text #:accessor text #:init-form "" #:init-keyword #:text)
+  (align #:accessor align #:init-value 'left #:init-keyword #:align)
+  (vertical-align #:accessor vertical-align #:init-value 'bottom
+                  #:init-keyword #:vertical-align))
+
+(define-method (initialize (label <label>) initargs)
+  (next-method)
+  (realign label))
+
+(define-method ((setter text) (label <label>) s)
+  (slot-set! label 'text s)
+  (realign label))
+
+(define-method (realign (label <label>))
+  (let ((font (asset-ref (font label))))
+    (set-vec2! (origin label)
+               (match (align label)
+                 ('left 0.0)
+                 ('right (font-line-width font (text label)))
+                 ('center (/ (font-line-width font (text label)) 2.0)))
+               (match (vertical-align label)
+                 ('bottom 0.0)
+                 ('top (font-line-height font))
+                 ('center (/ (font-line-height font) 2.0)))))
+  (dirty! label))
 
 (define-method (render (label <label>) alpha)
   (draw-text* (asset-ref (font label)) (text label) (world-matrix label)))
-- 
cgit v1.2.3