From db4e12948a1751fbcd20cb76ce28973191b9eb5a Mon Sep 17 00:00:00 2001
From: Frank Duncan <frank@kank.net>
Date: Sat, 28 May 2016 14:24:49 -0500
Subject: [PATCH] Shapes - dynamic coloring for only parts of shapes

---
 src/main/interface.lisp | 42 +++++++++++++++++++++--------------------
 src/test/viewtests.lisp |  6 ++++++
 2 files changed, 28 insertions(+), 20 deletions(-)

diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index 0f6fb59..931cede 100644
--- a/src/main/interface.lisp
+++ b/src/main/interface.lisp
@@ -46,7 +46,7 @@
   ((parse-points (sections)
     (when sections
      (cons
-      (list (parse-integer (car sections)) (parse-integer (cadr sections)))
+      (list (- 300 (parse-integer (car sections))) (parse-integer (cadr sections)))
       (parse-points (cddr sections))))))
   (list
    :polygon
@@ -131,30 +131,30 @@
       (t (triangulate (append (cdr points) (list (car points))) ccw))))))))
 
 (defun element->gl-list (shape)
- (case (car shape)
-  (:polygon
-   (progn
-    (gl:begin :triangles)
+ (progn
+  (when (not (getf (cdr shape) :marked))
+   (gl:push-attrib :all-attrib-bits)
+   (gl:color
+    (/ (ash (ldb (byte 24 0) (getf (cdr shape) :color)) -16) 255)
+    (/ (ash (ldb (byte 16 0) (getf (cdr shape) :color)) -8) 255)
+    (/ (ldb (byte 8 0) (getf (cdr shape) :color)) 255)))
+  (gl:begin :triangles)
+  (case (car shape)
+   (:polygon
     (mapcar
      (lambda (point) (gl:vertex (car point) (cadr point) 0))
-     (apply #'append (triangulate (getf (cdr shape) :coords))))
-    (gl:end)))
-  (:rectangle
-   (progn
-    (gl:begin :triangles)
+     (apply #'append (triangulate (getf (cdr shape) :coords)))))
+   (:rectangle
     (mapcar
      (lambda (point) (gl:vertex (car point) (cadr point) 0))
      (apply #'append
       (triangulate
        (list
-        (list (getf (cdr shape) :left) (getf (cdr shape) :top))
-        (list (getf (cdr shape) :right) (getf (cdr shape) :top))
-        (list (getf (cdr shape) :right) (getf (cdr shape) :bottom))
-        (list (getf (cdr shape) :left) (getf (cdr shape) :bottom))))))
-    (gl:end)))
-  (:circle
-   (progn
-    (gl:begin :triangles)
+        (list (- 300 (getf (cdr shape) :left)) (getf (cdr shape) :top))
+        (list (- 300 (getf (cdr shape) :right)) (getf (cdr shape) :top))
+        (list (- 300 (getf (cdr shape) :right)) (getf (cdr shape) :bottom))
+        (list (- 300 (getf (cdr shape) :left)) (getf (cdr shape) :bottom)))))))
+   (:circle
     (mapcar
      (lambda (point) (gl:vertex (car point) (cadr point) 0))
      (apply #'append
@@ -169,8 +169,10 @@
         :for n := 0 :then x
         :for x := r :then (- (* c x) (* s y))
         :for y := 0 :then (+ (* s n) (* c y))
-        :collect (list (+ (+ x left) r) (+ (+ y top) r))))))
-    (gl:end)))))
+        :collect (list (- 300 (+ (+ x left) r)) (+ (+ y top) r))))))))
+  (gl:end)
+  (when (not (getf (cdr shape) :marked))
+   (gl:pop-attrib))))
 
 (defun parse-shapes (str)
  (let
diff --git a/src/test/viewtests.lisp b/src/test/viewtests.lisp
index 3455b28..2f5eabb 100644
--- a/src/test/viewtests.lisp
+++ b/src/test/viewtests.lisp
@@ -26,3 +26,9 @@
 
 (defviewtest "size" "crt 10 ask turtles [ fd 2 set size 3 ] "
  '("E71BD61118B3B735DE4ADD2EF7897465084DD372" "6A4D9F29F10EAFCF5AB6156CCB35680EF4E41677"))
+
+(defviewtest "sheep" "set-default-shape turtles \"sheep\" crt 10 ask turtles [ fd 2 set size 3 ] "
+ '("6D86C178B84836F064C0084E9A0BDE3BACCA28A2" "33DD3FA4103731FA6A2EA675104CEEFCE16ADF54"))
+
+(defviewtest "wolves" "set-default-shape turtles \"wolf\" crt 10 ask turtles [ fd 2 set size 3 ] "
+ '("D455A70DBAD3195F23328B58B4D123934FEA0DC0" "4C108D1B2ED37A9C2152BE816E2B8947861333DE"))
-- 
2.25.1