Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
69 lines (58 sloc) 2.76 KB
(in-package :2d-geometry)
;;;; This file defines functions manipulating representation of geometric data.
(defun edge-list-from-point-list (point-list &optional (edge-type 'line-segment))
"Change polygon represented as a list of points into a list of edges (line segments)."
(let ((vertex-zero (car point-list)))
(maplist #'(lambda (lst)
(if (null (cadr lst))
(make-instance edge-type :start (car lst) :end vertex-zero)
(make-instance edge-type :start (car lst) :end (cadr lst))))
(defclass poly-ring-node ()
((val :accessor val :initarg :val)
(next :accessor next-node :initarg :next)
(prev :accessor prev-node :initarg :prev))
(:documentation "Double linked ring node."))
(defmethod print-object ((object poly-ring-node) stream)
(print-unreadable-object (object stream :type t)
(format stream "NODE: ~a" (val object))))
(defmethod x ((object poly-ring-node))
(x (val object)))
(defmethod y ((object poly-ring-node))
(y (val object)))
(defun double-linked-ring-from-point-list (point-list &optional (ring-type 'poly-ring-node))
"Change polygon representation from list of points to double linked ring of points."
(let ((head (make-instance ring-type)))
(let ((tail head))
(dolist (tk point-list)
(setf (val tail) tk
(next-node tail) (make-instance ring-type)
(prev-node (next-node tail)) tail
tail (next-node tail)))
(setf (prev-node head) (prev-node tail)
(next-node (prev-node tail)) head))
(defun collect-ring-nodes (ring)
"Construct a list of all nodes in a ring."
(labels ((recurse-ring (node head acc)
(if (eq node head)
(nreverse acc)
(recurse-ring (next-node node) head (cons node acc)))))
(cons ring (recurse-ring (next-node ring) ring nil))))
(defun point-list-from-ring (ring-node)
"Return a list of points in a ring."
(let ((all-nodes (collect-ring-nodes ring-node)))
(mapcar #'val all-nodes)))
(defun ring-to-list-of-edges (ring)
"Construct a list of edges attached to vertexes."
(labels ((recurse-ring (node head acc)
(if (eq node head)
(recurse-ring (next-node node) head (cons (make-instance 'line-segment
:start (prev-node node)
:end node)
(nreverse (cons (make-instance 'line-segment
:start (prev-node ring)
:end ring)
(recurse-ring (next-node ring) ring nil)))))