Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
156 lines (141 sloc) 5.44 KB
(defpackage :test-geometry (:use :common-lisp :2d-geometry :vecto :iterate)
(:export #:test-triangulate
#:test-decompose
#:test-bentley-ottmann
#:test-decompose-bo
#:test-decompose-triangle))
(in-package :test-geometry)
(defparameter *test-polygon*
(make-polygon-from-coords
10 10 20 20 20 70 70 70 70 20)
"Test concave polygon")
(defparameter *test-polygon2*
(make-polygon-from-coords
20 20 10 40 20 70 70 70 70 20)
"Test convex polygon")
(defparameter *test-polygon3*
(make-polygon-from-coords
20 20 10 40 70 40 70 70)
"Test small complex polygon")
(defparameter *test-polygon4*
(make-polygon-from-coords
20 20 10 30 70 15 70 40 30 35 50 10 45 35 25 60))
(defun test-triangulate (polygon w h &optional (x 0) (y 0))
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate x y)
(set-rgb-fill 0 0 0.8)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk point-list)
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(fill-path)
(set-rgb-stroke 0 1.0 0)
(set-line-width 2)
(set-line-join :bevel)
(dolist (tk (triangulate polygon))
(let ((point-list (point-list tk)))
(move-to (x (car point-list))(y (car point-list)))
(dolist (kk (cdr point-list))
(line-to (x kk)(y kk)))
(line-to (x (car point-list))(y (car point-list)))
(stroke)))
(save-png "test-geometry.png"))))
;; (test-triangulate *test-polygon* 100 100)
;; (test-triangulate *test-polygon2* 100 100)
(defun test-decompose (polygon w h &optional (x 0) (y 0))
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate x y)
(set-rgba-fill 0 0 0.8 1.0)
(set-rgba-stroke 0 0.8 0 0.5)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk point-list)
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(fill-and-stroke)
(let ((d-polys (decompose-complex-polygon-nondisjoint polygon)))
(dolist (tk (mapcar #'point-list d-polys))
(translate 100 0)
(set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
(move-to (x (car tk))(y (car tk)))
(dolist (kk (cdr tk))
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-path)))
(save-png "test-geometry.png"))))
;; (test-decompose *test-polygon3* 300 100)
;; (test-decompose *test-polygon4* 400 100)
(defun test-bentley-ottmann (polygon)
(if (frustrated-polygon-p polygon)
'frustrated
(let ((in-points (bentley-ottmann (edge-list polygon)))
(point-list (point-list polygon)))
(with-canvas (:width 400 :height 400)
(scale 4 4)
(set-rgb-stroke 0 0 1.0)
(set-line-width 1/5)
(move-to (x (car point-list))
(y (car point-list)))
(dolist (tk (cdr point-list))
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(stroke)
(set-rgba-fill 0 1.0 0 0.4)
(dolist (tk in-points)
(set-rgba-stroke (random 1.0) (random 1.0) (random 0.5) 0.5)
(move-to 0 (y tk))
(line-to 100 (y tk))
(move-to (x tk) 0)
(line-to (x tk) 100)
(stroke)
(centered-circle-path (x tk)(y tk) 1)
(fill-path))
(save-png "test-geometry.png")))))
;; (test-bentley-ottmann *test-polygon3*)
;; (test-bentley-ottmann *test-polygon4*)
(defun test-decompose-bo (polygon w h &optional (x 0) (y 0))
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate x y)
(set-rgba-fill 0 0 0.8 1.0)
(set-rgba-stroke 0 0.8 0 0.5)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk (cdr point-list))
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(fill-and-stroke)
(let ((d-polys (decompose-complex-polygon-bentley-ottmann polygon)))
(dolist (tk (mapcar #'point-list d-polys))
(translate 100 0)
(set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
(move-to (x (car tk))(y (car tk)))
(dolist (kk (cdr tk))
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-path)))
(save-png "test-geometry.png"))))
;;(test-decompose-bo *test-polygon3* 300 100)
;;(test-decompose-bo *test-polygon4* 400 100)
(defun test-decompose-triangle (polygon w h)
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate 10 10)
(set-rgba-fill 0 0 0.8 1.0)
(set-rgba-stroke 0 0.8 0 0.5)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk (cdr point-list))
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(even-odd-fill-and-stroke)
(translate 0 0)
(let ((d-polys (mapcar #'point-list
(decompose-complex-polygon-triangles polygon :in-test 'geometry:point-in-polygon-crossing-p))))
(set-rgba-fill 0 1.0 0 0.2)
(dolist (tk d-polys)
(move-to (x (car tk))(y (car tk)))
(dolist (kk tk)
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-and-stroke)))
(save-png "test-geometry.png"))))
Jump to Line
Something went wrong with that request. Please try again.