From 268b16dea9f447b3cf41090c44130d9b60807d7d Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 22 May 2016 14:37:07 -0500 Subject: [PATCH] Shapes - polygon, circle, rectangle --- resources/defaultshapes | 27 +++++ src/main/clnl.asd | 2 +- src/main/interface.lisp | 225 ++++++++++++++++++++++++++++++++++++---- src/main/nvm/nvm.lisp | 1 + 4 files changed, 233 insertions(+), 22 deletions(-) create mode 100644 resources/defaultshapes diff --git a/resources/defaultshapes b/resources/defaultshapes new file mode 100644 index 0000000..87b4db1 --- /dev/null +++ b/resources/defaultshapes @@ -0,0 +1,27 @@ +default +true +0 +Polygon -7500403 true true 150 5 40 250 150 205 260 250 + +sheep +false +15 +Circle -1 true true 203 65 88 +Circle -1 true true 70 65 162 +Circle -1 true true 150 105 120 +Polygon -7500403 true false 218 120 240 165 255 165 278 120 +Circle -7500403 true false 214 72 67 +Rectangle -1 true true 164 223 179 298 +Polygon -1 true true 45 285 30 285 30 240 15 195 45 210 +Circle -1 true true 3 83 150 +Rectangle -1 true true 65 221 80 296 +Polygon -1 true true 195 285 210 285 210 240 240 210 195 210 +Polygon -7500403 true false 276 85 285 105 302 99 294 83 +Polygon -7500403 true false 219 85 210 105 193 99 201 83 + +wolf +false +0 +Polygon -16777216 true false 253 133 245 131 245 133 +Polygon -7500403 true true 2 194 13 197 30 191 38 193 38 205 20 226 20 257 27 265 38 266 40 260 31 253 31 230 60 206 68 198 75 209 66 228 65 243 82 261 84 268 100 267 103 261 77 239 79 231 100 207 98 196 119 201 143 202 160 195 166 210 172 213 173 238 167 251 160 248 154 265 169 264 178 247 186 240 198 260 200 271 217 271 219 262 207 258 195 230 192 198 210 184 227 164 242 144 259 145 284 151 277 141 293 140 299 134 297 127 273 119 270 105 +Polygon -7500403 true true -1 195 14 180 36 166 40 153 53 140 82 131 134 133 159 126 188 115 227 108 236 102 238 98 268 86 269 92 281 87 269 103 269 113 diff --git a/src/main/clnl.asd b/src/main/clnl.asd index f66dbb6..17c3c3d 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -20,4 +20,4 @@ (:file "interface") (:file "cli") (:file "main")) - :depends-on #-travis(:cl-ppcre :mt19937 :cl-opengl :cl-glut :cl-charms :ieee-floats :strictmath) #+travis nil) + :depends-on #-travis(:cl-ppcre :mt19937 :cl-opengl :cl-glu :cl-glut :cl-charms :ieee-floats :strictmath) #+travis nil) diff --git a/src/main/interface.lisp b/src/main/interface.lisp index 95e2911..0f6fb59 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -1,12 +1,185 @@ (in-package #:clnl-interface) -(defvar *turtle-list* nil) +(defvar *turtle-lists* nil) (defvar *patch-list* nil) -; It may be useful to keep windows around (defvar *glut-window-opened* nil) (defvar *dimensions* nil) +; For now, shapes can live in here +; header is +; * name +; * rotatable (equal to "true" if yes) +; +; then after, the elements are like so: +; +; filled == filled in (always for now, ha) +; marked == use the turtle color instead of a color +; polygon -> Polygon +; circle -> Circle ; here, the left and top are NOT the center +; rectangle -> Rectangle +; +; then ends with an empty string + +(defun parse-circle (sections) + (list :circle + :color (parse-integer (car sections)) + :filled (string= (nth 1 sections) "true") + :marked (string= (nth 2 sections) "true") + :left (parse-integer (nth 3 sections)) + :top (parse-integer (nth 4 sections)) + :diameter (parse-integer (nth 5 sections)))) + +(defun parse-rectangle (sections) + (list + :rectangle + :color (parse-integer (car sections)) + :filled (string= (nth 1 sections) "true") + :marked (string= (nth 2 sections) "true") + :left (parse-integer (nth 3 sections)) + :top (parse-integer (nth 4 sections)) + :right (parse-integer (nth 5 sections)) + :bottom (parse-integer (nth 6 sections)))) + +(defun parse-polygon (sections) + (labels + ((parse-points (sections) + (when sections + (cons + (list (parse-integer (car sections)) (parse-integer (cadr sections))) + (parse-points (cddr sections)))))) + (list + :polygon + :color (parse-integer (car sections)) + :filled (string= (nth 1 sections) "true") + :marked (string= (nth 2 sections) "true") + :coords (parse-points (nthcdr 3 sections))))) + +(defun parse-shape (str) + (labels + ((parse-element (line) + (let + ((sections (cl-ppcre:split " " line))) + (cond + ((string= (car sections) "Circle") (parse-circle (cdr sections))) + ((string= (car sections) "Rectangle") (parse-rectangle (cdr sections))) + ((string= (car sections) "Polygon") (parse-polygon (cdr sections)))))) + (parse-elements () + (let + ((line (read-line str nil))) + (when (and line (string/= line "")) + (cons + (parse-element line) + (parse-elements)))))) + (let + ((next-line (read-line str nil))) + (when next-line + (list + :name next-line + :rotatable (string= "true" (read-line str)) + :rgb (read-line str) ; this is ignored for now, I think + :elements (parse-elements)))))) + +; Clipping ears algorithm. This can be slow due to the fact that it will only be run once. +(defun triangulate (points &optional (ccw :unknown)) + (labels + ((tri-is-ccw (x y z) + (< 0 (- (* (- (car y) (car x)) (- (cadr z) (cadr x))) (* (- (car z) (car x)) (- (cadr y) (cadr x)))))) + (tri-is-concave (x y z) (if (tri-is-ccw x y z) (not ccw) ccw)) + (poly-is-ccw (points &optional cur-tri) + (cond + ((not cur-tri) + (poly-is-ccw (append points (list (car points))) (list (car (last points)) (car points) (cadr points)))) + ((eql (length points) 2) + (apply #'tri-is-ccw cur-tri)) + ((or + (< (car (cadr points)) (car (cadr cur-tri))) + (and + (= (car (cadr points)) (car (cadr cur-tri))) + (< (cadr (cadr points)) (cadr (cadr cur-tri))))) + (poly-is-ccw (cdr points) (subseq points 0 3))) + (t (poly-is-ccw (cdr points) cur-tri)))) + (point-in-tri (x y z p) + ; Barycentric system test + (let* + ((denom (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z))))) + (a (/ (+ (* (- (cadr y) (cadr z)) (- (car p) (car z))) (* (- (car z) (car y)) (- (cadr p) (cadr z)))) denom)) + (b (/ (+ (* (- (cadr z) (cadr x)) (- (car p) (car z))) (* (- (car x) (car z)) (- (cadr p) (cadr z)))) denom)) + (c (- 1 a b))) + (and (<= 0 a 1) (<= 0 b 1) (<= 0 c 1)))) + (no-points-in-tri (tri points) + (every (lambda (point) (not (point-in-tri (car tri) (cadr tri) (caddr tri) point))) points)) + (tri-is-actually-line (x y z) + (zerop (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z))))))) + (cond + ((not (find :end points)) (triangulate (append points (list :end)) ccw)) + ((< (length points) 4) (error "Must have at least 3 points...")) + ((= (length points) 4) (list (remove :end points))) + ((eql ccw :unknown) (triangulate points (poly-is-ccw (remove :end points)))) + ((eql :end (car points)) (error "This polygon may not be triangulateable")) + (t + (let* + ((endless (remove :end points)) + (tri (subseq endless 0 3))) + (cond + ((apply #'tri-is-actually-line tri) + (triangulate (cons (car endless) (cddr endless)) ccw)) + ((apply #'tri-is-concave tri) + (triangulate (append (cdr points) (list (car points))) ccw)) + ((no-points-in-tri tri (nthcdr 3 endless)) + (cons tri (triangulate (cons (car endless) (cddr endless)) ccw))) + (t (triangulate (append (cdr points) (list (car points))) ccw)))))))) + +(defun element->gl-list (shape) + (case (car shape) + (:polygon + (progn + (gl:begin :triangles) + (mapcar + (lambda (point) (gl:vertex (car point) (cadr point) 0)) + (apply #'append (triangulate (getf (cdr shape) :coords)))) + (gl:end))) + (:rectangle + (progn + (gl:begin :triangles) + (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) + (mapcar + (lambda (point) (gl:vertex (car point) (cadr point) 0)) + (apply #'append + (triangulate + (loop + :repeat 360 + :with c := (strictmath:cos (strictmath:to-radians 1)) + :with s := (strictmath:sin (strictmath:to-radians 1)) + :with r := (/ (getf (cdr shape) :diameter) 2) + :with left := (getf (cdr shape) :left) + :with top := (getf (cdr shape) :top) + :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))))) + +(defun parse-shapes (str) + (let + ((shape (parse-shape str))) + (when shape (cons shape (parse-shapes str))))) + +(defun default-shapes () + (with-open-file (str "resources/defaultshapes") (parse-shapes str))) + (defvar *colors* '((140 140 140) ; gray (5) (215 48 39) ; red (15) @@ -66,10 +239,14 @@ (gl:with-pushed-matrix (gl:translate (* (getf turtle :xcor) (patch-size)) (* (getf turtle :ycor) (patch-size)) 0) (gl:translate x-modification y-modification 0) - (gl:rotate (getf turtle :heading) 0 0 -1) - (gl:scale (patch-size) (patch-size) 1) - (gl:scale (getf turtle :size) (getf turtle :size) 1) - (gl:call-list *turtle-list*))) + (let + ((turtle-list (find (getf turtle :shape) *turtle-lists* :test #'string= :key #'car))) + (when turtle-list + (when (second turtle-list) + (gl:rotate (getf turtle :heading) 0 0 -1)) + (gl:scale (patch-size) (patch-size) 1) + (gl:scale (getf turtle :size) (getf turtle :size) 1) + (gl:call-list (third turtle-list)))))) (list 0 (1- (world-width-in-pixels)) (- (1- (world-width-in-pixels))) 0 0) (list 0 0 0 (1- (world-height-in-pixels)) (- (1- (world-height-in-pixels)))))) turtles)) @@ -94,18 +271,24 @@ (cffi:defcallback close-func :void () (close-func)) (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height)) -(defun set-turtle-list () - (setf *turtle-list* (gl:gen-lists 1)) - (gl:with-new-list (*turtle-list* :compile) - (gl:rotate 180 0 0 -1) - (gl:scale (/ 1 300d0) (/ 1d0 300d0) 1) - (gl:translate -150 -150 -0.0) - (gl:begin :polygon) - (gl:vertex 150 5 0) - (gl:vertex 40 250 0) - (gl:vertex 150 205 0) - (gl:vertex 260 250 0) - (gl:end))) +(defun set-turtle-lists () + (setf + *turtle-lists* + (mapcar + (lambda (shape) + (let + ((turtle-list + (list + (getf shape :name) + (getf shape :rotatable) + (gl:gen-lists 1)))) + (gl:with-new-list ((third turtle-list) :compile) + (gl:rotate 180d0 0d0 0d0 -1d0) + (gl:scale (/ 1d0 300d0) (/ 1d0 300d0) 1) + (gl:translate -150d0 -150d0 -0.0d0) + (mapcar #'element->gl-list (getf shape :elements))) + turtle-list)) + (default-shapes)))) (defun set-patch-list () (setf *patch-list* (gl:gen-lists 1)) @@ -157,7 +340,7 @@ DESCRIPTION: ; I do this because I don't know who or what in the many layers ; is causing the floating point errors, but I definitely don't ; want to investigate until simply ignoring them becomes a problem. - (sb-int:with-float-traps-masked (:invalid) + (sb-int:with-float-traps-masked (:invalid :inexact :divide-by-zero :overflow :underflow) (cl-glut:init) (cl-glut:init-window-size (world-width-in-pixels) @@ -170,7 +353,7 @@ DESCRIPTION: (glut:reshape-func (cffi:callback reshape)) (cl-glut:idle-func (cffi:get-callback 'idle)) (cl-glut:close-func (cffi:get-callback 'close-func)) - (set-turtle-list) + (set-turtle-lists) (set-patch-list) (cl-glut:main-loop))) @@ -205,7 +388,7 @@ DESCRIPTION: (cl-glut:init-window-size 1 1) (cl-glut:create-window "CLNL Test Window") (gl:clear-color 0 0 0 1) - (set-turtle-list) + (set-turtle-lists) (set-patch-list) (setf *glut-window-opened* t)) (let diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 5540cae..fa28fca 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -785,6 +785,7 @@ DESCRIPTION: :xcor (turtle-xcor turtle) :ycor (turtle-ycor turtle) :heading (turtle-heading turtle) + :shape (turtle-shape turtle) :size (turtle-size turtle))) *turtles*) (mapcar -- 2.25.1