./000700 002223 000322 00000000000 06050465700 010435 5ustar00dwjCSI000000 000000 README000644 002223 000322 00000006124 06050406751 011176 0ustar00dwjCSI000000 000000 You have untarred COMMON LISP code for finding salient convex groups
in an image. The algorithm implemented here is described most fully
in: MIT Ai lab Technical Report #1416, "Recognizing 3-D Objects Using
2-D Images". The system is also described in a forthcoming paper in
IEEE Trans. PAMI, in `Finding Salient Convex Groups'', Proc.\ of the
DIMACS Workshop on Partitioning Data Sets. pp.~{237--269}, 1995, and,
very briefly, in ``Robust and Efficient Detection of Convex Groups'',
IEEE Conf.\ on Computer Vision and Pattern Recognition. pp.~{770--771},
1993. Here is the abstract of the PAMI paper:
This paper describes an algorithm that robustly locates {\em salient}
convex collections of line segments in an image. The algorithm is
guaranteed to find all convex sets of line segments in which the
length of the gaps between segments is smaller than some fixed
proportion of the total length of the lines. This enables the
algorithm to find convex groups whose contours are partially occluded
or a missing due to noise. We give an expected case analysis of
the algorithm's performance. This demonstrates that salient convexity
is unlikely to occur at random, and hence is a strong clue that
grouped line segments reflect underlying structure in the scene. We
also show that our algorithm's run time is $O(n^2\log(n) + nm)$, when
we wish to find the $m$ most salient groups in an image with $n$ line
segments. We support this analysis with experiments on real data, and
demonstrate the grouping system as part of a complete recognition
system.
Currently, this paper can be retrieved from my web page:
Web: http://www.neci.nj.nec.com/homepages/dwj.html. Questions or comments
on this paper or about the code should be directed to:
David Jacobs: dwj@research.nj.nec.com. I do not promise
to maintain this code, or fix any bugs, however I will be
glad to receive any feedback from user.
You will need to make two changes to this code, before running.
In the file group/system.lisp, two global variables are defined:
*home-directory* and *binary-type*. *home-directory* should be changed
to the main directory in which you put this code, ie it should contain
the two subdirectories group and geometry. *binary-type* may need to
be changed to the appropriate type used to denote binary files in
your lisp system. It is currently "fasl", which is right for Allegro
Common Lisp.
There are also known incompatibilities between Allegro and other Lisps.
For example, Lucid seems to want the argument to IN-PACKAGE to be quoted
as a symbol, while Allegro does not. MAKE-PATHNAME also seems to work
a little differently. So if you are not using Allegro you should expect
to have to do a little hacking to get the code to run, in order to overcome
incompatibilities between different common lisps.
The file loading-log shows what it looks like when I compile and load
this code using Allegro common lisp. This shows, for example, the
compiler warnings that I ignore.
To get started using the code, have a look at: group/tutorial.lisp.
This provides some sample code to call the convex grouping system.k
a little differently. So if you are not using Allegro you should expect
to have to do a little hacking to get the code to run, in order to overcome
incompatibilities between different common lisps.
The file loading-log shows what it looks like when I compile and load
this code using Allegro common lisp. This shows, for example, the
compiler warnings that I ignore.
To get started using the code, have a look at: grogeometry/000700 002223 000322 00000000000 06050465732 012140 5ustar00dwjCSI000000 000000 geometry/2d/000700 002223 000322 00000000000 06050445362 012442 5ustar00dwjCSI000000 000000 geometry/2d/angle.lisp000666 002223 000322 00000014211 06050466000 014426 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package 2DG)
(export '(direction parallel? parallel-vectors? vector-angle ordered-vector-angle angle-0
angle-2pi abs-angle-difference))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Parallelism
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DIRECTION (object)
"Returns a unit vector which defines the direction of OBJECT."
(unit (g-coerce object 'point)))
(defun PARALLEL? (line-1 line-2)
"Returns T if LINE-1 and LINE-2 are parallel. If parallel, they may or may not be colinear."
(let ((direction-1 (direction line-1))
(direction-2 (direction line-2)))
(parallel-vectors? direction-1 direction-2)))
(defun PARALLEL-VECTORS? (vector-1 vector-2)
"Returns T if VECTOR-1 and VECTOR-2 are parallel. The vectors are represented as points."
(cond ((not (and (point-p vector-1) (point-p vector-2)))
(error "~A and ~A must both be points."))
(t (let ((dot-1-2 (dot (unit vector-1) (unit vector-2))))
(or (~= dot-1-2 1)
(~= dot-1-2 -1))))))
(defun VECTOR-ANGLE (vec1 vec2)
"The angle formed by two vectors. Their order doesn't matter, so the angle varies
from 0 to PI."
(let ((vec1 (unit vec1))
(vec2 (unit vec2)))
(atan (abs (dot (normal vec1) vec2)) (dot vec1 vec2))))
(defun ORDERED-VECTOR-ANGLE (vec1 vec2)
"The angle found by rotating vec1 counter-clockwise to vec2. Angle returned varies
from -PI to PI. A negative angle means that rotating the first vector clockwise by
that angle brings it to the second vector."
(let ((vec1 (unit vec1))
(vec2 (unit vec2)))
(atan (- (dot (normal vec1) vec2)) (dot vec1 vec2))))
(defun CONNECTED-LINE-ANGLE (ls1 ls2)
"Finds the angle from the first line segment to the second, when the second point of ls1 =
the first point of ls2"
(ordered-vector-angle (multiply (g-coerce ls1 'point) -1) (g-coerce ls2 'point)))
(defun ANGLE-0 (point-1 point-2 point-3)
"
Purpose: Find the angle POINT-1 POINT-2 POINT-3 in radians.
This version uses the angle 0 and not 2*PI.
Returns: The angle, in radians, of POINT-1 POINT-2 POINT-3 in the range [0 2PI).
Caveats: If POINT-1 = POINT-2 or POINT-2 = POINT-3, an error will result.
"
(declare (values radians))
(if (point-equal point-1 point-3)
;; This is an easy case that can be missed due to finite-precision math
0
;; Normal case
(let* (
;; Get the vectors
(a (make-point (- (point-x point-1) (point-x point-2)) (- (point-y point-1) (point-y point-2))))
(b (make-point (- (point-x point-3) (point-x point-2)) (- (point-y point-3) (point-y point-2))))
;; Now the cosine
(cos-theta (/ (dot a b) (norm a) (norm b))))
;; Close points may lead to bad data, with |cosine(theta)| > 1, so we round to +/-1
(cond ((>= cos-theta 1.0) 0) ;Easy case. Use 0, not 2*PI.
((<= cos-theta -1.0) *short-pi*) ;Easy case. PI.
((minusp (side point-1 point-2 point-3)) (- *short-2pi* (acos cos-theta))) ;PI < THETA < 2*PI
(t (acos cos-theta)))))) ;0 < THETA < PI
(defun ANGLE-2PI (point-1 point-2 point-3)
"
Purpose: Find the angle POINT-1 POINT-2 POINT-3 in radians.
This version uses the angle 2*PI and not 0.
Returns: The angle, in radians, of POINT-1 POINT-2 POINT-3 in the range (0 2PI].
Caveats: If POINT-1 = POINT-2 or POINT-2 = POINT-3, an error will result.
2D: Any list elements after the y-coordinate of a point are ignored for calculations.
"
(declare (values radians))
(if (point-equal point-1 point-3)
;; This is an easy case that can be missed due to finite-precision math
*short-2pi*
;; Normal case
(let* (
;; Get the vectors
(a (diff point-1 point-2))
(b (diff point-3 point-2))
;; Now the cosine
(cos-theta (/ (dot a b) (norm a) (norm b))))
;; Close points may lead to bad data, with |cosine(theta)| > 1, so we round to +/-1
(cond ((>= cos-theta 1.0) *short-2pi*) ;Easy case. Use 2*PI, not 0.
((<= cos-theta -1.0) *short-pi*) ;Easy case. PI.
((minusp (side point-1 point-2 point-3)) (- *short-2pi* (acos cos-theta))) ;PI < THETA < 2*PI
(t (acos cos-theta)))))) ;0 < THETA < PI
(defun ABS-ANGLE-DIFFERENCE (a1 a2)
"Given two angles, from 0 to 2pi, find the absolute difference between them."
(let ((diff (abs (- a1 a2))))
(min diff (- g:*2pi* diff)))) data, with |cosine(theta)| > 1, so we round to +/-1
(cond ((>= cos-theta 1.0) *short-2pi*) ;Easy case. Use 2*PI, not 0.
((<= cos-theta -1.0) *short-pi*) ;Easy case. PI.
((minusp (side point-1 point-2 point-3)) (- *short-2pi* (acos cos-theta))) ;PI < THETA < 2*PI
(t (acos cos-theta)))))) ;0 < THETA < PI
(defun ABS-ANGLE-DIFFERENCE (a1 a2)
"Givengeometry/2d/colinear.lisp000666 002223 000322 00000012252 06050466001 015140 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(colinear? colinear-point-and-line? colinear-line-and-line? colinear-points?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Colinearity
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun COLINEAR? (object-1 object-2)
"Returns T if OBJECT-1 and OBJECT-2 are colinear."
(cond ((or (null object-1) (null object-2))
;; We include this case for calls where one of the objects is itself returned by a function
nil)
((point-p object-1)
;; OBJECT-1 is a point
(cond ((point-p object-2)
t) ;points are always colinear
((line-segment-p object-2)
(colinear-point-and-line? object-1 (g-coerce object-2 'line)))
((line-p object-2)
(colinear-point-and-line? object-1 object-2))
(t
(error "Can't determine colinearity between ~A and ~A" object-1 object-2))))
((point-p object-2)
;; OBJECT-2 is a point, but OBJECT-1 is not
(colinear? object-2 object-1))
((line-segment-p object-1)
;; OBJECT-1 is a line segment
(cond ((line-segment-p object-2)
(colinear-line-and-line? (g-coerce object-1 'line) (g-coerce object-2 'line)))
((line-p object-2)
(colinear-line-and-line? (g-coerce object-1 'line) object-2))
(t
(error "Can't determine colinearity between ~A and ~A" object-1 object-2))))
((line-segment-p object-2)
;; OBJECT-2 is a line segment, but OBJECT-1 is not
(colinear? object-2 object-1))
((line-p object-1)
;; OBJECT- is a line
(cond ((line-p object-2)
(colinear-line-and-line? object-1 object-2))
(t
(error "Can't determine colinearity between ~A and ~A" object-1 object-2))))
(t
(error "Can't determine colinearity between ~A and ~A" object-1 object-2))))
(defun THREE-POINTS-COLINEAR? (point point-1 point-2)
"Returns T if POINT, POINT-1, and POINT-2 are colinear."
(colinear-points? (list point point-1 point-2)))
(defun COLINEAR-POINT-AND-LINE? (point line)
"
Purpose: Determine if a point is colinear with a line
Args: POINT -- a point (X Y)
LINE -- a line
Returns: T if the point and line segment are colinear, Nil otherwise.
"
(declare (values boolean))
(colinear-points? (list point (first-point line) (second-point line))))
(defun COLINEAR-LINE-AND-LINE? (line-1 line-2)
"
Purpose: Determine if LINE-1 and LINE-2 are colinear
Returns: T if the line segments are colinear
"
(declare (values boolean))
(colinear-points? (list (line-point-1 line-1) (line-point-2 line-1)
(line-point-1 line-2) (line-point-2 line-2))))
(defun COLINEAR-POINTS? (pts)
"
Points are colinear when they could all be moved by less than *epsilon* and line up exactly.
A quick approximation to testing that is to find the line connecting the two exteme points,
and test that no other point is more than *epsilon from this line.
"
(let ((max-squared-distance 0)
(pt1)
(pt2))
(loop for p1 in pts
for rest-pts on (cdr pts)
doing
(loop for p2 in rest-pts
doing
(let ((squared-distance (distance-squared-between-point-and-point p1 p2)))
(when (<= max-squared-distance squared-distance)
(setf max-squared-distance squared-distance)
(setf pt1 p1)
(setf pt2 p2)))))
(let ((line (make-line pt1 pt2)))
(loop for pt in (remove pt1 (remove pt2 pts))
always
(~zerop (distance-between-point-and-line pt line))))))
tance 0)
(pt1)
(pt2))
(loop for p1 in pts
for rest-pts on (cdr pts)
doing
(loop for p2 in rest-pts
doing
(let ((squared-distance (distance-squared-between-point-and-point p1 p2)))
(when (<= max-squared-distance squared-distance)
(setf max-squared-distance squared-distance)
(setf pt1 p1)
(setf pt2 p2geometry/2d/constants.lisp000666 002223 000322 00000004170 06050466003 015362 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(*origin* *i* *j*))
(defvar *ORIGIN* (make-point 0 0) "The origin, i.e., #.")
(defvar *I* (make-point 1 0) "The unit vector in the x direction.")
(defvar *J* (make-point 0 1) "The unit vector in the y direction.")
n of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(*origin* *i* *j*))
(defvar *ORIGIN* (make-point 0 0) "The origin, i.e., #.")
(defvar *I* (makegeometry/2d/convex-hull.lisp000666 002223 000322 00000040513 06050466005 015615 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:2DG; Syntax:Common-lisp; Lowercase:Yes -*-
;;; Copyright 1988, 1989 (c) David J. Braunegg. All rights reserved.
;;; Distribution of this file is unrestricted provided that this notice is not removed.
;;;; Purpose: Implement a 2D convex hull.
;;;;
;;;; Author: David J. Braunegg
;;;; Creation Date: October 11, 1988
;;;; Modifications to released version:
;;;; Programmer Date Description of modifications
;;;; ________________ ___________ _________________________________________________________________
;;;;
;;;;
;;; Comments
;;;; 1) The L-Convex Hull is defined in "Visual Navigation for a Mobile Robot: Building a Map of the Occupied Space from Sparse 3-D Stereo Data"
;;;; by A. R. de Saint Vincent, 1987 IEEE International Conference on Robotics and Automation.
;;;;
;;;; To Do:
;;;; The L-Convex functions could be made faster by bucketing the points and only searching those points in the neighboring buckets to the current point.
;;;; The bucket size would be the L-Convex search distance.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Provide/Export/Require
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(export '(jarvis-march-convex-hull merge-convex-hulls intersect-segment-and-hull?
remove-colinear-vertices l-convex-hull l-convex-hull-strict))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Convex Hull
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun JARVIS-MARCH-CONVEX-HULL (points)
"
Purpose: Find the convex hull of POINTS.
Args: POINTS
Returns: a list of points, in order, which form the convex hull of POINTS.
Details:
1) The algorithm used is based on the Jarvis March algorithm given on p. 104 of Computational Geometry by Preparata and Shamos.
2) If more than two points are colinear on the hull, only the endpoints of that hull segment are included in the hull.
4) Worst-case running time is O(n^2), actual time is O(hn), where n = # points and h = # hull points.
5) If two points have the same x- and y-coordinates and that location is a hull vertex, one ot the points will arbitrarily be used.
6) Degenerate cases are handled correctly.
"
(declare (values convex-hull))
(let* ((extreme-point (extreme-point points))
;; Keep the EXTREME-POINT so that we can use it for an end test,
;; BUT, remove any other points with the same x- and y-coordinates as EXTREME-POINT from the point list so that they do not screw up the (eq) end test.
(remaining-points (cons extreme-point (remove extreme-point points :test #'point-equal) ))
(hull-points (list extreme-point)))
;; Jarvis march up the right side
(loop do
(loop for point in (cdr remaining-points)
with last-point = (first hull-points)
with current-point = (first remaining-points)
as side = (side last-point current-point point)
do
(cond ((plusp side)
;; POINT is to the right of the ray from LAST-POINT to CURRENT-POINT and so is a better hull candidate
(setf current-point point))
((zerop side)
;; POINT lies on the ray from LAST-POINT to CURRENT-POINT, so we want the point which is farther away from LAST-POINT.
;; Or, CURRENT-POINT matches LAST-POINT, in which case we don't want it.
(when (> (distance-squared-between-point-and-point last-point point)
(distance-squared-between-point-and-point last-point current-point))
(setf current-point point))))
finally (push current-point hull-points)
(setf remaining-points (remove current-point remaining-points :test #'eq)))
when (eq (first hull-points) extreme-point)
;; We have closed the hull by getting back to the original point, so we are done.
return nil)
;; Return the convex hull. The initial point will be duplicated at the end, so remove it from the beginning
(cdr hull-points)))
(defun MERGE-CONVEX-HULLS (convex-hull-1 convex-hull-2)
"
Purpose: Find the convex hull of POINTS.
Args: CONVEX-HULL-1 -- a list of points which, in order, form a convex hull
CONVEX-HULL-2 -- a list of points which, in order, form a convex hull
Returns: a list of points, in order, which form the convex hull of the points contained in CONVEX-HULL-1 and CONVEX-HULL-2
Details:
1) If more than two points are colinear on the hull, only the endpoints of that hull segment are included in the hull.
3) If two points have the same x- and y-coordinates and that location is a hull vertex, one ot the points will arbitrarily be used.
4) Degenerate cases are handled correctly.
"
(jarvis-march-convex-hull (append convex-hull-1 convex-hull-2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; L-Convex Hull
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun L-CONVEX-HULL-STRICT (points max-arc-length-squared)
"
Purpose: Find the L-Convex Hull of POINTS.
This function uses the strict definition of L-Convexity, which can yield degenerate polygons.
Args: POINTS
MAX-ARC-LENGTH-SQUARED -- square of maximum length of an arc connecting two hull points.
Returns: a list of points, in order, which form the L-Convex Hull of POINTS.
Details:
1) The algorithm used is based on the L-Convex Hull algorithm of A. R. de Saint Vincent.
2) If more than two points are colinear on the hull, only the endpoints of that hull segment are included in the hull.
4) Worst-case running time is O(kn + km), where n = # points, m = # arcs in the GC (Graph Component) and k = # arcs in of the hull
5) If two points have the same x- and y-coordinates and that location is a hull vertex, one ot the points will arbitrarily be used.
6) Degenerate cases look lousy.
"
(declare (values l-convex-hull))
(let* ((extreme-point (extreme-point points))
(hull-points (list extreme-point)))
(loop do
(push (find-l-convex-hull-point points hull-points max-arc-length-squared) hull-points)
when (point-equal (first hull-points) extreme-point)
;; We have closed the hull by getting back to the original point, so we are done.
;; (The initial point will be duplicated at the end, so remove it from the beginning.)
;; Return the convex hull.
return (cdr hull-points))))
(defun L-CONVEX-HULL (points max-arc-length-squared)
"
Purpose: Find the L-Convex Hull of POINTS.
This version relaxes the L-Convex condition to obtain non-degenerate polygons by eliminating hull points which cause a concave degeneracy.
Args: POINTS
MAX-ARC-LENGTH-SQUARED -- square of maximum length of an arc connecting two hull points.
Returns: a list of points, in order, which form the L-Convex Hull of POINTS.
Details:
1) The algorithm used is based on the L-Convex Hull algorithm of A. R. de Saint Vincent.
2) If more than two points are colinear on the hull, only the endpoints of that hull segment are included in the hull.
4) Worst-case running time is O(kn + km), where n = # points, m = # arcs in the GC (Graph Component) and k = # arcs in of the hull
5) If two points have the same x- and y-coordinates and that location is a hull vertex, one ot the points will arbitrarily be used.
6) Degenerate cases are handled correctly.
2D: Any list elements after the y-coordinate of a point are ignored for calculations.
"
(declare (values l-convex-hull))
(if (cddr points)
;; There are at least 3 points, so do full algorithm. (With 3, might be colinear and therefore degenerate. So, do all the work.)
(let* ((extreme-point (extreme-point points))
(hull-points (list extreme-point))
(last-point-degenerate nil)
degenerate-point
best-point
degenerate-pointer
first-part)
(loop do
(setf best-point (find-l-convex-hull-point points hull-points max-arc-length-squared))
(when last-point-degenerate
;; Skip degenerate hull points which are concave
(setf first-part (cdr hull-points))
(setf degenerate-pointer (position degenerate-point first-part :test #'point-equal))
(when (and (not (point-equal (nth degenerate-pointer first-part) extreme-point))
(not (left-turn? (nth (1+ degenerate-pointer) first-part)
(nth degenerate-pointer first-part)
(nth (1- degenerate-pointer) first-part))))
(setf hull-points (cons (first hull-points) (delete degenerate-point first-part :test #'point-equal :count 1))))
(when (not (left-turn? (second hull-points) (first hull-points) best-point))
(setf hull-points (cdr hull-points))))
(and (point-equal best-point extreme-point) ;Don't miss point to left of extreme point (see notes 5/4/89)
(not (left-turn? (find-l-convex-hull-point points (cons best-point hull-points) max-arc-length-squared)
best-point
(first hull-points)))
;; We have closed the hull by getting back to the original point, so we are done.
(return (remove-colinear-vertices hull-points)))
(if (member best-point hull-points :test #'point-equal)
;; Was this point degenerate?
(setf last-point-degenerate t
degenerate-point best-point)
(setf last-point-degenerate nil))
;; Add this point to the hull
(push best-point hull-points)))
;; There are only 1 or 2 points, so just return them
points))
(defun FIND-L-CONVEX-HULL-POINT (points hull-points max-arc-length-squared)
"
Purpose: Find the next L-Convex hull point from a set of points given the current hull.
Args: POINTS -- list of points for which we are finding the hull
HULL-POINTS -- list of hull points found so far
MAX-ARC-LENGTH-SQUARED -- square of maximum length of a hull arc
Returns: The next L-Convex hull point.
"
(declare (values l-convex-hull-point))
(let* ((last-point (first hull-points))
(two-points-ago (or (second hull-points) (diff last-point (make-point 0 1))))
(best-angle 7) ;7 > 2*PI
(best-last-point-to-point-distance-squared 0)
best-point
last-point-to-point-distance-squared
angle)
(loop for point in points
do
(cond ((or
;; First a quick distance check
(> (square-metric-distance-squared-between-point-and-point last-point point) max-arc-length-squared)
;; Now the more expensive Euclidean distance check
(and (setf last-point-to-point-distance-squared (distance-squared-between-point-and-point last-point point))
(> last-point-to-point-distance-squared max-arc-length-squared)))
;; Distance to this point is too great for point to be on L-Convex Hull
())
((point-equal point last-point)
()) ;Ignore duplicate points
((intersect-segment-and-hull? (make-line-segment last-point point) hull-points)
()) ;Can't use a segment that intersects the hull
((or
;; POINT forms a smaller angle with the last two points than our best current candidate, so keep it.
(and (setf angle (angle-2pi two-points-ago last-point point))
(or (when (< (abs angle) .01) (setf angle *short-2pi*)) t)
(< angle best-angle))
;; POINT lies on the same line as our current best point, so we want the point which is closest to LAST-POINT. (So that we end as soon as possible.)
(and (= angle best-angle)
(< last-point-to-point-distance-squared best-last-point-to-point-distance-squared)))
(setf best-point point
best-angle angle
best-last-point-to-point-distance-squared last-point-to-point-distance-squared)))
finally
(return best-point))))
(defun REMOVE-COLINEAR-VERTICES (vertices)
"
Purpose: Remove vertices from a polygon which actually lie on the line between the preceding and following vertices.
Args: VERTICES -- a list of points which are the vertices of a polygon.
Returns: a list of points which constitute the polygon with only real vertices.
"
(declare (values vertices))
(let ((new-vertices ())
(last-vertex (first (last vertices)))
last-new-vertices)
(loop for partial-vertices on vertices
;; Find a starting vertex which is not in line with the end vertices vertex and the next one.
when (not (three-points-colinear? (second partial-vertices) (first partial-vertices) last-vertex))
do
(push (first partial-vertices) new-vertices)
(setf last-new-vertices (first partial-vertices))
;; Now, go through the vertices, keeping only those vertices which do not lie on the straight-line edge between the previous vertex and the next one.
(loop as vertex-1 in (cdr partial-vertices)
for vertex-2 in (cddr partial-vertices)
unless (three-points-colinear? (first new-vertices) vertex-1 vertex-2)
do (push vertex-1 new-vertices)
finally
;; Make sure that the last vertex isn't on hte straight-line edge with the previous vertex and the first one.
(unless (three-points-colinear? (first new-vertices) vertex-1 last-new-vertices)
(push vertex-1 new-vertices)))
(loop-finish))
new-vertices))
(defun INTERSECT-SEGMENT-AND-HULL? (segment hull-points)
"
Purpose: Determine if a line segment intersects the L-Convex hull found so far.
Args: SEGMENT -- a line segment
HULL-POINTS -- a list of points
Returns: T if SEGMENT intersects the hull. However, an intersection of a segment endpoint and a hull point is allowed (Nil returned).
"
(declare (values boolean))
(loop as hull-endpoint-1 in hull-points
for hull-endpoint-2 in (cdr hull-points)
as hull-segment = (make-line-segment hull-endpoint-1 hull-endpoint-2)
as hull-segment-bounding-box = (bounding-box hull-segment)
with segment-bounding-box = (bounding-box segment)
with segment-endpoint-1 = (line-segment-point-1 segment)
with segment-endpoint-2 = (line-segment-point-2 segment)
when (intersect-rectangle-and-rectangle? segment-bounding-box hull-segment-bounding-box)
;; The bounding boxes intersect, so maybe the segments do
do
(and (not (point-equal segment-endpoint-1 hull-endpoint-1))
(not (point-equal segment-endpoint-1 hull-endpoint-2))
(not (point-equal segment-endpoint-2 hull-endpoint-1))
(not (point-equal segment-endpoint-2 hull-endpoint-2))
;; Endpoint intersections are OK. This only matters when NEW-POINT is taken from previous endpoints.
;; Note that there could be an intersection with a point on the hull segment that is not an endpoint. That point could lie on hte hull
;; segment but no be in the hull because the existing endpoints formed a longer segment.
(intersect-line-segment-and-line-segment? segment (make-line-segment hull-endpoint-1 hull-endpoint-2))
;; The segment intersected this hull segment
(return t))))
2))
;; Endpoint intersections are OK. This only matters when NEW-POINT is taken from previous endpoints.
;; Note that there could be an intersection with a point on the hull geometry/2d/distance.lisp000666 002223 000322 00000031442 06050466007 015146 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(distance distance-between-point-and-point distance-between-point-and-line-segment
distance-between-point-and-line distance-between-line-segment-and-line-segment
distance-between-line-segment-and-line distance-between-line-and-line distance-squared
distance-squared-between-point-and-point distance-squared-between-point-and-line-segment
distance-squared-between-point-and-line distance-squared-between-line-and-line
distance-squared-between-line-segment-and-line distance-squared-between-line-segment-and-line-segment
square-metric-distance-between-point-and-point square-metric-distance-squared-between-point-and-point))
;;; To do: Add distance functions for rectangles and polygons.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Distance functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DISTANCE (object-1 object-2)
"Returns the Euclidean distance between OBJECT-1 and OBJECT-2."
(cond ((point-p object-1)
;; OBJECT-1 is a point
(cond ((point-p object-2)
(distance-between-point-and-point object-1 object-2))
((line-segment-p object-2)
(distance-between-point-and-line-segment object-1 object-2))
((line-p object-2)
(distance-between-point-and-line object-1 object-2))
(t
(error
"Can't find the distance between ~A and ~A" object-1 object-2))))
((point-p object-2)
;; OBJECT-2 is a point, but OBJECT-1 is not
(distance object-2 object-1))
((line-segment-p object-1)
;; OBJECT-1 is a line segment
(cond ((line-segment-p object-2)
(distance-between-line-segment-and-line-segment object-1 object-2))
((line-p object-2)
(distance-between-line-segment-and-line object-1 object-2))
(t
(error
"Can't find the distance between ~A and ~A" object-1 object-2))))
((line-segment-p object-2)
;; OBJECT-2 is a line segment, but OBJECT-1 is not
(distance object-2 object-1))
((line-p object-1)
;; OBJECT-1 is a line
(cond ((line-p object-2)
(distance-between-line-and-line object-1 object-2))
(t
(error
"Can't find the distance between ~A and ~A" object-1 object-2))))
(t
(error "Can't find the distance between ~A and ~A" object-1 object-2))))
(defun DISTANCE-BETWEEN-POINT-AND-POINT (point-1 point-2)
"Returns the Euclidean distance between POINT-1 and POINT-2."
(sqrt (distance-squared-between-point-and-point point-1 point-2)))
(defun DISTANCE-BETWEEN-POINT-AND-LINE-SEGMENT (point line-segment)
"Returns the Euclidean distance between POINT and LINE-SEGMENT."
(sqrt (distance-squared-between-point-and-line-segment point line-segment)))
(defun DISTANCE-BETWEEN-POINT-AND-LINE (point line)
"Returns the Euclidean distance between POINT and LINE."
(abs (normal-directed-distance (line-point-1 line) point line)))
(defun DISTANCE-BETWEEN-LINE-SEGMENT-AND-LINE-SEGMENT
(line-segment-1 line-segment-2)
"Returns the Euclidean distance between LINE-SEGMENT-1 and LINE-SEGMENT-2."
(sqrt (distance-squared-between-line-segment-and-line-segment line-segment-1 line-segment-2)))
(defun DISTANCE-BETWEEN-LINE-SEGMENT-AND-LINE (line-segment line)
"Returns the Euclidean distance between LINE-SEGMENT and LINE."
(sqrt (distance-squared-between-line-segment-and-line line-segment line)))
(defun DISTANCE-BETWEEN-LINE-AND-LINE (line-1 line-2)
"Returns the Euclidean distance between LINE-1 and LINE-2."
(if (intersect? line-1 line-2) 0
(distance-between-point-and-line (line-point-1 line-1) line-2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Distance-squared functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DISTANCE-SQUARED (object-1 object-2)
"Returns the square of the Euclidean distance between OBJECT-1 and OBJECT-2."
(cond ((point-p object-1)
;; OBJECT-1 is a point
(cond ((point-p object-2)
(distance-squared-between-point-and-point object-1 object-2))
((line-segment-p object-2)
(distance-squared-between-point-and-line-segment object-1 object-2))
((line-p object-2)
(distance-squared-between-point-and-line object-1 object-2))
(t
(error
"Can't find the distance-squared between ~A and ~A" object-1 object-2))))
((point-p object-2)
;; OBJECT-2 is a point, but OBJECT-1 is not
(distance-squared object-2 object-1))
((line-segment-p object-1)
;; OBJECT-1 is a line segment
(cond ((line-segment-p object-2)
(distance-squared-between-line-segment-and-line-segment object-1 object-2))
((line-p object-2)
(distance-squared-between-line-segment-and-line object-1 object-2))
(t
(error
"Can't find the distance-squared between ~A and ~A" object-1 object-2))))
((line-segment-p object-2)
;; OBJECT-2 is a line segment, but OBJECT-1 is not
(distance-squared object-2 object-1))
((line-p object-1)
;; OBJECT- is a line
(cond ((line-p object-2)
(distance-squared-between-line-and-line object-1 object-2))
(t
(error
"Can't find the distance-squared between ~A and ~A" object-1 object-2))))
(t
(error "Can't find the distance-squared between ~A and ~A" object-1 object-2))))
(defun DISTANCE-SQUARED-BETWEEN-POINT-AND-POINT (point-1 point-2)
"Returns the square of the Euclidean distance between POINT-1 and POINT-2."
(+ (sq (- (point-x point-1) (point-x point-2)))
(sq (- (point-y point-1) (point-y point-2)))))
(defun DISTANCE-SQUARED-BETWEEN-POINT-AND-LINE-SEGMENT (point line-segment)
"Returns the square of the Euclidean distance between POINT and LINE-SEGMENT."
;; From "A Programmer's Geometry" by A. Bowyer and J. Woodwark
(let* ((x (point-x point))
(y (point-y point))
(point-0 (line-segment-point-1 line-segment))
(x0 (point-x point-0))
(y0 (point-y point-0))
(point-1 (line-segment-point-2 line-segment))
(x1 (point-x point-1))
(y1 (point-y point-1))
(x-x0 (- x x0))
(x1-x0 (- x1 x0))
(y-y0 (- y y0))
(y1-y0 (- y1 y0))
;; Consider line segment parameterized by k, k=0 => point-0, k = 1 => point-1
(k (/ (+ (* x-x0 x1-x0) (* y-y0 y1-y0))
(+ (sq x1-x0) (sq y1-y0)))))
;; Now, limit k to the range [0 1] so that it corresponds to the point on the LINE-SEGMENT closest to the POINT.
(setf k (or (and (> k 1) 1)
(and (< k 0) 0)
k))
;; Now calculate the distance squared
(+ (sq (- (* k x1-x0) x-x0))
(sq (- (* k y1-y0) y-y0)))))
(defun DISTANCE-SQUARED-BETWEEN-POINT-AND-LINE (point line)
"Returns the square of the Euclidean distance-squared between POINT and LINE."
(sq (distance-between-point-and-line point line)))
(defun DISTANCE-SQUARED-BETWEEN-LINE-AND-LINE (line-1 line-2)
"Returns the square of the Euclidean distance between LINE-1 and LINE-2."
(sq (distance-between-line-and-line line-1 line-2)))
(defun DISTANCE-SQUARED-BETWEEN-LINE-SEGMENT-AND-LINE (line-segment line)
"Returns the square of the Euclidean distance between LINE-SEGMENT and LINE."
(if (intersect? line-segment line) 0
(min (sq (normal-directed-distance (line-point-1 line) (line-segment-point-1 line-segment) line))
(sq (normal-directed-distance (line-point-1 line) (line-segment-point-2 line-segment) line)))))
(defun DISTANCE-SQUARED-BETWEEN-LINE-SEGMENT-AND-LINE-SEGMENT (line-segment-1 line-segment-2)
"
Purpose: Find the square of the Euclidean distance between two line segments
The result also holds if either or both of the line segments are degenerate.
Returns: Multiple-value-returns the square of the Euclidean distance between the line segments,
the point on LINE-SEGMENT-1 closest to the second line segment, and
the point on LINE-SEGMENT-2 closest to the first line segment.
Comment: One of the returned points will always be a line-segment endpoint since we are operating in 2D.
"
(declare (values distance-squared segment-1-closest-point segment-2-closest-point))
;; Initialize by checking point 1-a against LINE-SEGMENT-2
(let ((pt (intersection-object line-segment-1 line-segment-2)))
(if pt (values 0 pt pt)
(let ((best-point-1 (line-segment-point-1 line-segment-1)))
(multiple-value-bind (best-distance best-point-2)
(distance-squared-between-point-and-line-segment (line-segment-point-1 line-segment-1) line-segment-2)
;; Now compare point 1-b to LINE-SEGMENT-2
(multiple-value-bind (candidate-distance candidate-point)
(distance-squared-between-point-and-line-segment (line-segment-point-2 line-segment-1) line-segment-2)
(and (< candidate-distance best-distance)
(setf best-distance candidate-distance best-point-1 (line-segment-point-2 line-segment-1)
best-point-2 candidate-point))
;; Now compare point 2-a to LINE-SEGMENT-1
(multiple-value-setq (candidate-distance candidate-point)
(distance-squared-between-point-and-line-segment (line-segment-point-1 line-segment-2) line-segment-1))
(and (< candidate-distance best-distance)
(setf best-distance candidate-distance best-point-1 candidate-point best-point-2
(line-segment-point-1 line-segment-2)))
;; Now compare point 2-b to LINE-SEGMENT-1
(multiple-value-setq (candidate-distance candidate-point)
(distance-squared-between-point-and-line-segment (line-segment-point-2 line-segment-2) line-segment-1))
(and (< candidate-distance best-distance)
(setf best-distance candidate-distance best-point-1 candidate-point best-point-2
(line-segment-point-2 line-segment-2))))
;; Finally, return the closest distance and points
(values best-distance
best-point-1
best-point-2))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Distance Functions (Non-Euclidean)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun SQUARE-METRIC-DISTANCE-BETWEEN-POINT-AND-POINT (point-1 point-2)
"
Purpose: Find the Square-Metric distance between two points.
(The Square-Metric distance is the max of delta-x and delta-y.)
Args: POINT-1 -- a point
POINT-2 -- a point
Returns: The Square-Metric distance between POINT-1 and POINT-2
"
(declare (values square-metric-distance))
(max (abs (- (point-x point-1) (point-x point-2)))
(abs (- (point-y point-1) (point-y point-2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Distance-Squared Functions (Non-Euclidean)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun SQUARE-METRIC-DISTANCE-SQUARED-BETWEEN-POINT-AND-POINT (point-1 point-2)
"
Purpose: Find the square of the Square-Metric distance between two points.
(The Square-Metric distance is the max of delta-x and delta-y.)
Args: POINT-1 -- a point
POINT-2 -- a point
Returns: The square of the Square-Metric distance between POINT-1 and POINT-2
"
(declare (values square-metric-distance-squared))
(sq (square-metric-distance-between-point-and-point point-1 point-2)))
;;;;;;;;;;;;;;;;;;;;;;;;
(defun SQUARE-METRIC-DISTANCE-SQUARED-BETWEEN-POINT-AND-POINT (point-1 point-2)
"
Purpose: Find the square of the Square-Metric distance between two points.
(The Square-Metric distance is tgeometry/2d/general.lisp000666 002223 000322 00000017062 06050466011 014766 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(multiply divide bounding-box extreme-point norm norm-squared points-between
line-segment-length average-points))
;;; This file contains some miscellaneous geometric functions, too short
;;; to deserve their own files.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Scaling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun MULTIPLY (object scalar)
"Multiply the components of OBJECT by SCALAR and return the new object."
(make-from-defining-points
(loop for point in (defining-points-list object)
collecting
(make-point (* (point-x point) scalar)
(* (point-y point) scalar)))
(geometric-type object)))
(defun DIVIDE (object scalar)
"Divide the components of OBJECT by SCALAR and return the new object."
(make-from-defining-points
(loop for point in (defining-points-list object)
collecting
(make-point (/ (point-x point) scalar)
(/ (point-y point) scalar)))
(geometric-type object)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Bounding box functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun BOUNDING-BOX (object)
"
Purpose: Find the bounding box of OBJECT. The edges are aligned with the x- and y-axes.
Args: OBJECT -- a point, line segment, or polygon
Returns: A bounding box as a rectangle
"
(declare (values (rectangle)))
(case (geometric-type object)
((point line-segment polygon)
(loop for point in (defining-points-list object)
as x = (point-x point)
as y = (point-y point)
with min-x = most-positive-single-float
with max-x = most-negative-single-float
with min-y = most-positive-single-float
with max-y = most-negative-single-float
do
(when (> x max-x) (setf max-x x))
(when (< x min-x) (setf min-x x))
(when (> y max-y) (setf max-y y))
(when (< y min-y) (setf min-y y))
finally
(return (make-rectangle min-x max-x min-y max-y))))
(line (multiple-value-bind (x1 y1 x2 y2) (defining-point-coordinates object)
(make-rectangle (if (~= x1 x2) x1 most-negative-single-float) (if (~= x1 x2) x1 most-positive-single-float)
(if (~= y1 y2) y1 most-negative-single-float) (if (~= y1 y2) y1 most-positive-single-float))))
(rectangle object)
(otherwise
(error "Can't find bounding box of ~A" object))))
(defun EXTREME-POINT (points)
"
Purpose: Find the point in a point set with the smallest y-coordinate. If more than one such point exists, the one with the smallest x-coordinate is chosen.
Returns: Multiple-value-returns a point and the zero-based index of its position in POINTS
"
(declare (values point position))
(loop for point in points
as position from 0
with best-point = (make-point most-positive-fixnum most-positive-fixnum)
with best-position
do
(cond ((< (point-y point) (point-y best-point))
(setf best-point point
best-position position))
((= (point-y point) (point-y best-point))
(when (< (point-x point) (point-x best-point))
(setf best-point point
best-position position))))
finally (return (values best-point best-position))))
(defun NORM (point)
"
Purpose: Find the Euclidean norm of POINT.
Args: POINT
Returns: SQRT (X^2 + Y^2)
"
(declare (values norm))
(sqrt (norm-squared point)))
(defun NORM-SQUARED (point)
"
Purpose: Find the square of the Euclidean norm of POINT.
Args: POINT
Returns: X^2 + Y^2
"
(declare (values norm-squared))
(+ (sq (point-x point)) (sq (point-y point))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Points in between 2 Points.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun POINTS-BETWEEN (point-1 point-2)
"
Purpose: Find the points which lie between POINT-1 and POINT-2 which have integral x-, y-coordinates.
Rounds the x- and y-coordinates of POINT-1 and POINT-2.
Returns: A list of points. The first point corresponds to POINT-1 and the last to POINT-2.
"
(let ((x1 (round (point-x point-1)))
(y1 (round (point-y point-1)))
(x2 (round (point-x point-2)))
(y2 (round (point-y point-2))))
(if (and (= x1 x2) (= y1 y2))
;; Degenerate case, so try to be reasonable
(list (make-point x1 y1))
;; Non-degenerate case
(let (first-x first-y last-x last-y)
(if (> (abs (- x1 x2)) (abs (- y1 y2)))
;; X-distance is longer
(progn
(if (> x2 x1)
(setf last-x x2 last-y y2 first-x x1 first-y y1)
(setf last-x x1 last-y y1 first-x x2 first-y y2))
(loop for x from first-x to last-x
as offset from 0
with y-ratio = (/ (- last-y first-y) (- last-x first-x))
collect (make-point x (round (+ first-y (* offset y-ratio))))))
;; Y-distance is longer
(progn
(if (> y2 y1)
(setf last-y y2 last-x x2 first-y y1 first-x x1)
(setf last-y y1 last-x x1 first-y y2 first-x x2))
(loop for y from first-y to last-y
as offset from 0
with x-ratio = (/ (- last-x first-x) (- last-y first-y))
collect (make-point (round (+ first-x (* offset x-ratio))) y))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SIZE FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LINE-SEGMENT-LENGTH (ls)
(distance-between-point-and-point (line-segment-point-1 ls) (line-segment-point-2 ls)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MISCELLANEOUS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun AVERAGE-POINTS (pts)
(loop for i from 0
for pt in pts
sum (point-x pt) into x
sum (point-y pt) into y
finally (return (make-point (float (/ x i)) (float (/ y i))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LINE-SEGMENT-LENGTH (ls)
(distance-between-point-and-point (line-segment-point-1 ls) (line-segment-point-2 ls)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MISCELLANEOUS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun AVERAGE-POINTS (pts)
(loop for i from 0
for pt in pts
sum (point-x pt) into x
sum (point-y pt) into y
finally (returngeometry/2d/interface.lisp000666 002223 000322 00000020737 06050466013 015316 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
;(shadow 'coerce)
(export '(g-coerce first-point second-point point-coordinates point-coordinates-list defining-points
defining-points-list make-from-defining-points defining-point-coordinates-list
defining-point-coordinates object-equal point-equal polygon-line-segments))
;;; This file contains low-level routines to access and change objects.
;;; These routines don't access the actual structure of the object; that
;;; only happens in the file containing the structure definitions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Coercion from one object to another
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun G-COERCE (object type)
"G-Coerce object to type given, if reasonable"
(if (eq type (geometric-type object)) object
(case type
(point (case (geometric-type object)
((line line-segment) (diff (second-point object) (first-point object)))
(cons (make-point (first object) (second object)))
(t (error t "Don't know how to g-coerce ~A to type ~A." object type))))
(line (case (geometric-type object)
(line-segment (make-line (line-segment-point-1 object) (line-segment-point-2 object)))
(t (error t "Don't know how to g-coerce ~A to type ~A." object type))))
(t (error "Don't know how to g-coerce ~A to type ~A." object type)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic routines for accessing the parts of objects.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; These functions get the point of an object. They are provided so that the same routines can work on both
;;;; lines and line segments or planes and planar-patches.
(defun FIRST-POINT (object)
"Returns the POINT-1 of object."
(case (type-of object)
(point object) ;Obviously
(line (line-point-1 object))
(line-segment (line-segment-point-1 object))
(polygon (car (polygon-points object)))
(rectangle (make-point (rectangle-min-x object) (rectangle-min-y object)))
(otherwise (error "Can't find FIRST-POINT of ~A" object))))
(defun SECOND-POINT (object)
"Returns the POINT-2 of object."
(case (type-of object)
(point object) ;Obviously
(line (line-point-2 object))
(line-segment (line-segment-point-2 object))
(polygon (cadr (polygon-points object)))
(rectangle (make-point (rectangle-max-x object) (rectangle-max-y object)))
(otherwise (error "Can't find SECOND-POINT of ~A" object))))
(defun DEFINING-POINTS (object)
"Multiple-value-returns the defining points of OBJECT."
(case (geometric-type object)
(point object)
((line-segment line rectangle) (values (first-point object) (second-point object)))
(polygon (values-list (polygon-points object)))
(t (error "~A has no defining points." object))))
(defun DEFINING-POINTS-LIST (object)
"Returns a list of the defining points of OBJECT."
(case (type-of object)
(point (list object))
((line-segment line rectangle) (list (first-point object) (second-point object)))
(polygon (polygon-points object))
(t (error "~A has no defining points." object))))
(defun MAKE-FROM-DEFINING-POINTS (points type)
(case type
(point (car points))
(line-segment (make-line-segment (car points) (cadr points)))
(line (make-line (car points) (cadr points)))
(polygon (make-polygon points))
(rectangle (make-rectangle (min (point-x (car points)) (point-x (cadr points)))
(max (point-x (car points)) (point-x (cadr points)))
(min (point-y (car points)) (point-y (cadr points)))
(max (point-y (car points)) (point-y (cadr points)))))
(t (error "Don't know how to make a ~A." type))))
(defun DEFINING-POINT-COORDINATES-LIST (object)
"Returns a list of the x- and y-coordinates of the defining points of OBJECT."
(apply #'append
(mapcar #'(lambda (x) (multiple-value-list (point-coordinates x)))
(multiple-value-list (defining-points object)))))
(defun DEFINING-POINT-COORDINATES (object)
"Multiple-value-returns the x- and y-coordinates of the defining points of OBJECT."
(values-list
(apply #'append
(mapcar #'(lambda (x) (multiple-value-list (point-coordinates x)))
(multiple-value-list (defining-points object))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Simple generic functions. See file ??? for more complex functions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun OBJECT-EQUAL (object-1 object-2)
"Returns T if OBJECT-1 and OBJECT-2 are almost equal."
(case (geometric-type object-1)
(point (and (point-p object-2)
(point-equal object-1 object-2)))
(line-segment (and (line-segment-p object-2)
(object-equal (first-point object-1) (first-point object-2))
(object-equal (second-point object-1) (second-point object-2))))
(line (and (line-p object-2)
(colinear? object-1 object-2)))
(polygon (if (polygon-p object-2)
(error "No currently defined method of checking polygon equality")
nil))
(rectangle (and (rectangle-p object-2)
(object-equal (first-point object-1) (first-point object-2))
(object-equal (second-point object-1) (second-point object-2))))
(otherwise nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Points
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun POINT-EQUAL (pt1 pt2)
"Returns t if the two points have coordinates that are ~=."
(and (~= (point-x pt1) (point-x pt2))
(~= (point-y pt1) (point-y pt2))))
(defun POINT-COORDINATES (point)
"Multiple-value-returns the X, and Y coordinates of POINT."
(values (point-x point) (point-y point)))
(defun POINT-COORDINATES-LIST (point)
"Returns a list of the X and Y coordinates of POINT."
(list (point-x point) (point-y point)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Line Segments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Lines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Polygons
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun MAKE-POLYGON-FROM-LINES (line-segments)
"Make a polygon from line segments. This assumes that the segments are connected, and in order."
(make-polygon (loop for ls in line-segments
collecting
(line-segment-point-1 ls))))
(defun POLYGON-LINE-SEGMENTS (poly)
(loop for pt1 in (polygon-points poly)
for pt2 in (append (cdr (polygon-points poly)) (list (car (polygon-points poly))))
collecting
(make-line-segment pt1 pt2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;geometry/2d/intersect.lisp000666 002223 000322 00000034340 06050466015 015353 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(intersect? intersect-point-and-point? intersect-point-and-line-segment?
intersect-point-and-line? intersect-line-segment-and-line?
intersect-line-and-line? intersect-line-segment-and-line-segment?
intersection-object intersection-of-point-and-point
intersection-of-point-and-line-segment intersection-of-point-and-line
intersection-of-line-segment-and-line-segment
intersection-of-line-segment-and-line intersection-of-line-and-line
intersect-rectangle-and-rectangle?))
;;; To do: write intersect code for line/line-segments and polygon/rectangles.
;;; Write intersect-object code to include polygons and rectangles.
(defun INTERSECT? (object-1 object-2)
"Returns T if OBJECT-1 and OBJECT-2 intersect."
(cond ((or (null object-1) (null object-2))
;; We include this case for calls where one of the objects is itself returned by a function
nil)
((point-p object-1)
;; OBJECT-1 is a point
(case (geometric-type object-2)
(point (intersect-point-and-point? object-1 object-2))
(line-segment (intersect-point-and-line-segment? object-1 object-2))
(line (intersect-point-and-line? object-1 object-2))
((polygon rectangle) (inside? object-1 object-2))
(t (error "Can't determine if ~A and ~A intersect" object-1 object-2))))
((point-p object-2)
;; OBJECT-2 is a point, but OBJECT-1 is not
(intersect? object-2 object-1))
((line-segment-p object-1)
;; OBJECT-1 is a line segment
(cond ((line-segment-p object-2) (intersect-line-segment-and-line-segment? object-1 object-2))
((line-p object-2) (intersect-line-segment-and-line? object-1 object-2))
((rectangle-p object-2) (intersect-line-segment-and-rectangle? object-1 object-2))
(t (error "Can't determine if ~A and ~A intersect" object-1 object-2))))
((line-segment-p object-2)
;; OBJECT-2 is a line-segment, but OBJECT-1 is not
(intersect? object-2 object-1))
((line-p object-1)
;; OBJECT-1 is a line
(cond ((line-p object-2) (intersect-line-and-line? object-1 object-2))
(t (error "Can't determine if ~A and ~A intersect" object-1 object-2))))
((line-p object-2)
;; OBJECT-2 is a line, but OBJECT-1 is not
(intersect? object-2 object-1))
((rectangle-p object-1)
(cond ((rectangle-p object-2) (intersect-rectangle-and-rectangle? object-1 object-2))
(t (error "Can't determine if ~A and ~A intersect" object-1 object-2))))
(t
;; OBJECT-1 is an unknown type
(error "Can't determine if ~A and ~A intersect" object-1 object-2))))
(defun INTERSECT-POINT-AND-POINT? (point-1 point-2)
"Returns T if POINT-1 and POINT-2 coincide."
(object-equal point-1 point-2))
(defun INTERSECT-POINT-AND-LINE-SEGMENT? (point line-segment)
"
Purpose: Determines if POINT intersects LINE SEGMENT.
If they do not intersect, but come within OK-DISTANCE of each other, we count that as an intersection.
The test also holds if the line segment is degenerate.
Args: POINT -- a list (X Y)
LINE-SEGMENT -- a list of two endpoints, each endpoint a list (X Y)
Returns: T if the point and line segment intersect
"
(declare (values boolean))
;; The distance function works for degenerate line segments.
(~zerop (distance-between-point-and-line-segment point line-segment)))
(defun INTERSECT-POINT-AND-LINE? (point line)
"Returns T if POINT intersects LINE."
(colinear? point line))
(defun INTERSECT-LINE-SEGMENT-AND-LINE? (line-segment line)
"Returns T if LINE-SEGMENT and LINE intersect.
Returns T in degenerate case, where they could intersect, modulo *epsilon*,
at the end point of the line segment."
(or (colinear? line-segment line)
(not (plusp (* (side (line-point-1 line) (line-point-2 line) (line-segment-point-1 line-segment))
(side (line-point-1 line) (line-point-2 line) (line-segment-point-2 line-segment)))))))
(defun INTERSECT-LINE-AND-LINE? (line-1 line-2)
"Returns T if LINE-1 and LINE-2 intersect."
(or (not (parallel? line-1 line-2))
(colinear? line-1 line-2)))
(defun INTERSECT-LINE-SEGMENT-AND-LINE-SEGMENT? (line-segment-1 line-segment-2 &optional (ok-distance *epsilon*))
"
Purpose: Determines if LINE-SEGMENT-1 intersects LINE-SEGMENT-2.
If they do not intersect, but come within OK-DISTANCE of each other, we count that as an intersection.
The test also holds for degenerate line segments.
Args: LINE-SEGMENT-1 -- a line-segment
LINE-SEGMENT-2 -- a line-segment
OK-DISTANCE -- distance within which we declare an intersection
Returns: T if the segments intersect, modulo OK-DISTANCE
"
(declare (values boolean))
;; Make the endpoints easier to get at
(let ((seg1-a (line-segment-point-1 line-segment-1))
(seg1-b (line-segment-point-2 line-segment-1))
(seg2-a (line-segment-point-1 line-segment-2))
(seg2-b (line-segment-point-2 line-segment-2)))
(if (point-equal seg1-a seg1-b)
;; Segment 1 is degenerate. (The distance function works for degenerate line segments.)
(<= (distance-between-point-and-line-segment seg1-a line-segment-2) ok-distance)
;; Segment 1 is not degenerate
(if (point-equal seg2-a seg2-b)
;; Segment 2 is degenerate
(<= (distance-between-point-and-line-segment seg2-a line-segment-1) ok-distance)
;; Segment 2 is not degerate
(or
;; Check if the endpoints of one segment fall on either side of the line of the other segment, and vice-versa.
;; If the two segments are colinear, the endpoints fall on the line of the other line segment, so "on the line" isn't good enough.
(and (not (plusp (* (side seg1-a seg1-b seg2-a) (side seg1-a seg1-b seg2-b))))
(not (plusp (* (side seg2-a seg2-b seg1-a) (side seg2-a seg2-b seg1-b)))))
;; Check for an endpoint intersecting the other segment
(<= (distance-between-point-and-line-segment seg1-a line-segment-2) ok-distance)
(<= (distance-between-point-and-line-segment seg1-b line-segment-2) ok-distance)
(<= (distance-between-point-and-line-segment seg2-a line-segment-1) ok-distance)
(<= (distance-between-point-and-line-segment seg2-b line-segment-1) ok-distance))))))
(defun INTERSECT-RECTANGLE-AND-RECTANGLE? (r1 r2)
(and
;; Overlap in x dimension?
(<= (rectangle-min-x r1) (rectangle-max-x r2)) (<= (rectangle-min-x r2) (rectangle-max-x r1))
;; Overlap in y dimension?
(<= (rectangle-min-y r1) (rectangle-max-y r2)) (<= (rectangle-min-y r2) (rectangle-max-y r1))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Intersection-object functions (return intersection object or NIL)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun INTERSECTION-OBJECT (object-1 object-2)
"Returns the intersection object of OBJECT-1 and OBJECT-2, or NIL if they do not intersect."
(cond ((or (null object-1) (null object-2))
;; We include this case for calls where one of the objects is itself returned by a function
nil)
((point-p object-1)
;; OBJECT-1 is a point
(cond ((point-p object-2) (intersection-of-point-and-point object-1 object-2))
((line-segment-p object-2) (intersection-of-point-and-line-segment object-1 object-2))
((line-p object-2) (intersection-of-point-and-line object-1 object-2))
(t (error "Can't determine intersection between ~A and ~A" object-1 object-2))))
((point-p object-2)
;; OBJECT-2 is a point, but OBJECT-1 is not
(intersection-object object-2 object-1))
((line-segment-p object-1)
;; OBJECT-1 is a line segment
(cond ((line-segment-p object-2) (intersection-of-line-segment-and-line-segment object-1 object-2))
((line-p object-2) (intersection-of-line-segment-and-line object-1 object-2))
(t (error "Can't determine intersection between ~A and ~A" object-1 object-2))))
((line-segment-p object-2)
;; OBJECT-2 is a line-segment, but OBJECT-1 is not
(intersection-object object-2 object-1))
((line-p object-1)
;; OBJECT-1 is a line
(cond ((line-p object-2) (intersection-of-line-and-line object-1 object-2))
(t (error "Can't determine intersection between ~A and ~A" object-1 object-2))))
((line-p object-2)
;; OBJECT-2 is a line, but OBJECT-1 is not
(intersection-object object-2 object-1))
(t
;; OBJECT-1 is an unknown type
(error "Can't determine intersection between ~A and ~A" object-1 object-2))))
(defun INTERSECTION-OF-POINT-AND-POINT (point-1 point-2)
"Returns POINT-1 if POINT-1 and POINT-2 coincide."
(when (object-equal point-1 point-2) point-1))
(defun INTERSECTION-OF-POINT-AND-LINE-SEGMENT (point line-segment)
"Returns POINT if POINT and LINE-SEGMENT intersect."
(when (intersect? point line-segment) point))
(defun INTERSECTION-OF-POINT-AND-LINE (point line)
"Returns POINT if POINT and LINE intersect."
(when (intersect? point line) point))
(defun INTERSECTION-OF-LINE-SEGMENT-AND-LINE-SEGMENT (line-segment-1 line-segment-2)
"Returns the intersection point or line-segment of LINE-SEGMENT-1 and LINE-SEGMENT-2, or NIL if they do not intersect."
(let ((intersection-point (intersection-of-line-and-line (g-coerce line-segment-1 'line) (g-coerce line-segment-2 'line))))
(cond ((point-p intersection-point)
;; Does the intersection point lie in each segment?
(when (and (intersect-point-and-line-segment? intersection-point line-segment-1)
(intersect-point-and-line-segment? intersection-point line-segment-2))
intersection-point))
(intersection-point
;; The lines are colinear. See if they overlap.
(let ((point-1-1 (first-point line-segment-1))
(point-1-2 (second-point line-segment-1))
(point-2-1 (first-point line-segment-2))
(point-2-2 (second-point line-segment-2))
(intersection-endpoints ()))
;; Find the overlap, if any, of the segments.
(when (intersect-point-and-line-segment? point-1-1 line-segment-2)
(push point-1-1 intersection-endpoints))
(when (intersect-point-and-line-segment? point-1-2 line-segment-2)
(push point-1-2 intersection-endpoints))
(when (intersect-point-and-line-segment? point-2-1 line-segment-1)
(push point-2-1 intersection-endpoints))
(when (intersect-point-and-line-segment? point-2-2 line-segment-1)
(push point-2-2 intersection-endpoints))
;; Check the overlap
(case (length (setf intersection-endpoints (delete-duplicates intersection-endpoints :test #'object-equal)))
(0 nil) ;No overlap
(1 (first intersection-endpoints)) ;Overlap at an enpoint
(2 ;Two endpoints overlap
(make-line-segment (first intersection-endpoints) (second intersection-endpoints))) ;Normal overlap
(4 line-segment-1) ;Segments are equal
(otherwise (error "Things are pretty screwed up in INTERSECTION-OF-LINE-SEGMENT-AND-LINE-SEGMENT")))))
(t
;; The lines are parallel and not colinear
nil))))
(defun INTERSECTION-OF-LINE-SEGMENT-AND-LINE (line-segment line)
"Returns the intersection point or line-segment of LINE-SEGMENT and LINE, or NIL if they do not intersect."
(let ((intersection-point (intersection-of-line-and-line (g-coerce line-segment 'line) line)))
(cond ((point-p intersection-point)
;; The lines intersect in a point. Does the intersection point lie in the segment?
(when (intersect-point-and-line-segment? intersection-point line-segment)
intersection-point))
(intersection-point
;; LINE-SEGMENT and LINE are colinear. Return LINE-SEGMENT.
line-segment)
(t
;; The lines are parallel and do not intersect.
nil))))
(defun INTERSECTION-OF-LINE-AND-LINE (line-1 line-2)
"
Purpose: Find the intersection of two lines
Args: LINE-1
LINE-2
Returns: a point if the lines intersect
One of the lines if the lines are colinear
Nil if the lines are parallel but not colinear
"
(declare (values point-or-boolean))
(multiple-value-bind (x1 y1) (point-coordinates (line-point-1 line-1))
(multiple-value-bind (x2 y2) (point-coordinates (line-point-2 line-1))
(multiple-value-bind (x3 y3) (point-coordinates (line-point-1 line-2))
(multiple-value-bind (x4 y4) (point-coordinates (line-point-2 line-2))
(let ((denominator (- (* (- x4 x3) (- y2 y1))
(* (- y4 y3) (- x2 x1)))))
(if (~zerop denominator)
;; Lines are parallel and maybe colinear
(if (colinear? line-1 line-2) line-1 nil)
;; Lines actually intersect
(let ((beta (/ (- (* (- y3 y1) (- x2 x1))
(* (- x3 x1) (- y2 y1)))
denominator)))
(make-point (+ x3 (* beta (- x4 x3)))
(+ y3 (* beta (- y4 y3))))))))))))
(line-point-1 line-2))
(multiple-value-bind (x4 y4) (point-coordinates (line-point-2 line-2))
(let ((denominator (- (* (- x4 x3) (- y2 y1))
(* (- y4 y3) (- x2 x1)))))
(if (~zerop denominator)
;; Lines are parallel and maybe colinear
(if (colinear? line-1 line-2) line-1 geometry/2d/linearfit.lisp000666 002223 000322 00000030376 06050466017 015337 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:2DG; Syntax:Common-lisp; Lowercase:Yes -*-
;;; Copyright 1988, 1989 (c) David J. Braunegg. All rights reserved.
;;; Distribution of this file is unrestricted provided that this notice is not removed.
;;;; File: LINEARFIT.LSP
;;;;
;;;; Purpose: Functions to perform a least-squares linear fit to a set of 2D data points. (Slope-intercept or rho-theta line description.)
;;;; Also code for drawing a rho-theta line.
;;;;
;;;; Author: David J. Braunegg
;;;; Creation Date: May 9, 1988
;;;; Modifications to released version:
;;;; Programmer Date Description of modifications
;;;; ________________ ___________ _________________________________________________________________
;;;;
;;;;
;;;; Comments:
;;;; 1) Reference: Robot Vision by B. K. P. Horn, Section 3.2, pp. 48--53
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Export
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(export '(least-squares-rho-theta
least-squares-slope-intercept
rho-theta-to-slope-intercept
slope-intercept-to-rho-theta
line-intersection-rho-theta
line-intersection-slope-intercept
closest-rho-theta-line-point
distance-between-point-and-rho-theta-line
distance-squared-between-point-and-rho-theta-line))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Rho-Theta Line Fitting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LEAST-SQUARES-RHO-THETA (point-list)
"
Purpose: Fit a line to a point set, minimizing the sum of the distances from the points to the line.
Args: POINT-LIST -- a list of point to which we fit a line.
Returns: a list of (Line X Y), where
Line -- The line that best fits the points
X-BAR -- x-coordinate of center of area
Y-BAR -- y-coordinate of center of area
"
(declare (values (rho theta x-bar y-bar)))
;; Find the center of area of the points, which we will use as a point on the line.
(let (x-bar y-bar a b c)
(loop for (x y) in (mapcar #'point-coordinates-list point-list)
as count from 1
sum x into sum-x
sum y into sum-y
finally
(setf x-bar (float (/ sum-x count)))
(setf y-bar (float (/ sum-y count))))
;; Find the angle (slope) of the line
(loop for (x y) in (mapcar #'point-coordinates-list point-list)
as x-prime = (- x x-bar)
as y-prime = (- y y-bar)
sum (sq x-prime) into almost-a
sum (* x-prime y-prime) into almost-b
sum (sq y-prime) into almost-c
finally
(setf a almost-a)
(setf b (* 2 almost-b))
(setf c almost-c))
(let ((theta (/ (atan b (- a c)) 2.0)))
(list (line-from-rho-theta (- (* y-bar (cos theta)) (* x-bar (sin theta))) theta) x-bar y-bar))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Slope-Intercept Line Fitting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LEAST-SQUARES-SLOPE-INTERCEPT (point-list)
"
Purpose: Fit a line to a point set, minimizing the sum of the vertical (y) distances from the points to the line.
The line determined has the form y = mx + b.
Args: POINT-LIST -- a list of point to which we fit a line.
Returns: a line
Returns: a list of (Line X-BAR Y-BAR), where
X-BAR -- x-coordinate of center of area
Y-BAR -- y-coordinate of center of area
"
(declare (values (m b)))
(loop for (x y) in (mapcar #'point-coordinates-list point-list)
with n = (length point-list)
sum x into sum-x
sum y into sum-y
sum (* x y) into sum-x-y
sum (* x x) into sum-x-squared
finally
(return
(list
(line-from-slope-intercept
;; M
(/ (float (- (* n sum-x-y) (* sum-x sum-y)))
(float (- (* n sum-x-squared) (* sum-x sum-x))))
;; B
(/ (float (- (* sum-y sum-x-squared) (* sum-x sum-x-y)))
(float (- (* n sum-x-squared) (* sum-x sum-x)))))
;; X-BAR
(/ sum-x (float n))
;; Y-BAR
(/ sum-y (float n))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Line equation conversions: slope-intercept to rho-theta and vice-versa
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun RHO-THETA-TO-SLOPE-INTERCEPT (rho theta)
"
Purpose: Convert rho-theta representation of a line to slope-intercept representation
Args: RHO -- distance from origin to line
THETA -- angle of the line wrt x-axis, in radians, CCW positive
Returns: a list of the slope (m) and y-intercept (b) of the line
"
(declare (values (m b)))
(list (tan theta) (/ rho (cos theta))))
(defun SLOPE-INTERCEPT-TO-RHO-THETA (m b)
"
Purpose: Convert slope-intercept representation of a line to rho-theta representation
Args: M -- slope of line
B -- y-intercept of line
Returns: a list of the distance from the origin to the line (rho) and the angle of the line wrt the x-axis (theta), in radians, CCW positive
"
(declare (values (rho theta)))
(list (* b (/ 1 (sqrt (1+ (sq m))))) (atan m)))
(defun LINE-FROM-RHO-THETA (rho theta)
"The line determined has the form x*sin(theta) + y*cos(theta) + rho = 0."
(if (= 0 (cos theta)) (make-line (make-point 0 0) (make-point 0 1)) ; vertical line
(make-line (make-point 0 (/ rho (cos theta)))
(make-point 1 (/ (+ rho (sin theta)) (cos theta))))))
(defun LINE-FROM-SLOPE-INTERCEPT (m b)
"The line determined has the form y = mx + b."
(make-line (make-point 0 b)
(make-point 1 (+ m b))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Line intersections
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LINE-INTERSECTION-RHO-THETA (rho-1 theta-1 rho-2 theta-2)
"
Purpose: Find the intersection point of two lines
Args: RHO-1 -- distance from origin to line 1
THETA-1 -- angle of line 1 wrt x-axis, in radians, CCW positive
RHO-2 -- distance from origin to line 2
THETA-2 -- angle of line 2 wrt x-axis, in radians, CCW positive
Returns: The intersection point
NIL if the lines are parallel and not coincident, or
T if the lines coincide
Caveats: If either of THETA-1 or THETA-2 is a double-float, we assume that the other is also
Remarks: Modified from edge-intersection-coordinates in WH:/HL/DMS/LISPM/HAPTICS/OBJECTS.LISP
"
(declare (values (x y)))
(let ((t-1 (if (typep theta-1 'double-float) (mod theta-1 *2pi*) (mod theta-1 *short-2pi*)))
(t-2 (if (typep theta-2 'double-float) (mod theta-2 *2pi*) (mod theta-2 *short-2pi*))))
(cond
;; Check for parallel lines
((= t-1 t-2)
;; Equal angles
(if (= rho-1 rho-2)
t
()))
((or (and (typep theta-2 'double-float) (= t-1 (mod (+ theta-2 pi) *2pi*)))
(= t-1 (mod (+ t-2 *short-pi*) *short-2pi*)))
;; Opposite angles
(if (= rho-1 (- rho-2))
t
()))
;; Non-Parallel lines
(t
(let ((y (/ (- (* rho-2 (sin theta-1)) (* rho-1 (sin theta-2)))
(- (* (sin theta-1) (cos theta-2)) (* (sin theta-2) (cos theta-1))))))
(make-point
;; x
(if (= (sin theta-1) 0)
(/ (- (* y (cos theta-2)) rho-2)
(sin theta-2))
(/ (- (* y (cos theta-1)) rho-1)
(sin theta-1)))
;; y
y))))))
(defun LINE-INTERSECTION-SLOPE-INTERCEPT (m-1 b-1 m-2 b-2)
"
Purpose: Find the intersection point of two lines
Args: M-1 -- slope of line 1
B-1 -- y-intercept of line 1
M-2 -- slope of line 2
B-2 -- y-intercept of line 2
Returns: The intersection point, as a list (x y), or
NIL if the lines are parallel and not coincident, or
T if the lines coincide
Caveat: Since arbitrary vertical lines cannot be represented in slope-intercept form, if either slope is infinity an error is generated.
"
(declare (values (x y)))
(when (or (= m-1 +1e) (= m-2 +1e) (= m-1 -1e) (= m-2 -1e))
(error "Vertical lines are not allowed."))
(cond
;; Check for parallel lines
((= m-1 m-2)
;; Equal slopes
(if (= b-1 b-2)
t
()))
;; Non-Parallel lines
(t
(let ((x (/ (- b-2 b-1) (- m-1 m-2))))
(make-point
;; X
x
;; Y
(+ (* m-1 x) b-1))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Closest point
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CLOSEST-RHO-THETA-LINE-POINT (point rho-theta)
"
Purpose: Find the point on a RHO-THETA line closest to a given POINT
Args: POINT
RHO-THETA -- a list (RHO THETA) describing the line
Returns: A point on the line
Reference: Robot Vision, p. 51
"
(declare (values point))
;; New method (from BKPH's book)
(let* ((rho (first rho-theta))
(theta (second rho-theta))
(cos-theta (cos theta))
(sin-theta (sin theta))
(s (+ (* (point-x point) cos-theta) (* (point-y point) sin-theta))))
(make-point (- (* s cos-theta) (* rho sin-theta))
(+ (* rho cos-theta) (* s sin-theta)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Distance functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DISTANCE-BETWEEN-POINT-AND-RHO-THETA-LINE (point rho-theta)
"
Purpose: Find the Euclidean distance between a point and a line.
Args: POINT
RHO-THETA -- a list (RHO THETA) describing the line
Returns: Multiple-value-returns the Euclidean distance between POINT and the line described by RHO-THETA
and the point on the line closest to POINT.
"
(declare (values distance))
(multiple-value-bind (dist-sq pt) (distance-squared-between-point-and-rho-theta-line point rho-theta)
(values (sqrt dist-sq) pt)))
(defun DISTANCE-SQUARED-BETWEEN-POINT-AND-RHO-THETA-LINE (point rho-theta)
"
Purpose: Find the square of the Euclidean distance between a point and a line.
Args: POINT
RHO-THETA -- a list (RHO THETA) describing the line
Returns: Multiple-value-returns the square of the Euclidean distance between POINT and the line described by RHO-THETA
and the point on the line closest to POINT.
"
(declare (values distance-squared))
(let ((closest-point (closest-rho-theta-line-point point rho-theta)))
(values (distance-squared-between-point-and-point point closest-point) closest-point)))
Find the square of the Euclidean distance between a point and a line.
Args: POINT
RHO-THETA -- a list (RHO THETA) describing the line
Returns: Multiple-value-returns the square of the Euclidean distance between POINT and the line described by RHO-THETAgeometry/2d/optional.lisp000666 002223 000322 00000006416 06050466021 015200 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:2DG; Syntax:Common-lisp; -*-
(defvar OPTIONAL-FILES-LIST
"List contains lists of two items. The first is a string describing the application , the second
contains a list of the name of the files used by the application.")
(setq OPTIONAL-FILES-LIST (list (list "Polygon, and rectangle specific code"
(list "polyrect"))
(list "Generate random objects"
(list "random"))
(list "Fit a line to points"
(list "linearfit"))
(list "Convex Hulls"
(list "convex"))
(list "Extract Strings from Edges"
(list "string"))
(list "Straight Line Approximations to Edges"
(list "string" "straight"))
))
(defun ALL-FILES ()
(send file-menu ':set-highlighted-items optional-files-list)
(send file-menu ':highlighted-values))
(defun FILES-DO-IT ()
(send file-menu ':highlighted-values))
(defvar FILE-CHOICES)
(defvar FILE-MENU)
(setq FILE-CHOICES '(("Do it" :eval (files-do-it)) ("All" :eval (all-files))))
(setq FILE-MENU
(tv:make-window 'tv:multiple-menu ':label "Optional Applications" ':borders 3
':item-list optional-files-list ':special-choices file-choices))
(defun ACTION-ON-FILES ()
(send file-menu ':expose-near '(:mouse))
(let ((files-to-load (loop for files in (send file-menu ':choose) appending files)))
(send file-menu ':deactivate)
(loop for file in files-to-load
doing
(load (string-append "geometry-2d:geometry-2d;" file)))))
(action-on-files)
val (all-files))))
(setq FILE-MENU
(tv:make-window 'tv:multiple-menu ':label "Optional Applications" ':borders 3
':item-list optional-files-list ':special-choices file-choices))
(defun ACTION-ON-FILES ()
(send file-menu ':exgeometry/2d/polyrect.lisp000666 002223 000322 00000027446 06050466000 015217 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(inside? point-inside-rectangle? point-inside-polygon? point-inside-convex-polygon? polygon-diameter
intersect-rectangle-and-convex-polygon? line-segment-crosses-rectangle? intersect-line-segment-and-rectangle?))
(defun INSIDE? (object container)
(case (geometric-type object)
(point (case (geometric-type container)
(polygon (point-inside-polygon? object container))
(rectangle (point-inside-rectangle? object container))
(t (error "Don't know how to find out if a point is inside ~A" container))))
(line-segment (case (geometric-type container)
(rectangle (and (inside? (line-segment-point-1 object) container)
(inside? (line-segment-point-1 object) container)))
(t (error "Don't know how to find out if a line segment is inside ~A" container))))
(line nil)
(polygon (case (geometric-type container)
(rectangle (loop for point in (polygon-points object)
always
(inside? point container)))
(t (error "Don't know how to find out if a polygon is inside ~A" container))))
(rectangle (case (geometric-type container)
(rectangle (and (point-inside-rectangle? (first-point object) container)
(point-inside-rectangle? (second-point object) container)))
(t (error "Don't know how to find out if a rectangle is inside ~A" container))))))
(defun POINT-INSIDE-RECTANGLE? (pt rect)
(let ((x (point-x pt))
(y (point-y pt)))
(and (~<= (rectangle-min-x rect) x)
(~<= x (rectangle-max-x rect))
(~<= (rectangle-min-y rect) y)
(~<= y (rectangle-max-y rect)))))
(defun POINT-INSIDE-POLYGON? (point polygon)
"
Purpose: Determine if a point is inside of or on one of the edges of a simple polygon.
Works for degenerate polygons as long as no point is repeated.
Returns: T if POINT is inside or on an edge of POLYGON.
"
(declare (values boolean))
(let ((vertices (polygon-points polygon)))
(cond ((= 2 (length vertices))
(intersect-point-and-line-segment? point (make-line-segment (car vertices) (cadr vertices))))
((member point vertices :test #'point-equal)
t) ;POINT was a POLYGON vertex
(t
(multiple-value-bind (extreme-vertex extreme-position) (extreme-point vertices)
;; Reorder the polygon from the vertex with min y-coordinate (and min x-coordinate if there is a tie)
(let ((reordered-vertices (append (nthcdr extreme-position vertices)
(butlast vertices (- (length vertices) extreme-position 1))))
(point-x (point-x point))
(point-y (point-y point)))
(when (~<= (point-y extreme-vertex) (point-y point)) ;POLYGON doesn't sit totally above POINT
(loop for (x y) in (mapcar #'point-coordinates-list reordered-vertices)
with count = 0
with last-x = (point-x extreme-vertex)
with last-y = (point-y extreme-vertex)
with horizontal-intersect
do
;; Count the number of intersections of the polygon with a line drawn horizontally to the left from POINT.
;; An odd number of intersections means we are inside.
(cond ((~= last-y point-y y)
;; The current polygon side is horizontal and in line with POINT. Does POINT lie on it?
(and (monotonic? last-x point-x x) t))
((~= last-x point-x x)
;; The current polygon side is vertical and in line with POINT. Does POINT lie on it?
(and (monotonic? last-y point-y y) t))
((~= y point-y)
;; POINT is horizontal with one endpoint of the current segment. Count a crossing if it is the upper endpoint and it is to the left POINT.
(and (> y last-y) (< x point-x) (incf count)))
((~= last-y point-y)
;; POINT is horizontal with one endpoint of the current segment. Count a crossing if it is the upper endpoint and it is to the left POINT.
(and (> last-y y) (< last-x point-x) (incf count)))
((monotonic? last-y point-y y)
;; We crossed the horizontal of POINT
(setf horizontal-intersect (horizontal-intersect point-y last-x last-y x y))
(cond ((~= horizontal-intersect point-x)
;; POINT lies on this edge
(return t))
((< horizontal-intersect point-x)
;; The polygon edge is to the left of POINT
(incf count)))))
;; Keep track of last vertex
(setf last-x x
last-y y)
finally
(return (oddp count))))))))))
(defun POINT-INSIDE-CONVEX-POLYGON? (point convex-polygon)
"
Purpose: Determine if a point is inside of or on one of the edges of a convex polygon.
Works for degenerate polygons as long as no point is repeated.
Doesn't actually check that polygon is convex.
Returns: T if POINT is inside or on an edge of CONVEX-POLYGON.
"
(declare (values boolean))
(let ((vertices (polygon-points convex-polygon)))
(cond ((= 2 (length convex-polygon))
(intersect-point-and-line-segment? point (make-line-segment (car vertices) (cadr vertices))))
((member point convex-polygon :test #'point-equal)
t) ;POINT was a CONVEX-POLYGON vertex
(t
(multiple-value-bind (extreme-vertex extreme-position) (extreme-point vertices)
;; Reorder the convex-polygon from the vertex with min y-coordinate (and min x-coordinate if there is a tie)
(let ((reordered-vertices (append (nthcdr extreme-position convex-polygon)
(butlast vertices (- (length vertices) extreme-position 1))))
(point-x (point-x point))
(point-y (point-y point)))
(when (~<= (point-y extreme-vertex) (point-y point))
nil ;CONVEX-POLYGON sits totally above POINT
(loop for (x y) in (mapcar #'point-coordinates-list reordered-vertices)
with count = 0
with last-x = (point-x extreme-vertex)
with last-y = (point-y extreme-vertex)
with horizontal-intersect
do
;; Count the number of intersections of the polygon with a line drawn horizontally to the left from POINT. A single intersection means we are inside.
(cond ((~= last-y point-y y)
;; The current polygon side is horizontal and in line with POINT. Does POINT lie on it?
(and (monotonic? last-x point-x x) (return t)))
((~= last-x point-x x)
;; The current polygon side is vertical and in line with POINT. Does POINT lie on it?
(and (monotonic? last-y point-y y) (return t)))
((~= y point-y)
;; POINT is horizontal with one endpoint of the current segment. Count a crossing if it is the upper endpoint and it is to the left POINT.
(and (> y last-y) (< x point-x) (incf count)))
((~= last-y point-y)
;; POINT is horizontal with one endpoint of the current segment. Count a crossing if it is the upper endpoint and it is to the left POINT.
(and (> last-y y) (< last-x point-x) (incf count)))
((monotonic? last-y point-y y)
;; We crossed the horizontal of POINT
(setf horizontal-intersect (horizontal-intersect point-y last-x last-y x y))
(cond ((~= horizontal-intersect point-x)
;; POINT lies on this edge
(return t))
((< horizontal-intersect point-x)
;; The polygon edge is to the left of POINT
(incf count)))))
;; If we intersect the CONVEX-POLYGON twice, we can't be inside it
(when (= count 2) (return nil))
;; Keep track of last vertex
(setf last-x x
last-y y)
finally
(return (= count 1))))))))))
(defun MONOTONIC? (a b c)
"
Purpose: Determine if three numbers are monotonically increasing or decreasing.
Args: A -- a number
B -- a number
C -- a number
Returns: T if the sequence A B C is monotonic
"
(declare (values boolean))
(or (<= a b c)
(>= a b c)))
(defun HORIZONTAL-INTERSECT (y x1 y1 x2 y2)
"
Purpose: Assuming that y1 /= y2, find the intersection of the line through (X1 Y1) and (X2 Y2) with the horizontal line through Y.
Args: Y -- y-coordinate of horizontal line of interest
X1 -- x-coordinate of one point on line
Y1 -- y-coordinate of one point on line
X2 -- x-coordinate of other point on line
Y2 -- y-coordinate of other point on line
Returns: x-coordinate of intersection point
"
(declare (values x-coordinate))
(if (= x1 x2)
x1
;; Assume y /= y1 /= y2
(+ x2 (* (/ (- y y2) (- y1 y2)) (- x1 x2)))))
(defun POLYGON-DIAMETER (poly)
(let ((points (polygon-points poly)))
(loop for pt1 in points
for rest-points on (cdr points)
maximize
(loop for pt2 in rest-points
maximize
(distance pt1 pt2)))))
(defun INTERSECT-RECTANGLE-AND-CONVEX-POLYGON? (rect poly)
(or (loop for pt in (polygon-points poly)
thereis
(inside? pt rect))
(loop for line in (polygon-line-segments poly)
thereis
(line-segment-crosses-rectangle? line rect))))
(defun INTERSECT-LINE-SEGMENT-AND-RECTANGLE? (ls rect)
(or (inside? (line-segment-point-1 ls) rect)
(inside? (line-segment-point-2 ls) rect)
(line-segment-crosses-rectangle? ls rect)))
(defun LINE-SEGMENT-CROSSES-RECTANGLE? (ls rect)
(let* ((pt1 (line-segment-point-1 ls))
(pt2 (line-segment-point-2 ls))
(x1 (point-x pt1))
(y1 (point-y pt1))
(x2 (point-x pt2))
(y2 (point-y pt2))
(m (/ (- y2 y1) (- x2 x1)))
(b (- y1 (* m x1)))
(bottom-cross (/ (- (rectangle-min-y rect) b) m))
(top-cross (/ (- (rectangle-max-y rect) b) m))
(left-cross (+ b (* (rectangle-min-x rect) m)))
(right-cross (+ b (* (rectangle-max-x rect) m))))
(or (and (~<= (min x1 x2) (rectangle-min-x rect))
(~<= (rectangle-min-x rect) (max x1 x2))
(~<= (rectangle-min-y rect) left-cross)
(~<= left-cross (rectangle-max-y rect)))
(and (~<= (min x1 x2) (rectangle-max-x rect))
(~<= (rectangle-max-x rect) (max x1 x2))
(~<= (rectangle-min-y rect) right-cross)
(~<= right-cross (rectangle-max-y rect)))
(and (~<= (min y1 y2) (rectangle-min-y rect))
(~<= (rectangle-min-y rect) (max y1 y2))
(~<= (rectangle-min-x rect) bottom-cross)
(~<= bottom-cross (rectangle-max-x rect)))
(and (~<= (min y1 y2) (rectangle-max-y rect))
(~<= (rectangle-max-y rect) (max y1 y2))
(~<= (rectangle-min-x rect) top-cross)
(~<= top-cross (rectangle-max-x rect))))))
(rectangle-max-x rect) (max x1 x2))
(~<= (rectangle-min-y rect) right-cross)
(~<= right-cross (rectangle-max-y rect)))
(and (~<= (min y1 y2) (rectangle-min-y rect))
(~<= (rectangle-min-y rect) (max ygeometry/2d/random.lisp000666 002223 000322 00000022317 06050466002 014630 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package 2DG)
;;; This file contains code to create a random convex polygon.
;;; It's not obvious, at least to me, what it means to make a random polygon from a uniform
;;; Distribution over all polygons. The approach taken here is to allow the user to provide
;;; distributions on certain aspects of a polygon, with defaults provided for all distributions.
;;; First of all, the user provides a function which, when called with no arguments, returns the
;;; number of sides the polygon should have. Secondly, the user provides a scaling function, which
;;; decides how big the polygon should be. Given a polygon, this function returns a factor by which
;;; the polygon is scaled. For example, the default is to choose a diameter randomly from between
;;; *MIN-RANDOM-POLYGON-DIAMETER*, and *MAX-RANDOM-POLYGON-DIAMETER*, and scale the polygon so that it has that diameter.
;;; Next, a length function is provided. This is called with no arguments, and returns the length of a
;;; side of the polygon. Finally, an angle function is provided, which is called with the total number
;;; of sides of the polygon, the angles selected so far, a minimum angle and a maximum angle.
;;; First, the sides function is called, to find the the number of sides the polygon has. Next, the length
;;; function is called that number of times, to find the length of each side. Finally, if there are n sides,
;;; the angle function is called (n - 2) times, to find all but 2 of the polygon angles. Since a collection of
;;; too large or too small angles will make it impossible to form a convex polygon, we calculate the minimum
;;; and maximum possible angles before each call to the angle generating function. This function may return
;;; nil too indicate that the whole process should begin over in generating a random convex polygon.
;;; This whole process is a bit kludgey, but fine for generating sort of random polygons with no specific
;;; characteristics.
(export '(random-polygon random-polygon-uniform-vertices))
(defvar *MAX-RANDOM-POLYGON-DIAMETER* 100)
(defvar *MIN-RANDOM-POLYGON-DIAMETER* 10)
(defvar *MAX-RANDOM-POLYGON-ANGLE* (- PI .01))
(defvar *MIN-RANDOM-POLYGON-ANGLE* .01)
(defvar *MAX-RANDOM-POLYGON-EDGE-LENGTH* 10.0)
(defvar *MIN-RANDOM-POLYGON-EDGE-LENGTH* 2.0)
(defun *DEFAULT-SIDES-FUNCTION* ()
(+ 3 (random 4)))
(defun *DEFAULT-SIZE-FUNCTION* (poly)
(let ((dia (random-between *MIN-RANDOM-POLYGON-DIAMETER* *MAX-RANDOM-POLYGON-DIAMETER*)))
(/ dia (polygon-diameter poly))))
;;; The idea is to figure out the average angle value left over, and pick an angle
;;; from a distribution that slopes linearly upward from a minimum to that angle,
;;; then slopes downward to the maximum possible angle.
(defun *DEFAULT-ANGLE-FUNCTION* (num-sides angles min-angle max-angle)
(when (< min-angle max-angle)
(let* ((total-angles (* PI (- num-sides 2)))
(angles-left (- total-angles (apply #'+ angles)))
(number-angles-left (- num-sides (length angles)))
(average-left (/ angles-left number-angles-left))
(above-average? (> (+ min-angle (random (- max-angle min-angle)))
average-left)))
(if above-average? (+ average-left (random (random (- max-angle average-left))))
(- average-left (random (random (- average-left min-angle))))))))
(defun *DEFAULT-LENGTH-FUNCTION* ()
(+ *MIN-RANDOM-POLYGON-EDGE-LENGTH*
(random (- *MAX-RANDOM-POLYGON-EDGE-LENGTH* *MIN-RANDOM-POLYGON-EDGE-LENGTH*))))
(defun RANDOM-POLYGON (&key (sides #'*default-sides-function*)
(size #'*default-size-function*)
(length #'*default-length-function*)
(angle-function #'*default-angle-function*)
&aux (polygon nil))
(let ((num-sides (apply sides nil)))
(loop while (not polygon)
doing
(let ((lengths (loop for i from 1 to num-sides
collecting
(apply length nil))))
(setf polygon (calculate-polygon lengths angle-function))))
(multiply polygon (apply size (list polygon)))))
(defun RANDOM-POLYGON-UNIFORM-VERTICES (&key (sides #'*default-sides-function*)
(image-size-x 500) (image-size-y 500))
(let ((num-sides (apply sides nil)))
(loop for vertices = (n-random-round-points num-sides image-size-x image-size-y)
for convex-hull = (jarvis-march-convex-hull vertices)
until (= num-sides (length convex-hull))
finally (return (make-polygon convex-hull)))))
(defun N-RANDOM-ROUND-POINTS (n max-x max-y)
(loop repeat n
collecting
(make-point (random max-x) (random max-y))))
;;; This proc creates a polygon on n sides with n side-lengths, and an angle generating function.
(defun CALCULATE-POLYGON (side-lengths angle-function &aux (polygon-possible t))
(let* ((lines (list (make-line-segment (make-point (car side-lengths) 0) (make-point 0 0))))
(angles nil)
(num-sides (length side-lengths))
(total-angles (* PI (- num-sides 2))))
(loop for length in (nthrdc 2 (cdr side-lengths))
while polygon-possible
doing
(let* ((angles-left (- total-angles (apply #'+ angles)))
(number-angles-left (- num-sides (length angles)))
(angle
(apply angle-function
(list num-sides angles
(max *MIN-RANDOM-POLYGON-ANGLE*
(- angles-left (* (1- number-angles-left) *MAX-RANDOM-POLYGON-ANGLE*))
(connected-line-angle
(make-line-segment (make-point 0 0) (line-segment-point-1 (car lines)))
(car lines)))
(min *MAX-RANDOM-POLYGON-ANGLE*
(- angles-left (* (1- number-angles-left)
*MIN-RANDOM-POLYGON-ANGLE*)))))))
(if angle
(progn (push angle angles) (push (calculate-line angle length (car lines)) lines))
(setf polygon-possible nil))))
(if (not polygon-possible) nil
(let ((next-length (nlast 1 side-lengths))
(last-length (nlast 0 side-lengths))
(length-left (distance (line-segment-point-1 (car lines))
(make-point 0 0))))
(if (not (lengths-make-triangle next-length last-length length-left)) nil
(let ((next-angle
(+ (connected-line-angle (make-line-segment (make-point 0 0) (line-segment-point-1 (car lines)))
(car lines))
(angle-from-sides last-length length-left next-length)))
(mid-angle (angle-from-sides length-left last-length next-length))
(last-angle
(+ (connected-line-angle (nlast 0 lines)
(make-line-segment (make-point 0 0) (line-segment-point-1 (car lines))))
(angle-from-sides next-length last-length length-left))))
(if (or (< PI next-angle) (< PI mid-angle) (< PI last-angle))
nil
(progn
(push (calculate-line next-angle next-length (car lines)) lines)
(push (calculate-line mid-angle last-length (car lines)) lines)
(make-polygon-from-lines lines)))))))))
;;; Given a line, an angle and a length, determine a new line that connects to
;;; the start of the old line.
(defun CALCULATE-LINE (angle length last-line)
(let* ((unit-last (unit (g-coerce last-line 'point)))
(unit-new (add (multiply unit-last (cos angle))
(multiply (normal unit-last) (sin angle)))))
(make-line-segment
(add (line-segment-point-1 last-line)
(multiply unit-new length))
(line-segment-point-1 last-line))))
;;; Finds angle of triangle opposite to side a
(defun ANGLE-FROM-SIDES (a b c)
(acos (/ (- (+ (square b) (square c)) (square a)) (* 2 b c))))
;;; Can a triangle be made from lines of these lengths?
(defun LENGTHS-MAKE-TRIANGLE (a b c)
(and (< a (+ b c)) (< b (+ a c)) (< c (+ a b))))
ltiply unit-last (cos angle))
(multiply (normal unit-last) (sin angle)))))
(make-line-segment
(add (line-segment-point-1 last-line)
(multiply unit-new length))
(line-segment-point-1 last-line))))
;;; Finds angle of triangle opposite to side a
(defun ANGLE-FROM-SIDES (a b c)
(acgeometry/2d/smooth-convolve.lisp000666 002223 000322 00000034247 06050466004 016521 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(gaussian-smooth-uniform-theta-s *default-gaussian-cutoff* gaussian-convolve-1d
1-2-1-convolve spring-2d-smooth gaussian make-1d-gaussian-filter normalize-filter
derivative-theta-s derivative-vector clemens-smooth dejag-2d-smooth find-jag-run fill-jag-run))
(defvar *DEFAULT-GAUSSIAN-CUTOFF* .01)
(defun GAUSSIAN-SMOOTH-UNIFORM-THETA-S (theta-s sigma &key (end-case :truncate))
"We smooth a theta-s space graph with
a Gaussian with the appropriate sigma. By 'uniform', we mean that
the theta-s s's all increase uniformly, i.e., we know the tangent
at uniform intervals in the curve."
(let ((new-nums (gaussian-convolve-1d (theta-s-thetas theta-s) sigma end-case)))
(if (null new-nums) nil
(let* ((new-length (car (array-dimensions new-nums)))
(new-theta-s (make-theta-s new-length)))
(loop for i from 0 to (1- new-length)
doing
(set-theta-s-theta new-theta-s i (aref new-nums i)))
(loop for i from (/ (- (theta-s-length theta-s) new-length) 2)
for j from 0 to (1- new-length)
doing
(set-theta-s-s new-theta-s j (theta-s-s theta-s i)))
new-theta-s))))
(defun GAUSSIAN-CONVOLVE-1D (nums sigma end-case)
"Convolve an array of numbers with a Gaussian.
With end-case = :truncate, this will shorten the array; nil will be returned when
the filter is bigger than the number vector."
(ecase end-case
(:truncate
(let* ((filter (make-1d-gaussian-filter sigma *default-gaussian-cutoff*))
(filter-length--1 (1- (car (array-dimensions filter)))))
(if (< (car (array-dimensions nums)) (car (array-dimensions filter))) nil
(let* ((cutoff (/ filter-length--1 2))
(new-nums (make-array (list (- (car (array-dimensions nums)) (* 2 cutoff))) :element-type 'float)))
(loop for i from cutoff to (- (1- (car (array-dimensions nums))) cutoff)
for new-i from 0
doing
(setf (aref new-nums new-i)
(loop for j from 0 to filter-length--1
for num-index from (- i cutoff) to (+ i cutoff)
summing
(* (aref filter j) (aref nums num-index)))))
new-nums))))
(:repeat ; Repeats the first and last numbers.
(let* ((filter (make-1d-gaussian-filter sigma *default-gaussian-cutoff*))
(filter-length--1 (1- (car (array-dimensions filter))))
(filter-length--1/2 (/ filter-length--1 2)))
(if (< (car (array-dimensions nums)) (car (array-dimensions filter))) nil
(let* ((new-nums (make-array (array-dimensions nums) :element-type 'float))
(num-len (car (array-dimensions nums)))
(1st-num (aref nums 0))
(last-num (aref nums (1- num-len))))
(loop for i from 0 to (1- num-len)
doing
(setf (aref new-nums i)
(loop for j from 0 to filter-length--1
for k from (- i filter-length--1/2) to (+ i filter-length--1/2)
summing
(* (aref filter j) (if (< k 0) 1st-num
(if (<= num-len k) last-num
(aref nums k)))))))
new-nums))))
(:reflect
(let* ((filter (make-1d-gaussian-filter sigma *default-gaussian-cutoff*))
(filter-length--1 (1- (car (array-dimensions filter))))
(filter-length--1/2 (/ filter-length--1 2)))
(if (< (car (array-dimensions nums)) filter-length--1/2) nil
(let* ((reflected-nums (make-reflected-nums nums filter-length--1/2))
(new-nums (make-array (array-dimensions nums) :element-type 'float))
(num-len (car (array-dimensions nums))))
(loop for counter from 0 to (1- num-len)
for i from filter-length--1/2
doing
(setf (aref new-nums counter)
(loop for j from 0 to filter-length--1
for k from (- i filter-length--1/2) to (+ i filter-length--1/2)
summing
(* (aref filter j) (aref reflected-nums k)))))
new-nums))))
))
(defun MAKE-REFLECTED-NUMS (nums reflection-length)
"We assume that the reflection-length isn't greater than the number of nums"
(let* ((num-length (car (array-dimensions nums)))
(new-nums (make-array (list (+ (* 2 reflection-length) num-length))
:element-type (array-element-type nums))))
(loop for i from 0 to (1- reflection-length)
for j from (1- reflection-length) downto 0
doing
(setf (aref new-nums i) (aref nums j)))
(loop for i from reflection-length
for j from 0 to (1- num-length)
doing
(setf (aref new-nums i) (aref nums j)))
(loop for i from (+ reflection-length num-length)
for j from (1- num-length) downto (- num-length reflection-length)
doing
(setf (aref new-nums i) (aref nums j)))
new-nums))
(defun 1-2-1-CONVOLVE (nums end-case)
;"Convolve the numbers with a |1|2|1| template.
(case end-case
(:truncate
(loop for last-num in nums
for num in (cdr nums)
for next-num in (cddr nums)
collecting
(/ (+ last-num num num next-num) 4.0)))))
(defun SPRING-2D-SMOOTH (points closed? n k &optional (smooth-points))
"The goal of this routine is to compensate for error caused by pixelization.
On each iteration, the smooth point is set to be the center of mass
of its starting position (weighted by k) and its two smooth-point
neighbors (each weighted by 1). This is the equilibrium position
the point would find if it were attached to the three other points
with springs of appropriate stiffness. End points remain fixed
unless the curve is closed. The optional smooth-points arg is
useful when repeated applications are desired."
(if (null (cddr points)) points
(progn
(unless smooth-points (setq smooth-points (mapcar #'copy-point points)))
(loop repeat n
doing
(let* ((k+2 (+ k 2))
(spt-1 (if closed? (car (last smooth-points)) (first smooth-points)))
(spt (if closed? (first smooth-points) (second smooth-points)))
(spt-cdr (if closed? (nthcdr 1 smooth-points) (nthcdr 2 smooth-points)))
(spt+1 (first spt-cdr))
(sx-1 (point-x spt-1))
(sy-1 (point-y spt-1))
(sx (point-x spt))
(sy (point-y spt))
(sx+1 (point-x spt+1))
(sy+1 (point-y spt+1)) )
(loop for pt in (if closed? points (rest points))
for x = (point-x pt)
for y = (point-y pt)
doing
(mutate-point-x spt (/ (+ (* k x) sx-1 sx+1) k+2))
(mutate-point-y spt (/ (+ (* k y) sy-1 sy+1) k+2))
(setq spt-cdr (cdr spt-cdr))
(when (null spt-cdr)
(if closed? (setq spt-cdr smooth-points) (return)) )
(setq spt spt+1 spt+1 (first spt-cdr)
sx-1 sx sx sx+1 sx+1 (point-x spt+1)
sy-1 sy sy sy+1 sy+1 (point-y spt+1) ))))
smooth-points )))
(defun GAUSSIAN (sigma x)
(* (/ 1 (* sigma (sqrt g:*2pi*)))
(exp (/ (- (square x)) (* 2 (square sigma))))))
(defun MAKE-1D-GAUSSIAN-FILTER (sigma cutoff-ratio)
"Returns a 1d array, that can be used for convolution. The array is
as long as necessary to ensure that we represent enough of the gaussian.
We stop when an entry in the filter would be less than the peak of the
gaussian times the cutoff-ratio."
(let* ((max-num (gaussian sigma 0))
(cutoff-num (* max-num cutoff-ratio)))
(let ((nums
(loop for i from 1
for gi = (gaussian sigma i)
until (< gi cutoff-num)
collecting
gi)))
(let ((filter (make-array (list (1+ (* 2 (length nums)))) :element-type 'float))
(center-index (length nums)))
(setf (aref filter center-index) max-num)
(loop for i from 1
for num in nums
doing
(setf (aref filter (+ center-index i)) num)
(setf (aref filter (- center-index i)) num))
(normalize-filter filter)))))
(defun NORMALIZE-FILTER (filter)
"Adjust the values of a filter so they sum to 1."
(let ((last-index (1- (car (array-dimensions filter)))))
(let ((sum (loop for i from 0 to last-index
summing
(aref filter i))))
(loop for i from 0 to last-index
doing
(setf (aref filter i) (/ (aref filter i) sum)))))
filter)
(defun DERIVATIVE-THETA-S (theta-s)
"This assumes that the s's in the theta-s graph are just integers"
(let ((new-ts (make-theta-s (1- (theta-s-length theta-s)))))
(loop for i from 0 to (- (theta-s-length theta-s) 2)
doing
(set-theta-s-theta new-ts i (- (theta-s-theta theta-s (1+ i)) (theta-s-theta theta-s i)))
(set-theta-s-s theta-s i i))
new-ts))
(defun DERIVATIVE-VECTOR (vector)
(let ((dvector (make-array (list (1- (car (array-dimensions vector))))
:element-type (array-element-type vector))))
(loop for i from 0 to (- (car (array-dimensions vector)) 2)
doing
(setf (aref dvector i) (- (aref vector (1+ i)) (aref vector i))))
dvector))
(defun CLEMENS-SMOOTH (points closed? n k)
(spring-2d-smooth (dejag-2d-smooth points closed?) closed? n k))
;;; Dejags in the image space. Looks for horizontal or vertical runs
;;; with diagonals at each end and moves the points to lie on a straight
;;; line between the midpoints of the diagonals. (Does not work if the
;;; points have been smoothed already).
(defun DEJAG-2D-SMOOTH (points closed? &optional (smooth-points (mapcar #'copy-point points)))
(let* ((circ-s-points smooth-points)
(end-pt (first (last circ-s-points)))
(prev-dx) (prev-dy)
(hit-end?) )
(when closed?
(setq circ-s-points (copy-seq circ-s-points)) ; Copies list, but uses same points.
(setf (cdr (last circ-s-points)) circ-s-points) ) ; Make list circular.
; Find a starting point.
(if closed?
(progn
(multiple-value-setq (circ-s-points ignore ignore prev-dx prev-dy ignore)
(find-jag-run circ-s-points end-pt) )
(setq end-pt (first circ-s-points)) )
(multiple-value-setq (ignore ignore ignore prev-dx prev-dy ignore)
(find-jag-run circ-s-points end-pt) ))
; Fill the runs.
(loop doing
(multiple-value-setq (circ-s-points prev-dx prev-dy hit-end?)
(fill-jag-run circ-s-points prev-dx prev-dy end-pt) )
until hit-end? )
smooth-points ))
;;; Takes a connected-point list and finds the first diagonal jump, or
;;; the first jump that is different from the run-jump once it has been
;;; established. Returns six values: the cdr of the point list in which
;;; the first point is immediately after the "bad" jump, whether the run
;;; is vertical, the number of points in the run, the DX and DY of the
;;; "bad" jump, and whether the end point was detected. Returns a
;;; run-len of 0 if a diagonal is found immediately (no run). Returns a
;;; DX and DY of NIL if no "bad" jump is found to terminate the run.
(defun FIND-JAG-RUN (points &optional end-pt)
(declare (values point-cdr vert-run? run-len last-dx last-dy hit-end?))
(loop with run-dx = nil
with run-dy = nil
with hit-end? = nil
for pt-cdr on points
for run-len upfrom 0
for pt1 = (first pt-cdr)
for pt2 = (second pt-cdr)
doing
(unless pt2
(return (values nil (when run-dx (= run-dx 0)) run-len nil nil t)) )
(when (eq pt2 end-pt) (setq hit-end? t))
(let ((dx (- (point-x pt2) (point-x pt1)))
(dy (- (point-y pt2) (point-y pt1))))
(if run-dx
(when (or (not (= dx run-dx)) (not (= dy run-dy)))
(return (values (cdr pt-cdr) (= run-dx 0) run-len dx dy hit-end?)) )
(if (or (zerop dx) (zerop dy))
(setq run-dx dx run-dy dy)
(return (values (cdr pt-cdr) nil run-len dx dy hit-end?)) )))))
;;; Requires that the first point came right after a diagonal jump of
;;; PREV-DX PREV-DY. Finds the next diagonal, and fills the run, if any.
;;; Returns the points after the diagonal and the jump of that diagonal.
(defun FILL-JAG-RUN (points prev-dx prev-dy end-pt)
(declare (values point-cdr next-dx next-dy hit-end?))
(multiple-value-bind (point-cdr vert-run? run-len next-dx next-dy hit-end?)
(find-jag-run points end-pt)
; (format t "~&~d pts -> ~d pts, prev (~d ~d), next (~d ~d), end? ~a"
; (length points) (length point-cdr) prev-dx prev-dy next-dx next-dy hit-end? )
(when (> run-len 0)
(unless next-dx
(if prev-dx
(setq next-dx prev-dx next-dy prev-dy)
(setq next-dx 0 prev-dx 0 next-dy 0 prev-dy 0) ))
(let ((step-delta)
(delta-0) )
(if vert-run?
(setq step-delta (/ (+ next-dx prev-dx) 2.0 (1+ run-len))
delta-0 (/ (- step-delta prev-dx) 2.0) )
(setq step-delta (/ (+ next-dy prev-dy) 2.0 (1+ run-len))
delta-0 (/ (- step-delta prev-dy) 2.0) ))
(loop
for pt in points
until (eq pt (first point-cdr))
for delta upfrom delta-0 by step-delta
doing
(if vert-run?
(incf (point-x pt) delta)
(incf (point-y pt) delta) ))))
(values point-cdr next-dx next-dy hit-end?) ))
a)
(delta-0) )
(if vert-run?
(setq step-delta (/ (+ next-dx prev-dx) 2.0 (1+ run-len))
delta-0 (/ (- step-delta prev-dx) 2.0) )
(setq step-delta (/ (+ next-dy prev-dy) 2.0 (1+ run-len))
delta-0 (/ (- step-delta prev-dy) 2.0) ))
(loop
for pt in points
until (eq pt (first point-cdr))
for delta upfrom delta-0 by geometry/2d/straight.lisp000666 002223 000322 00000027037 06050466006 015205 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Package: 2DG; Syntax: Common-Lisp; Base: 10. -*-
(in-package 2DG)
(export '(strings-to-line-segments edges-to-line-segments split-and-merge))
(defun STRINGS-TO-LINE-SEGMENTS (strings thresh)
"Makes straight line approximations to strings of points. A string is a
list of connected points. This forms a line from the begining point of
the string to the end. It then breaks this into 2 lines at the point where
the string deviates most from the line. This process continues recursively
until the lines approximate the string to within a desired accuracy.
Input: strings - Each string is a list of points. Each point must be adjacent
to the next.
thresh - The maximum allowed distance from the string to any of the
line segments. When the lines don't approximate the string to
within thresh, the process stops. 2 is a reasonable value for
thresh."
(loop for string in strings
collecting
(break-line (copy-list string) (car (last string)) (length string) thresh) ))
(defun EDGES-TO-LINE-SEGMENTS (edge-array thresh)
"This calls edge-image-strings with edge-array, and strings-to-line-segments with thresh."
(flatten (strings-to-line-segments (edge-image-strings edge-array) thresh)))
(defun DIST-X-Y (dx dy) (sqrt (+ (* dx dx) (* dy dy))))
(defun DOT-X-Y (x1 x2 y1 y2) (+ (* x1 x2) (* y1 y2)))
(defun BREAK-LINE (line-list last-point length thresh)
(when (= length 1)
(return-from break-line nil) )
(when (< length 3)
(return-from break-line (list (make-line-segment (car line-list) last-point))) )
(let* ((x0 (point-x (first line-list)))
(y0 (point-y (first line-list)))
(xn (point-x last-point))
(yn (point-y last-point))
e (max-e 0)
(line-1-length)
(line-1-end)
(dx (- xn x0))
(dy (- yn y0))
(d (dist-x-y dx dy))
(tan-x (/ dx d))
(tan-y (/ dy d))
(norm-x (- tan-y))
(norm-y tan-x) )
(loop for point in (cdr line-list)
for line-end on (cdr line-list)
for line-length from 2
for p-dx = (- (point-x point) x0)
and p-dy = (- (point-y point) y0)
for tan-d = (dot-x-y tan-x p-dx tan-y p-dy)
do
(cond
((< tan-d 0) (setq e (dist-x-y p-dx p-dy)) )
((> tan-d d)
(let ((p-dxn (- (point-x point) xn))
(p-dyn (- (point-y point) yn)) )
(setq e (dist-x-y p-dxn p-dyn)) ))
(t (setq e (abs (dot-x-y norm-x p-dx norm-y p-dy)))) )
(when (> e max-e)
(setq line-1-length line-length
line-1-end line-end
max-e e )))
(if (> max-e thresh)
(let ((line-2 (cons (car line-1-end) (cdr line-1-end))))
(rplacd line-1-end nil)
(append (break-line line-list (car line-1-end) line-1-length thresh)
(break-line line-2 last-point (- length line-1-length -1) thresh) ))
(list (make-line-segment (car line-list) last-point)) )))
;;; LINE SEGMENT STRING APPROXIMATION
;;; ----------------------------------------------------------------------
;;; SPLIT-AND-MERGE fits connected straight line segments to smooth
;;; string intervals such that the maximum perpendicular distance between
;;; the segment and the string is below a threshold. It uses a recursive
;;; split (like TLP's version).
;;; The maximum pixel error allowed between a line and the string it is
;;; approximating.
(defvar *STRING-LINE-BREAK-MAX-ERR*)
(setq *STRING-LINE-BREAK-MAX-ERR* 2.0) ; 1.0)
;;; The maximum average pixel error allowed between a line and the string
;;; it is approximating.
(defvar *STRING-LINE-BREAK-MAX-AVE-ERR*)
(setq *STRING-LINE-BREAK-MAX-AVE-ERR* 0.6) ; .3)
;;; The minimum length of a line used to approximate a string.
(defvar *STRING-LINE-MIN-LENGTH*)
(setq *STRING-LINE-MIN-LENGTH* 5)
;;; The maximum pixel error allowed between a line and the string it is
;;; approximating.
(defvar *STRING-LINE-MERGE-MAX-ERR*)
(setq *STRING-LINE-MERGE-MAX-ERR* 3.0) ; 1.5)
;;; The maximum average pixel error allowed between a line and the string
;;; it is approximating.
(defvar *STRING-LINE-MERGE-MAX-AVE-ERR*)
(setq *STRING-LINE-MERGE-MAX-AVE-ERR* 1.2) ; 0.6)
;;; The maximum angle that can separate two lines we will try to merge.
(defvar *MAX-MERGE-ANGLE*)
(setq *MAX-MERGE-ANGLE* .1)
(defstruct (split-and-merge-line
:named
(:print-function (lambda (l stream &rest ignore)
(format stream "#~~"
(split-and-merge-line-pt1 l)
(split-and-merge-line-pt2 l)))))
"Special line structure for split-and-merge routine. It stores info about the line"
pt1
pt2
index1
index2
length
angle
norm-x
norm-y
norm-dot)
(defun SPLIT-AND-MERGE (strings &optional
(break-max-error *string-line-break-max-err*)
(break-max-ave-error *string-line-break-max-ave-err*)
(min-length *string-line-min-length*)
(merge-max-error *string-line-merge-max-err*)
(merge-max-ave-error *string-line-merge-max-ave-err*) )
(loop ;; with len = (length strings)
for string in strings
for i upfrom 0
with line-res = nil
with string-res = nil
doing
(multiple-value-bind (lines strings)
(string-to-lines string break-max-error break-max-ave-error min-length
merge-max-error merge-max-ave-error )
(setf line-res (nconc lines line-res))
(setf string-res (nconc strings string-res)))
finally (return (values line-res string-res))))
(defun STRING-TO-LINES (string break-max-error break-max-ave-error min-length
merge-max-error merge-max-ave-error )
(let* ((points (point-array-from-string string))
(lines (split-and-merge-break-line points 0 (1- (length points))
break-max-error break-max-ave-error min-length )))
(when lines
(setq lines (merge-lines lines points merge-max-error merge-max-ave-error)) )
(loop for line in lines
collect (split-and-merge-to-segment line) into line-segments
collect (loop for i from (split-and-merge-line-index1 line) to (split-and-merge-line-index2 line)
collecting
(aref points i))
into strings
finally (return (values line-segments strings)))))
(defun SPLIT-AND-MERGE-TO-SEGMENT (line)
(make-line-segment (split-and-merge-line-pt1 line)
(split-and-merge-line-pt2 line)))
(defun POINT-ARRAY-FROM-STRING (c)
(let ((a (make-array (list (length c)))))
(loop for p in c
for i from 0
doing
(setf (aref a i) p) )
a ))
;;; END-I is included in the interval.
(defun SPLIT-AND-MERGE-BREAK-LINE (points start-i end-i max-error max-ave-error min-length)
(when (>= (1+ (- end-i start-i)) min-length)
(let ((line (make-line-from-points points start-i end-i)))
(multiple-value-bind (max-err break-i ave-err) (find-line-max-error line points)
(if (or (> max-err max-error) (> ave-err max-ave-error))
(append (split-and-merge-break-line points start-i break-i
max-error max-ave-error min-length)
(split-and-merge-break-line points break-i end-i
max-error max-ave-error min-length))
(list line) )))))
(defun MAKE-LINE-FROM-POINTS (points index-1 index-2)
(let* ((point-1 (aref points index-1))
(point-2 (aref points index-2))
(x0 (point-x point-1))
(y0 (point-y point-1))
(xn (point-x point-2))
(yn (point-y point-2))
(dx (- xn x0))
(dy (- yn y0))
(d (dist-x-y dx dy))
(tan-x (/ dx d))
(tan-y (/ dy d))
(norm-x (- tan-y))
(norm-y tan-x) )
(make-split-and-merge-line :pt1 point-1 :pt2 point-2 :index1 index-1 :index2 index-2
:length d :angle (atan dy dx)
:norm-x norm-x :norm-y norm-y
:norm-dot (dot-x-y norm-x x0 norm-y y0) )))
;;; Finds the location of the pixel with maximum distance (error) from
;;; the line. It returns the max error and information for breaking the
;;; line at the max error point, and the average error.
(defun FIND-LINE-MAX-ERROR (line points)
(declare (values max-error max-error-i ave-error))
(let* ((start-i (split-and-merge-line-index1 line))
(end-i (split-and-merge-line-index2 line))
(x0 (point-x (split-and-merge-line-pt1 line)))
(y0 (point-y (split-and-merge-line-pt1 line)))
(xn (point-x (split-and-merge-line-pt2 line)))
(yn (point-y (split-and-merge-line-pt2 line)))
(d (dist-x-y (- xn x0) (- yn y0)))
e (max-e 0) (max-e-i start-i) (ave-e 0)
(norm-x (split-and-merge-line-norm-x line))
(norm-y (split-and-merge-line-norm-y line))
(tan-x norm-y)
(tan-y (- norm-x)) )
(loop
for i from start-i to end-i
for point = (aref points i)
for p-dx = (- (point-x point) x0)
for p-dy = (- (point-y point) y0)
for tan-d = (dot-x-y tan-x p-dx tan-y p-dy)
doing
(cond
((< tan-d 0) (setq e (dist-x-y p-dx p-dy)) )
((> tan-d d)
(let ((p-dxn (- (point-x point) xn))
(p-dyn (- (point-y point) yn)) )
(setq e (dist-x-y p-dxn p-dyn)) ))
(t (setq e (abs (dot-x-y norm-x p-dx norm-y p-dy)))) )
(incf ave-e e)
(when (> e max-e) (setq max-e e max-e-i i)) )
(setq ave-e (/ ave-e (1+ (- end-i start-i))))
(values max-e max-e-i ave-e) ))
(defun MERGE-LINES (lines points max-error max-ave-error)
(loop for first? in *FIRST-T-THEN-NIL*
for prev-line = (if first? (first lines) (or merged-line line))
for line in (rest lines)
for merged-line = nil
doing
(when (< (abs-angle-difference (split-and-merge-line-angle line) (split-and-merge-line-angle prev-line)) *max-merge-angle*)
; (format t "~&Trying merge... ")
(setq merged-line
(make-line-from-points points (split-and-merge-line-index1 prev-line) (split-and-merge-line-index2 line)) )
(multiple-value-bind (max-err ignore ave-err) (find-line-max-error merged-line points)
(when (or (> max-err max-error) (> ave-err max-ave-error))
(setq merged-line nil) ;(format t "failed.")
)))
; (when merged-line (format t "succeeded."))
unless merged-line ; postpone collection until further merging
collect prev-line into merged-lines
finally (return (nconc merged-lines (list prev-line)))) )
(split-and-merge-line-index1 prev-line) (split-and-merge-line-index2 line)) )
(multiple-value-bind (max-err ignore ave-err) (find-line-max-error merged-line points)
(when (or (> max-err max-error) (> ave-err max-ave-error))
(setq merged-line nil) ;(format t "failed.")
)))
; (when merged-line (format t "succeeded."))
unless merged-line ; postpone collection until further merging
collect prev-line into merged-lines
finally (return (nconc mergegeometry/2d/string.lisp000666 002223 000322 00000012614 06050466010 014654 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Package: 2DG; Syntax: Common-Lisp; Base: 10. -*-
(in-package '2DG)
(export '(edge-image-strings))
(defvar *FIRST-T-THEN-NIL*)
(setq *FIRST-T-THEN-NIL* (list t nil))
(rplacd (cdr *FIRST-T-THEN-NIL*) (cdr *FIRST-T-THEN-NIL*))
;;; This makes *FIRST-T-THEN-NIL* a list of (t nil nil nil nil ...)
(defun EDGE-IMAGE-STRINGS (edge-image)
"Find connected strings of edge points in an image represented as a binary array.
Strings are broken at junctions (when points have more than
two neighbors).
Input: A binary array, with 1 where there is an edge, 0 where there isn't.
Output: A list of strings. Each string is a list of connected points, in order."
(destructuring-bind (h w) (array-dimensions edge-image)
(let* ((image (make-array (list (+ h 2) (+ w 2)) :element-type 'bit :initial-element 0))
(strings nil) )
(my-bitblt h w edge-image 0 0 image 1 1)
(loop for i from 1 to h
doing
(loop for j from 1 to w
doing
(when (= 1 (aref image i j))
(push (grow-string image j i) strings) )))
strings )))
(defun MY-BITBLT (h w from-array from-start-row from-start-col
to-array to-start-row to-start-col)
(loop for fi from from-start-row to (+ from-start-row h -1)
for ti from to-start-row
doing
(loop for fj from from-start-col to (+ from-start-col w -1)
for tj from to-start-col
doing
(setf (aref to-array ti tj) (aref from-array fi fj)))))
(defmacro SSIN (orient)
`(let ((morient (mod ,orient 8)))
(cond ((< morient 2) (- 1 morient))
((<= morient 4) -1)
((< morient 6) (- morient 5))
(T 1))))
(defmacro SCOS (orient)
`(let ((morient (mod ,orient 8)))
(cond ((<= morient 2) 1)
((< morient 4) (- 3 morient))
((<= morient 6) -1)
(T (- morient 7)))))
(defun NEXT (edge-array cxy)
(loop with (orient x y) = cxy
and next
for norient from (- orient 2) to (+ orient 2)
for nx = (+ x (scos norient))
and ny = (+ y (ssin norient)) do
(when (= 1 (aref edge-array ny nx))
(if next
(return nil)
(setq next (list norient nx ny)) ))
finally (return next) ))
(defun PREVIOUS (edge-array cxy)
; (format t "~& Prev: ~a" cxy)
(loop with (orient x y) = cxy
and prev
for norient from (+ orient 2) downto (- orient 2)
for nx = (+ x (scos norient))
and ny = (+ y (ssin norient))
do
; (format t " [~a ~a ~a ~a]" norient nx ny (aref edge-array ny nx))
(when (= 1 (aref edge-array ny nx))
(if prev
(return nil)
(setq prev (list norient nx ny)) ))
finally (return prev) ))
(defun TRACE-TO-END (edge-array x y)
"Given an edge array and a point, finds the beginning of the string that contains
this point. If the string is circular, the initial point is returned. A second
value of t indicates a circular string"
; (format t "~& Trace-to-end: ~a ~a" x y)
(loop for first? in *FIRST-T-THEN-NIL*
for pcxy = (if first? (previous edge-array (list 1 x y)) (previous edge-array pcxy))
and cxy = (if first? (list 1 x y) pcxy)
until (null pcxy)
if (and (= (second pcxy) x)
(= (third pcxy) y) )
do (return (values cxy T))
finally (return (values cxy nil)) ))
(defun GROW-STRING (edge-array x y)
; (format t "~&Grow-String: ~a ~a" x y)
(let ((icxy (trace-to-end edge-array x y))
(string) )
(incf (car icxy) 4)
(loop for first? in *FIRST-T-THEN-NIL*
for cxy = (if first? icxy (next edge-array cxy))
for (nil x y) = cxy
until (null cxy)
do
(setf (aref edge-array y x) 0)
(push (make-point (1- x) (1- y)) string) )
; (format t "~&~a" string)
string ))
do (return (values cxy T))
finally (return (values cxy nil)) ))
(defun GROW-STRING (edge-array x y)
; (formgeometry/2d/structs.lisp000666 002223 000322 00000016474 06050466011 015066 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(point-x point-y point-p make-point mutate-point line-segment-point-1 line-segment-point-2
line-segment-p make-line-segment mutate-line-segment line-point-1 line-point-2
line-p make-line mutate-line polygon-points polygon-p make-polygon mutate-polygon
rectangle-min-x rectangle-max-x rectangle-min-y rectangle-max-y rectangle-p make-rectangle
mutate-rectangle geometric-type))
;;; This file contains definitions for all the structures in the geometry package.
;;; For each structure, xxx, there is a routine "make-xxx", accessors for all components
;;; of the stucture, called "xxx-component", a predicate to test for that type of
;;; structure, called xxx-p, and a mutator called mutate-xxx. Their is also a routine
;;; called geometric-type that returns 'xxx when called with an instance of xxx as an arguement.
;;; The contents of this file can be freely changed as long as they conform to these conventions.
;;; No other routines will rely on any other aspect of an object's structure.
;;; For example, to make points use up less space
;;; one might redefine make-point as cons, point-x as car, point-y as cdr,
;;; point-p as (and (consp pt) (numberp (car pt)) (numberp (cdr pt))),
;;; mutate-point as (defun (pt new-x new-y) (rplaca pt new-x) (rplacd pt new-y) pt).
;;; One would also have to redefine geometric-type as
;;; (defun geometric-type (object) (if (point-p object) 'point (type-of object))).
;;; All code in the geometry package should then continue to work correctly.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Points
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct (point
;:named
(:constructor make-point (x &optional y))
:predicate
(:print-function (lambda (point stream &rest ignore)
(format stream "#"
(point-x point) (point-y point)))))
"A point"
(x 0)
(y 0))
(defun MUTATE-POINT (point new-x new-y)
"Mutate POINT so that its components are now NEW-X, and NEW-Y. The mutated point is
returned."
(setf (point-x point) new-x)
(setf (point-y point) new-y)
point)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Line Segments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct (line-segment
;:named
(:constructor make-line-segment (point-1 point-2))
:predicate
(:print-function
(lambda (line-segment stream &rest ignore)
(format stream "#"
(point-x (line-segment-point-1 line-segment))
(point-y (line-segment-point-1 line-segment))
(point-x (line-segment-point-2 line-segment))
(point-y (line-segment-point-2 line-segment))))))
"A line segment"
point-1
point-2)
(defun mutate-line-segment (line-segment new-point-1 new-point-2)
"Mutate LINE-SEGMENT so that its components are now NEW-POINT-1 and NEW-POINT-2. The
mutated point is returned."
(setf (line-segment-point-1 line-segment) new-point-1)
(setf (line-segment-point-2 line-segment) new-point-2)
line-segment)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Lines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct (line
;:named
(:constructor make-line (point-1 point-2))
:predicate
(:print-function
(lambda (line stream &rest ignore)
(format stream "#"
(point-x (line-point-1 line))
(point-y (line-point-1 line))
(point-x (line-point-2 line))
(point-y (line-point-2 line))))))
"A line"
point-1
point-2)
(defun MUTATE-LINE (line new-point-1 new-point-2)
"Mutate LINE so that its components are now NEW-POINT-1 and NEW-POINT-2. The
mutated point is returned."
(setf (line-point-1 line) new-point-1)
(setf (line-point-2 line) new-point-2)
line)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Polygons
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct (polygon
;:named
(:constructor make-polygon (POINTS))
:predicate
(:print-function
(lambda (POLYGON stream &rest ignore)
(format stream "#"
(POLYGON-POINTS POLYGON)))))
"A polygon"
points)
(defun MUTATE-POLYGON (polygon new-points)
"Mutate polygon so that its points are new-points."
(setf (polygon-points polygon) new-points)
polygon)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Rectangles
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct (rectangle
;:NAMED
(:CONSTRUCTOR MAKE-RECTANGLE (MIN-X MAX-X MIN-Y MAX-Y))
:PREDICATE
(:PRINT-FUNCTION
(LAMBDA (RECTANGLE STREAM &REST IGNORE)
(FORMAT STREAM "#"
(RECTANGLE-MIN-X RECTANGLE)
(RECTANGLE-MAX-X RECTANGLE)
(RECTANGLE-MIN-Y RECTANGLE)
(RECTANGLE-MAX-Y RECTANGLE)))))
"A rectangle"
min-x
max-x
min-y
max-y)
(defun MUTATE-RECTANGLE (rectangle min-x max-x min-y max-y)
"Mutate LINE so that its components are now NEW-POINT-1 and NEW-POINT-2. The
mutated point is returned."
(setf (rectangle-min-x rectangle) min-x)
(setf (rectangle-max-x rectangle) max-x)
(setf (rectangle-min-y rectangle) min-y)
(setf (rectangle-max-y rectangle) max-y)
rectangle)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; General
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun GEOMETRIC-TYPE (object)
(type-of object))
x max-x min-y max-y)
"Mutate LINE so that its components are now NEW-POINT-1 and NEW-POINT-2. The
mutated point is returned."
(setf (rectangle-min-x rectangle) min-x)
(setf (rectangle-mageometry/2d/system.lisp000666 002223 000322 00000007473 06050466014 014705 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:USER; Syntax:Common-lisp; Lowercase:Yes; Default-character-style:(:FIX :ROMAN :NORMAL) -*-
;;;; File: SYSTEM.LSP
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Package definition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (find-package 'g)
(load (pathname (format nil "~A~A" group-loading:*home-directory* "geometry/general/system"))))
;;;; Exports are in the individual files.
(unless (find-package '2dg)
(make-package 'geometry-2d :use '(g common-lisp) :nicknames '(2dg)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; System definition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package 2dg)
(defun COMPILE-LOAD (file)
(let ((bin (make-pathname
:directory (format nil "~A~A" group-loading:*home-directory* "geometry/2d/")
:name file :type group-loading:*binary-type*))
(source (make-pathname
:directory (format nil "~A~A" group-loading:*home-directory* "geometry/2d/")
:name file :type "lisp"))
)
(when (or (not (probe-file bin)) (< (file-write-date bin) (file-write-date source)))
(compile-file source))
(load bin)))
(compile-load "structs")
(compile-load "constants")
(compile-load "interface")
(compile-load "general")
(compile-load "vector")
(compile-load "angle")
(compile-load "transform")
(compile-load "colinear")
(compile-load "distance")
(compile-load "intersect")
(compile-load "polyrect")
(compile-load "random")
(compile-load "linearfit")
(compile-load "convex-hull")
(compile-load "string")
(compile-load "straight")
(compile-load "theta-s")
(compile-load "smooth-convolve")
(compile-file source))
(load bin)))
(compile-load "structs")
(compile-load "constants")
(compile-load "interface")
(compile-load "general")
(compile-load "vector")
(compile-load "angle")
(compgeometry/2d/test-colinear.lisp000666 002223 000322 00000005207 06050466016 016125 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(defun TEST-THREE-POINTS-COLINEAR (n)
(let ((p1 (make-point 0 0))
(p2 (make-point 10 0))
(p3 (make-point 30 0)))
(loop for i from 1 to n
collecting
(let ((ang (random *2pi*))
(dx (random 100.0))
(dy (random 100.0)))
(three-points-colinear? (rotate (translate p1 dx dy) ang)
(rotate (translate p2 dx dy) ang)
(rotate (translate p3 dx dy) ang))))))
(defun TEST-COLINEAR-POINTS (n)
(let ((p1 (make-point 0 0))
(p2 (make-point 10 0))
(p3 (make-point 30 0)))
(loop for i from 1 to n
collecting
(let ((ang (random *2pi*))
(dx (random 100.0))
(dy (random 100.0)))
(colinear-points? (list (rotate (translate p1 dx dy) ang)
(rotate (translate p2 dx dy) ang)
(rotate (translate p3 dx dy) ang)))))))
points-colinear? (rotate (translate p1 dx dy) ang)
(rotate (translate p2 dx dy) ang)
(rotate (translate p3 dx dy) ang))))))
(defun TEST-COLINEAR-POINTS (n)
(let ((p1 (make-point 0 0))
(p2 (make-point 10 0))
(p3 (make-point 30 0)))
(loop for i from 1 to n
collecting
(let ((ang (random *2pi*))
(dx (random 100.0))
(dy (random 100.0)))
(colingeometry/2d/test-convex.lisp000666 002223 000322 00000005037 06050466020 015627 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:2DG; Syntax:Common-lisp; Lowercase:Yes -*-
(defun TEST-CONVEX-HULL-RECTANGLE (n)
(let ((pts (list (make-point 10 0) (make-point 10 10) (make-point 0 10) (make-point 0 0)))
(other-pts
(cons (make-point 10 5)
(loop for i from 1 to n
collecting
(make-point (random 10.0) (random 10.0))))))
(jarvis-march-convex-hull (randomize-list (append other-pts pts)))))
(defun TEST-LCONVEX-HULL-RECTANGLE (n)
(let ((pts (list (make-point 10 0) (make-point 10 10) (make-point 0 10) (make-point 0 0)))
(other-pts
(cons (make-point 10 5)
(loop for i from 1 to n
collecting
(make-point (random 10.0) (random 10.0))))))
(l-convex-hull-strict (randomize-list (append other-pts pts)) 20)))
ake-point 10 5)
(loop for i from 1 to n
collecting
(make-point (random 10.0) (random 10.0))))))
(jarvis-march-convex-hull (randomize-list (append other-pts pts)))))
(defun TEST-LCONVEX-HULL-RECTANGLE (n)
(let ((pts (list (make-point 10 0) (make-point 10 10) (make-point 0 10) (make-point 0 0)))
(other-pts
(cons (make-point 10 5)
(loop for i from 1 to n
collecting
(make-point (random 10.0) (random 10.0))))))
(l-convex-hull-strict (randomize-list geometry/2d/test-distance.lisp000666 002223 000322 00000006756 06050466021 016131 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(defun TEST-POINT-DISTANCE ()
(let ((pt1 (make-point 0 0))
(pt2 (make-point (random 100.0) (random 100.0))))
(let ((distance (sqrt (+ (square (point-x pt2)) (square (point-y pt2))))))
(let ((ang (random *2pi*))
(dx (random 100.0))
(dy (random 100.0)))
(and
(~= distance
(distance
(rotate (translate pt1 dx dy) ang)
(rotate (translate pt2 dx dy) ang)))
(~= (square distance)
(distance-squared
(rotate (translate pt1 dx dy) ang)
(rotate (translate pt2 dx dy) ang))))))))
(defun TEST-PARALLEL-LINE-DISTANCE ()
(let* ((line1 (make-line (make-point 0 0) (make-point 20 0)))
(distance (random 100.0))
(line2 (make-line (make-point (random 100.0) distance) (make-point (random 100.0) distance))))
(let ((ang (random *2pi*))
(dx (random 100.0))
(dy (random 100.0)))
(let ((trans-line1 (rotate (translate line1 dx dy) ang))
(trans-line2 (rotate (translate line2 dx dy) ang)))
(list
(/ (abs (- distance
(distance trans-line1 trans-line2))) distance)
(/ (abs (- (square distance)
(distance-squared trans-line1 trans-line2))) (square distance)))))))
(defun TEST-OVERLAPPING-SEGMENT-DISTANCE ()
(let* ((line1 (make-line-segment (make-point 0 0) (make-point 20 0)))
(line2 (make-line-segment (make-point (random 20.0) 0) (make-point (+ 20 (random 100.0)) 0))))
(let ((ang (random *2pi*))
(dx (random 100.0))
(dy (random 100.0)))
(let ((trans-line1 (rotate (translate line1 dx dy) ang))
(trans-line2 (rotate (translate line2 dx dy) ang)))
(distance trans-line1 trans-line2)))))
(defun TEST-LINE-SEGMENT-DISTANCE ()
re distance)))))))geometry/2d/test-intersect.lisp000666 002223 000322 00000005403 06050466001 016321 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(defun TEST-INTERSECT-POINT-LINE-T ()
(let* ((line (make-line (make-point (random-between -10.0 10.0) (random-between -10.0 10.0))
(make-point (random-between -10.0 10.0) (random-between -10.0 10.0))))
(pt (add (line-point-1 line) (multiply (g-coerce line 'point) (random 2.0)))))
(list (intersect? line pt) (distance line pt)))) ; Distance should be near 0.
(defun TEST-INTERSECT-POINT-LINE-SEGMENT ()
(let* ((line (make-line-segment (make-point (random-between -10.0 10.0) (random-between -10.0 10.0))
(make-point (random-between -10.0 10.0) (random-between -10.0 10.0))))
(scale (random 2.0))
(pt (add (line-segment-point-1 line) (multiply (g-coerce line 'point) scale))))
(let ((intersect? (intersect? line pt)))
(when (or (and intersect? (< (+ 1.0 *epsilon*) scale))
(and (not intersect?) (~<= scale 1.0)))
(error "Mistaken intersection")))))
efun TEST-INTERSECT-POINT-LINE-SEGMENT ()
(let* ((line (make-line-segment (make-point (random-between -10.0 10.0) (random-between -10.0 10.0))
(make-point (random-between -10.0 10.0) (random-between -10.0 10.0))))
(scale (random 2.0))
(pt (ageometry/2d/test-linearfit.lisp000666 002223 000322 00000007317 06050466003 016306 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:2DG; Syntax:Common-lisp; Lowercase:Yes -*-
(defun TEST-LEAST-SQUARES-RHO-THETA (&optional rot (angle 0))
(let ((line (make-line (make-point 0 0) (make-point (* 10 (cos angle)) (* 10 (sin angle)))))
(dy 0)); (random-between 0 .1)))
(let ((pts (loop for x from 0 below 10 by .1
collecting
(if (= 0 (mod (* x 10) 2))
(make-point x dy)
(make-point x (- dy))))))
(let* ((pose-vars (when rot (random-pose-vars)))
(line (if rot (apply-pose-vars line pose-vars) line))
(pts (if rot (loop for pt in pts collecting (apply-pose-vars pt pose-vars)) pts)))
(let ((min-line (car (least-squares-rho-theta pts))))
(list min-line line dy (average (loop for p in pts collecting (distance p line)))
(average (loop for p in pts collecting (distance p min-line))))))))
)
(defun TEST-LEAST-SQUARES-RHO-THETA-2 (&optional (dx 0) (dy 0) (angle 0))
(let ((line (make-line (make-point dx dy) (make-point (+ dx (* 10 (cos angle))) (+ dy (* 10 (sin angle)))))))
(let ((pts (loop for d from 0 below 10 by .1
collecting
(make-point (+ dx (* d (cos angle))) (+ dy (* d (sin angle)))))))
(let ((min-line (car (least-squares-rho-theta pts))))
(list line min-line (average (loop for p in pts collecting (distance p line)))
(average (loop for p in pts collecting (distance p min-line))))))))
(defun TEST-LEAST-SQUARES-SLOPE-INTERCEPT-2 (&optional (dx 0) (dy 0) (angle 0))
(let ((line (make-line (make-point dx dy) (make-point (+ dx (* 10 (cos angle))) (+ dy (* 10 (sin angle)))))))
(let ((pts (loop for d from 0 below 10 by .1
collecting
(make-point (+ dx (* d (cos angle))) (+ dy (* d (sin angle)))))))
(let ((min-line (car (least-squares-slope-intercept pts))))
(list line min-line (average (loop for p in pts collecting (distance p line)))
(average (loop for p in pts collecting (distance p min-line))))))))
(&optional (dx 0) (dy 0) (angle 0))
(let ((line (make-line (make-point dx dy) (make-point (+ dx (* 10 (cos angle))) (+ dy (* 10 (sin angle)))))))
(let ((pts (loop for d from 0 below 10 by .1
collecting
(make-point (+ dx (* d (cos angle))) (+ dy (* d (sin angle)))))))
(let ((migeometry/2d/test-polyrect.lisp000666 002223 000322 00000011500 06050466005 016161 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(defun RANDOMLY-POSE (obj)
(let ((ang (random *2pi*))
(dx (random 100.0))
(dy (random 100.0)))
(rotate (translate obj dx dy) ang)))
(defun RANDOM-POSE-VARS ()
(list (random *2pi*) (random 1.0) (random 1.0)))
(defun APPLY-POSE-VARS (obj lst)
(let ((ang (car lst))
(dx (cadr lst))
(dy (caddr lst)))
(rotate (translate obj dx dy) ang)))
(defun TEST-INSIDE-ON-POINT (container)
(let ((vars (random-pose-vars)))
(inside? (apply-pose-vars (random-choose (defining-points-list container)) vars)
(apply-pose-vars container vars))))
(defun RANDOM-POINT ()
(make-point (random-between -100 100) (random-between -100 100)))
(defun TEST1-RECTANGLE ()
(test-inside-on-point (make-rectangle -7 12 3 8)))
(defun TEST2-POLYGON ()
(let* ((poly (make-polygon (list (random-point) (random-point) (random-point))))
(pt (random-point))
(rect (bounding-box poly)))
(when (and (not (inside? pt rect)) (inside? pt poly))
(error "Point is inside a polygon, but not inside a bounding box around it?"))))
(defun TEST3-POLYGON (n)
(let ((poly (make-polygon
(append (list (make-point 30 0) (make-point 0 0) (make-point 2 2))
(loop for i from 3 to 29 by 2
appending
(list (make-point i 1) (make-point (1+ i) 2)))))))
(loop for i from 1 to n
doing
(let* ((vars (random-pose-vars))
(point (make-point (random-between 5.0 25.0) 1.5))
(inside? (inside? (apply-pose-vars point vars) (apply-pose-vars poly vars)))
(really-inside? (or (~= .5 (mod (point-x point) 1))
(evenp (round (point-x point))))))
(when (or (and inside? (not really-inside?))
(and (not inside?) really-inside?))
(error "What can I say?"))))))
(defun TEST-INTERSECT-LINE-SEGMENT-AND-RECTANGLE (&optional outside?)
(let* ((min-x (random-between -10.0 10.0))
(min-y (random-between -10.0 10.0))
(max-x (random-between min-x 15.0))
(max-y (random-between min-y 15.0)))
(let ((rect (make-rectangle min-x max-x min-y max-y))
(ls (make-line-segment (make-point (random-between -10.0 20.0) (random-between -10.0 20.0))
(make-point (random-between -10.0 20.0) (random-between -10.0 20.0)))))
(when (xor (intersect-line-segment-and-rectangle? ls rect)
(or (intersect-line-segment-and-line-segment? (make-line-segment (make-point min-x min-y)
(make-point min-x max-y))
ls)
(intersect-line-segment-and-line-segment? (make-line-segment (make-point min-x min-y)
(make-point max-x min-y))
ls)
(intersect-line-segment-and-line-segment? (make-line-segment (make-point max-x max-y)
(make-point min-x max-y))
ls)
(intersect-line-segment-and-line-segment? (make-line-segment (make-point max-x max-y)
(make-point max-x min-y))
ls)
(inside? (line-segment-point-1 ls) rect)
(inside? (line-segment-point-2 ls) rect)))
(error "One method found intersection, the other didn't.")))))
(make-point max-x min-y))
ls)
(intersect-line-segment-and-line-segment? (make-line-segment (make-point max-x max-y)
(make-point min-x max-y))
geometry/2d/test-straight.lisp000666 002223 000322 00000007240 06050466006 016154 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Package: 2DG; Syntax: Common-Lisp; Base: 10. -*-
(in-package '2DG)
(defun TEST-EDGES-TO-LINE-SEGMENTS (n)
;; Test with a single, simple curve.
(labels ((numbers-from (n1 n2) ; Don't know which is bigger. Don't include n1 or n2.
(if (< n1 n2) (loop for i from (1+ n1) below n2 collecting i)
(loop for i from (1+ n2) below n1 collecting i))))
(let ((bit-array (make-raster-array 128 128 :element-type '(unsigned-byte 1)))
(last-y 0))
(loop for x from 0 to 127
doing
(let ((y (floor (* 127 (sin (* (/ x 127) PI))))))
(setf (raster-aref bit-array x y) 1)
(when (< 1 (abs (- y last-y)))
(loop for y in (numbers-from y last-y)
doing
(setf (raster-aref bit-array x y) 1)))
(setf last-y y)))
(edges-to-line-segments bit-array n))))
(defun TEST-EDGE-IMAGE-STRINGS ()
;; Test with a single, simple curve.
(labels ((numbers-from (n1 n2) ; Don't know which is bigger. Don't include n1 or n2.
(if (< n1 n2) (loop for i from (1+ n1) below n2 collecting i)
(loop for i from (1+ n2) below n1 collecting i))))
(let ((bit-array (make-raster-array 128 128 :element-type '(unsigned-byte 1)))
(last-y 0))
(loop for x from 0 to 127
doing
(let ((y (floor (* 127 (sin (* (/ x 127) PI))))))
(setf (raster-aref bit-array x y) 1)
(when (< 1 (abs (- y last-y)))
(loop for y in (numbers-from y last-y)
doing
(setf (raster-aref bit-array x y) 1)))
(setf last-y y)))
(edge-image-strings bit-array))))
(defun TEST-EDGES-TO-LINE-SEGMENTS2 (n)
(let ((bit-array (make-raster-array 128 128 :element-type '(unsigned-byte 1)))
(y 0))
(loop for x1 from 0 to 63
for x2 from 127 downto 64
doing
(setf (raster-aref bit-array x1 y) 1)
(setf (raster-aref bit-array x2 y) 1)
(when (= (random 2) 0)
(setf y (1+ y))))
(edges-to-line-segments bit-array n)))
rs-from y last-y)
doing
(setf (raster-aref bit-array x y) 1)))
(setf last-y y)))
(edge-image-strings bit-array))))
(defun TEST-EDGES-TO-LINE-SEGMENTS2 (n)
(let ((bit-array (make-raster-array 128 128 :element-type '(unsigned-byte 1)))
(y 0))
(loop for x1 from 0 to 63
for x2 from 127 downto 64
doing
(setf (rastergeometry/2d/test-theta-s.lisp000666 002223 000322 00000010713 06050466010 015666 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(defun BIGGEST-STRING-SMOOTHED (image sigma)
(let* ((strings (edge-image-strings image))
(biggest-string (car strings)))
(loop for s in (cdr strings)
doing
(when (< (length biggest-string) (length s))
(setf biggest-string s)))
(let* ((theta-s (theta-s-from-string biggest-string))
(smoothed-theta-s (gaussian-smooth-uniform-theta-s theta-s sigma))
(reconstructed-string (string-from-theta-s theta-s))
(reconstructed-smoothed-string (string-from-theta-s smoothed-theta-s)))
(list biggest-string reconstructed-string reconstructed-smoothed-string theta-s smoothed-theta-s))))
(defun TEST-SPRING-2D-SMOOTH (n k)
(let ((string (make-quadratic-string 0 10 10)))
(let ((smoothed-string (spring-2d-smooth string nil n k)))
(loop for pt1 in string
for pt2 in smoothed-string
collecting
(distance pt1 pt2)))))
(defun MAKE-STRING-FROM-FUNCTION (start end function pixels-per-number)
"Forms a string of points that satisfy y = (function x). If pixels-per-number is
10, for example, the point (20 40) corresponds to the xy coordinate (2 4)."
(let ((last-j (round (1- (* pixels-per-number (apply function (list start)))))))
(loop for x from start to end by (/ 1 pixels-per-number)
for i = (round (* pixels-per-number x))
appending
(let ((j (round (* pixels-per-number (apply function (list x))))))
(if (= last-j j) (list (make-point i j))
(let ((points
(loop for intermediate-j from (1+ last-j) to j
collecting
(make-point i intermediate-j))))
(setf last-j j)
points))))))
(defun MAKE-QUADRATIC-STRING (start end pixels-per-number)
(make-string-from-function start end (lambda (x) (square x)) pixels-per-number))
(defun SMOOTH-LINE-TO-QUADRATIC ()
"Take a curve which is a line segment from (0 0) to (2 4) and quadratic
from (2 4) to (4 16). Returns the curve and its theta-s graph, the
smoothed curve and its theta-s graph, and the spring-smoothed, then smoothed
curve and its theta-s graph."
(let* ((string (make-string-from-function
0 4
(lambda (x) (if (< x 2) (* 2 x) (square x)))
20))
(theta-s (theta-s-from-string string))
(smooth-theta-s (gaussian-smooth-uniform-theta-s theta-s 2))
(smooth-string (string-from-theta-s smooth-theta-s))
(spring-string (spring-2d-smooth string nil 10 1))
(spring-theta-s (theta-s-from-string spring-string))
(smooth-spring-theta-s (gaussian-smooth-uniform-theta-s spring-theta-s 2))
(smooth-spring-string (string-from-theta-s smooth-spring-theta-s)))
(list theta-s smooth-theta-s spring-theta-s smooth-spring-theta-s
2 x) (square x)))
20))
(theta-s (theta-s-from-geometry/2d/theta-s.lisp000666 002223 000322 00000032711 06050466012 014715 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(in-package 'g)
(export '(*sqrt2*))
(in-package '2dg)
(export '(theta-s-length theta-s-thetas theta-s-ss make-theta-s theta-s-p
set-theta-s-theta set-theta-s-s theta-s-theta-list theta-s-s theta-s-theta print-theta-s
theta-s-from-string string-from-theta-s))
(defstruct (THETA-S
:named
(:constructor make-theta-s (length &aux (thetas (make-array (list length) :element-type 'double-float))
(ss (make-array (list length) :element-type 'double-float))))
:predicate
(:print-function (lambda (theta-s stream &rest ignore)
(format stream "#"))))
"A theta-s space graph"
length
thetas
ss)
;;; Accessors for theta-s-graph
(defun SET-THETA-S-THETA (ts i val)
(setf (aref (theta-s-thetas ts) i) val))
(defun SET-THETA-S-S (ts i val)
(setf (aref (theta-s-ss ts) i) val))
(defun THETA-S-THETA-LIST (ts)
(let ((thetas (theta-s-thetas ts)))
(loop for i from 0 to (1- (theta-s-length ts))
collecting
(aref thetas i))))
(defun THETA-S-S (ts i)
(aref (theta-s-ss ts) i))
(defun THETA-S-THETA (ts i)
(aref (theta-s-thetas ts) i))
(defun PRINT-THETA-S (ts &optional (stream t) max-length (start 0) (new-lines t))
(when new-lines (format stream "~%"))
(format stream ":length = ~A" (theta-s-length ts))
(loop for i from start to (1- (if max-length (min (+ start max-length) (theta-s-length ts))
(theta-s-length ts)))
doing
(when (and new-lines (= 0 (mod i 5))) (format stream "~%"))
(if (integerp (theta-s-s ts i)) (format stream "(~3D " (theta-s-s ts i))
(format stream "(~3F " (theta-s-s ts i)))
(format stream "~5F) " (theta-s-theta ts i))))
;;; This routine describes the direction between two neighboring points with a number, as follows:
;;;
;;; 3 2 1
;;; 4 P 0
;;; 5 6 7
;;; where P shows the point.
(defun THETA-S-FROM-INTEGER-STRING (string)
"Construct a theta-s space graph from a list of connected points."
(flet ((neighbor-direction (point neighbor)
(cond ((= (point-x point) (point-x neighbor))
(if (< (point-y point) (point-y neighbor)) 2 6))
((< (point-x point) (point-x neighbor))
(cond ((= (point-y point) (point-y neighbor)) 0)
((< (point-y point) (point-y neighbor)) 1)
(t 7)))
(t (cond ((= (point-y point) (point-y neighbor)) 4)
((< (point-y point) (point-y neighbor)) 3)
(t 5))))))
(let* ((string-circular? (points-neighbors? (car string) (car (last string))))
(excess-distance 0) ; The length of diagonal connections in excess of 1 is accumulated so
; that some points are counted twice.
(thetas nil))
(loop for point in string
for next-point in (if string-circular? (append (cdr string) (list (car string))) (cdr string))
for i from 0
doing
(let ((dir (neighbor-direction point next-point)))
(when (oddp dir)
(setf excess-distance (+ excess-distance (- *sqrt2* 1))))
(push (* dir *PI/4*) thetas)
(when (<= 1 excess-distance)
(push (* dir *PI/4*) thetas)
(decf excess-distance))))
(let* ((theta-s-length (length thetas))
(theta-s-graph (make-theta-s theta-s-length)))
(loop for theta in thetas
for i from (1- theta-s-length) downto 0 ; The thetas were put in in reverse order
doing
(set-theta-s-theta theta-s-graph i theta)
(set-theta-s-s theta-s-graph i i))
theta-s-graph))))
(defun THETA-S-FROM-STRING (string &optional string-circular?)
"Construct a theta-s space graph from a list of connected points."
(flet ((neighbor-direction (point neighbor)
(let ((dx (- (point-x neighbor) (point-x point)))
(dy (- (point-y neighbor) (point-y point))))
(values (atan-0-2pi dy dx) (sqrt (+ (sq dx) (sq dy))))))
(direction-difference (d1 d2) ; A direction is from 0 to 2pi. This gives d1 - d2, ranging from -pi to pi.
(if (< (abs (- d1 d2)) pi)
(- d1 d2)
(if (< d1 d2)
(- d1 (- d2 *2pi*))
(- (- d1 *2pi*) d2)))))
(let* ((excess-distance 0) ; The length of diagonal connections in excess of 1 is accumulated so
; that some points are counted twice.
(thetas nil)
(last-theta 0)
(last-direction 0)) ; The first theta will be between -PI and PI
(loop for point in string
for next-point in (if string-circular? (append (cdr string) (list (car string))) (cdr string))
for i from 0
doing
(multiple-value-bind (direction distance)
(neighbor-direction point next-point)
(let ((theta (+ last-theta (direction-difference direction last-direction))))
(setf last-theta theta)
(setf last-direction direction)
(setf excess-distance (+ excess-distance distance))
(loop until (< excess-distance 1)
doing
(push theta thetas)
(decf excess-distance)))))
;; We essentially sample the string at intervals of 1 pixel, finding the theta at those points.
;; Excess-distance keeps track of how far "point" is from the last integer distance.
(let* ((theta-s-length (length thetas))
(theta-s-graph (make-theta-s theta-s-length)))
(loop for theta in thetas
for i from (1- theta-s-length) downto 0 ; The thetas were put in in reverse order
doing
(set-theta-s-theta theta-s-graph i theta)
(set-theta-s-s theta-s-graph i i))
theta-s-graph))))
(defun STRING-FROM-THETA-S (ts &optional (start-point (make-point 0 0)))
"Returns a string of connected points that begin at (0 0). If two
adjacent entries in the theta-s space graph map to non-neighbor points
in the plane, we interpolate between them with a line."
(let* ((last-point start-point)
(round-last-point last-point)
(last-theta (theta-s-theta ts 0))
(last-s (theta-s-s ts 0)))
(cons start-point
(loop for i from 1 to (1- (theta-s-length ts))
appending
(let* ((ds (- (theta-s-s ts i) last-s))
(new-theta (theta-s-theta ts i))
(new-point (add last-point (make-point (* ds (cos last-theta)) (* ds (sin last-theta)))))
(round-new-point (round-point new-point))
(string-points
(if (point-equal round-last-point round-new-point) nil
(if (points-neighbors? round-last-point round-new-point) (list round-new-point)
(cdr (points-between round-last-point round-new-point))))))
;; Cdr to prevent repitition of last point.
(setf last-s (+ last-s ds))
(setf last-point new-point)
(setf round-last-point round-new-point)
(setf last-theta new-theta)
string-points)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These go into other files in the geometry package.
(export '(round-point points-neighbors? mutate-point-x mutate-point-y geometric-object? grow-strings))
(defun ROUND-POINT (pt)
(make-point (round (point-x pt)) (round (point-y pt))))
(defun POINTS-NEIGHBORS? (point1 point2)
(and (<= (abs (- (point-x point1) (point-x point2))) 1)
(<= (abs (- (point-y point1) (point-y point2))) 1)))
(defun MUTATE-POINT-X (pt new-x)
(setf (point-x pt) new-x))
(defun MUTATE-POINT-Y (pt new-y)
(setf (point-y pt) new-y))
(defun GEOMETRIC-OBJECT? (object)
(case (geometric-type object)
((point line line-segment rectangle polygon) t)
(t nil)))
(defun ATAN-0-2PI (y x)
(let ((ans (atan y x)))
(if (< ans 0) (+ *2pi* ans) ans)))
(defun GROW-STRINGS (strings raster &optional (max-dist 2.9))
(let* ((sq-max-dist (square max-dist))
(last-points (loop for s in strings collecting (car (last s))))
(potential-matches
(loop for s1 in strings
for p1 = (car s1)
for p1l in last-points
for rest-strings on (cdr strings)
for rest-last on (cdr last-points)
appending
(when (not (points-neighbors? p1 p1l))
(loop for s2 in rest-strings
for p2 = (car s2)
for p2l in rest-last
appending
(when (not (points-neighbors? p2 p2l))
(append (when (and (< (distance-squared p1 p2) sq-max-dist)
(point-endpoint? p1 raster) (point-endpoint? p2 raster))
(list (list s1 s2 nil nil)))
(when (and (< (distance-squared p1l p2) sq-max-dist)
(point-endpoint? p1l raster) (point-endpoint? p2 raster))
(list (list s1 s2 t nil)))
(when (and (< (distance-squared p1 p2l) sq-max-dist)
(point-endpoint? p1 raster) (point-endpoint? p2l raster))
(list (list s1 s2 nil t)))
(when (and (< (distance-squared p1l p2l) sq-max-dist)
(point-endpoint? p1l raster) (point-endpoint? p2l raster))
(list (list s1 s2 t t)))))))))
(matches (loop for match in potential-matches
appending
(when (and (= 1 (loop for match2 in potential-matches
summing
(if (and (eq (car match) (car match2)) (eq (nth 2 match) (nth 2 match2)))
1 0)))
(= 1 (loop for match2 in potential-matches
summing
(if (and (eq (cadr match) (cadr match2)) (eq (nth 3 match) (nth 3 match2)))
1 0))))
(list match))))
(matches-left matches))
(let* ((strings-to-remove nil)
(new-strings
(loop until (null matches-left)
appending
(let* ((match (pop matches-left))
(s1 (if (not (nth 2 match)) (reverse (car match)) (car match)))
;; The first string, with its last point the one that's near the second string.
(rev-s1 (if (nth 2 match) (reverse (car match)) (car match))) ; reverse of s1
(s2 (if (nth 3 match) (reverse (cadr match)) (cadr match))) ; first point is the one near s1.
(connecting-points (string-connecting-points (car rev-s1) (car s2) raster)))
(when connecting-points
(let ((new-string (append s1 connecting-points s2)))
(push (car match) strings-to-remove)
(push (cadr match) strings-to-remove)
(loop for match2 in matches-left
doing
(when (eq (car match) (car match2))
(progn (rplaca match2 new-string)
(rplaca (nth 2 match2) nil))) ; The nearby point in this match must be the end of the new string
;; We don't have to compare (car match) and (cadr match2), because of the order of the matches
(if (eq (cadr match) (car match2))
(progn (rplaca match2 new-string)
(rplaca (cdddr match2) t))
(if (eq (cadr match) (cadr match2))
(progn (rplaca (cdr match2) new-string)
(rplaca (cdddr match2) t)))))
(list new-string)))))))
(append new-strings (loop for string in strings appending (when (not (member string strings-to-remove)) (list string)))))))
(defun STRING-CONNECTING-POINTS (p1 p2 raster)
"The first points of the two strings are nearby. We return a list of points that bridges the gap. This must
done with points that aren't adjacent to other
For now, they must be separated by only a single pixel."
(loop for candidate in (intersection (point-neighbors p1 raster) (point-neighbors p2 raster) :test #'point-equal)
doing
(when (loop for candidate-neighbor in (remove p1 (remove p2 (point-neighbors candidate raster) :test #'point-equal)
:test #'point-equal)
always
(= 0 (raster-aref raster (point-x candidate-neighbor) (point-y candidate-neighbor))))
(return (list candidate)))))
(defun POINT-ENDPOINT? (point raster)
(= 1 (loop for pt in (point-neighbors point raster)
summing
(raster-aref raster (point-x pt) (point-y pt)))))
(defun POINT-NEIGHBORS (point raster-image)
(multiple-value-bind (max-x max-y)
(decode-raster-array raster-image)
(loop for dx in (list -1 0 1)
with x = (point-x point)
with y = (point-y point)
appending
(loop for dy in (if (= dx 0) (list -1 1) (list -1 0 1))
for nx = (+ x dx)
for ny = (+ y dy)
appending
(when (and (<= 0 nx) (<= 0 ny) (< nx max-x) (< ny max-y))
(list (make-point nx ny)))))))
(defun STRING-CIRCULAR? (s)
(and (null (cdr s)) (points-neighbors? (car s) (car (last s)))))
ster-image)
(multiple-value-bind (max-x max-y)
geometry/2d/transform.lisp000666 002223 000322 00000005222 06050466014 015362 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(translate rotate translate-point rotate-point))
;;; To do: Add code to rotate, and stimultaneously rotate and translate, using
;;; matrices.
(defun TRANSLATE (object dx dy)
(make-from-defining-points (loop for pt in (defining-points-list object)
collecting
(translate-point pt dx dy))
(geometric-type object)))
(defun ROTATE (object angle)
(make-from-defining-points (loop for pt in (defining-points-list object)
collecting
(rotate-point pt angle))
(geometric-type object)))
(defun TRANSLATE-POINT (pt dx dy)
(make-point (+ (point-x pt) dx) (+ (point-y pt) dy)))
(defun ROTATE-POINT (pt angle)
(multiple-value-bind (mag new-angle)
(cart-to-polar pt)
(polar-to-cart mag (+ new-angle angle))))
collecting
(translate-point pt dx dy))
(geometric-type object)))
(defun ROTATE (object angle)
(make-from-defining-points (loop for pt in (defining-points-list object)
collecting
(rotate-point pt angle))
(geometric-type object)))
(defun TRANSLATE-POINT (pt dx dy)
(make-point (+ (point-x pt) dx) (+ (point-y pt) dy)geometry/2d/tstring.lisp000666 002223 000322 00000004670 06050466016 015051 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: 2DG; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(test-grow-strings))
(defun TEST-GROW-STRINGS (testnum)
(let ((a (make-raster-array 32 32 :element-type 'bit)))
(loop for i from 1 to 9
doing
(setf (raster-aref a i i) 1))
(loop for i from 19 downto 11
for j from 1 to 9
doing
(setf (raster-aref a i j) 1))
(when (not (= testnum 1))
(loop for j from 11 to 19
doing
(setf (raster-aref a 10 j) 1)))
(when (= testnum 2)
(setf (raster-aref a 10 10) 1))
(let* ((strings (edge-image-strings a))
(new-strings (grow-strings strings a)))
ROW-STRINGS (testnum)
(let ((a (make-raster-array 32 32 :element-type geometry/2d/vector.lisp000666 002223 000322 00000011773 06050466020 014656 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Package: 2DG; Base: 10; Mode: LISP; Syntax: Common-Lisp -*-
(in-package '2DG)
(export '(normal cross dot diff add unit directed-distance normal-directed-distance cart-to-polar polar-to-cart side
left-turn?))
(defun NORMAL (v)
(let ((v (g-coerce v 'point)))
(make-point (point-y v) (- (point-x v)))))
(defun CROSS (v1 v2)
(let ((v1 (g-coerce v1 'point))
(v2 (g-coerce v2 'point)))
(- (* (point-x v1) (point-y v2))
(* (point-y v1) (point-x v2)))))
(defun DOT (v1 v2)
(let ((v1 (g-coerce v1 'point))
(v2 (g-coerce v2 'point)))
(+ (* (point-x v1) (point-x v2))
(* (point-y v1) (point-y v2)))))
(defun DIFF (v1 v2)
(let ((v1 (g-coerce v1 'point))
(v2 (g-coerce v2 'point)))
(make-point (- (point-x v1) (point-x v2))
(- (point-y v1) (point-y v2)))))
(defun ADD (v1 v2)
(let ((v1 (g-coerce v1 'point))
(v2 (g-coerce v2 'point)))
(make-point (+ (point-x v1) (point-x v2))
(+ (point-y v1) (point-y v2)))))
(defun UNIT (v)
(let ((v (g-coerce v 'point)))
(let ((mag (sqrt (dot v v))))
(if (< (abs mag) *epsilon*) nil (multiply v (/ 1.0 mag))))))
(defun DIRECTED-DISTANCE (pt1 pt2 line) ; Distance from pt1 to pt2
; in direction from first pt in line to second
(dot (unit line) (make-line pt1 pt2)))
(defun NORMAL-DIRECTED-DISTANCE (pt1 pt2 line) ; distance from pt1 to pt2 in direction of
; normal of line.
(dot (diff pt2 pt1) (unit (normal (g-coerce line 'point)))))
(defun CART-TO-POLAR (pt)
(values (sqrt (+ (square (point-x pt)) (square (point-y pt))))
(if (point-equal pt *ORIGIN*)
0
(atan (point-y pt) (point-x pt)))))
(defun POLAR-TO-CART (mag angle)
(make-point (* mag (cos angle)) (* mag (sin angle))))
(defun SIDE (point-1 point-2 point-3)
"
Purpose: Given the ray (POINT-1 --> POINT-2), determine on which side POINT-3 lies.
Args: POINT-1 -- a point (X Y)
POINT-2 -- a point (X Y)
POINT-3 -- a point (X Y)
Returns:
+1 if POINT-3 lies to the right of (POINT-1 --> POINT-2), i.e., POINT-1 to POINT-2 to POINT-3 is a right turn
0 if POINT-3 is colinear with (POINT-1 --> POINT-2)
-1 if POINT-3 lies to the left of (POINT-1 --> POINT-2)
However, if any of the points coincide, zero (0) is returned.
Method: Find the sign of the dot product of (perpendicular to POINT-1 --> POINT-2) with (POINT-2 --> POINT-3).
This is equivalent (with 4 fewer multiplies) to the method on p. 43 of Computational Geometry by Preparata and Shamos where we find the sign of the determinant
| x1 y1 1 |
| x2 y2 1 |
| x3 y3 1 |
with the sign reversed.
"
(declare (values sign))
(let ((x2 (point-x point-2))
(y2 (point-y point-2)))
(~signum (+ (* (- y2 (point-y point-1)) (- (point-x point-3) x2))
(* (- (point-x point-1) x2) (- (point-y point-3) y2))))))
(defun LEFT-TURN? (point-1 point-2 point-3)
"
Purpose: Determine if travelling from POINT-1 to POINT-2 to POINT-3 is a left turn.
Alternatively, determine if POINT-3 is to the left of the ray from POINT-1 to POINT-2.
Returns: T if a left turn. Nil if a right turn or the points are colinear
2D: Any list elements after the y-coordinate of a point are ignored for calculations.
"
(declare (values boolean))
(minusp (side point-1 point-2 point-3)))
poingeometry/general/000700 002223 000322 00000000000 06050445303 013545 5ustar00dwjCSI000000 000000 geometry/general/constants.lisp000666 002223 000322 00000005172 06050502536 016477 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: G; Syntax: Common-Lisp -*-
(in-package G)
(export '(*short-pi* *2pi* *short-2pi* *pi/2* *short-pi/2* *pi/4* *short-pi/4* *epsilon* *-epsilon*))
(defconstant *SHORT-PI* (coerce pi 'short-float) "PI as a short-float.")
(defconstant *2PI* (* 2.0 pi) "2*PI.")
(defconstant *SHORT-2PI* (coerce (* 2.0 pi) 'short-float) "2*PI as a short-float.")
(defconstant *PI/2* (/ pi 2.0) "PI / 2.")
(defconstant *SHORT-PI/2* (coerce (/ pi 2.0) 'short-float) "PI / 2 as a short-float.")
(defconstant *PI/4* (/ pi 4.0) "PI / 4.")
(defconstant *SHORT-PI/4* (coerce (/ pi 4.0) 'short-float) "PI / 4 as a short-float.")
(defvar *epsilon* 0.0001 "Tolerance used in almost-equal calculations. (Should always be positive.)")
(defvar *-epsilon* (- *epsilon*))
(defconstant *SQRT2* (sqrt 2.0) "The square root of 2")
oerce (* 2.0 pi) 'short-float) "2*PI as a short-float.")
(defconstant *PI/2* (/ pi 2.0) "PI / 2.")
(defconstant *SHORT-PI/2* (coerce (/ pi 2.0) 'short-float) "PI / 2 as a short-float.")
(defconstant *PI/4* (/ pi 4.0) "PI / 4.")
(defconstant *SHORT-PI/4* (coerce (/ pi 4.0) 'short-float) "PI / 4 as a short-float.")
(defvar *epsilon* 0.0001 "Tolerance used in almost-equal calculations. (geometry/general/system.lisp000666 002223 000322 00000005725 06050502537 016014 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:USER; Syntax:Common-lisp; Lowercase:Yes; Default-character-style:(:FIX :ROMAN :NORMAL) -*-
;;;; File: SYSTEM.LSP
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Package definition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Exports are in the individual files.
(unless (find-package 'g)
(make-package 'geometry :nicknames '(g)))
(in-package g)
(defun COMPILE-LOAD (file)
(let ((bin (make-pathname
:directory (format nil "~A~A" group-loading:*home-directory* "geometry/general/")
:name file :type group-loading:*binary-type*))
(source (make-pathname
:directory (format nil "~A~A" group-loading:*home-directory* "geometry/general/")
:name file :type "lisp"))
)
(when (or (not (probe-file bin)) (< (file-write-date bin) (file-write-date source)))
(compile-file source))
(load bin)))
(compile-load "constants")
(compile-load "utils")
ory (format nil "~A~A" group-loading:*home-geometry/general/utils.lisp000666 002223 000322 00000012710 06050502537 015620 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode: LISP; Base: 10; Package: G; Syntax: Common-Lisp -*-
(in-package G)
(export '(SQ SQUARE ~= ~=x-y ~zerop ~< ~<= ~> ~>= ~signum filter flatten randomize-list random-between
random-choose remnth nthrdc nlast average xor remdups help))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Auxiliary macros and functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun SQ (x)
"Returns the square of X"
(* x x))
(defun SQUARE (x)
"Returns the square of X"
(* x x))
(defun ~= (number &rest more-numbers)
"Returns T if for all pairs (X Y) of the arguments, |X-Y| <= (X * *EPSILON*) or *EPSILON*."
(loop for remaining-numbers on (cons number more-numbers)
as first = (first remaining-numbers)
unless (loop for second in (cdr remaining-numbers)
unless (~=x-y first second)
return nil
finally (return t))
return nil
finally (return t)))
(defun ~=x-y (x y)
"Returns T if |X-Y| <= (X * *EPSILON*) or *EPSILON*."
(<= (abs (- x y)) (max (* x *epsilon*) *epsilon*)))
(defun ~zerop (number)
"Returns T if NUMBER is within *EPSILON*."
(<= (abs number) *epsilon*))
(defun ~SIGNUM (number)
"Returns 0 if number is ~zerop, otherwise like signum"
(cond ((< *epsilon* number) 1)
((< number *-epsilon*) -1)
(t 0)))
;;; Note that with the EPSILON slop, <= and < are equivalent. So are > and >=.
(defun ~< (number &rest more-numbers)
"Returns T if < holds within *EPSILON*."
(loop as first in (cons number more-numbers)
for second in more-numbers
unless (or (< first second)
(~= first second))
return nil
finally (return t)))
(defun ~<= (number &rest more-numbers)
"Returns T if <= holds within *EPSILON*."
(apply #'~< number more-numbers))
(defun ~> (number &rest more-numbers)
"Returns T if > holds within *EPSILON*."
(loop as first in (cons number more-numbers)
for second in more-numbers
unless (or (> first second)
(~= first second))
return nil
finally (return t)))
(defun ~>= (number &rest more-numbers)
"Returns T if >= holds within *EPSILON*."
(apply #'~> number more-numbers))
(defun FILTER (proc lst)
(loop for mem in lst
appending
(if (apply proc (list mem)) (list mem))))
(defun FLATTEN (lst-of-lsts)
(loop for lst in lst-of-lsts
appending
lst))
(defun RANDOMIZE-LIST (lst)
(if (null (cdr lst)) lst
(let ((n (random (length lst))))
(cons (nth n lst) (randomize-list (remnth n lst))))))
;;; pick a number between 1st and last. It may equal 1st, but must be less than last.
(defun RANDOM-BETWEEN (1st last)
(+ 1st (random (- last 1st))))
(defun RANDOM-CHOOSE (lst)
(nth (random (length lst)) lst))
(defun REMNTH (n lst)
(loop for i from 0 to (1- (length lst))
for mem in lst
appending
(if (/= i n) (list mem) nil)))
(defun NTHRDC (n lst)
(reverse (nthcdr n (reverse lst))))
(defun NLAST (n lst) (nth n (reverse lst)))
(defun AVERAGE (nums)
(/ (apply #'+ nums) (length nums)))
(defun XOR (a1 a2)
(or (and a1 (not a2)) (and (not a1) a2)))
(defun REMDUPS (lst &optional (test-fun #'equal) (order-fun nil))
"If order-fun is provided, then the lst may be mutated."
(if order-fun
(if (null lst) nil
(let ((lst (sort lst order-fun)))
(cons (car lst)
(loop for last-item in lst
for item in (cdr lst)
appending
(when (not (apply test-fun (list last-item item)))
(list item))))))
(loop for mem in lst
for rest-lst on lst
appending
(if (not (member mem (cdr rest-lst) :test test-fun))
(list mem)))))
(defun help ()
(format t "~%The geometry system is documented in the file: geometry-gen:geometry-gen;document.tex"))
(if order-fun
(if (null lst) nil
(let ((lst (sogeometry/x2dg/000700 002223 000322 00000000000 06050445533 013001 5ustar00dwjCSI000000 000000 geometry/x2dg/print.lisp000666 002223 000322 00000054554 06050502555 015057 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
(in-package 2dg)
(export '(*image-size-x* *image-size-y* *CONVEX-DOT-RATE* DISPLAY-OBJECT? DISPLAY-BOUNDING-BOX DISPLAY-OBJECT-POINTS
WITH-OUTPUT-INTO-BITMAP DISPLAY-OBJECT-TO-ARRAY DISPLAY-AREA-TO-ARRAY DISPLAY-STRING-TO-ARRAY
DISPLAY-LINE-SEGMENT-TO-ARRAY DISPLAY-STRIP-TO-ARRAY DISPLAY-EXTREMA-TO-ARRAY DISPLAY-CONVEX-GROUP-TO-ARRAY
DISPLAY-DISTINGUISHED-POINTS-TO-ARRAY
AVERAGE-POINTS DISPLAY-OBJECT? DISPLAY-BOUNDING-BOX PRINT-TRAITS CLASSIFY-TRAIT TRAIT-TYPE-LESS?
TRAITS-MEET-UNARY-CONSTRAINT? TRAIT-TYPES-MEET-UNARY-CONSTRAINT? PRINT-CONVEX-GROUPS RECTANGLE-LINE-SEGMENTS
PRINT-COMBINED-CONVEX-GROUPS COLLECT-SEPARATE-CONVEX-GROUPS COLLECT-SEPARATE-CONVEX-GROUPS-NON-RECURSIVE
PRINT-ORDERED-CONVEX-GROUPS
PRINT-COMBINED-TRAITS PADDED-DISPLAY-BOUNDING-BOX DISPLAY-BOUNDING-BOX-LIST COLLECT-SEPARATE-TRAITS
PRINT-TRAIT-LIST DOTTED-EDGE-IMAGE MY-PS-HARDCOPY-1-BIT-RASTER))
(defvar *image-size-x* 646)
(defvar *image-size-y* 486)
(defvar *CONVEX-DOT-RATE* 3)
(defvar *DISPLAY-CORNER-WIDTH* 5)
(defun DISPLAY-OBJECT? (object)
(or (geometric-object? object)
(list-of-points? object)
(extrema-p object)
(strip? object)
(area? object)
(tline-p object)
(convex-group-p object)))
(defun DISPLAY-BOUNDING-BOX (obj)
"Just like Bounding-Box, but can handle strings of points too."
(cond ((geometric-object? obj) (bounding-box obj))
((tline-p obj)
(bounding-box (tline-to-segment obj)))
((list-of-points? obj)
(loop for point in obj
as x = (point-x point)
as y = (point-y point)
with min-x = most-positive-single-float
with max-x = most-negative-single-float
with min-y = most-positive-single-float
with max-y = most-negative-single-float
do
(when (> x max-x) (setf max-x x))
(when (< x min-x) (setf min-x x))
(when (> y max-y) (setf max-y y))
(when (< y min-y) (setf min-y y))
finally
(return (make-rectangle min-x max-x min-y max-y))))
((area? obj)
(make-rectangle (area-min-x obj) (area-max-x obj) (area-min-y obj) (area-max-y obj)))
((extrema-p obj)
(make-rectangle (point-x (extrema-point obj)) (point-y (extrema-point obj))
(point-x (extrema-point obj)) (point-y (extrema-point obj))))
((strip? obj)
(display-bounding-box (strip-points obj)))
((convex-group-p obj)
(display-bounding-box (append (loop for cl in (convex-group-lines obj)
appending
(list (c-line-point-1 cl)
(c-line-point-2 cl)))
(if (eq (convex-group-corners obj) :uncomputed)
nil
(loop for corner in (convex-group-corners obj)
for pt = (convex-corner-point corner)
collect (make-point (+ (point-x pt) *display-corner-width*)
(+ (point-y pt) *display-corner-width*))
collect (make-point (- (point-x pt) *display-corner-width*)
(- (point-y pt) *display-corner-width*)))))))))
(defun DISPLAY-OBJECT-POINTS (obj)
(cond ((list-of-points? obj) obj)
((point-p obj) (list obj))
((line-segment-p obj) (points-between (line-segment-point-1 obj) (line-segment-point-2 obj)))
((area? obj) (area-display-points obj))
((extrema-p obj) (list (extrema-point obj)))
((strip? obj) (strip-display-points obj))
((convex-group-p obj) (convex-group-display-points obj))))
"
(defmacro WITH-OUTPUT-INTO-BITMAP (args &rest body)
(let ((bm (car args)))
`(multiple-value-bind (bitmap x0 y0 xend yend)
,(append `(graphics:with-output-to-bitmap ())
body)
;; If x0-var is negative or greater than max-width, it means we want to draw outside the image.
;; If x0-var < 0, we want to bitblt to 0, cutting off the front of the bitmap-var.
(let* ((x-start (if (< x0 0) 0 x0)) ; Place in bm we bitblt to
(x-stop (if (<= *image-size-x* xend) (1- *image-size-x*) xend))
(y-start (if (< y0 0) 0 y0))
(y-stop (if (<= *image-size-y* yend) (1- *image-size-y*) yend))
(bit-x-start (- x-start x0)) ; Place in bitmap we start bitblting from
(bit-y-start (- y-start y0))
(width (- x-stop x-start))
(height (- y-stop y-start)))
(if (/= width 0)
;; If there were no graphic output commands, bitmap will be a 0x0 array
(bitblt tv:alu-ior width height bitmap bit-x-start bit-y-start ,bm x-start y-start)
,bm)))))
"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Display Routines
(defun DISPLAY-OBJECT-TO-ARRAY (obj array)
; (let ((stream (dw:get-program-pane rex::'curve-display-pane)))
; (dw:with-output-as-presentation (:stream stream :type 'symbol :object name)
; (graphics:with-room-for-graphics (t 0)
(ecase (geometric-type obj)
(2dg::line-segment (display-line-segment-to-array obj array))
(2dg::tline (display-line-segment-to-array (tline-to-segment obj) array))
(2dg::string (display-string-to-array obj array))
(2dg::strip (display-strip-to-array obj array))
(2dg::area (display-area-to-array obj array))
(2dg::convex-group (display-convex-group-to-array obj array))
(2dg::extrema (display-extrema-to-array obj array))))
;))
; )
(defun DISPLAY-AREA-TO-ARRAY (area array &optional (gray (multiple-value-bind (n frac)
(floor (sqrt (norm (car (area-points area)))))
(ignore n)
(* .7 frac))))
nil)
"
(let ((a (make-array (list *image-size-y* *image-size-x*) :element-type '(unsigned-byte 1)))
(max-x 0)
(max-y 0)
(min-x *image-size-x*)
(min-y *image-size-y*))
(loop for pt in (area-points area)
doing
(setf (aref a (point-y pt) (point-x pt)) 1)
(setf max-x (max max-x (point-x pt)))
(setf max-y (max max-y (point-y pt)))
(setf min-x (min min-x (point-x pt)))
(setf min-y (min min-y (point-y pt))))
(with-output-into-bitmap (array)
(graphics:draw-rectangle min-x min-y max-x max-y :mask a :gray-level gray))))
"
(defun DISPLAY-STRING-TO-ARRAY (string array)
(loop for pt in (string-points string)
doing
(setf (aref array (point-y pt) (point-x pt)) 1)))
(defun DISPLAY-LINE-SEGMENT-TO-ARRAY (ls array &key check-bounds?)
(multiple-value-bind (max-x max-y)
(values-list (array-dimensions array))
(loop for pt in (points-between (line-segment-point-1 ls) (line-segment-point-2 ls))
for x = (point-x pt)
for y = (point-y pt)
doing
(when (or (not check-bounds?)
(and (<= 0 x) (<= 0 y) (< x max-x) (< y max-y)))
(setf (aref array (point-y pt) (point-x pt)) 1)))))
(defun DISPLAY-STRIP-TO-ARRAY (strip array)
(loop for pt in (mapcar #'angle-point-point (strip-angle-points strip))
doing
(setf (aref array (point-y pt) (point-x pt)) 1))
(loop for mp in (strip-matching-points strip)
doing
(let ((pt1 (strip-matching-point-point mp))
(pt2 (angle-point-point (nth (strip-matching-point-number mp)
(strip-angle-points strip)))))
(loop for pt in (points-between pt1 pt2)
doing
(setf (aref array (point-y pt) (point-x pt)) 1)))))
(defun DISPLAY-EXTREMA-TO-ARRAY (extrema array)
nil)
"
(with-output-into-bitmap (array)
(let* ((point (extrema-point extrema))
(scale (extrema-scale extrema))
(size (cond ((< scale 5) 4)
((< scale 10) 6)
((< scale 20) 8)
(t 10))))
(if (extrema-type-max? extrema)
(graphics:draw-circle (point-x point) (point-y point) size :filled nil)
(let ((x (point-x point))
(y (point-y point)))
(graphics:draw-rectangle (- x size) (- y size) (+ x size) (+ y size) :filled nil))))))
"
(defun DISPLAY-CONVEX-GROUP-TO-ARRAY (cg array)
(when (convex-group-lines cg)
;; Not a "mock" convex group, that just has corner points.
(let* ((midpoints (loop for l in (convex-group-lines cg)
collecting
(average-points (list (c-line-point-1 l) (c-line-point-2 l)))))
(midpoint (average-points midpoints)))
(loop for ls in (convex-group-line-segments cg)
doing
(display-line-segment-to-array ls array))
(loop for mp in midpoints
doing
(loop for pt in (points-between (round-point midpoint) (round-point mp))
for i from 1
doing
(when (= 0 (mod i *CONVEX-DOT-RATE*))
(setf (aref array (point-y pt) (point-x pt)) 1))))))
(when (not (eq (convex-group-corners cg) :uncomputed))
(display-distinguished-points-to-array (mapcar #'convex-corner-point (convex-group-corners cg)) array)))
(defun DISPLAY-DISTINGUISHED-POINTS-TO-ARRAY (pts array &optional (type 0))
nil)
"
(with-output-into-bitmap (array)
(ecase type
(0
(loop for pt in pts
doing
(graphics:draw-circle (round (point-x pt))
(round (point-y pt))
*display-corner-width*
:filled nil)))
(1
(loop for pt in pts
for x = (point-x pt)
for y = (point-y pt)
doing
(graphics:draw-rectangle (- x *display-corner-width*)
(- y *display-corner-width*)
(+ x *display-corner-width*)
(+ y *display-corner-width*)
:filled nil))))))
"
(defun AVERAGE-POINTS (pts)
(loop for i from 0
for pt in pts
sum (point-x pt) into x
sum (point-y pt) into y
finally (return (make-point (float (/ x i)) (float (/ y i))))))
(defun PRINT-TRAITS (traits strings name &optional (printer "pravda"))
nil)
"
(let ((raster (make-array (list *image-size-y* *image-size-x*) :element-type '(unsigned-byte 1))))
(loop for string in strings
doing
(display-object-to-array string raster))
(loop for ext in (append (nth 7 traits) (nth 9 traits))
doing
(display-object-to-array ext raster))
(user::ps-hardcopy-1-bit-raster raster printer :title (string-append name " extrema") :zoom 4)
(bitblt tv:alu-setz *image-size-x* *image-size-y* raster 0 0 raster 0 0)
(loop for strip in (nth 5 traits)
doing
(display-object-to-array strip raster))
(loop for line in (nth 1 traits)
doing
(display-object-to-array line raster))
(user::ps-hardcopy-1-bit-raster raster printer :title (string-append name " strips/lines") :zoom 4)
(bitblt tv:alu-setz *image-size-x* *image-size-y* raster 0 0 raster 0 0)
(loop for string in strings
doing
(display-object-to-array string raster))
(loop for area in (nth 3 traits)
doing
(display-object-to-array area raster))
(user::ps-hardcopy-1-bit-raster raster printer :title (string-append name " areas") :zoom 4)))
"
(defun CLASSIFY-TRAIT (trait)
(geometric-type trait))
(defun TRAIT-TYPE-LESS? (type1 type2)
(geometric-type-less? type1 type2))
(defun TRAITS-MEET-UNARY-CONSTRAINT? (trait1 trait2)
(eq (classify-trait trait1) (classify-trait trait2)))
(defun TRAIT-TYPES-MEET-UNARY-CONSTRAINT? (type1 type2)
(eq type1 type2))
(defun PRINT-CONVEX-GROUPS (cgs &key name (printer "pravda")
(raster (make-array (list *image-size-y* *image-size-x*) :element-type 'bit))
print-cover-pages)
nil)
"
(loop for cg in cgs
doing
(display-object-to-array cg raster)
(loop for c-line in (convex-group-lines cg)
for ls = (c-line-segment c-line)
doing
(display-object-to-array ls raster))
(let ((bb (padded-display-bounding-box cg)))
(loop for ls in (rectangle-line-segments bb)
doing
(display-object-to-array ls raster))))
(my-ps-hardcopy-1-bit-raster raster printer :title (string-append name " convex groups") :zoom 4
:print-cover-pages print-cover-pages))
"
(defun ARRAY-CONVEX-GROUPS (cgs &key (raster (make-array (list *image-size-y* *image-size-x*)
:element-type 'bit)))
(loop for cg in cgs
doing
(display-object-to-array cg raster)
(loop for c-line in (convex-group-lines cg)
for ls = (c-line-segment c-line)
doing
(display-object-to-array ls raster))
(let ((bb (padded-display-bounding-box cg)))
(loop for ls in (rectangle-line-segments bb)
doing
(display-object-to-array ls raster))))
raster)
(defun file-CONVEX-GROUPS (cgs name raster)
(loop for cg in cgs
doing
(display-object-to-array cg raster)
(loop for c-line in (convex-group-lines cg)
for ls = (c-line-segment c-line)
doing
(display-object-to-array ls raster))
(let ((bb (padded-display-bounding-box cg)))
(loop for ls in (rectangle-line-segments bb)
doing
(display-object-to-array ls raster))))
(user::ps-file-1-bit-raster raster name :zoom 4))
(defun RECTANGLE-LINE-SEGMENTS (r)
(list
(make-line-segment (make-point (rectangle-min-x r) (rectangle-min-y r))
(make-point (rectangle-max-x r) (rectangle-min-y r)))
(make-line-segment (make-point (rectangle-max-x r) (rectangle-max-y r))
(make-point (rectangle-max-x r) (rectangle-min-y r)))
(make-line-segment (make-point (rectangle-max-x r) (rectangle-max-y r))
(make-point (rectangle-min-x r) (rectangle-max-y r)))
(make-line-segment (make-point (rectangle-min-x r) (rectangle-min-y r))
(make-point (rectangle-min-x r) (rectangle-max-y r)))))
(defun PRINT-COMBINED-CONVEX-GROUPS (cgs &optional name (printer "pravda") background-mask (number-to-print 100)
print-cover-pages)
(loop for print-collection in (collect-separate-convex-groups-non-recursive cgs)
; nil nil (mapcar #'padded-display-bounding-box cgs) nil nil)
for print-num from 1 to number-to-print
doing
(print-convex-groups print-collection :name (string-append name (format nil " ~A" print-num)) :printer printer
:raster (if background-mask (copy-array background-mask) nil)
:print-cover-pages print-cover-pages)))
(defun ARRAY-COMBINED-CONVEX-GROUPS (cgs &optional background-mask (number-to-print 100))
(loop for print-collection in (collect-separate-convex-groups-non-recursive cgs)
repeat number-to-print
collecting
(array-convex-groups print-collection
:raster (if background-mask (copy-array background-mask) nil))))
(defun FILE-COMBINED-CONVEX-GROUPS (cgs file background-mask &optional (number-to-print 100))
(loop for print-collection in (collect-separate-convex-groups-non-recursive cgs)
; nil nil (mapcar #'padded-display-bounding-box cgs) nil nil)
for print-num from 1 to number-to-print
doing
(file-convex-groups print-collection (string-append file (format nil "-~A.ps" print-num)) (copy-array background-mask))))
(defun PRINT-ORDERED-CONVEX-GROUPS (cgs &optional name (printer "pravda") background-mask (number-to-print 100)
print-cover-pages)
(loop for print-collection in (mapcar #'list cgs)
; nil nil (mapcar #'padded-display-bounding-box cgs) nil nil)
for print-num from 1 to number-to-print
doing
(print-convex-groups print-collection :name (string-append name (format nil " ~A" print-num)) :printer printer
:raster (if background-mask (copy-array background-mask) nil)
:print-cover-pages print-cover-pages)))
(defun COLLECT-SEPARATE-CONVEX-GROUPS (cgs-to-go &optional print-collection excess
(bbs-to-go (mapcar #'padded-display-bounding-box cgs-to-go)) print-bbs excess-bbs answer)
(flet ((bb-intersects (bb bbs)
(loop for bb2 in bbs thereis (intersect? bb bb2))))
(if (null cgs-to-go)
(if (null excess) (reverse (cons print-collection answer))
(collect-separate-convex-groups excess nil nil excess-bbs nil nil (cons print-collection answer)))
(if (bb-intersects (car bbs-to-go) print-bbs)
(collect-separate-convex-groups (cdr cgs-to-go) print-collection (cons (car cgs-to-go) excess)
(cdr bbs-to-go) print-bbs (cons (car bbs-to-go) excess-bbs) answer)
(collect-separate-convex-groups (cdr cgs-to-go) (cons (car cgs-to-go) print-collection) excess
(cdr bbs-to-go) (cons (car bbs-to-go) print-bbs) excess-bbs answer)))))
(defun COLLECT-SEPARATE-CONVEX-GROUPS-non-recursive (cgs-to-go &optional (pad 4))
(flet ((bb-intersects (bb bbs)
(loop for bb2 in bbs thereis (intersect? bb bb2))))
(loop with bbs-to-go = (loop for cg in cgs-to-go collect (padded-display-bounding-box cg pad))
with print-collection = nil
with excess = nil
with print-bbs = nil
with excess-bbs = nil
with answer = nil
until (and (null cgs-to-go) (null excess))
finally (return (reverse (cons print-collection answer)))
doing
(if (null cgs-to-go)
(setq cgs-to-go excess
answer (cons print-collection answer)
print-collection nil
excess nil
bbs-to-go excess-bbs
print-bbs nil
excess-bbs nil)
(if (bb-intersects (car bbs-to-go) print-bbs)
(setq excess (cons (car cgs-to-go) excess)
cgs-to-go (cdr cgs-to-go)
excess-bbs (cons (car bbs-to-go) excess-bbs)
bbs-to-go (cdr bbs-to-go))
(setq print-collection (cons (car cgs-to-go) print-collection)
cgs-to-go (cdr cgs-to-go)
print-bbs (cons (car bbs-to-go) print-bbs)
bbs-to-go (cdr bbs-to-go)))))))
(defun PRINT-COMBINED-TRAITS (traits &optional name (printer "pravda"))
(loop for print-collection in (collect-separate-traits traits nil nil (mapcar #'display-bounding-box-list traits) nil nil)
for print-num from 1
doing
(print-trait-list print-collection (string-append name (format nil " ~A" print-num)) printer)))
(defun PADDED-DISPLAY-BOUNDING-BOX (trait &optional (pad 4))
(let ((rect (display-bounding-box trait)))
(make-rectangle (max 0 (- (rectangle-min-x rect) pad))
(min (1- *image-size-x*) (+ (rectangle-max-x rect) pad))
(max 0 (- (rectangle-min-y rect) pad))
(min (1- *image-size-y*) (+ (rectangle-max-y rect) pad)))))
(defun DISPLAY-BOUNDING-BOX-LIST (traits)
(let ((bbs (loop for trait in traits collecting (display-bounding-box trait))))
(loop for bb in (cdr bbs)
with min-x = (rectangle-min-x (car bbs))
with min-y = (rectangle-min-y (car bbs))
with max-x = (rectangle-max-x (car bbs))
with max-y = (rectangle-max-y (car bbs))
doing
(setq min-x (min min-x (rectangle-min-x bb))
min-y (min min-y (rectangle-min-y bb))
max-x (max max-x (rectangle-max-x bb))
max-y (max max-y (rectangle-max-y bb)))
finally (return (make-rectangle min-x max-x min-y max-y)))))
(defun COLLECT-SEPARATE-TRAITS (traits-to-go &optional print-collection excess
(bbs-to-go (mapcar #'display-bounding-box-list traits-to-go)) print-bbs excess-bbs answer)
(flet ((bb-intersects (bb bbs)
(loop for bb2 in bbs thereis (intersect? bb bb2))))
(if (null traits-to-go)
(if (null excess) (reverse (cons print-collection answer))
(collect-separate-traits excess nil nil excess-bbs nil nil (cons print-collection answer)))
(if (bb-intersects (car bbs-to-go) print-bbs)
(collect-separate-traits (cdr traits-to-go) print-collection (cons (car traits-to-go) excess)
(cdr bbs-to-go) print-bbs (cons (car bbs-to-go) excess-bbs) answer)
(collect-separate-traits (cdr traits-to-go) (append (car traits-to-go) print-collection) excess
(cdr bbs-to-go) (cons (car bbs-to-go) print-bbs) excess-bbs answer)))))
(defun PRINT-TRAIT-LIST (traits &optional name (printer "pravda")
(raster (make-array (list *image-size-y* *image-size-x*) :element-type 'bit)))
nil)
"
(loop for trait in traits
doing
(display-object-to-array trait raster))
(my-ps-hardcopy-1-bit-raster raster printer :title name ; (string-append name " traits")
:zoom 4))
"
(defun DOTTED-EDGE-IMAGE (edges dot-rate)
(let ((strings (edge-image-strings edges))
(raster (make-array (list *image-size-y* *image-size-x*) :element-type 'bit
:initial-element 0)))
(loop for string in strings
finally (return raster)
doing
(loop for pt in string
for i from 0
doing
(when (= 0 (mod i dot-rate))
(setf (aref raster (point-y pt) (point-x pt)) 1))))))
(defun MY-PS-HARDCOPY-1-BIT-RASTER (raster printer
&key (zoom 1) (position :center) (landscape-mode t)
(title "1 Bit Raster Hardcopy")
(print-cover-pages t))
nil)
"
(multiple-value-bind (width height) (decode-raster-array raster)
(with-open-stream
(hc-stream (hardcopy:make-hardcopy-stream
(hardcopy:get-hardcopy-device printer)
:landscape-p landscape-mode
:print-cover-pages print-cover-pages
:title title ))
(send hc-stream :set-allow-draw-outside-of-bounding-box t)
(multiple-value-bind (p-width p-height) (send hc-stream :inside-size)
(setq p-width (send hc-stream :convert-from-device-units p-width :pixel :horizontal))
(setq p-height (send hc-stream :convert-from-device-units p-height :pixel :vertical))
(let ((left (user::conv-to-dev hc-stream
(if (eql position :center)
(floor (- p-width (* zoom width)) 2)
(first position))
:x))
(top (user::conv-to-dev hc-stream
(if (eql position :center)
(- p-height (floor (- p-height (* zoom height)) 2))
(second position) )
:y )))
(send hc-stream :string-out title)
(send hc-stream :show-bitmap
raster width height :left left :top top :hzoom zoom :vzoom zoom))
))))
"
ice-units p-height :pixel :vertical))
(let ((left (user::conv-to-dev hc-stream
(if (eql position :center)
(floor (- p-width (* zoom wgeometry/x2dg/structs.lisp000666 002223 000322 00000030011 06050502556 015411 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
(in-package 2dg)
;;; It's guaranteed that the implementation of the procs in this file can change
;;; without affecting anything outside this file.
(export '(MAKE-ANGLE-POINT ANGLE-POINT-POINT ANGLE-POINT-ANGLE ANGLE-POINT? MAKE-SQUARE SQUARE-CORNER
SQUARE-WIDTH AREA-SIZE AREA-POINTS AREA-FROM-POINTS AREA? AREA-MAX-X AREA-MAX-Y AREA-MIN-X AREA-MIN-Y
MAKE-STRIP
STRIP? STRIP-MATCHING-POINT? STRIP-ANGLE-POINTS STRIP-MATCHING-POINTS STRIP-MATCHING-POINT-POINT
STRIP-MATCHING-POINT-NUMBER STRIP-MAX-X STRIP-MAX-Y STRIP-END-POINTS STRIP-POINTS STRING?
STRING-MAX-X STRING-MAX-Y STRING-POINTS STRING-FROM-POINTS STRING-END-POINTS
MAKE-EXTREMA EXTREMA-TYPE EXTREMA-MAG EXTREMA-STRING EXTREMA-POINT EXTREMA-POINT-INDEX EXTREMA-SCALE
EXTREMA-P EXTREMA-TYPE-MAX? EXTREMA-TYPE-MIN?
MAKE-RESOURCE-POINT FREE-ALL-RESOURCE-POINTS FREE-RESOURCE-POINT
MAKE-CONVEX-GROUP-INTERNAL CONVEX-GROUP-P CONVEX-GROUP-LAST-LINE CONVEX-GROUP-LAST-POINT CONVEX-GROUP-LINES
CONVEX-GROUP-POINTS COPY-CONVEX-GROUP CONVEX-GROUP-TOTAL-ANGLES CONVEX-GROUP-ANGLES
CONVEX-GROUP-LENGTH CONVEX-GROUP-GAP-LENGTH CONVEX-GROUP-MAX-GAP-SQUARED CONVEX-GROUP-GAPS
CONVEX-GROUP-FIRST-LINE CONVEX-GROUP-FIRST-POINT CONVEX-GROUP-CLOSED CONVEX-GROUP-LINE-SEGMENTS
CONVEX-GROUP-LAST-LINE-EFFECTIVE-LENGTH CONVEX-GROUP-LENGTH-REDUCTIONS CONVEX-GROUP-GAP-RATIO
MAKE-C-LINE C-LINE-P C-LINE-SEGMENT C-LINE-NORMAL C-LINE-VECTOR C-LINE-REVERSE-VECTOR C-LINE-LENGTH C-LINE-INDEX
C-LINE-POINT-1 C-LINE-POINT-2 C-LINE-UNDERLYING-POINTS C-LINE-CENTER C-LINE-NORMAL-ROTATED-CLOCKWISE
C-LINE-NORMAL-ROTATED-COUNTERWISE C-LINE-ANGLE C-LINES-SAME? C-LINE-ANGLE-ERROR
MAKE-TRAIT TRAIT-INDEX TRAIT-UNDERLYING-POINTS TRAIT-P MAKE-TLINE TLINE-POINT-1 TLINE-POINT-2 TLINE-P
TLINE-LENGTH TLINE-TO-SEGMENT
MAKE-CONVEX-CORNER CONVEX-CORNER-P CONVEX-CORNER-POINT CONVEX-CORNER-LINE-1 CONVEX-CORNER-LINE-2
CONVEX-GROUP-CORNERS
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Traits
(defstruct (TRAIT
:named
(:constructor make-trait (index &optional underlying-points))
:predicate
(:print-function (lambda (trait stream &rest ignore)
(format stream "#" (trait-index trait))))
)
index
underlying-points)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tlines
(defstruct (TLINE
:named
(:include trait)
(:constructor make-tline (point-1 point-2 &optional underlying-points))
:PREDICATE
(:print-function (lambda (tline stream &rest ignore)
(format stream "#" (tline-point-1 tline) (tline-point-2 tline))))
)
point-1
point-2)
(defun TLINE-LENGTH (tl)
(line-segment-length (tline-to-segment tl)))
(defun TLINE-TO-SEGMENT (tl)
(make-line-segment (tline-point-1 tl) (tline-point-2 tl)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Angle points are point and angle.
(defun MAKE-ANGLE-POINT (angle point)
(cons angle point))
(defun ANGLE-POINT-POINT (ap)
(cdr ap))
(defun ANGLE-POINT-ANGLE (ap)
(car ap))
(defun ANGLE-POINT? (object)
(and (consp object)
(numberp (car object))
(point-p (cdr object))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Squares
(defun MAKE-SQUARE (pt width)
(cons pt width))
(defun SQUARE-CORNER (sq)
(car sq))
(defun SQUARE-WIDTH (sq)
(cdr sq))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Areas
(defstruct (AREA
(:include trait)
:named
(:constructor make-area-internal (points))
:predicate
(:print-function (lambda (area stream &rest ignore)
(format stream "#" (area-points area))))
)
points)
(defun AREA-SIZE (area)
(length (area-points area)))
(defun AREA-FROM-POINTS (points)
(make-area-internal points))
(defun AREA? (object)
(area-p object))
(defun AREA-MAX-X (area)
(apply #'max (mapcar #'point-x (area-points area))))
(defun AREA-MAX-Y (area)
(apply #'max (mapcar #'point-y (area-points area))))
(defun AREA-MIN-X (area)
(apply #'min (mapcar #'point-x (area-points area))))
(defun AREA-MIN-Y (area)
(apply #'min (mapcar #'point-y (area-points area))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Strip data abstraction
(defstruct (STRIP
(:include trait)
:named
(:constructor make-strip (angle-points matching-points))
:predicate
(:print-function (lambda (strip stream &rest ignore)
(format stream "# >"
(strip-angle-points strip) (strip-matching-points strip))))
)
angle-points
matching-points)
;;; matching-point = (number of angle-point it matches point)
(defun STRIP? (item)
(strip-p item))
(defun STRIP-MATCHING-POINT-POINT (mp)
(cadr mp))
(defun STRIP-MATCHING-POINT-NUMBER (mp)
(car mp))
;;; The biggest x of any point mentioned in a strip, including the matching points
(defun STRIP-MAX-X (strip)
(let ((strip-points (append (mapcar #'angle-point-point (strip-angle-points strip))
(mapcar #'strip-matching-point-point (strip-matching-points strip)))))
(apply #'max (mapcar #'point-x strip-points))))
;;; The biggest y of any point mentioned in a strip, including the matching points
(defun STRIP-MAX-Y (strip)
(let ((strip-points (append (mapcar #'angle-point-point (strip-angle-points strip))
(mapcar #'strip-matching-point-point (strip-matching-points strip)))))
(apply #'max (mapcar #'point-y strip-points))))
(defun STRIP-END-POINTS (strip)
(list (angle-point-point (car (strip-angle-points strip))) (angle-point-point (nlast 0 (strip-angle-points strip)))
(strip-matching-point-point (car (strip-matching-points strip)))
(strip-matching-point-point (nlast 0 (strip-matching-points strip)))))
(defun STRIP-POINTS (strip)
(append (mapcar #'angle-point-point (strip-angle-points strip))
(mapcar #'strip-matching-point-point (strip-matching-points strip))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Strings
(defun STRING? (obj)
(list-of-points? obj))
(defun STRING-MAX-X (string)
(apply #'max (mapcar #'point-x string)))
(defun STRING-MAX-Y (string)
(apply #'max (mapcar #'point-y string)))
(defun STRING-POINTS (string)
string)
(defun STRING-FROM-POINTS (points)
points)
(defun STRING-END-POINTS (string)
(list (car string) (nlast 0 string)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Curvature Extrema
(defstruct (extrema
(:include trait)
:named
(:constructor make-extrema (type string mag point-index scale &optional point))
:predicate
(:print-function (lambda (ext stream &rest ignore)
(format stream "#<~A-EXTREMA ~A (MAG ~A)>"
(if (eq (extrema-type ext) 'max) "MAX" "MIN")
(extrema-point ext)
(EXTREMA-MAG EXT)))))
type
string
mag
point-index
scale
(point (nth point-index string)))
(defun EXTREMA-TYPE-MAX? (ext)
(eq 'max (extrema-type ext)))
(defun EXTREMA-TYPE-MIN? (ext)
(eq 'min (extrema-type ext)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Resource Points
;;;
;;; These are points that are resources, so they may be freed
"
(defresource RESOURCE-POINT (x y)
:constructor (make-point x y)
:initializer (mutate-point object x y)
:matcher t)
(defun MAKE-RESOURCE-POINT (x y)
(allocate-resource 'resource-point x y))
(defun FREE-ALL-RESOURCE-POINTS ()
(deallocate-whole-resource 'resource-point))
(defun FREE-RESOURCE-POINT (pt)
(deallocate-resource 'resource-point pt))
(defun T (&rest args) (ignore args) t)
"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Convex Groups
(defstruct (convex-group
(:include trait)
:named
(:constructor make-convex-group-internal)
:predicate
(:copier copy-convex-group)
(:print-function (lambda (cg stream &rest ignore)
(format stream "#"
(convex-group-gap-length cg) (convex-group-length cg) (convex-group-lines cg))))
)
last-line
last-point
lines
length
gap-length
max-gap-squared ; The largest gap to the next line
first-line
first-point
closed
gaps
(corners :uncomputed)
last-line-effective-length
length-reductions
(total-angles 0)
angles
)
(defun CONVEX-GROUP-POINTS (cg)
(loop for cl in (convex-group-lines cg)
for ls = (c-line-segment cl)
appending
(points-between (line-segment-point-1 ls) (line-segment-point-2 ls))))
(defun CONVEX-GROUP-END-POINTS (cg)
(loop for cl in (convex-group-lines cg)
for ls = (c-line-segment cl)
appending
(list (line-segment-point-1 ls) (line-segment-point-2 ls))))
(defun CONVEX-GROUP-GAP-RATIO (cg)
(/ (convex-group-length cg)
(+ (convex-group-length cg) (convex-group-gap-length cg))))
(defstruct (c-line
:named
(:constructor make-c-line (segment))
:predicate
(:print-function (lambda (cl stream &rest ignore)
(format stream "#" (c-line-point-1 cl) (c-line-point-2 cl))))
)
segment
normal
vector
reverse-vector
length
index
underlying-points
center
normal-rotated-clockwise
normal-rotated-counterwise
angle
angle-error
)
(defun C-LINE-POINT-1 (cl) (line-segment-point-1 (c-line-segment cl)))
(defun C-LINE-POINT-2 (cl) (line-segment-point-2 (c-line-segment cl)))
(defun C-LINES-SAME? (cl1 cl2)
"This is based on the way CONVEX-LINES works. Each line segment in the image forms two c-lines,
which are the same as each other, and no other c-lines.
"
(or (eq cl1 cl2)
(and (eq (c-line-point-1 cl1) (c-line-point-2 cl2))
(eq (c-line-point-2 cl1) (c-line-point-1 cl2)))))
(defun CONVEX-GROUP-LINE-SEGMENTS (cg) (mapcar #'c-line-segment (convex-group-lines cg)))
(defstruct (CONVEX-CORNER
:named
(:constructor make-convex-corner (point line-1 line-2))
:predicate
(:print-function (lambda (cc stream &rest ignore)
(format stream "#"
(point-x (convex-corner-point cc))
(point-y (convex-corner-point cc)))))
)
point
line-1
line-2
;; The point is the intersection of the two lines
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LIST-OF-POINTS
(defun LIST-OF-POINTS? (obj)
(and (consp obj)
(loop for item in obj always (point-p item))))
-corner (point line-1 line-2))
:predicate
(:print-function (lambda (cc stream &rest ignore)
(format stream "#"
(point-x (convex-corner-point cc))
(point-y (convex-corner-point cc)))))
)
point
line-1
line-2
;; The point is the intersection of the two lines
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LIST-OF-POINTS
(defun LIST-OF-POINTS? (obj)
(and (consp obj)
(loop for item in obj always (point-p itgeometry/x2dg/system.lisp000666 002223 000322 00000005261 06050502557 015240 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:USER; Syntax:Common-lisp; Lowercase:Yes; Default-character-style:(:FIX :ROMAN :NORMAL) -*-
(unless (find-package '2dg)
(load (format nil "~A~A" group-loading:*home-directory* "geometry/2d/system"))))
(in-package 2dg)
(defun COMPILE-LOAD (file)
(let ((bin (make-pathname
:directory (format nil "~A~A" group-loading:*home-directory* "geometry/x2dg/")
:name file :type group-loading:*binary-type*))
(source (make-pathname
:directory (format nil "~A~A" group-loading:*home-directory* "geometry/x2dg/")
:name file :type "lisp"))
)
(when (or (not (probe-file bin)) (< (file-write-date bin) (file-write-date source)))
(compile-file source))
(load bin)))
(defvar *X2DG-LOADED* t)
(compile-load "structs")
(compile-load "utilities")
(compile-load "print")-directory* "geometry/x2dg/")
:name file :type group-loading:*binary-type*))
(source (make-pathname
:directory (format nil "~A~A" group-loading:*home-directory* "geometry/x2dg/")
:name file :type "lisp"))
)
(when (or (not (probe-file bin)) (< (file-write-date bigeometry/x2dg/utilities.lisp000666 002223 000322 00000064025 06050502557 015732 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
(in-package g)
(export '(*TIMES* RESET-TIME TIME-TOTALS DEFTIME DEFTIME-BY-RESULT PROGNTIME ADD-TIME! DEFMEMO
CLEAR-MEMOIZED-FUNCTION *VERY-LARGE-NUMBER*
ERROR-FUDGE DIV slice-list reslice-list ONE AWRITE WRITE-ARRAY FIRST-N FIRST-TEST
;; SIGN
REMLIST REMDUPS-AND-APPEND
DIFFERENT-RANDOM-BETWEEN ALL-ORDERED-NTUPLES ALL-NTUPLES ALL-INSERTIONS ALL-PERMUTATIONS ALL-COMBINATIONS
;; REPEAT
LIST?
2LENGTH? MERGE-PARTITIONS PARTITION SORTED-INTERSECTION MAX-TEST RASTER-ARRAY-DIMENSIONS
TIMED-SORT TIMED-REMOVE TIMED-AREF2 FLET* COPY-ARRAY COPY-INTO-ARRAY COPY-INTO-BIT-ARRAY FLIP-ARRAY CONVERT-ARRAY CLEAR-ARRAY!
ARRAY-NULL-VALUE ARRAY-BITBLTABLE? BITBLTABLE-DIMENSIONS OR-ARRAYS WRITE-4D-ARRAY-AS-BINARY
FIND-ARRAY PROJECT-ARRAY BITS-IN-ELEMENT-TYPE TIMES-N-IS-FACTOR WHOLE? LENGTH= RESIZE-BINARY-RASTER
ROTATE-LIST ALL-ROTATIONS MULTI-MEMBER SCALE-IMAGE REALP
MAKE-CYCLE CYCLE-P CYCLE-LENGTH ROTATE-CYCLE-RIGHT ROTATE-CYCLE-LEFT CYCLE-CAR POP-CYCLE
PUSH-CYCLE DOCYCLE DOTIMES-CYCLE CYCLE-LIST CYCLE-NTH-RIGHT CYCLE-NTH-LEFT REMOVE-FROM-CYCLE
ADD-TO-CYCLE))
(defvar *TIMES* nil)
(defun RESET-TIME () (setf *TIMES* nil))
(defun TIME-TOTALS (&optional (times *times*))
(loop for time in times
doing
(print (list (car time) :time-in-minutes (/ (round (/ (cadr time) 600)) 100.0)
:number-of-calls (caddr time)))))
(defmacro DEFTIME (proc-name args &rest body)
(let ((time-var-name (gensym (symbol-name proc-name))))
`(defun ,proc-name ,args
(let ((,time-var-name (get-internal-real-time)))
(let ((result
(multiple-value-list
,(cons 'progn body))))
(let ((,time-var-name (time-difference (get-internal-real-time) ,time-var-name)))
(add-time! (quote ,proc-name) ,time-var-name)
(apply #'values result)))))))
(defmacro DEFTIME-BY-RESULT (proc-name args &rest body)
(let ((time-var-name (gensym (symbol-name proc-name))))
`(defun ,proc-name ,args
(let ((,time-var-name (get-internal-real-time)))
(multiple-value-bind (val1 val2 val3 val4 val5 val6 val7 val8)
,(cons 'progn body)
(let ((,time-var-name (time-difference (get-internal-real-time) ,time-var-name)))
(add-time! (list (quote ,proc-name) val1) ,time-var-name)
(values val1 val2 val3 val4 val5 val6 val7 val8)))))))
(defmacro PROGNTIME (progn-name &rest exps)
(let ((time-var-name (gensym (symbol-name progn-name))))
`(let ((,time-var-name (get-internal-real-time)))
(multiple-value-bind (val1 val2 val3 val4 val5 val6 val7 val8)
,(cons 'progn exps)
(let ((,time-var-name (time-difference (get-internal-real-time) ,time-var-name)))
(add-time! (quote ,progn-name) ,time-var-name)
(values val1 val2 val3 val4 val5 val6 val7 val8))))))
(defun TIME-DIFFERENCE (t1 t2) (- t1 t2))
(defun ADD-TIME! (name time)
(let ((time-pair (assoc name *TIMES* :test #'equal)))
(if (null time-pair)
(setf *TIMES* (cons (list name time 1) *TIMES*))
(progn
(rplaca (cdr time-pair) (+ time (cadr time-pair)))
(rplaca (cddr time-pair) (1+ (caddr time-pair)))))))
(defun CLEAR-MEMOIZED-FUNCTION (fun-name)
(if (functionp (intern (string-append "CLEAR-MEMO-" fun-name)))
(funcall (intern (string-append "CLEAR-MEMO-" fun-name)))
nil))
(defmacro DEFMEMO (proc-name args &rest body)
(let ((memo-table (make-hash-table :test #'equal)))
`(progn
(defun ,(intern (string-append "CLEAR-MEMO-" proc-name)) () (not (not (clrhash ,memo-table))))
(defun ,proc-name ,args
(let ((lookup (gethash ,(cons 'list args) ,memo-table)))
(if lookup (apply #'values lookup)
(let ((res-list (multiple-value-list ,(cons 'progn body))))
(setf (gethash ,(cons 'list args) ,memo-table) res-list)
(apply #'values res-list))))))))
(defvar *VERY-LARGE-NUMBER* 9999999999)
(defvar ERROR-FUDGE .00001)
(defun div (x y) (if (= y 0) *VERY-LARGE-NUMBER* (/ x y)))
;(defun FILTER (proc lst &rest arg-lists)
; (if (null arg-lists)
; (loop for mem in lst
; appending
; (if (apply proc (list mem)) (list mem)))
; (loop for mem in lst
; for args in (slice-list arg-lists (length lst))
; appending
; (if (apply proc (cons mem args)) (list mem)))))
(defun SLICE-LIST (lst-of-lsts res-lengths)
(if (zerop res-lengths) nil
(cons (loop for lst in lst-of-lsts
collecting
(if (consp lst) (car lst) lst))
(slice-list (loop for lst in lst-of-lsts
collecting
(if (consp lst) (cdr lst) lst)) (1- res-lengths)))))
(defun RESLICE-LIST (list-of-lists)
(let ((list-of-lists (copy-list list-of-lists)))
(loop until (loop for list in list-of-lists
never list)
collecting
(loop for lists on list-of-lists
collecting
(pop (car lists))))))
(defun ONE (x) (ignore x) 1)
(defun AWRITE (array) (write array :array t))
(defun WRITE-ARRAY (array x1 y1 x2 y2)
(loop for j from y1 to y2
doing
(format t "~%~A:" j)
(loop for i from x1 to x2
doing
(format t " ~A" (aref array i j)))))
(defun FIRST-N (n lst) (loop for m in lst for i from 1 to n collecting m))
(defun FIRST-TEST (lst test)
(if (null lst) nil
(if (apply test (list (car lst))) (car lst)
(first-test (cdr lst) test))))
(defun ROTATE-LIST (n lst)
"Assumes (< n (length lst))"
(append (nthcdr n lst)
(loop for i in lst
repeat n
collecting i)))
(defun ALL-ROTATIONS (lst)
(loop for i from 0 below (length lst)
collecting
(rotate-list i lst)))
(defun MULTI-MEMBER (item lst &key (test #'eql) (key #'identity))
(loop for item2 in lst
when (funcall test item (funcall key item2))
collect item2))
(defun SIGN (x)
(if (< x 0)
-1
1))
;;; Remove all occurrences of lst1 from lst2
(defun REMLIST (lst1 lst2 &key (test #'eql))
(remove lst1 lst2 :test (lambda (lst item) (member item lst :test test))))
;;; Like remdups, but we know that each list contains no duplicates.
(defun REMDUPS-AND-APPEND (lsts)
(flet ((thing-in-list-of-lists (thing list-of-lists)
(loop for lst in list-of-lists
thereis
(member thing lst))))
(loop for lst in lsts
for rest on lsts
appending
(if (null (cdr rest)) lst
(loop for mem in lst
appending
(if (thing-in-list-of-lists mem (cdr rest))
nil
(list mem)))))))
;;; We assume start and end are integers, and n integers between/including them are desired.
(defun DIFFERENT-RANDOM-BETWEEN (start end n)
(if (= n 0) nil
(let ((num (random-between start (1+ end)))
(rest-nums (different-random-between start (1- end) (1- n))))
(cons num
(loop for m in rest-nums
collecting
(if (< m num) m (1+ m)))))))
(defun ALL-ORDERED-NTUPLES (lst n)
(if (= n 0) (list nil)
(if (length= lst n) (all-permutations lst)
(append (all-ordered-ntuples (cdr lst) n)
(loop for sub-tup in (all-ordered-ntuples (cdr lst) (1- n))
appending
(all-insertions (car lst) sub-tup))))))
(defun ALL-NTUPLES (lst n)
(if (= n 0) (list nil)
(if (length= lst n) (list lst)
(append (all-ntuples (cdr lst) n)
(loop for sub-tup in (all-ntuples (cdr lst) (1- n))
collecting
(cons (car lst) sub-tup))))))
(defun ALL-INSERTIONS (elm lst)
(loop for i from 0 to (length lst)
collecting
(append (first-n i lst)
(list elm)
(copy-list (nthcdr i lst)))))
(defun ALL-PERMUTATIONS (lst)
(if (null lst) nil
(if (length= lst 1) (list lst)
(loop for sub-permut in (all-permutations (cdr lst))
append
(all-insertions (car lst) sub-permut)))))
(defun ALL-COMBINATIONS (lst-of-lsts)
(if (null lst-of-lsts)
nil
(loop for lst in lst-of-lsts
with result = (list nil)
doing
(setq result
(loop for res in result
appending
(loop for item in lst
collecting
(cons item res))))
finally (return (mapcar #'reverse result)))))
(defun MERGE-PARTITIONS (part1 part2 test)
(labels ((add-set-to-partitions (set part)
(let ((n (position set part :test (lambda (s1 s2) (apply test (list (car s1) (car s2)))))))
(if (null n) (cons set part)
(append (first-n n part) (list (append set (nth n part))) (nthcdr (1+ n) part))))))
(if (null part1) part2
(merge-partitions (cdr part1) (add-set-to-partitions (car part1) part2) test))))
(defun PARTITION (set test &optional len)
(when (null len) (setf len (length set)))
(if (= len 0) nil
(if (= len 1) (list set)
(merge-partitions (partition (first-n (floor (/ len 2)) set) test (floor (/ len 2)))
(partition (nthcdr (floor (/ len 2)) set) test (ceiling (/ len 2)))
test))))
;;; Find the intersection of two sorted lists. Comparison function
(defun SORTED-INTERSECTION (lst1 lst2 comparison-function equality-function)
(cond ((or (null lst1) (null lst2)) nil)
((apply equality-function (list (car lst1) (car lst2)))
(cons (car lst1) (sorted-intersection (cdr lst1) (cdr lst2)
comparison-function equality-function)))
((apply comparison-function (list (car lst1) (car lst2)))
(sorted-intersection (cdr lst1) lst2 comparison-function equality-function))
(t (sorted-intersection lst1 (cdr lst2) comparison-function equality-function))))
;;; compare function returns t if the second arguement is bigger.
(defun MAX-TEST (set binary-compare-function)
(if (null (cdr set)) (car set)
(let ((other (max-test (cdr set) binary-compare-function)))
(if (apply binary-compare-function (list (car set) other))
other
(car set)))))
(defun RASTER-ARRAY-DIMENSIONS (a)
(let ((dim (array-dimensions a)))
(when (/= (length dim) 2)
(error "~A is not a raster array" a))
(list (nth 1 dim) (nth 0 dim))))
(deftime TIMED-SORT (lst proc &key key)
(if key (funcall #'sort lst proc :key key)
(funcall #'sort lst proc)))
(deftime TIMED-REMOVE (x lst &key test)
(funcall #'remove x lst :test test))
(deftime TIMED-AREF2 (ar i j)
(aref ar i j))
(defmacro FLET* (&rest rest)
(cons 'labels rest))
(defun COPY-ARRAY (ar)
(let* ((dims (array-dimensions ar))
(new-array (make-array dims :element-type (array-element-type ar))))
; (if (array-bitbltable? ar)
; (bitblt tv:alu-seta (cadr dims) (car dims) ar 0 0 new-array 0 0)
(let ((1d-ar (make-array (list (apply #'* dims)) :element-type (array-element-type ar)
:displaced-to ar))
(1d-new-array (make-array (list (apply #'* dims)) :element-type (array-element-type ar)
:displaced-to new-array)))
(loop for i from 0 to (1- (apply #'* dims))
doing
(setf (aref 1d-new-array i) (aref 1d-ar i))))
; )
new-array))
(deftime COPY-INTO-ARRAY (ar1 ar2)
"Arrays must be same size."
(let* ((dims (array-dimensions ar1)))
(let ((1d-ar1 (make-array (list (apply #'* dims))
:element-type (array-element-type ar1)
:displaced-to ar1))
(1d-ar2 (make-array (list (apply #'* dims))
:element-type (array-element-type ar2)
:displaced-to ar2)))
(loop for i from 0 to (1- (apply #'* dims))
doing
(setf (aref 1d-ar2 i) (aref 1d-ar1 i))))
ar2))
(deftime COPY-INTO-BIT-ARRAY (ar1 ar2)
"Arrays must be same size, and must both be binary."
(bit-and ar1 ar1 ar2))
(defun FLIP-ARRAY (ar)
(let ((dimensions (array-dimensions ar)))
(when (not (= (length dimensions) 2)) (error "FLIP-ARRAY can only work on 2d arrays."))
(let ((new-ar (make-array (reverse dimensions) :element-type (array-element-type ar))))
(loop for i from 0 below (car dimensions)
doing
(loop for j from 0 below (cadr dimensions)
doing
(setf (aref new-ar j i) (aref ar i j))))
new-ar)))
"
(let ((dimensions (array-dimensions ar)))
(when (not (= (length dimensions) 2)) (error "FLIP-ARRAY can only work on 2d arrays."))
(let ((new-ar (make-array (reverse dimensions) :element-type (array-element-type ar))))
(declare (compiler:array-register-1d ar))
(declare (compiler:array-register-1d new-ar))
(loop for ar-index from 0 to (1- (apply #'* dimensions))
doing
(let* ((i (mod ar-index (cadr dimensions)))
(j (floor (/ ar-index (cadr dimensions))))
(new-ar-index (+ j (* i (car dimensions)))))
(setf (sys:%1d-aref new-ar new-ar-index) (sys:%1d-aref ar ar-index))))
new-ar)))
"
(defun CONVERT-ARRAY (ar)
(multiple-value-bind (w h span) (decode-raster-array ar)
(ignore w)
(make-raster-array h span :element-type (array-element-type ar) :displaced-to ar)))
(defun CLEAR-ARRAY! (ar)
(let ((null-value (array-null-value ar))
(dims (array-dimensions ar)))
; (if (array-bitbltable? ar)
; (bitblt tv:alu-setz (cadr dims) (car dims) ar 0 0 ar 0 0)
(let ((1d-ar (make-array (list (apply #'* dims)) :element-type (array-element-type ar)
:displaced-to ar)))
(loop for i from 0 to (1- (apply #'* dims))
doing
(setf (aref 1d-ar i) null-value)))))
; )
(defun ARRAY-NULL-VALUE (ar)
(if (eq t (array-element-type ar)) nil 0))
(defun ARRAY-BITBLTABLE? (ar)
(if (= 2 (length (array-dimensions ar)))
(if (listp (array-element-type ar))
(and
(eq (car (array-element-type ar)) 'integer)
(let ((bits (bits-in-element-type (array-element-type ar))))
(= 0 (mod (cadr (array-dimensions ar)) (/ 32 bits)))))
(eq (array-element-type ar) 'fixnum))))
(defun BITBLTABLE-DIMENSIONS (x y)
(values (* 32 (ceiling (/ x 32))) y))
(defun OR-ARRAYS (first-array &rest arrays)
(if (null arrays) first-array
(let ((element-type (array-element-type first-array)))
(loop for et in (mapcar #'array-element-type arrays)
doing
(when (not (equal element-type et)) (error "Arrays must have same element type")))
(loop for a in (cons first-array arrays)
doing
(when (not (= (length (array-dimensions a)) 2)) (error "Arrays must all be raster arrays"))
(when (not (array-bitbltable? a)) (error "Arrays must all be bitblt-able")))
(let ((x (apply #'max (mapcar #'cadr (mapcar #'array-dimensions (cons first-array arrays)))))
(y (apply #'max (mapcar #'car (mapcar #'array-dimensions (cons first-array arrays))))))
(let ((new-array (make-raster-array x y :element-type element-type)))
(loop for ar in (cons first-array arrays)
doing
(bitblt boole-ior (cadr (array-dimensions ar)) (car (array-dimensions ar))
ar 0 0 new-array 0 0))
new-array)))))
;;; Inspecting 4d arrays.
(defun WRITE-4D-ARRAY-AS-BINARY (struct)
(let* ((array (find-array struct))
(dims (array-dimensions array)))
(format t "~%")
(loop for i from 0 to (1- (car dims))
doing
(loop for j from 0 to (1- (cadr dims))
doing
(loop for k from 0 to (1- (caddr dims))
doing
(loop for l from 0 to (1- (cadddr dims))
doing
(if (aref array i j k l) (format t "1") (format t "0")))
(format t "~%"))
(format t "~%"))
(format t "~%"))))
(defun FIND-ARRAY (struct)
(if (arrayp struct) struct
(if (not (consp struct)) nil
(let ((a? (find-array (car struct))))
(if (arrayp a?) a?
(find-array (cdr struct)))))))
(defun PROJECT-ARRAY (array dims-wanted)
(labels ((next-indices (inds dims)
(if (null inds) nil
(if (< (car inds) (1- (car dims))) (cons (1+ (car inds)) (cdr inds))
(let ((rest-inds (next-indices (cdr inds) (cdr dims))))
(if (null rest-inds) nil
(cons 0 rest-inds)))))))
(let* ((old-dims (array-dimensions array))
(new-array (make-array (loop for dim in dims-wanted collecting (nth dim old-dims))
:element-type '(unsigned-byte 1)))
(start-indices (loop for d in old-dims collecting 0))
(indices start-indices))
(loop until (null indices)
doing
(setf (apply #'aref (cons new-array (loop for dim in dims-wanted collecting (nth dim indices))))
(if (or (= 1 (apply #'aref (cons new-array (loop for dim in dims-wanted collecting (nth dim indices)))))
(apply #'aref (cons array indices)))
1
0))
(setf indices (next-indices indices old-dims)))
new-array)))
;;; This is not complete. I'm only making it work on types of 'integer, for now.
(defun BITS-IN-ELEMENT-TYPE (element-type)
(round (log (caaddr element-type) 2)))
(defun TIMES-N-IS-FACTOR (n num)
(if (whole? (/ num n))
(1+ (times-n-is-factor n (/ num n)))
0))
(defun WHOLE? (n)
(= n (round n)))
;;; Efficient testing if (= n (length lst))
(defun LENGTH= (lst n)
(if (null lst)
(if (= n 0) t nil)
(if (= n 0) nil
(length= (cdr lst) (1- n)))))
(defun RESIZE-BINARY-RASTER (ar factor)
(let ((new-ar (make-array (list (floor (/ (car (array-dimensions ar)) factor)) (floor (/ (cadr (array-dimensions ar)) factor)))
:element-type '(unsigned-byte 1))))
(loop for i from 0 to (1- (car (array-dimensions new-ar)))
doing
(loop for j from 0 to (1- (cadr (array-dimensions new-ar)))
doing
(setf (aref new-ar i j)
(if (loop for k from (* i factor) to (1- (+ (* i factor) factor))
thereis
(loop for l from (* j factor) to (1- (+ (* j factor) factor))
thereis
(= 1 (aref ar k l))))
1
0))))
new-ar))
;;; (defun SCALE-IMAGE (im)
;;; "given an image, scale the pixel values so that they are between 0 and 255"
;;; (let* ((new-im (make-array (array-dimensions im) :element-type '(unsigned-byte 8))))
;;; (declare (compiler:array-register-1d im))
;;; (declare (compiler:array-register-1d new-im))
;;; (let ((max-val 0)
;;; (min-val 255))
;;; (loop for i from 0 below (reduce #'* (array-dimensions im))
;;; for val = (sys:%1d-aref im i)
;;; doing
;;; (setq max-val (max max-val val)
;;; min-val (min min-val val)))
;;; (loop for i from 0 below (reduce #'* (array-dimensions im))
;;; with scale = (/ 255 (- max-val min-val))
;;; doing
;;; (setf (sys:%1d-aref new-im i) (floor (* scale (- (sys:%1d-aref im i) min-val)))))
;;; new-im)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RANDOM SIMPLE PROCS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun REPEAT (mem n)
(loop for i from 1 to n collecting mem))
(defun LIST? (lst)
(if (null lst) t
(if (atom lst) nil
(loop for a on lst
doing
(if (atom a) (return nil)
(if (null (cdr a)) (return t)))))))
(defun 2LENGTH? (lst)
(and (not (null lst)) (not (null (cdr lst))) (null (cddr lst))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Cycle abstraction
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (defstruct (CYCLE
;;; :named
;;; (:constructor make-cycle-internal (first-element length))
;;; :predicate
;;; (:print-function (lambda (cycle stream &rest ignore)
;;; (cycle-print-function cycle stream)))
;;; )
;;; first-element
;;; length)
;;;
;;; (defmacro DOCYCLE ((var cycle &optional resultform) &body forms)
;;; "this is a little primitive. For example, if an error occurs
;;; inside this loop, the results will be unpredictable.
;;; "
;;; (append `(dotimes-cycle (,var ,cycle (cycle-length ,cycle) ,resultform))
;;; forms))
;;;
;;; (defmacro DOTIMES-CYCLE ((var cycle n &optional resultform) &body forms)
;;; "This says loop through n elements of a cycle, but don't disturb its state."
;;; (let ((elm-var (gensym "elm")))
;;; `(loop repeat ,n
;;; for ,elm-var first (cycle-first-element ,cycle)
;;; then (cycle-element-right ,elm-var)
;;; for ,var = (cycle-element-val ,elm-var)
;;; do ,(cons 'progn forms)
;;; finally
;;; (return ,(if resultform resultform 'nil)))))
;;;
;;; (defun CYCLE-PRINT-FUNCTION (cycle stream)
;;; ; (if (= 0 (cycle-length cycle))
;;; ; (format stream "[#CYCLE ()]")
;;; ; (progn
;;; ; (format stream "[#CYCLE (")
;;; ; (loop repeat (1- (cycle-length cycle))
;;; ; do (format stream "~A " (cycle-car cycle))
;;; ; (rotate-cycle-right cycle))
;;; ; (format stream "~A)]" (cycle-car cycle))
;;; ; (rotate-cycle-right cycle)))))
;;; (format stream "[#CYCLE (")
;;; (dotimes-cycle (elm cycle (cycle-length cycle))
;;; (format stream "~A " elm))
;;; (format stream ")]"))
;;;
;;; (defstruct (CYCLE-ELEMENT
;;; (:constructor make-cycle-element (val &optional right left))
;;; (:print-function (lambda (ce stream &rest ignore)
;;; (format stream "~A"
;;; (cycle-element-val ce)))))
;;; val
;;; right
;;; left)
;;;
;;; (defun MAKE-CYCLE (lst)
;;; (if (null lst)
;;; (make-cycle-internal nil 0)
;;; (let ((elements (mapcar #'make-cycle-element lst)))
;;; (loop with first-element = (car elements)
;;; for len from 1
;;; for e in elements
;;; for next-e in (cdr elements)
;;; do (setf (cycle-element-right e) next-e)
;;; (setf (cycle-element-left next-e) e)
;;; finally (setf (cycle-element-right e) first-element)
;;; (setf (cycle-element-left first-element) e)
;;; (return (make-cycle-internal first-element len))))))
;;;
;;; (defun CYCLE-LAST-ELEMENT (cycle) (cycle-element-left (cycle-first-element cycle)))
;;;
;;; (defun ROTATE-CYCLE-RIGHT (cycle &optional (n 1))
;;; (loop repeat n
;;; doing
;;; (setf (cycle-first-element cycle) (cycle-element-right (cycle-first-element cycle)))))
;;;
;;; (defun ROTATE-CYCLE-LEFT (cycle &optional (n 1))
;;; (loop repeat n
;;; doing
;;; (setf (cycle-first-element cycle) (cycle-last-element cycle))))
;;;
;;; (defun CYCLE-CAR (cycle) (cycle-element-val (cycle-first-element cycle)))
;;;
;;; (defun CYCLE-NTH-RIGHT-ELEMENT (n cycle)
;;; (if (< n 0)
;;; (cycle-nth-left-element (- n) cycle)
;;; (loop for element first (cycle-first-element cycle)
;;; then (cycle-element-right element)
;;; repeat n
;;; finally (return element))))
;;;
;;; (defun CYCLE-NTH-RIGHT (n cycle)
;;; (cycle-element-val (cycle-nth-right-element n cycle)))
;;;
;;; (defun CYCLE-NTH-LEFT-ELEMENT (n cycle)
;;; (if (< n 0)
;;; (cycle-nth-right-element (- n) cycle)
;;; (loop for element first (cycle-first-element cycle)
;;; then (cycle-element-left element)
;;; repeat n
;;; finally (return element))))
;;;
;;; (defun CYCLE-NTH-LEFT (n cycle)
;;; (cycle-element-val (cycle-nth-left-element n cycle)))
;;;
;;; (defun POP-CYCLE (cycle)
;;; (let* ((first-element (cycle-first-element cycle))
;;; (last-element (cycle-element-left first-element))
;;; (second-element (cycle-element-right first-element)))
;;; (setf (cycle-element-right last-element) second-element)
;;; (setf (cycle-element-left second-element) last-element)
;;; (setf (cycle-first-element cycle) second-element)
;;; (decf (cycle-length cycle))
;;; (cycle-element-val first-element)))
;;;
;;; (defun PUSH-CYCLE (cycle val)
;;; (let* ((first-e (cycle-first-element cycle))
;;; (last-e (cycle-last-element cycle))
;;; (e (make-cycle-element val first-e last-e)))
;;; (setf (cycle-element-left first-e) e)
;;; (setf (cycle-element-right last-e) e)
;;; (setf (cycle-first-element cycle) e)
;;; (incf (cycle-length cycle))
;;; cycle))
;;;
;;; (defun REMOVE-FROM-CYCLE (cycle from to)
;;; "Remove all elements of the cycle from (cycle-nth-right cycle from)
;;; to (cycle-nth-right cycle to)
;;; Currently restricted so that (< from to cycle-length)
;;; "
;;; (let ((from (mod from (cycle-length cycle)))
;;; (to (mod to (cycle-length cycle))))
;;; (let ((left-of-remove (cycle-nth-right-element (1- from) cycle))
;;; (right-of-remove (cycle-nth-right-element (1+ to) cycle))
;;; (number-removed (if (<= from to) (1+ (- to from))
;;; (1+ (- (+ to (cycle-length cycle)) from)))))
;;; (setf (cycle-element-right left-of-remove) right-of-remove)
;;; (setf (cycle-element-left right-of-remove) left-of-remove)
;;; (decf (cycle-length cycle) number-removed)
;;; (when (or (<= from 0 to) (< to from))
;;; (setf (cycle-first-element cycle) left-of-remove)))))
;;;
;;; (defun ADD-TO-CYCLE (cycle object n)
;;; "Make OBJECT the N'th thing in CYCLE"
;;; (let* ((left-element (cycle-nth-right-element (1- n) cycle))
;;; (right-element (cycle-nth-right-element n cycle))
;;; (new-element (make-cycle-element object right-element left-element)))
;;; (setf (cycle-element-left right-element) new-element)
;;; (setf (cycle-element-right left-element) new-element)
;;; (incf (cycle-length cycle))
;;; (when (= n 0)
;;; (setf (cycle-first-element cycle) new-element))))
;;;
;;; (defun CYCLE-LIST (c &optional (len (cycle-length c)))
;;; (let ((res nil))
;;; (dotimes-cycle (val c len)
;;; (push val res))
;;; (reverse res)))
ght-element n cycle))
;;; (new-element (make-cycle-element object right-element left-element)))
;;; (setf (cycle-element-left right-element) new-element)
;;; (setf (cycle-element-right left-element) new-element)
;;; (incf (cycle-length cycle))
;;; (when (= n 0)
;;; (setf (cycle-first-element cycle) new-element))))
;;;
;;; (defun CYCLE-LIST (c &optional (len (cycle-length c)))
;;; (let ((res nil))
;;; (dotimes-cycle (val c len)
;;; (push val res))
;;;group/000700 002223 000322 00000000000 06050445153 011434 5ustar00dwjCSI000000 000000 group/convex-points.lisp000666 002223 000322 00000056244 06050465335 015176 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Package: GROUP; Mode: LISP; Base: 10; Syntax: Common-Lisp -*-
(in-package group)
;;; Given a convex-group, this file will find point features.
;;; In a convex group the lines are arranged so that the second point of the
;;; last line should join the first point of the next to last line ...
;;; and the second point of the first line joins the first point of the last line.
;;; Whether a line segment is stable depends on the strings that produce it. Put this off
;;; for now.
;;; Suppose the lines are colinear, or parallel and almost colinear.
;;; Think of this as arising from: ____________|----|___________
;;; The colinear lines will be in the same convex group, and their endpoints
;;; will be stable, so if they're close enough together, there should be a stable
;;; corner.
;;; COMMENTS
;;; The method of computing line-segment-angle-error seems bad.
;;; To Do
;;; If a line doesn't contribute to a corner, consider its neighboring lines.
;;; Fix unstable corner problem from way back.
;;; If only a small part of a long line appears in a cg, the presence of this line
;;; is probably unstable, and so the line should not contribute to any corners.
(defvar *very-large-number* 999999999999)
(defvar *MAX-CORNER-INSTABILITY* 15)
(defvar *MAX-POINT-ERROR* 5)
(defvar *POINT-ERROR-FOR-CORNER-ANGLES* 5)
(defvar *GENERAL-CORNER-ERROR* 2)
(defvar *MERGEABLE-CORNER-DISTANCE* 2 "Corners may merge into one point if they are no more than
this far from the point")
(defvar *MERGEABLE-CORNER-DISTANCE-SQUARED*
(g:sq *MERGEABLE-CORNER-DISTANCE*))
(defvar *2-MERGEABLE-CORNER-DISTANCE-SQUARED*
(g:sq (* 2 *MERGEABLE-CORNER-DISTANCE*)))
(defun CONVEX-GROUPS-WITH-SUPERSET-CORNERS (cgs &optional (min-size 0))
"Even a cg has fewer than min-size corners, or its corners are a subset of the
corners of another cg, than toss it out. If many cgs have the same corners, keep
only one of them.
"
(let ((big-cgs (remove-if #'(lambda (cg) (< (length (convex-group-corners cg)) min-size)) cgs)))
(loop for cg1 in big-cgs
for i from 0
when (loop for cg2 in big-cgs
for j from 0
always
(if (< i j)
(not (list-of-convex-corners-proper-subset (convex-group-corners cg1) (convex-group-corners cg2)))
(if (< j i)
(not (list-of-convex-corners-subset (convex-group-corners cg1) (convex-group-corners cg2)))
t)))
collect cg1)))
(defun CONVEX-GROUPS-WITH-UNIQUE-CORNERS (cgs &optional (min-size 0))
"Find the corners of each convex group, and only keep the ones that are truly different,
and have more than MIN-SIZE corners.
"
(remdups (copy-list
(remove-if #'(lambda (cg) (< (length (convex-group-corners cg)) min-size)) cgs))
#'(lambda (cg1 cg2) (list-of-convex-corners-same (convex-group-corners cg1)
(convex-group-corners cg2)))
#'(lambda (cg1 cg2) (unordered-list-of-convex-corners-ordering
(convex-group-corners cg1)
(convex-group-corners cg2)))))
(defun UNORDERED-LIST-OF-CONVEX-CORNERS-ORDERING (list1 list2)
"We have two lists of convex corners. We want some canonical way of ordering them, so
we can sort them and remove identical ones.
"
(let ((len1 (length list1))
(len2 (length list2)))
(if (< len1 len2) t
(if (< len2 len1) nil
(let ((sorted-list1 (sort (copy-list list1) #'convex-corner-ordering))
(sorted-list2 (sort (copy-list list2) #'convex-corner-ordering)))
(loop for cc1 in sorted-list1
for cc2 in sorted-list2
doing
(when (not (convex-corners-eq cc1 cc2))
(return
(if (convex-corner-ordering cc1 cc2)
t
nil)))
finally (return nil)))))))
(defun LIST-OF-CONVEX-CORNERS-SAME (list1 list2)
"This fails if a list has the same convex corner more than once."
(and (= (length list1) (length list2))
(loop for cc in list1
always
(member cc list2 :test #'convex-corners-eq))))
(defun LIST-OF-CONVEX-CORNERS-SUBSET (list1 list2)
"Is list 1 a subset of list 2? It need not be a proper subset."
(loop for cc in list1
always (member cc list2 :test #'convex-corners-eq)))
(defun LIST-OF-CONVEX-CORNERS-PROPER-SUBSET (list1 list2)
"Is list 1 a subset of list 2? It need not be a proper subset."
(and (< (length list1) (length list2))
(loop for cc in list1
always (member cc list2 :test #'convex-corners-eq))))
(defun COMPUTE-CONVEX-GROUPS-CORNERS (cgs) ; ht)
(loop for cg in cgs
doing
(setf (convex-group-corners cg) (find-convex-group-corners cg)); ht))))
finally (clear-memoized-function 'adjacent-lines-feature-point)))
;(defun FIND-CONVEX-GROUP-CORNERS (cg ht)
; "ht is a hash table containing all unstable line segments"
; (let* ((c-lines (remove-if (lambda (cl) (line-segment-unstable? (c-line-segment cl) ht))
; (cons (car (convex-group-lines cg)) (reverse (convex-group-lines cg))))))
; (loop for cl1 in c-lines
; for cl2 in (cdr c-lines)
; for point-error = (adjacent-lines-feature-point cl1 cl2)
; when (and (cadr point-error) (< (cadr point-error) *max-corner-instability*))
; collect (make-convex-corner (car point-error) (c-line-segment cl1) (c-line-segment cl2)))))
;; finally (clear-memoized-function 'adjacent-lines-feature-point))))
(defun ADJACENT-LINES-FEATURE-POINT (cl1 cl2)
"We have two lines in a sequence. That is, ls1 = (p1-1 p1-2), ls2 = (p2-1 p2-2)
and a connection is hypothesized between p1-2 and p2-1.
We want to find the feature point, if any that
is their vertex. There are two issues. First, do we want to say there is a feature
point. Reasons for saying there isn't one are:
- Are the end points being connected stable? Could a little error in the underlying
edges change the end points a lot? We can't judge this by just looking at the two
lines, however.
- Is the location of the vertex stable?
Second, where is the vertex?
In addition to these questions, we probably want to make this a memo-ized function, since many
different convex groups will share the same line segment sequences.
It's possible that one of the line segments should be truncated, for reasons of convexity.
In that case, we locate the end point of the line at the intersection point when determining
the two rays, although we use the full line length for determing the error.
Reconsider what happens if the rays don't intersect after angle error is added
(this might be a problem for the old code too). I think this is OK because of symmetry.
"
(destructuring-bind (ls1 ls2 line-rays-should-intersect?)
(convex-cls-line-segments cl1 cl2)
(if (not line-rays-should-intersect?)
(list nil nil)
(let* ((point-error (relative-point-error ls1 ls2)))
(if (point-equal (line-segment-point-2 ls1) (line-segment-point-1 ls2))
(list (line-segment-point-2 ls1)
; (+ point-error *GENERAL-CORNER-ERROR*))
(connected-line-error ls1 ls2))
(let ((ip-error (ray-intersection-error
(line-segment-point-2 ls1) (line-segment-point-1 ls2)
(c-line-vector cl1)
(c-line-reverse-vector cl2)
point-error point-error
(line-segment-angle-error (c-line-segment cl1))
(line-segment-angle-error (c-line-segment cl2)))))
(if (car ip-error)
(list (float-point (car ip-error))
(+ *straight-line-approximation-extra-error* (cadr ip-error)))
;; This extra error is our uncertainty about the overall position
;; of the pair of end points, as opposed to our uncertainty about
;; their relative position.
ip-error)))))))
(defun CONNECTED-LINE-ERROR (ls1 ls2)
"If (line-segment-point-2 ls1) = (line-segment-point-1 ls2), then error is due to two factors.
- error in edge detection.
- error introduced by straight-line approximation.
"
(let ((forward-shift (amount-corner-can-shift ls1 ls2 :forward))
(back-shift (amount-corner-can-shift ls1 ls2 :back)))
(if (or (< (line-segment-length ls1) back-shift)
(< (line-segment-length ls2) forward-shift))
*very-large-number*
(max back-shift forward-shift))))
(defun CONVEX-CLS-LINE-SEGMENTS (cl1 cl2)
(if (point-equal (c-line-point-2 cl1) (c-line-point-1 cl2))
(list (c-line-segment cl1) (c-line-segment cl2) (c-line-point-2 cl1))
(let* ((ip-unfloated (intersection-of-line-and-line (2dg:g-coerce (c-line-segment cl1) '2dg::line)
(2dg:g-coerce (c-line-segment cl2) '2dg::line))))
(if (or (not (point-p ip-unfloated)) (c-lines-colinear cl1 cl2))
;; c-lines are parallel
(list (c-line-segment cl1) (c-line-segment cl2) t)
(let* ((ip (if ip-unfloated (float-point ip-unfloated) nil))
(ip-in-front-line-1? (plusp (dot (c-line-vector cl1)
(diff ip (c-line-point-2 cl1)))))
(ip-in-front-line-2? (minusp (dot (c-line-vector cl2)
(diff ip (c-line-point-1 cl2)))))
(ip-in-back-line-1?
(if ip-in-front-line-1? nil
(not (plusp (dot (c-line-vector cl1)
(diff ip (c-line-point-1 cl1)))))))
(ip-in-back-line-2?
(if ip-in-front-line-2? nil
(not (minusp (dot (c-line-vector cl2)
(diff ip (c-line-point-2 cl2))))))))
(if (or ip-in-back-line-1? ip-in-back-line-2?)
(list nil nil nil)
;; This means the intersection point is behind the lines. This can occur
;; when the angle between the lines is greater than pi. We assume that
;; no useful corner can come from such a situation.
(list (if ip-in-front-line-1?
(c-line-segment cl1)
(make-line-segment (c-line-point-1 cl1) ip))
(if ip-in-front-line-2?
(c-line-segment cl2)
(make-line-segment ip (c-line-point-2 cl2)))
t)))))))
(defun FLOAT-POINT (p)
(make-point (float (point-x p)) (float (point-y p))))
(defun RELATIVE-POINT-ERROR (ls1 ls2)
(let ((d (distance (line-segment-point-2 ls1) (line-segment-point-1 ls2))))
(if (= d 0)
(straight-line-approximation-error ls1 ls2)
(min *max-point-error* (/ d 10.0)))))
(defun LINE-SEGMENT-ANGLE-ERROR (ls &optional (error *point-error-for-corner-angles*))
(/ error (line-segment-length ls)))
;;; RAY-INTERSECTION-ERROR inefficient because p1 and p2 may be generated many times.
(defun RAY-INTERSECTION-ERROR (p1 p2 v1 v2 p1-error p2-error v1-error v2-error)
"We are given two rays, in the form of their points, and vectors for each ray.
There may be error in the locations of the points, up to p1-error, p2-error, in
any direction. There may be error in the vectors, which is given in terms of angle.
We want to find the maximum amount of variation in the intersection point of the rays.
That is, how much can their intersection point deviate from the error-free case.
Return (error-free-intersection-point magnitude-of-error).
(nil nil) is returned when error can be infinite.
"
(let* ((a1 (angle-of-vector v1))
(a2 (angle-of-vector v2))
(a-diff (abs-angle-difference a1 a2))
(a-total-error (+ v1-error v2-error)))
(if (or (<= a-diff a-total-error) (<= (abs (- pi a-diff)) a-total-error))
;; If rays could be parallel (pointing in same direction) intersection is unstable
;; If rays could be colinear (pointing in opposite directions, they are often produced
;; by a single broken line.
'(nil nil)
(let ((corner (intersection-of-line-and-line (make-line p1 (add p1 v1)) (make-line p2 (add p2 v2)))))
;; (let ((ip (intersection-of-ray-and-ray p1 v1 p2 v2)))
;; (if ip ip (multiply (add p1 p2) .5)))))
(list corner
(loop for ip in (ray-intersections@extremal-error p1 p2 a1 a2 p1-error p2-error v1-error v2-error)
maximize (distance corner ip)))))))
(defun INTERSECTION-OF-RAY-AND-RAY (p1 v1 p2 v2)
(let ((intersection (intersection-of-line-and-line (make-line p1 (add p1 v1)) (make-line p2 (add p2 v2)))))
(if (or (null intersection) (line-p intersection))
;; If the rays are colinear or parallel, return the mid-point between the two ray end points.
nil
(if (and (plusp (dot v1 (diff intersection p1)))
(plusp (dot v2 (diff intersection p2))))
intersection
;; If not, the rays don't intersect.
nil))))
(defun RAY-INTERSECTIONS@EXTREMAL-ERROR (p1 p2 a1 a2 p1-error p2-error v1-error v2-error)
"Here, instead of vectors, the angles of the rays are given"
(loop for a1-error in (list v1-error (- v1-error))
for v1 = (unit-vector-from-angle (+ a1 a1-error))
appending
(loop for a2-error in (list v2-error (- v2-error))
for v2 = (unit-vector-from-angle (+ a2 a2-error))
appending
(ray-intersections@extremal-point-error p1 p2 v1 v2 p1-error p2-error))))
(defun RAY-INTERSECTIONS@EXTREMAL-POINT-ERROR (p1 p2 v1 v2 p1-error p2-error)
"Assume vectors are unit vectors"
(loop with v1-normal = (normal v1)
for p1-error in (list (multiply v1-normal p1-error) (multiply v1-normal (- p1-error)))
for p1+error = (add p1 p1-error)
appending
(loop with v2-normal = (normal v2)
for p2-error in (list (multiply v2-normal p2-error) (multiply v2-normal (- p2-error)))
for p2+error = (add p2 p2-error)
for ip = (intersection-of-ray-and-ray p1+error v1 p2+error v2)
when ip collect ip
when (null ip) append (list p1 p2))))
(defun ANGLE-OF-VECTOR (v)
(atan (point-y v) (point-x v)))
(defun UNIT-VECTOR-FROM-ANGLE (a)
(make-point (cos a) (sin a)))
(defun MERGE-CONVEX-GROUPS-NEARBY-CORNERS (cgs)
(merge-nearby-convex-corners (flatten (mapcar #'convex-group-corners cgs)))
(mapcar #'remove-duplicate-corners cgs)
cgs)
(defun REMOVE-DUPLICATE-CORNERS (cg)
(setf (convex-group-corners cg) (remove-duplicates (convex-group-corners cg)
:test #'(lambda (c1 c2) (eq (convex-corner-point c1)
(convex-corner-point c2))))))
(defun MERGE-NEARBY-CONVEX-CORNERS (convex-corners)
(let ((list-of-replace-point-old-point
(sort
(loop for rep-neigh in (mergeable-corners-and-reps (remdups (copy-list convex-corners)
#'convex-corners-eq
#'convex-corner-ordering))
;; This is a pt, and the convex corners that are within *MERGEABLE-CORNER-DISTANCE* of it.
appending
(loop for n in (cadr rep-neigh)
collecting
(list (car rep-neigh) (convex-corner-point n))))
#'point-ordering
:key #'cadr)))
; (format t "~%list-of-replace-point-old-corner = ~A" list-of-replace-point-old-point)
(loop with sorted-convex-corners = (sort (copy-list convex-corners) #'convex-corner-ordering)
; do (format t "~%~%sorted-convex-corners = ~A...~%list-of-replace-point-old-corner = ~A"
; (loop for c in sorted-convex-corners repeat 5 collecting c) list-of-replace-point-old-point)
until (or (null sorted-convex-corners) (null list-of-replace-point-old-point))
for replace-point-point = (car list-of-replace-point-old-point)
doing
(if (point-equal (cadr replace-point-point)
(convex-corner-point (car sorted-convex-corners)))
(setf (convex-corner-point (pop sorted-convex-corners)) (car replace-point-point))
(if (point-ordering (cadr replace-point-point) (convex-corner-point (car sorted-convex-corners)))
(pop list-of-replace-point-old-point)
(pop sorted-convex-corners))))))
(defun MERGEABLE-CORNERS-AND-REPS (convex-corners)
(loop for neigh in (convex-corner-neighborhoods convex-corners)
when (cdr neigh)
append (convex-corner-neighborhood-reps neigh)))
(defun CONVEX-CORNER-NEIGHBORHOOD-REPS (neigh)
(if (null neigh) nil
(if (null (cdr neigh))
(list (list (convex-corner-point (car neigh)) neigh))
(if (null (cddr neigh))
(if (<= (distance-squared-between-point-and-point
(convex-corner-point (car neigh))
(convex-corner-point (cadr neigh)))
*2-mergeable-corner-distance-squared*)
(list (list (multiply (add (convex-corner-point (car neigh))
(convex-corner-point (cadr neigh)))
.5)
neigh))
(list (list (convex-corner-point (car neigh)) (list (car neigh)))
(list (convex-corner-point (cadr neigh)) (list (cadr neigh)))))
(let ((neigh-rep
(biggest-represented-neighborhood neigh)))
(cons neigh-rep
(convex-corner-neighborhood-reps (remlist (cadr neigh-rep) neigh))))))))
(defun BIGGEST-REPRESENTED-NEIGHBORHOOD (neigh)
(let ((best-radius-squared *very-large-number*)
(biggest-neigh nil)
(best-center nil)
(size-biggest-neigh 0))
(loop for perimeter-corners in (all-pairs-and-triples neigh)
for perimeter-points = (mapcar #'convex-corner-point perimeter-corners)
doing
(let ((center (circle-center-from-perimeter-points perimeter-points)))
(when center
(let ((radius-squared (distance-squared-between-point-and-point center (car perimeter-points))))
(when (<= radius-squared *2-mergeable-corner-distance-squared*)
(let* ((circle-neigh (loop for c in neigh
for p = (convex-corner-point c)
when (or (member c perimeter-corners)
(<= (distance-squared-between-point-and-point center p)
*2-mergeable-corner-distance-squared*))
collect c))
(size-circle-neigh (length circle-neigh)))
(when (or (< size-biggest-neigh size-circle-neigh)
(and (= size-biggest-neigh size-circle-neigh)
(<= radius-squared best-radius-squared)))
(setq best-radius-squared radius-squared
size-biggest-neigh size-circle-neigh
best-center center
biggest-neigh circle-neigh))))))))
(list best-center biggest-neigh)))
(defun ALL-PAIRS-AND-TRIPLES (lst)
(append
(loop for i in lst
for rest on (cdr lst)
appending
(loop for j in rest
collecting
(list i j)))
(loop for i in lst
for rest1 on (cdr lst)
appending
(loop for j in rest1
for rest2 on (cdr rest1)
appending
(loop for k in rest2
collecting
(list i j k))))))
(defun CIRCLE-CENTER-FROM-PERIMETER-POINTS (pts)
"Assume there is a circle with PTS on the perimeter, and pts are unique, so only the first 3 matter."
(let ((pts (remdups pts #'point-equal)))
(if (null (cdr pts))
(car pts)
(if (null (cddr pts))
(multiply (add (car pts) (cadr pts)) .5)
(let* ((p1 (car pts))
(p2 (cadr pts))
(p3 (caddr pts))
(x1 (point-x p1))
(y1 (point-y p1))
(x2 (point-x p2))
(y2 (point-y p2))
(x3 (point-x p3))
(y3 (point-y p3)))
(if (= x1 x2 x3)
nil
(if (= x1 x2)
(circle-center-from-perimeter-points (list p1 p3 p2))
(let* ((k (/ (+ (g:sq x2) (- (g:sq x1)) (g:sq y2) (- (g:sq y1)))
(* 2 (- x2 x1))))
(m (* 2 (/ (- y2 y1) (- x2 x1))))
(denom (* 2 (+ (* x1 m) (- (* x3 m)) y3 (- y1)))))
(if (= 0 denom)
nil
(let ((y (/ (+ (g:sq x3) (- (g:sq x1)) (- (* 2 k (- x3 x1))) (g:sq y3) (- (g:sq y1)))
denom)))
(make-point (- k (* m y)) y)))))))))))
(defun CONVEX-CORNER-NEIGHBORHOODS (corners)
"Find sets of points using the neighbor equivalence class, where two
points are neighbors if they are no more than (* 2 *MERGEABLE-CORNER-DISTANCE*)
pixels apart.
"
(let ((buckets (sort-corners-in-buckets corners (* 2 *MERGEABLE-CORNER-DISTANCE*))))
(loop for index in (get-buckets-indices buckets)
when (access-corner-buckets buckets index)
append (bucket-neighborhoods buckets index))))
(defun BUCKET-NEIGHBORHOODS (buckets index)
(loop collect (corner-neighborhood (pop-corner-buckets buckets index) buckets index)
until (null (access-corner-buckets buckets index))))
(defun CORNER-NEIGHBORHOOD (c buckets index)
"Assume that all buckets before (i j) are empty, or we would have started with a seed
that was earlier on."
(let* ((i (car index))
(j (cadr index))
(neigh (expand-equivalence-class
(list (list c i j))
(loop for ii from i to (1+ i)
appending
(loop for jj from j to (1+ j)
appending
(loop for c in (access-corner-buckets buckets (list ii jj))
collecting
(list c ii jj))))
#'(lambda (c&i1 c&i2)
(<= (distance-squared-between-point-and-point
(convex-corner-point (car c&i1))
(convex-corner-point (car c&i2)))
*2-mergeable-corner-distance-squared*)))))
(loop for corner&index in neigh
for corner = (car corner&index)
for index = (cdr corner&index)
doing
(delete-corner-from-bucket corner buckets index))
(mapcar #'car neigh)))
(defun EXPAND-EQUIVALENCE-CLASS (class rest fun &optional (in-class-looked-at nil))
"Return class plus all elements of rest, r1, such that (fun c1 r1) => t for some element, c1,
such that c1 is in class or will be added to class."
(let* ((to-add
(loop for r in rest
when (member r class :test fun)
collect r)))
(if to-add
(expand-equivalence-class to-add (remlist to-add rest) fun (append class in-class-looked-at))
(append class in-class-looked-at))))
(defun SORT-CORNERS-IN-BUCKETS (corners bucket-width)
(let ((buckets (make-buckets (length corners))))
(loop for corner in corners
for pt = (convex-corner-point corner)
doing
(add-corner-to-bucket corner buckets
(list (floor (/ (point-x pt) bucket-width))
(floor (/ (point-y pt) bucket-width)))))
buckets))
(defun ACCESS-CORNER-BUCKETS (buckets index)
(gethash index buckets))
(defun DELETE-CORNER-FROM-BUCKET (corner buckets index)
(delete corner (gethash index buckets)))
(defun ADD-CORNER-TO-BUCKET (corner buckets index)
(push corner (gethash index buckets)))
(defun MAKE-BUCKETS (size)
(make-hash-table :test #'equal :size size))
(defun POP-CORNER-BUCKETS (buckets index)
(pop (gethash index buckets)))
(defun GET-BUCKETS-INDICES (buckets)
(let ((indices nil))
(maphash #'(lambda (key &rest ignore)
(push key indices))
buckets)
indices))ndex buckets))
(defun DELETE-CORNER-FROM-BUCKET (corner buckets index)
(delete corner (gethash index buckets)))
(defun ADD-CORNER-TO-BUCKET (corner buckets index)
(push corner (gethash index buckets)))
(defun MAKE-BUCKETS (size)
(make-hash-table :test #'equal :size size))
(defun POP-CORNER-BUCKETS (buckets index)
(pop (gethash index bgroup/convex.lisp000666 002223 000322 00000154376 06050465337 013673 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Package: GROUP; Mode: LISP; Base: 10; Syntax: Common-Lisp -*-
(in-package group)
(defvar *FIRST-T-THEN-NIL*)
(setq *FIRST-T-THEN-NIL* (list t nil))
(rplacd (cdr *FIRST-T-THEN-NIL*) (cdr *FIRST-T-THEN-NIL*))
;;; This makes *FIRST-T-THEN-NIL* a list of (t nil nil nil nil ...)
;;; SET-ANGLE-ARRAY can be fixed to handle angle change ambiguity only in case of colinearity.
;;; Removing overlapping sequences calls MAKE-CONVEX-GROUP which doesn't deal with new cg structure.
;;; Handle connected lines separately when determining convexity
;;; Relics that I think can be removed: a convex group begin closed, *positive-dot-threshold*, entering
;;; four values in the LENGTH-ARRAY, when only the front of the first line and back of the second are
;;; used.
;;; I think it would probably pay to store distance in the lookup table instead of the square of the distance.
;;; this can be checked empirically.
(defvar *FULL-CONSTRAINTS* t)
(defvar *POSITIVE-DOT-THRESHOLD* -2)
(defvar *ABS-POSITIVE-DOT-THRESHOLD* 2)
(defvar *CONVEX-ADDS*)
(defvar *CONVEX-TOTAL*)
(defvar *SQUARED-IGNORABLE-DISTANCE* 4 "The square of the length of a connecting line in a group for which we ignore convexity")
(defvar *MAX-SQUARED-GAP* 40000 "We don't consider adding line 2 to a cg ending in line 1 if the gap between them is
bigger than this."
)
(defvar *MAX-CONNECTED-COLINEAR-LINE-DEVIATION* 6
"Two connected lines are considered colinear if a line connecting their endpoints is no more than
this value from any point on the lines.")
(defvar *COLINEAR-LINE-POINT-ERROR* 6)
(defvar *CONVEX-POSITIONAL-ERROR* 5)
(defvar *MAX-ANGLE-LINE-ERROR* (/ *short-pi* 15))
(defvar *MAX-ANGLES-CONVEX-GROUP* (+ *short-2pi* (* 2 *max-angle-line-error*)))
(export '(convex-lines convex-lines-from-edges))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MATCH INFORMATION ABSTRACTION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These macro definitions have to come before they are used.
(defun MAKE-MATCH-INFORMATION (compat-array dist-array match-array length-array angle-array)
(list compat-array dist-array match-array length-array angle-array))
(defmacro MAKE-COMPATIBILITY-ARRAY (len)
; `(make-array (list ,len ,len) :element-type 'boolean :initial-element NIL))
`(make-array (list ,len ,len) :element-type 'bit :initial-element 0))
(defmacro MAKE-DISTANCE-ARRAY (len)
`(make-array (list ,len ,len) :initial-element 0 :element-type '(unsigned-byte 32)))
(defmacro MAKE-MATCH-ARRAY (len)
`(make-array (list ,len) :initial-element NIL))
(defmacro MAKE-ANGLE-ARRAY (len)
`(make-array (list ,len ,len) :initial-element NIL))
;;; A good way to save space here might be to use a hash table, and only enter lengths
;;; not equal to (0 0).
(defmacro MAKE-LENGTH-ARRAY (len)
`(make-array (list ,len ,len) :initial-element NIL))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; See below for more of this abstraction
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; What is CONVEX-LINES? really supposed to compute, and does it?
;;; I think we want all convex lines that satisfy k, but in addition
;;; to that we want to rule out subsets, supersets, and duplicates if possible.
;;; - Duplicates: It's inherent in my algorithm that we may build up to n
;;; copies of a convex group with n lines, because we will try each line
;;; as a starting point.
;;; - If the sequence (... A B C) is convex and satisfies the gap constraint,
;;; and so does the sequence (... A C), then we don't want to consider both possiblities,
;;; if possible. If we did, we would get every subset of a valid convex group that is also
;;; valid. We have to consider whichever of the two has a better gap ratio, because it might
;;; be that only that one leads to a convex group. Our current code considers that case,
;;; which means that a superset convex group with a weaker gap ratio might be omitted.
;;; This is done by never considering (... A B C) if (... A C) has a better ratio.
;;; On the other hand, if (... A B C) has the better ratio, than we don't consider
;;; (... A C) subsequently, but it's possible that we have already considered it.
;;; If we always wanted to get the largest convex groups, a more conservative approach
;;; would be to always consider (... A B C), but exclude (... A C) when it has a lower
;;; gap ratio.
;;; - Finally, we may get subsets because even though we exclude (... A C) when it has a
;;; lower gap ratio, we don't exclude (C ... A).
;;; Proposed changes to this:
;;; I think we might want to define the output by saying that if two groups meet the gap
;;; criteria, and one is a superset of the other, we want the one with the better gap ratio.
;;; We already do this in many cases anyway. This just means fixing the "finally" above.
(defun CONVEX-LINES (lines strings k) ; &optional c-array)
"This routine should return every collection of line segments that meet the following criteria:
Traversing a path from the first point of ls1 to the second point to the first point of ls2 ...
should lead to no concavities. If the length of this path is P, and the length of the segments
is L, then L/P > k.
Additionally, we do not include a line in a convex group if eliminating it would produce a higher
ratio of L/P, and we try to avoid forming groups that are subsets of other groups.
"
; (when c-array
; (let ((c-array-1d (make-array (list (reduce #'* (array-dimensions c-array))) :displaced-to c-array)))
; (fill c-array-1d nil)))
(when (null strings)
(setq strings (loop repeat (length lines) collecting nil)))
(let* ((c-lines (make-c-lines lines strings)) ; a list of c-lines and a list of their reverse
(len (length c-lines)))
(let ((compat-array (make-compatibility-array len))
(dist-array (make-distance-array len))
(length-array (make-length-array len))
(angle-array (make-angle-array len))
(match-array (make-match-array len)))
(let ((c-line-matches (make-c-line-matches c-lines k compat-array dist-array length-array angle-array match-array)))
(convex-backtrack c-lines c-line-matches k)))))
(defun CONVEX-LINES-FROM-EDGES-SPLIT (edges k &optional (m 1))
(multiple-value-bind (lines strings)
(split-and-merge (edge-image-strings edges) (* 2dg::*string-line-break-max-err* m)
(* 2dg::*string-line-break-max-ave-err* m))
(convex-lines lines strings k)))
(defun CONVEX-LINES-FROM-EDGES (edges k &optional (thresh 2))
(let* ((lines (edges-to-line-segments edges thresh))
(strings (loop for line in lines collecting nil)))
(convex-lines lines strings k)))
;;; When there is nothing more to add to a cg, we don't test whether a superset of the cg
;;; with a better gap ratio was accepted.
(defun CONVEX-BACKTRACK (c-lines matches k)
(let ((done? nil)
(current-convex-group (make-initial-convex-group (car c-lines) k))
(next-base-line (cdr c-lines))
(convex-groups nil)
(search-list (list (get-c-line-match-list matches (car c-lines))))
(min-gap-ratio-list (list k)) ; the min gap ratio a group at the level must have.
(excluded-lists (list nil))) ; For eliminate subsets
(labels ((backtrack ()
(if (null current-convex-group)
(setf done? t)
(progn
(let ((removed-line (car (convex-group-lines current-convex-group)))) ; For eliminate subsets
(when (convex-group-acceptable? current-convex-group k matches)
(let* ((finished-copy (copy-to-answer current-convex-group k matches))
(finished-gap (convex-group-gap-ratio finished-copy)))
; (format t "~%finished-gap = ~A, min-gap-ratio-list = ~A"
; finished-gap min-gap-ratio-list)
(when (or (not *FULL-CONSTRAINTS*) (< (car min-gap-ratio-list) finished-gap))
;; Is this cg's gap ratio better than any accepted cg that is a superset of it?
;; If yes, keep it, and update the min-gap-ratio of it's subsets.
(push finished-copy convex-groups)
(loop for k-list on (cdr min-gap-ratio-list)
doing
(rplaca k-list (max (car k-list) finished-gap))))))
(setf current-convex-group (pop-convex-group! current-convex-group k))
(pop search-list)
(pop min-gap-ratio-list)
(pop excluded-lists) ; For elim sub
(loop for xl on excluded-lists doing (push removed-line (car xl))) ; for elim sub
))) )
(next ()
(if search-list
(let ((c-line (pop-c-line-match-list current-convex-group (car search-list))))
(if (null c-line) nil
(if
(or (member c-line (convex-group-lines current-convex-group) :test #'c-lines-same?)
(and *FULL-CONSTRAINTS* (member c-line (car excluded-lists)))) ; For elim sub
(next)
c-line)))
(let ((new-base-line (pop next-base-line)))
;; This is the case where current group had one line, and nothing more to add to it.
(when new-base-line
(push (get-c-line-match-list matches new-base-line) search-list)
(push k min-gap-ratio-list))
new-base-line)))
(add-line (c-line)
;; The test about adding the line has already added it to the cg structure.
(push nil excluded-lists) ; For elim sub
(push k min-gap-ratio-list)
(push (get-c-line-match-list matches c-line) search-list)))
(loop until done?
doing
(let ((next-c-line (next)))
(if (null next-c-line)
(backtrack)
(if (null current-convex-group)
(setf current-convex-group (make-initial-convex-group next-c-line k))
(when (add-c-line-convex-group?! current-convex-group next-c-line matches k)
(add-line next-c-line))))))
convex-groups)))
(defun MAKE-C-LINE-MATCHES (c-lines k &optional c-array d-array l-array a-array m-array)
"Like the old version, but: it will account for error, it will allow lines to be
broken if parts of them can be in a convex group, and it will be simpler and slower.
The output of this routine is a compatibility array, a length array, an angle array, and a match array.
The match-array tells us, for a given c-line, all other lines that could be added
next to a cg containing it, and the distance squared to each of these lines.
The compat-array, given 2 c-lines should give the distance squared from the end of the
first line to the start of the second line, after taking into account any reductions
in either line that might be necessary to maintain convexity,
(or a nil marker if they can not be mutually convex),
The angle array indicates the change in angle when going from one c-line to the next.
The length array tells us that in going from c-line-1 to c-line-2, we must reduce the
length of the front of c-line-1 and the rear of c-line-2 by a given amount (or 0).
This table contains some null value when there is no convexity.
"
(let* ((len (length c-lines))
(compat-array (if c-array c-array (make-compatibility-array len)))
(dist-array (if d-array d-array (make-distance-array len)))
(length-array (if l-array l-array (make-length-array len)))
;; entries here are of the form ((d11 d12) (d21 d22))
(angle-array (if a-array a-array (make-angle-array len)))
(match-array (if m-array m-array (make-array (list len))))
(match-info (make-match-information compat-array dist-array match-array length-array angle-array)))
(loop for first? in *FIRST-T-THEN-NIL*
for c-line-1-ptr = (if first? c-lines (cddr c-line-1-ptr))
for index1-offset from 0 by 2 below len
doing
(loop for first? in *FIRST-T-THEN-NIL*
for c-line-2-ptr = (if first? (cddr c-line-1-ptr) (cddr c-line-2-ptr))
for index2-offset from (+ 2 index1-offset) by 2 below len
doing
(let ((convexity-reductions (c-lines-convexity (car c-line-1-ptr) (car c-line-2-ptr) k)))
(loop for c-line-1 in c-line-1-ptr
for index1 from index1-offset to (1+ index1-offset)
for c-reds in (list (list (first convexity-reductions) (third convexity-reductions))
(list (second convexity-reductions) (fourth convexity-reductions)))
doing
(loop for c-line-2 in c-line-2-ptr
for index2 from index2-offset to (1+ index2-offset)
for c-red in c-reds
;; c-red = ((c-line-1-front-reduction c-line-2-rear-reduction)
;; (c-line-2-front-reduction c-line-1-rear-reduction)
doing
(when (car c-red)
(add-c-lines-to-tables c-line-1 c-line-2 index1 index2 (car c-red) match-info))
(when (cadr c-red)
(add-c-lines-to-tables c-line-2 c-line-1 index2 index1 (cadr c-red) match-info))
(when (caddr c-red)
(set-c-lines-compatible index1 index2 match-info)
(set-angle-array (match-info-angle-array match-info) index1 index2 c-line-1 c-line-2 (car c-red))
(set-angle-array (match-info-angle-array match-info) index2 index1 c-line-2 c-line-1 (cadr c-red)))
)))))
(loop for i from 0 to (1- len)
doing
(setf (aref match-array i) (sort (aref match-array i) #'< :key #'car)))
match-info))
(defun ADD-C-LINES-TO-TABLES (cl1 cl2 index1 index2 c-red match-info)
(let ((dist (distance-squared-between-convex-c-lines cl1 cl2 c-red))
;; Change above routine
(length-reductions (cons (* (car c-red) (c-line-length cl1)) (* (cadr c-red) (c-line-length cl2)))))
(when (reduced-lines-long-enough? cl1 cl2 length-reductions)
(setf (aref (match-info-distance-array match-info) index1 index2) (round dist))
(when (< dist *max-squared-gap*)
(push (cons dist cl2) (aref (match-info-match-array match-info) index1)))
(set-length-reductions match-info index1 index2 length-reductions))))
(defun REDUCED-LINES-LONG-ENOUGH? (cl1 cl2 c-lengths)
"c-length = ((length-rear-reduction-cl1 length-front-reduction-cl1) and same for cl2.
If to make convexity, the length of a line has to be reduced to no more than:
*CONVEX-POSITIONAL-ERROR* we figure that (a) it's not worth the effort of using it,
and (b), nearly connected lines can always be reduced to this point.
NOTE: This routine is on hold, because the change made that avoids accounting for
error except for colinearity may make this unnecessary.
"
(ignore-it cl1 cl2 c-lengths)
t)
(defun IGNORE-IT (&rest x)
x
nil)
(defun DISTANCE-SQUARED-BETWEEN-CONVEX-C-LINES (cl1 cl2 c-red)
"Return the distance squared from the place in cl1 to the place in cl2 where
a convex connection is made (this will usually be the second point in cl1 and
the first point in cl2).
"
(distance-squared-between-point-and-point
(point-along-c-line cl1 (- 1 (first c-red)))
(point-along-c-line cl2 (second c-red))))
(defun POINT-ALONG-C-LINE (cl frac)
(cond ((= 0 frac) (c-line-point-1 cl))
((= 1 frac) (c-line-point-2 cl))
(t
(add (c-line-point-1 cl) (multiply (c-line-vector cl) (* (c-line-length cl) frac))))))
(defun COLINEAR-CONVEXITY (cl1 cl2)
(multiple-value-bind (colinear? reverse-cl1? reverse-cl2?)
;; If COLINEAR? than reverse the c-lines as indicated means colinearity occurs going
;; from the first c-line to the second.
(c-lines-colinear cl1 cl2)
(if colinear?
(cond ((and (not reverse-cl1?) (not reverse-cl2?))
;; Colinearity for (1 2 3 4) (4 3 2 1)
(list (list (list 0 0) nil t) nil nil (list nil (list 0 0) t)))
((and reverse-cl1? (not reverse-cl2?))
;; Colinearity for (2 1 3 4) (4 3 1 2)
(list nil (list (list 0 0) nil t) (list nil (list 0 0) t) nil))
((and (not reverse-cl1?) reverse-cl2?)
;; Colinearity for (1 2 4 3) (3 4 2 1)
(list nil (list nil (list 0 0) t) (list (list 0 0) nil t) nil))
(t
;; Colinearity for (2 1 4 3) (3 4 1 2)
(list (list nil (list 0 0) t) nil nil (list (list 0 0) nil t))))
nil)))
(defun C-LINES-COLINEAR (cl1 cl2)
"If not, return nil, if yes, return (values t reverse-cl1? reverse-cl2?) indicating what
reversals of the lines are necessary to have colinearity when going from line 1 to 2.
My test here is whether a vector at the center of each line can be rotated within error
bounds so that the entire line is first entirely on one side of the vector, then entirely
on the other side. In addition, the lines must have similar angles, and must be entirely
in front of each other (ie not to the side of each other). This last test rules out
lines that are parallel, and near each other.
"
(let ((total-error (+ (c-line-angle-error cl1) (c-line-angle-error cl2)))
(a-diff (mod (- (c-line-angle cl1) (c-line-angle cl2)) *short-pi*)))
(if (and (or (< a-diff total-error) (< (- *short-pi* a-diff) total-error))
(line-colinear-wrt-line cl1 cl2)
(line-colinear-wrt-line cl2 cl1))
(let ((dist1 (dot (c-line-vector cl1) (diff (c-line-point-1 cl2) (c-line-point-1 cl1))))
(dist2 (dot (c-line-vector cl1) (diff (c-line-point-2 cl2) (c-line-point-1 cl1))))
(len (c-line-length cl1)))
;; len = distance from cl1-point1 to cl1-point2
(if (and (< dist1 *CONVEX-POSITIONAL-ERROR*) (< dist2 *CONVEX-POSITIONAL-ERROR*))
(values t t (if (< dist1 dist2) t nil))
(if (and (< (- len *CONVEX-POSITIONAL-ERROR*) dist1) (< (- len *CONVEX-POSITIONAL-ERROR*) dist2))
(values t nil (if (< dist1 dist2) nil t))
nil)))
nil)))
(defun LINE-COLINEAR-WRT-LINE (cl1 cl2)
(flet ((sign-with-error (dot1 dot2)
;; If the two dot products can both be positive, or both be negative, with allowed error,
;; return -1, 0, or 1, otherwise return nil. -1 means they can both be neg., 1 means
;; they can both be positive, 0 means they can both be either.
(let ((dot1-sign (if (< dot1 (- *CONVEX-POSITIONAL-ERROR*)) -1
(if (< *CONVEX-POSITIONAL-ERROR* dot1) 1 0)))
(dot2-sign (if (< dot2 (- *CONVEX-POSITIONAL-ERROR*)) -1
(if (< *CONVEX-POSITIONAL-ERROR* dot2) 1 0))))
(if (= -1 (* dot1-sign dot2-sign)) nil
(if (= 0 dot1-sign)
dot2-sign
dot1-sign))))
(signs-different? (s1 s2)
;; Are values from above routine indicative that line 2 can be on opposite sides of 1?
(/= 1 (* s1 s2))))
(let* ((center1 (c-line-center cl1))
(normal-clock-1 (c-line-normal-rotated-clockwise cl1))
(normal-counter-1 (c-line-normal-rotated-counterwise cl1))
(pt21 (c-line-point-1 cl2))
(pt22 (c-line-point-2 cl2))
(vec11 (diff pt21 center1))
(vec12 (diff pt22 center1))
(dot11-clock (dot normal-clock-1 vec11))
(dot12-clock (dot normal-clock-1 vec12))
(dot11-counter (dot normal-counter-1 vec11))
(dot12-counter (dot normal-counter-1 vec12)))
(let ((same-sign-with-error-1-clock? (sign-with-error dot11-clock dot12-clock)))
(if (null same-sign-with-error-1-clock?)
nil
(let ((same-sign-with-error-1-counter? (sign-with-error dot11-counter dot12-counter)))
(if (null same-sign-with-error-1-counter?)
nil
(signs-different? same-sign-with-error-1-clock? same-sign-with-error-1-counter?))))))))
(defun ANGLES-CONVEX? (diff error)
(< (- diff error) *short-pi*))
(defun MAX-ANGLE-LINE-ERROR (pt1 pt2)
(min *max-angle-line-error*
(/ *COLINEAR-LINE-POINT-ERROR*
(distance pt1 pt2))))
(defun C-LINES-CONVEXITY (cl1 cl2 k)
(if *FULL-CONSTRAINTS*
(c-lines-convexity-full cl1 cl2 k)
(c-lines-convexity-simple cl1 cl2)))
; (format t "~%cl1 = ~A, cl2 = ~A~%full = ~A~%simple = ~A"
; cl1 cl2 (c-lines-convexity-full cl1 cl2 k) (c-lines-convexity-simple cl1 cl2)))
(defun C-LINES-CONVEXITY-SIMPLE (cl1 cl2)
(let* ((norm1 (c-line-normal cl1))
(norm2 (c-line-normal cl2))
(vec11 (diff (c-line-point-1 cl2) (c-line-point-1 cl1)))
(vec12 (diff (c-line-point-2 cl2) (c-line-point-1 cl1)))
(vec21 (diff (c-line-point-1 cl2) (c-line-point-2 cl1)))
;; vecij is the vector from point i of line 1 to point j of line 2.
(dot11 (dot norm1 vec11))
(dot12 (dot norm1 vec12))
;; dotij is the distance from line i to point j of line not-i in the direction normal to line i.
(dot21 (- (dot norm2 vec11)))
;; The - is there because vec11 is in the wrong direction for this computation
(dot22 (- (dot norm2 vec21))))
(cond ((and (~<= 0 dot11) (~<= 0 dot12) (~<= 0 dot21) (~<= 0 dot22))
(list '((0 0) (0 0) t) '(nil nil nil) '(nil nil nil) '(nil nil nil)))
((and (~>= 0 dot11) (~>= 0 dot12) (~<= 0 dot21) (~<= 0 dot22))
(list '(nil nil nil) '((0 0) (0 0) t) '(nil nil nil) '(nil nil nil)))
((and (~<= 0 dot11) (~<= 0 dot12) (~>= 0 dot21) (~>= 0 dot22))
(list '(nil nil nil) '(nil nil nil) '((0 0) (0 0) t) '(nil nil nil)))
((and (~>= 0 dot11) (~>= 0 dot12) (~>= 0 dot21) (~>= 0 dot22))
(list '(nil nil nil) '(nil nil nil) '(nil nil nil) '((0 0) (0 0) t)))
(t (list '(nil nil nil) '(nil nil nil) '(nil nil nil) '(nil nil nil))))))
(defun C-LINES-CONVEXITY-FULL (cl1 cl2 k)
"This function takes two c-lines as arguments. It returns four results:
(cl1 cl2) (reversed-cl1 cl2) (cl1 reversed-cl2) (reversed-cl1 reversed-cl2)
For each of these cases, we will return
((d12 d21) (d22 d11) t/nil). dij Means that for c-line i, the
front (j = 1) or back (j = 2) should be reduced in length by dij, in order to
accomodate convexity, and provide the best addition to the gap ratio of the group.
If the lines are just convex, these lengths will be 0.
(d12 d21) for example, can be NIL if the lines are not mutually convex, or if they
are convex, but adding the second line would only hurt the gap ratio of the first.
The third value in the list is T or NIL, indicating whether convexity is possible
at all between the two lines. This is needed because we also want to be able to check
if the CL1 can be added to a group when CL2 is the group's first line.
We want to reduce the length of a line not just when it's necessary for convexity,
but when doing so will improve the gap ratio.
NEW NOTES: My new strategy is to not consider angular error when finding convexity
between parts of lines. This will greatly simplify the routines below. I do still
want to find possible colinearity, allowing for angular error.
COLINEARITY: Suppose we have four points, colinear, in line from left to right, 1,2,3,4.
One line has points 1 & 2, the other has 3 & 4. A convex group can traverse the lines
in the order: (1,2,3,4) or (4,3,2,1). Other convex interpretations are possible, but they
will never be as good, since they will all involve angle changes of pi or 2pi while covering
the same ground, and with longer gaps.
This is the only case where (d12 d21) might have a value, while (d22 d11) is NIL.
"
(or (colinear-convexity cl1 cl2)
(let* ((norm1 (c-line-normal cl1))
(norm2 (c-line-normal cl2))
(vec11 (diff (c-line-point-1 cl2) (c-line-point-1 cl1)))
(vec12 (diff (c-line-point-2 cl2) (c-line-point-1 cl1)))
(vec21 (diff (c-line-point-1 cl2) (c-line-point-2 cl1)))
;; vecij is the vector from point i of line 1 to point j of line 2.
(dot11 (dot norm1 vec11))
(dot12 (dot norm1 vec12))
;; dotij is the distance from line i to point j of line not-i in the direction normal to line i.
(dot21 (- (dot norm2 vec11)))
;; The - is there because vec11 is in the wrong direction for this computation
(dot22 (- (dot norm2 vec21))))
(list (bidirectional-convexity-from-dot-products dot11 dot12 dot21 dot22 cl1 cl2 k nil nil)
(bidirectional-convexity-from-dot-products dot11 dot12 dot21 dot22 cl1 cl2 k t nil)
(bidirectional-convexity-from-dot-products dot11 dot12 dot21 dot22 cl1 cl2 k nil t)
(bidirectional-convexity-from-dot-products dot11 dot12 dot21 dot22 cl1 cl2 k t t)))))
(defun BIDIRECTIONAL-CONVEXITY-FROM-DOT-PRODUCTS (dot11 dot12 dot21 dot22 cl1 cl2 k rev-cl1? rev-cl2?)
(let ((d11 (* (if rev-cl2? dot12 dot11) (if rev-cl1? -1 1)))
(d12 (* (if rev-cl2? dot11 dot12) (if rev-cl1? -1 1)))
(d21 (* (if rev-cl1? dot22 dot21) (if rev-cl2? -1 1)))
(d22 (* (if rev-cl1? dot21 dot22) (if rev-cl2? -1 1))))
(if (or (and (< d11 g:*epsilon*) (< d12 g:*epsilon*))
(and (< d21 g:*epsilon*) (< d22 g:*epsilon*)))
(list nil nil nil)
(let ((cl1-pt1 (if rev-cl1? (c-line-point-2 cl1) (c-line-point-1 cl1)))
(cl1-pt2 (if rev-cl1? (c-line-point-1 cl1) (c-line-point-2 cl1)))
(cl2-pt1 (if rev-cl2? (c-line-point-2 cl2) (c-line-point-1 cl2)))
(cl2-pt2 (if rev-cl2? (c-line-point-1 cl2) (c-line-point-2 cl2)))
(cl1-vec (if rev-cl1? (c-line-reverse-vector cl1) (c-line-vector cl1)))
(cl2-vec (if rev-cl2? (c-line-reverse-vector cl2) (c-line-vector cl2)))
(cl1-rvec (if rev-cl1? (c-line-vector cl1) (c-line-reverse-vector cl1)))
(cl2-rvec (if rev-cl2? (c-line-vector cl2) (c-line-reverse-vector cl2))))
(list (convexity-from-dot-products d11 d12 d21 d22 cl1-pt2 cl2-pt1 cl1-rvec cl2-vec k (c-line-length cl1)
(c-line-length cl2))
(convexity-from-dot-products d21 d22 d11 d12 cl2-pt2 cl1-pt1 cl2-rvec cl1-vec k (c-line-length cl2)
(c-line-length cl1))
t)))))
(defun CONVEXITY-FROM-DOT-PRODUCTS (dot11 dot12 dot21 dot22 cl1-p2 cl2-p1 cl1-vec cl2-vec k cl1-length cl2-length)
;; Note: cl1-vec is reversed, ie each vec is the vector from the connecting
;; point to the other.
;; We look to see how much, if any, of the end of the first line and the start of the second line
;; should be cut off to (1) maintain the convexity of the two lines, and (2) improve their gap
;; ratio. If the two lines are convex, then if cutting any part of both lines improves the gap
;; ratio, we know the gap ratio is better with just the first line. So if one of the lines must
;; be truncated to make them convex, we must do that first.
(flet ((frac-cutoff (dot1 dot2) (if (and (minusp dot1) (plusp dot2)) (/ (abs dot1) (- dot2 dot1))
(if (and (minusp dot1) (minusp dot2)) 1 0)))
(dist-cutoff (dist cl-len) (if (< dist 0) 0 (/ dist cl-len))))
(let ((convexity-cutoff-2 (frac-cutoff dot11 dot12))
(convexity-cutoff-1 (frac-cutoff dot22 dot21))
;; convexity-cutoff-i is the fraction of line i that must be removed to make the lines convex.
)
(when (not (zerop convexity-cutoff-1))
(setq cl1-p2 (add cl1-p2 (multiply cl1-vec (* cl1-length convexity-cutoff-1)))
cl1-length (* (- 1 convexity-cutoff-1) cl1-length)))
(when (not (zerop convexity-cutoff-2))
(setq cl2-p1 (add cl2-p1 (multiply cl2-vec (* cl2-length convexity-cutoff-2)))
cl2-length (* (- 1 convexity-cutoff-2) cl2-length)))
(let ((dist2 (line-distance-maximizing-gap-ratio cl1-p2 cl2-p1 cl2-vec k))
;; This is the distance along cl2 from its first point to the point where the two lines
;; should be connected to maximize the gap ratio.
)
;; The gap ratio is worst at -infinity and +infinity, and improves from each of them to dist2.
(if (< cl2-length dist2)
nil
;; this means that the gap ratio improves continuously as we use less of cl2.
(let ((dist1 (line-distance-maximizing-gap-ratio cl2-p1 cl1-p2 cl1-vec k)))
(if (< cl1-length dist1)
nil
(if (no-connection-better? dist1 dist2 cl1-p2 cl2-p1 cl1-vec cl2-vec k)
nil
(list (round-near-0 (+ convexity-cutoff-1 (* (- 1 convexity-cutoff-1) (dist-cutoff dist1 cl1-length))))
(round-near-0 (+ convexity-cutoff-2
(* (- 1 convexity-cutoff-2) (dist-cutoff dist2 cl2-length)))))))))))))
(defun ROUND-NEAR-0 (x)
(if (~zerop x) 0 x))
(defun NO-CONNECTION-BETTER? (dist1 dist2 cl1-p2 cl2-p1 cl1-vec cl2-vec k)
(if (and (plusp dist1) (plusp dist2))
t
(if (or (plusp dist1) (plusp dist2))
(let ((first-point (if (plusp dist1) (add cl1-p2 (multiply cl1-vec dist1)) cl1-p2))
(second-point (if (plusp dist2) (add cl2-p1 (multiply cl2-vec dist2)) cl2-p1)))
(if (plusp dist1)
(if (plusp (line-distance-maximizing-gap-ratio first-point second-point cl2-vec k))
t
nil)
(if (plusp (line-distance-maximizing-gap-ratio second-point first-point cl1-vec k))
t
nil)))
nil)))
(defun LINE-DISTANCE-MAXIMIZING-GAP-RATIO (p1 p2 v k)
(let ((current-epsilon g:*epsilon*))
(unwind-protect
(progn
(setq g:*epsilon* .01)
(let* ((k- (/ (- 1 k) k))
(x1 (point-x p1))
(y1 (point-y p1))
(x2 (point-x p2))
(y2 (point-y p2))
(vx (point-x v))
(vy (point-y v))
(c1 (- (g:sq vx) (g:sq k-)))
(c2 (- (g:sq vy) (g:sq k-)))
(c3 (* 2 vx vy))
(x3 (- x1 x2))
(y3 (- y1 y2))
(a (+ (* c1 (g:sq vx))
(* c2 (g:sq vy))
(* c3 vx vy)))
(b (- (+ (* 2 c1 x3 vx)
(* 2 c2 y3 vy)
(* c3 x3 vy)
(* c3 y3 vx))))
(c (+ (* c1 (g:sq x3))
(* c2 (g:sq y3))
(* c3 x3 y3)))
(-b (- b))
(bb (g:sq b))
(4ac (* 4 a c))
(sqrt-bb-4ac (if (g:~= bb 4ac) 0 (sqrt (- bb 4ac))))
(2a (* 2 a))
(d1 (/ (- -b sqrt-bb-4ac) 2a))
(d2 (/ (+ -b sqrt-bb-4ac) 2a))
(valid-answers
(loop for d in (list d1 d2)
for exp1 = (* vx (- x3 (* d vx)))
for exp2 = (* vy (- y3 (* d vy)))
when (or (g:~<= 0 (+ exp1 exp2))
(g:~= exp1 (- exp2)))
;; (g:~<= 0 (+ (* vx (- x3 (* d vx))) (* vy (- y3 (* d vy)))))
collect d)))
(if (or (null (cdr valid-answers)) (reduce #'g:~= valid-answers))
(if (g:~zerop (car valid-answers)) 0 (car valid-answers))
(error "Found two answers for point maximizing gap ratio"))))
(setq g:*epsilon* current-epsilon))))
(defun MAKE-C-LINES (line-segments strings)
(loop for ls in line-segments
for string in strings
for cl = (make-c-line ls)
for rev-cl = (make-c-line (make-line-segment (line-segment-point-2 ls) (line-segment-point-1 ls)))
for index from 0 by 2
for angle-error = (min *max-angle-line-error* (line-segment-angle-error ls *convex-positional-error*))
for vec = (unit (diff (line-segment-point-2 ls) (line-segment-point-1 ls)))
for angle = (atan (point-y vec) (point-x vec))
collect cl into cls
collect rev-cl into cls
do
(setf (c-line-vector cl) vec)
(setf (c-line-reverse-vector cl) (multiply vec -1))
(setf (c-line-normal cl) (normal vec))
(setf (c-line-length cl) (distance (line-segment-point-1 ls) (line-segment-point-2 ls)))
(setf (c-line-index cl) index)
(setf (c-line-underlying-points cl) string)
(setf (c-line-center cl) (average-points (list (line-segment-point-1 ls) (line-segment-point-2 ls))))
(setf (c-line-normal-rotated-clockwise cl) (rotate-point (c-line-normal cl) (- *short-2pi* angle-error)))
(setf (c-line-normal-rotated-counterwise cl) (rotate-point (c-line-normal cl) angle-error))
(setf (c-line-angle cl) angle)
(setf (c-line-angle-error cl) angle-error)
(setf (c-line-vector rev-cl) (c-line-reverse-vector cl))
(setf (c-line-reverse-vector rev-cl) (c-line-vector cl))
(setf (c-line-normal rev-cl) (multiply (c-line-normal cl) -1))
(setf (c-line-length rev-cl) (c-line-length cl))
(setf (c-line-index rev-cl) (1+ index))
(setf (c-line-underlying-points rev-cl) string)
(setf (c-line-center rev-cl) (c-line-center cl))
(setf (c-line-normal-rotated-clockwise rev-cl) (multiply (c-line-normal-rotated-clockwise cl) -1))
(setf (c-line-normal-rotated-counterwise rev-cl) (multiply (c-line-normal-rotated-counterwise cl) -1))
(setf (c-line-angle rev-cl) (let ((rev-ang (+ angle *short-pi*)))
(if (<= rev-ang *short-pi*)
rev-ang
(- rev-ang *short-2pi*))))
(setf (c-line-angle-error rev-cl) angle-error)
finally (return cls)))
(defun C-LINES-EQUAL (cl1 cl2)
(let ((diff (- (c-line-index cl1) (c-line-index cl2))))
(and (< (abs diff) 2)
(or (= 0 diff)
(if (< 0 diff)
(oddp (c-line-index cl1))
(evenp (c-line-index cl1)))))))
(defun ADD-C-LINE-CONVEX-GROUP?! (convex-group c-line matches k)
"Combine functions of add-line-to-convex? and add-c-line-convex-group!.
If c-line should be added, add it.
I have a new theory: if the total of the angles turned in the polygon is not more than 360 degrees,
and no angle is less than 0 than the polygon is convex.
"
(let ((first-line (convex-group-first-line convex-group))
(last-line (convex-group-last-line convex-group)))
(when (and (not (convex-group-closed convex-group))
(c-lines-compatible c-line first-line matches))
;; Is the c-line convex to the first line in the convex group? We don't care about the distance.
(let ((angle-1 (c-lines-turning-angle last-line c-line matches))
(angle-2 (c-lines-turning-angle c-line first-line matches)))
(when (angles-acceptable? (convex-group-total-angles convex-group) angle-1 angle-2)
;; Ok, at this point, we know that the lines are all convex.
(let ((dist (sqrt (c-lines-distance-squared last-line c-line matches))))
;; Additional gap in convex-group
(destructuring-bind (last-front-reduction c-line-rear-reduction)
(lengths-reduced last-line c-line matches)
(when (line-length-worth-adding? convex-group dist last-front-reduction k c-line matches)
(add-c-line-convex-group! convex-group c-line k last-front-reduction c-line-rear-reduction
dist angle-1)
t))))))))
(defun LINE-LENGTH-WORTH-ADDING? (cg dist last-front-reduction k c-line matches)
(if *FULL-CONSTRAINTS* (line-length-worth-adding?-full cg dist last-front-reduction k c-line matches)
t))
(defun LINE-LENGTH-WORTH-ADDING?-FULL (cg dist last-front-reduction k c-line matches)
"We know that the distance to the new line is less than the maximum allowable gap.
We need to check three things:
First, if the last line in the cg has its length reduced by the new c-line,
this reduces the allowable gap, so we must make sure the added line is still ok.
Second, we must check whether the cg with the new c-line wouldn't be better
if we excluded the last line in the original cg. If so, we want to avoid
adding this c-line now, and add it later, after we backtrack.
Third, the last c-line in the cg isn't wiped out by a reduction in its front from
the new line.
We are not taking into account how the new line might effect the first line in the cg.
Our rule of thumb is to ignore that effect until the cg is done.
"
; (when (= 4 (length (convex-group-lines cg))) (break))
(and (or (zerop last-front-reduction)
(and
(new-gap-allowable? (- (convex-group-length cg) last-front-reduction)
(convex-group-gap-length cg)
dist
k)
;; First test
(< last-front-reduction (convex-group-last-line-effective-length cg)))
;; Third test
)
(or (null (cdr (convex-group-lines cg)))
;; If cg has only one group, don't check second condition.
(let ((new-line-reduces-second-last-line
(car (lengths-reduced (convex-group-second-last-line cg) c-line matches))))
;; If this value is nil, it means the new line is incompatible with the second to last line.
;; This is possible because allowing for error might make the last line compatible with both,
;; while they are not mutually compatible.
;; Or, adding the new line to the second to last directly might produce a worse gap ratio,
;; while we get a better gap ratio when the last line is present.
;; Either way, we want to add the new line.
(or (null new-line-reduces-second-last-line)
(line-improves-gap-ratio
(- (convex-group-last-line-effective-length cg) last-front-reduction)
;; length the last line contributes
(convex-group-last-gap cg)
dist
(sqrt (c-lines-distance-squared (convex-group-second-last-line cg) c-line matches))
(convex-group-second-last-front-reduced cg)
;; length new c-line would take off the cg without this line
new-line-reduces-second-last-line
;; length this line takes off the rest of the cg.
k))))))
(defun LINE-IMPROVES-GAP-RATIO (effective-line-length line-gap-1 line-gap-2 gap-without-line
group-reduction-with-line group-reduction-without-line k)
(if *FULL-CONSTRAINTS* (line-improves-gap-ratio-full effective-line-length line-gap-1 line-gap-2 gap-without-line
group-reduction-with-line group-reduction-without-line k)
t))
(defun LINE-IMPROVES-GAP-RATIO-FULL (effective-line-length line-gap-1 line-gap-2 gap-without-line
group-reduction-with-line group-reduction-without-line k)
"We want to test (>= (increment in line length from line)
(* (/ k (- 1 k)) increment in gap from line.
"
(>= (+ effective-line-length group-reduction-without-line (- group-reduction-with-line))
(* (/ k (- 1 k))
(- (+ line-gap-1 line-gap-2 gap-without-line)))))
(defun ANGLES-ACCEPTABLE? (group-angle-total angle-to-new-line angle-from-new-line)
(< (+ group-angle-total angle-to-new-line angle-from-new-line)
*MAX-ANGLES-CONVEX-GROUP*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Convex Group Stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun UPDATE-CONVEX-GROUP-MAX-GAP! (cg k)
; (format t "~%convex-group-length = ~A" (convex-group-length cg))
(setf (convex-group-max-gap-squared cg)
(square (max 0 (- (/ (* (convex-group-length cg) (- 1 k)) k) (convex-group-gap-length cg))))))
;; (/ len (+ len total-gap)) >= k
(defun CONVEX-GROUP-LAST-NORMAL (cg)
(c-line-normal (convex-group-last-line cg)))
(defun NEW-GAP-ALLOWABLE? (cg-length cg-gap new-gap k)
(>= (* (- 1 k) cg-length) (* k (+ cg-gap new-gap))))
(defun CONVEX-GROUP-ACCEPTABLE? (cg k matches)
"Could we tie off this group now? We know it's convex, or we wouldn't have gotten this far, so
we must just check that the remaining gap isn't too big.
This means also taking acount of any shortening of the first or last line by the other one.
Also, we check whether we'd get a better gap ratio by dropping the last line.
"
(if (null (cdr (convex-group-lines cg)))
(<= k .5)
(let ((reds (lengths-reduced (convex-group-last-line cg) (convex-group-first-line cg) matches)))
(if (null reds)
nil
;; This means that the cg's gap ratio would be better without its first line.
(let ((last-front-reduction (car reds))
(first-rear-reduction (cadr reds))
(new-gap-squared (c-lines-distance-squared (convex-group-last-line cg)
(convex-group-first-line cg)
matches)))
(and (if (and (zerop last-front-reduction) (zerop first-rear-reduction))
(<= new-gap-squared (convex-group-max-gap-squared cg))
(and (< last-front-reduction (convex-group-last-line-effective-length cg))
(< (+ first-rear-reduction (cadr (car (last (convex-group-length-reductions cg)))))
(c-line-length (convex-group-first-line cg)))
;; Check that the reductions from considering the first and last lines won't wipe
;; out either of them.
(new-gap-allowable? (- (convex-group-length cg) last-front-reduction first-rear-reduction)
(convex-group-gap-length cg) (sqrt new-gap-squared) k)))
(if (null (cddr (convex-group-lines cg)))
;; If there are only two lines in the group, we don't check if it would be better with one line.
t
(line-improves-gap-ratio
(- (convex-group-last-line-effective-length cg) last-front-reduction)
(convex-group-last-gap cg)
(sqrt new-gap-squared)
(distance-between-point-and-point (c-line-point-2 (convex-group-second-last-line cg))
(convex-group-first-point cg))
(+ first-rear-reduction (convex-group-second-last-front-reduced cg))
(reduce #'+ (lengths-reduced (convex-group-second-last-line cg) (convex-group-first-line cg) matches))
k))))))))
(defun COPY-TO-ANSWER (cg k matches)
"Given a convex group, it returns a structure that we want to save"
(let ((new-cg (copy-cg cg)))
(destructuring-bind (last-front-reduction first-rear-reduction)
(if (null (cdr (convex-group-lines new-cg)))
(list 0 0)
(lengths-reduced (convex-group-last-line new-cg) (convex-group-first-line new-cg) matches))
(let ((new-gap (sqrt (c-lines-distance-squared (convex-group-last-line new-cg) (convex-group-first-line new-cg)
matches))))
(when (or (plusp last-front-reduction) (plusp first-rear-reduction))
(decf (convex-group-length new-cg) (+ last-front-reduction first-rear-reduction))
(decf (convex-group-last-line-effective-length new-cg) last-front-reduction)
(rplaca (cdr (first (convex-group-length-reductions new-cg))) last-front-reduction)
(rplaca (car (last (convex-group-length-reductions new-cg))) first-rear-reduction)
)
(incf (convex-group-gap-length new-cg) new-gap)
(push new-gap (convex-group-gaps new-cg))))
(update-convex-group-max-gap! new-cg k)
new-cg))
(defun COPY-CG (cg)
(let ((cg (copy-convex-group cg)))
(setf (convex-group-lines cg) (copy-list (convex-group-lines cg)))
(setf (convex-group-gaps cg) (copy-list (convex-group-gaps cg)))
(setf (convex-group-length-reductions cg) (copy-tree (convex-group-length-reductions cg)))
(setf (convex-group-angles cg) (copy-list (convex-group-angles cg)))
cg))
(defun MAKE-INITIAL-CONVEX-GROUP (c-line k)
(let ((cg (make-convex-group-internal :last-line c-line
:last-point (c-line-point-2 c-line)
:lines (list c-line)
:length (c-line-length c-line)
:gap-length 0
:total-angles 0
:first-line c-line
:first-point (c-line-point-1 c-line)
:closed nil
:gaps nil
:last-line-effective-length (c-line-length c-line)
:length-reductions (list (list 0 0))
)))
(update-convex-group-max-gap! cg k)
cg))
(defun MAKE-CONVEX-GROUP (c-lines k)
(let ((cg (make-convex-group-internal)))
(setf (convex-group-first-point cg) (c-line-point-1 (car c-lines)))
(setf (convex-group-first-line cg) (car c-lines))
(loop for first? in *FIRST-T-THEN-NIL*
for prev-point = (if first? nil (c-line-point-2 cl))
for cl in c-lines
for cl-upoints = (c-line-underlying-points cl)
for next-point = (if first? nil (c-line-point-1 cl))
for gap = (if first? 0 (distance prev-point next-point))
sum (c-line-length cl) into len
sum gap into gap-total
append cl-upoints into upoints
doing
(push cl (convex-group-lines cg))
(push gap (convex-group-gaps cg))
finally (progn (setf (convex-group-length cg) len)
(setf (convex-group-gap-length cg) gap-total)
(setf (convex-group-last-line cg) cl)
(setf (convex-group-last-point cg) (c-line-point-2 cl))
(setf (trait-underlying-points cg) upoints)
(update-convex-group-max-gap! cg k) ))
cg))
(defun MOCK-CONVEX-GROUP-FROM-LINE-SEGMENTS (lss)
(let ((cg (make-convex-group-internal)))
(loop for ls in (reverse lss)
for cl = (make-c-line ls)
doing
(push cl (convex-group-lines cg)))
cg))
(defun MAKE-SIMPLE-CONVEX-GROUP (c-lines)
(let ((cg (make-convex-group-internal)))
(setf (convex-group-lines cg) c-lines)
cg))
(defun CONVEX-GROUP-SECOND-LAST-LINE (cg)
(cadr (convex-group-lines cg)))
(defun CONVEX-GROUP-SECOND-LAST-FRONT-REDUCED (cg)
(car (second (convex-group-length-reductions cg))))
(defun CONVEX-GROUP-LAST-GAP (cg)
(car (convex-group-gaps cg)))
(defun ADD-C-LINE-CONVEX-GROUP! (cg cl k last-front-reduction c-line-rear-reduction dist angle)
; (format t "~%Adding, cg = ~A" cg)
(setf (convex-group-last-line-effective-length cg)
(- (c-line-length cl) c-line-rear-reduction))
(incf (convex-group-length cg) (- (convex-group-last-line-effective-length cg)
last-front-reduction))
(rplaca (cdr (first (convex-group-length-reductions cg)))
last-front-reduction)
(push (list c-line-rear-reduction 0) (convex-group-length-reductions cg))
(incf (convex-group-gap-length cg) dist)
(push cl (convex-group-lines cg))
(push dist (convex-group-gaps cg))
(setf (convex-group-last-line cg) cl)
(setf (convex-group-last-point cg) (c-line-point-2 cl))
(incf (convex-group-total-angles cg) angle)
(push angle (convex-group-angles cg))
; (when (< (distance-squared-between-point-and-point (convex-group-first-point cg) last-point)
; *squared-ignorable-distance*)
; (setf (convex-group-closed cg) t))
(update-convex-group-max-gap! cg k)
; (format t "~%cg = ~A" cg)
)
(defun POP-CONVEX-GROUP! (cg k)
"Remove the most recently added c-line from the group. If this would leave none, return nil"
; (format t "~%Popping, cg = ~A" cg)
(let ((cl (pop (convex-group-lines cg)))
(last-gap (pop (convex-group-gaps cg)))
(last-reductions (pop (convex-group-length-reductions cg))))
(if (null (convex-group-lines cg))
nil
(progn (setf (convex-group-last-line cg) (car (convex-group-lines cg)))
(setf (convex-group-last-point cg) (c-line-point-2 (convex-group-last-line cg)))
(decf (convex-group-length cg) (- (c-line-length cl) (car last-reductions)))
;; the CADR of last-reductions should always be 0.
(rplaca (cdr (first (convex-group-length-reductions cg))) 0)
(setf (convex-group-last-line-effective-length cg)
(- (c-line-length (convex-group-last-line cg))
(car (first (convex-group-length-reductions cg)))))
(decf (convex-group-gap-length cg) last-gap)
(decf (convex-group-total-angles cg) (pop (convex-group-angles cg)))
(setf (convex-group-closed cg) nil)
(update-convex-group-max-gap! cg k)
; (format t "~%cg = ~A" cg)
cg))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MATCH INFORMATION ABSTRACTION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun SET-LENGTH-REDUCTIONS (m i1 i2 reds)
"reds = cons of 2 floats indicating length reductions."
(setf (aref (match-info-length-array m) i1 i2) reds))
(defun MATCH-INFO-DISTANCE-ARRAY (mi) (second mi))
(defun MATCH-INFO-MATCH-ARRAY (mi) (third mi))
(defun MATCH-INFO-LENGTH-ARRAY (mi) (fourth mi))
(defun MATCH-INFO-ANGLE-ARRAY (mi) (fifth mi))
(defun SET-C-LINES-COMPATIBLE (index1 index2 match-info)
; (setf (aref (car match-info) index1 index2) t)
; (setf (aref (car match-info) index2 index1) t))
(setf (aref (car match-info) index1 index2) 1)
(setf (aref (car match-info) index2 index1) 1))
(defun LENGTHS-REDUCED (cl1 cl2 matches)
(let ((lens (aref (fourth matches) (c-line-index cl1) (c-line-index cl2))))
(if lens (list (car lens) (cdr lens))
nil)))
(defun GET-C-LINE-MATCH-LIST (matches c-line)
(list (aref (third matches) (c-line-index c-line))))
(defun POP-C-LINE-MATCH-LIST (convex-group match-list)
(let ((match (pop (car match-list))))
(if (null match) nil
(if (< (car match) (convex-group-max-gap-squared convex-group))
(cdr match)
nil))))
(defun C-LINES-COMPATIBLE (cl1 cl2 matches)
"Returns the squared distance if they are compatible"
; (aref (car matches) (c-line-index cl1) (c-line-index cl2)))
(= 1 (aref (car matches) (c-line-index cl1) (c-line-index cl2))))
(defun C-LINES-DISTANCE-SQUARED (cl1 cl2 matches)
(aref (second matches) (c-line-index cl1) (c-line-index cl2)))
(defun SET-ANGLE-ARRAY (angle-array index1 index2 cl1 cl2 c-red)
(setf (aref angle-array index1 index2)
(let ((a-diff (mod (- (c-line-angle cl1) (c-line-angle cl2)) *short-2pi*))
;; Going clockwise, the angle decreases, then jumps from -pi to pi.
(a-error (+ (c-line-angle-error cl1) (c-line-angle-error cl2))))
;; There's some potential ambiguity about whether an angle difference of nearly
;; *short-2pi* reflects that big an angle change, or a small negative angle change which
;; is allowed by assuming some error. To differentiate between these, basically if
;; the second line is in front of the first, it must be a small negative change,
;; otherwise a large change.
(if (< a-diff (- *short-2pi* a-error))
a-diff
(if (null c-red)
;; if the lines aren't really compatible, the second isn't in front of the first and colinear.
a-diff
(if (< (dot (c-line-vector cl1)
(diff (point-along-c-line cl2 (* (cadr c-red) (c-line-length cl2)))
(point-along-c-line cl1 (- 1 (* (car c-red) (c-line-length cl1))))))
(- *CONVEX-POSITIONAL-ERROR*))
;; If the real end of cl1 is more than error bounds in front of the real start of cl2:
a-diff
(- a-diff *short-2pi*)))))))
(defun C-LINES-TURNING-ANGLE (cl1 cl2 matches)
(aref (fifth matches) (c-line-index cl1) (c-line-index cl2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Post-process answers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun REMOVE-DUPLICATE-ANSWERS (answers &optional (ignorable-length 0))
(let ((c-lines&reds (loop for a in answers
collecting
(loop for cl in (convex-group-lines a)
for red in (convex-group-length-reductions a)
for long-enough? = (< ignorable-length (- (c-line-length cl) (reduce #'+ red)))
when long-enough? collect cl into cls
when long-enough? collect red into reds
finally (return (list cls reds))))))
(loop for answer in answers
for cls&reds in c-lines&reds
for i from 0
appending
(when (loop for cls&reds2 in c-lines&reds
for j from 0
always
(if (< i j)
(not (line-proper-subset (car cls&reds) (cadr cls&reds) (car cls&reds2) (cadr cls&reds2)))
(if (< j i)
(not (line-subset (car cls&reds) (cadr cls&reds) (car cls&reds2) (cadr cls&reds2)))
t)))
(list answer)))))
(defun COMBINE-OVERLAPPING-ANSWERS (answers k &optional (thresh .75))
"When 2 groups have a common sequence of lines accounting for a given percentage of their total length,
just keep this common sequence, throwing out the groups."
; (let ((answers (loop for a in answers collecting (list (convex-group-length a) a))))
;; Each answer is (len convex-group) so that when we build a sub-answer we may retain the longest
(loop until (null answers)
with res = nil
for a1 = (pop answers) ; Note that this can't be for a1 in answers, since things get pushed on answers.
doing
(loop for a2 in answers
for overlap-ans = (convex-group-overlapping-sequence a1 a2 k thresh)
doing
(when overlap-ans
(setf answers (remove a2 answers))
(push overlap-ans answers)
(return))
finally (push a1 res))
finally (return res)))
(defun CONVEX-GROUP-OVERLAPPING-SEQUENCE (cg1 cg2 k overlap-thresh)
(let* ((cls1 (convex-group-lines cg1))
(cls2 (convex-group-lines cg2))
(min-seq-length (* (max (apply #'+ (mapcar #'c-line-length cls1))
(apply #'+ (mapcar #'c-line-length cls2)))
overlap-thresh))
(seqs (eq-sequences-circular cls1 cls2)))
(loop for seq in seqs
doing
(when (< min-seq-length (apply #'+ (mapcar #'c-line-length seq)))
;(format t "Sequence long enough")
(let ((cg (make-convex-group (reverse seq) k)))
;(format t "~%Dist = ~A, max-gap = ~A, group = ~A"
; (distance-squared-between-point-and-point (convex-group-first-point cg) (convex-group-last-point cg))
; (convex-group-max-gap-squared cg) cg)
(when (< (distance-squared-between-point-and-point (convex-group-first-point cg) (convex-group-last-point cg))
(convex-group-max-gap-squared cg))
;(format t "Gap ok")
(return cg)))))))
(defun EQ-SEQUENCES-CIRCULAR (lst1 lst2)
(labels ((eq-sequence-2nd-circular (lst1 lst2)
;; Find sequence beginning at start of lst1
(let ((mem (member (car lst1) lst2)))
(when mem
(loop for i1 in lst1
for i2 in (append mem lst2)
until (not (eq i1 i2))
collect i1 into res
finally (return (values res (- (length lst2) (length mem))))))))
(eq-sequences-2nd-circular (lst1 lst2)
;; Find all sequences in first lst that don't wrap around from end to beginning
(if (null lst1) nil
(let ((seq (eq-sequence-2nd-circular lst1 lst2)))
(if (null seq)
(eq-sequences-2nd-circular (cdr lst1) lst2)
(cons seq (eq-sequences-2nd-circular (nthcdr (length seq) lst1) lst2)))))))
(multiple-value-bind (seq seq-start)
(eq-sequence-2nd-circular lst1 lst2)
(if (null seq)
(eq-sequences-2nd-circular (cdr lst1) lst2)
(multiple-value-bind (seq-front seq-front-start)
(eq-sequence-2nd-circular (reverse lst1) (reverse lst2))
(if (or (null seq-front)
(/= seq-front-start (mod (1- (- (1- (length lst2)) seq-start)) (length lst2))))
(cons seq (eq-sequences-2nd-circular (nthcdr (length seq) lst1) lst2))))))))
(defun PROPER-SUBSET-EQ (set1 set2)
(and (loop for e1 in set1 always (member e1 set2))
(< (length set1) (length set2))))
(defun SUBSET-EQ (set1 set2)
(loop for e1 in set1 always (member e1 set2)))
(defun LINE-PROPER-SUBSET (lines1 reductions1 lines2 reductions2)
(and (< (length lines1) (length lines2))
(line-subset lines1 reductions1 lines2 reductions2)))
(defun LINE-SUBSET (lines1 reductions1 lines2 reductions2)
"We have two lists of c-lines, and two matching lists of reductions in their length, from
the front and back. It's these reduced lines we want to compare, making sure that
for every line in LINES1 there's a superset of that line in LINES2.
"
(loop for line1 in lines1
for red1 in reductions1
always
(loop for line2 in lines2
for red2 in reductions2
thereis
(reduced-line-subset line1 red1 line2 red2))))
(defun REDUCED-LINE-SUBSET (line1 red1 line2 red2)
(and (eq line1 line2)
(<= (car red2) (car red1))
(<= (cadr red2) (cadr red1))))ir length, from
the front and back. It's these reduced lines we want to compare, making sure that
for every line in LINES1 there's a superset of that line in LINES2.
"
(loop for line1 in lines1
for red1 in reductions1
always
(loop for line2 in group/interface.lisp000666 002223 000322 00000016127 06050465340 014312 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
(in-package group)
(export '(EDGE-FILE-TO-CONVEX-GROUP-FILE))
(defun EDGE-FILE-TO-CONVEX-GROUP-FILE (infile outfile k &key (width 640) (height 486))
"This takes a file that gives edges, in raw format, where 0 indicates no edge,
and 255 indicates an edge. The output is an ASCII file showing the convex groups
found. Each line in the file shows a line segment, there are blank lines separating
the convex groups. k indicates the salience of each group (see the paper).
"
(let ((cgs (remove-duplicate-answers
(CONVEX-LINES-FROM-EDGES-SPLIT
(read-raw-canny-edges infile :width width :height height) k))))
(with-open-file (s outfile :direction :output)
(loop for cg in cgs
doing
(loop for ls in (convex-group-bounding-line-segments cg)
doing
(format s "((~A ~A) (~A ~A))~%"
(point-x (line-segment-point-1 ls))
(point-y (line-segment-point-1 ls))
(point-x (line-segment-point-2 ls))
(point-y (line-segment-point-2 ls))))
(format s "~%")))))
(defun READ-RAW-CANNY-EDGES (file &key (width 640) (height 486))
(let ((a (make-array (list height width) :element-type 'bit :initial-element 0)))
(with-open-file (s file :direction :input :element-type '(unsigned-byte 1))
(loop for i from 0 below height doing
(loop for j from 0 below width doing
(when (= 255 (read-byte s)) (setf (aref a i j) 1)))))
a))
(defun N-LONGEST-LINES (edges n &optional (m 1))
(loop repeat n
for line in (sort (split-and-merge (edge-image-strings edges)
(* 2dg::*string-line-break-max-err* m)
(* 2dg::*string-line-break-max-ave-err* m))
#'>
:key #'(lambda (line) (distance (line-segment-point-1 line)
(line-segment-point-2 line))))
collecting line))
(defun CONVEX-LINES-USING-LONGEST (edges n k &optional (m 1))
(group:convex-lines (n-longest-lines edges n m) nil k))
(defun N-BEST-DISJOINT-CGS (edges k n &key (num-lines 350))
(n-best-cgs (group::remove-duplicate-answers (convex-lines-using-longest edges num-lines k)) n))
(defun N-BEST-CGS (cgs n)
(loop repeat n
for cg in
(sort (copy-list cgs)
#'(lambda (cg1 cg2) (< (/ (convex-group-gap-length cg1)
(convex-group-length cg1))
(/ (convex-group-gap-length cg2)
(convex-group-length cg2)))))
collecting cg))
(defun CONVEX-GROUP-BOUNDING-LINE-SEGMENTS (cg)
(reverse
(loop for cl in (convex-group-lines cg)
for lr in (convex-group-length-reductions cg)
collect (make-line-segment
(add (c-line-point-1 cl) (multiply (c-line-vector cl) (car lr)))
(add (c-line-point-2 cl) (multiply (c-line-reverse-vector cl) (cadr lr)))))))
(defun SORT-CONVEX-GROUPS-BY-LENGTH (cgs)
(sort (copy-list cgs) #'> :key #'convex-group-length))
;;; Since a convex group can contain disconnected line segments, it defines two
;;; closed convex polygons. One is the "inner" ie smallest convex polygon that
;;; contains the group, the other is the "outer" largest such convex polygon.
;;; The useful routines here are: CONVEX-GROUP-INNER-POLYGON-VERTICES and
;;; CONVEX-GROUP-OUTER-POLYGON-VERTICES.
(defun LINE-SEGMENTS-INNER-POLYGON-VERTICES (lss)
(jarvis-march-convex-hull (loop for ls in lss appending (defining-points-list ls))))
(defun CONVEX-GROUP-INNER-POLYGON-VERTICES (cg)
(line-segments-inner-polygon-vertices (convex-group-bounding-line-segments cg)))
(defun LINE-SEGMENTS-OUTER-POLYGON-VERTICES (lss)
"This doesn't work if the polygon is unbounded."
(jarvis-march-convex-hull (loop for ls1 in (append (last lss) lss)
for ls2 in lss
collecting
(intersection-of-line-and-line
(g-coerce ls1 '2dg::line)
(g-coerce ls2 '2dg::line)))))
(defun CONVEX-GROUP-OUTER-POLYGON-VERTICES (cg)
(line-segments-outer-polygon-vertices (convex-group-bounding-line-segments cg)))
(defun BEST-NON-OVERLAPPING-CGS (cgs)
(loop for cg in (sort (copy-list cgs) #'>
:key #'(lambda (cg) (/ (convex-group-length cg)
(+ (convex-group-length cg) (convex-group-gap-length cg)))))
with best-cgs = nil
doing
(when (non-overlap-list cg best-cgs) (push cg best-cgs))
finally (return (reverse best-cgs))))
(defun LEAST-GAP-NON-OVERLAPPING-CGS (cgs)
(loop for cg in (sort (copy-list cgs) #'<
:key #'(lambda (cg) (convex-group-gap-length cg)))
with best-cgs = nil
doing
(when (non-overlap-list cg best-cgs) (push cg best-cgs))
finally (return (reverse best-cgs))))
(defun NON-OVERLAP-LIST (cg cg-list)
(loop for cg2 in cg-list
always
(non-overlap cg cg2)))
(defun NON-OVERLAP (cg1 cg2)
(loop for cl1 in (convex-group-lines cg1)
always
(loop for cl2 in (convex-group-lines cg2)
always
(not (eq cl1 cl2))))) :key #'(lambda (cg) (convex-group-gap-length cg)))
with best-cgs = nil
doing
(when (non-overlap-list cg best-cgs) (push cg best-cgs))
finally (return (reverse best-cgs))))
(defun NON-OVERLAP-LIST (cg cg-list)
(loop for cg2 in cg-list
always
(non-overlap cg cg2)))
(defun NON-OVERLAP (cg1 cg2)
(loop for cl1 in (convex-group-lines cg1)
always
(loopgroup/system.lisp000666 002223 000322 00000005701 06050465336 013677 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
;;; -*- Mode:LISP; Base:10; Package:USER; Syntax:Common-lisp; Lowercase:Yes; Default-character-style:(:FIX :ROMAN :NORMAL) -*-
(unless (find-package 'group-loading)
(make-package 'group-loading))
(in-package group-loading)
(defvar *home-directory* "~/lisp/group-tar/")
(defvar *binary-type* "fasl")
(export '(*home-directory* *binary-type*))
(unless (find-package '2dg)
(load (pathname (format nil "~A~A" group-loading:*home-directory* "geometry/x2dg/system"))))
(unless (find-package 'group)
(make-package 'group :use '(2dg g common-lisp)))
(in-package group)
(defun COMPILE-LOAD (file)
(let ((bin (make-pathname :directory (format nil "~A~A" group-loading:*home-directory* "group/")
:name file :type group-loading:*binary-type*))
(source (make-pathname :directory (format nil "~A~A" group-loading:*home-directory* "group/")
:name file :type "lisp"))
)
(when (or (not (probe-file bin)) (< (file-write-date bin) (file-write-date source)))
(compile-file source))
(load bin)))
(compile-load "convex")
(compile-load "convex-points")
(compile-load "interface")
"~A~A" group-loading:*home-directory* "group/")
group/tutorial.lisp000666 002223 000322 00000025233 06050465337 014221 0ustar00dwjCSI000000 000000 ;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license. By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;;
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;;
;;; Copyright 1995 by the Massachusetts Institute of Technology. All
;;; rights reserved. Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;;
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software. Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;;
(in-package group)
;;; This file contains some sample code for running the grouping system. It should
;;; not be loaded; rather, portions of this file may be extracted and run.
;;; To load the system, a command such as:
(LOAD "~/lisp/group/system")
;;; is executed. "~/lisp/" should be replaced by whatever main directory the system
;;; resides in.
;;; *** Ignore starred documentation if you've ftp'ed this code. This refers only to my
;;; *** own version of the code.
;;; *** It will be more useful, though, to load the file "~dwj/lisp/region-matching" since
;;; *** This will also load my window system code, and functions for looking at the convex groups.
;;; *** The functions given at the bottom of this file will now be loaded, and run, and
;;; *** can be used to look at groups and select them.
;;; If you want to try to run the system using a single LISP command, because, for example,
;;; you don't hack LISP, you can use the following command:
(group:edge-file-to-convex-group-file infile outfile k :width filewidth :height fileheight)
;;; This takes a file that gives edges, in raw format, where 0 indicates no edge,
;;; and 255 indicates an edge. The output is an ASCII file showing the convex groups
;;; found. Each line in the file shows a line segment, there are blank lines separating
;;; the convex groups. k indicates the salience of each group (see the paper).
;;; :width and :height should by typed just like that, whereas filewidth and fileheight
;;; are replaced by the file dimensions.
;;; Next, you should switch to the GROUP package:
(in-package group)
;;; To find convex groups, one should create a binary array as an edge map, and then
;;; run:
(remove-duplicate-answers (CONVEX-LINES-FROM-EDGES-SPLIT *TEST-ARRAY* 0.9))
;;; Here, CONVEX-LINES-FROM-EDGES-SPLIT is the main routine which returns a list of
;;; convex groups given a binary array and a threshold, k, (see the paper for a
;;; description of k, as well as the whole grouping system). There is a third
;;; optional argument, which adjusts the thresholds for the split-and-merge line
;;; extractor. The default is 1, and any other value will create a coarser approximation.
;;; 2 is a reasonable value here.
;;; remove duplicate answers removes identical convex groups. One always wants to do this,
;;; and that should probably have been the default.
;;; Here is an example of some code that builds a test array, and finds groups:
(progn
(defvar *test-array*)
(setq *test-array* (make-array (list 50 50) :element-type 'bit :initial-element 0))
(loop for i from 11 to 29
doing
(setf (aref *test-array* i 10) 1)
(setf (aref *test-array* i 30) 1))
(loop for j from 11 to 29
doing
(setf (aref *test-array* 10 j) 1)
(setf (aref *test-array* 30 j) 1))
;; This array now has a square in it.
(loop for i from 0 below 50
doing
(format t "~%")
(loop for j from 0 below 50
doing
(format t "~A" (aref *test-array* i j))))
(format t "~%~%")
;; This shows the array.
(remove-duplicate-answers (CONVEX-LINES-FROM-EDGES-SPLIT *TEST-ARRAY* 0.9))
)
;;; The convex groups that get returned are structures. If, for example, you only
;;; want the end points of the line segments that make up the convex groups, you
;;; could run:
(CONVEX-GROUP-BOUNDING-LINE-SEGMENTS cg)
;;; This is contained in the file, "group/interface.lisp", along with a bunch of other
;;; useful routines for processing the convex groups.
;;; It returns a list of line segments that form a convex group. These are structures as well.
;;; The points of the line segments are accessed with: line-segment-point-1, line-segment-point-2.
;;; The points are structures, accessed by point-x, and point-y. Note that the above
;;; routine is slightly complicated, because a line segment found in the image may participate
;;; only partially in a convex group, ie. only a subset of the line might be in the group.
;;; However, if you don't look at this routine, and try to extract the line segments yourself
;;; from the convex group structure, you are liable to make a mistake.
;;; Two other useful routines in "group/interface.lisp" are:
;;; CONVEX-GROUP-INNER-POLYGON-VERTICES and
;;; CONVEX-GROUP-OUTER-POLYGON-VERTICES. See that file for a brief description of them.
;;; Finally, you may find that the code is too slow, or bombs out altogether due to a
;;; lack of space. This is because both space and runtime will be quadratic in the number
;;; of lines found in the image. The best way to deal with this is to either use a coarser
;;; straight-line approximation to the edges in the image, or to just throw away the really
;;; short lines in the image. The algorithm will be robust to these measures because it
;;; will use only portions of lines in a single group, and because it is robust to small gaps
;;; in groups. To try this, use the routine
(CONVEX-LINES-USING-LONGEST edges n k &optional (m 1))
;;; also found in "group/interface.lisp". You also want to remove duplicates here. ie, do:
(remove-duplicate-answers (CONVEX-LINES-USING-LONGEST edges n k &optional (m 1)))
;;; Here edges is a binary array of the edge map, as
;;; above. n indicates how many lines to use from the image (the n longest are used).
;;; k is the salience threshold, as above. And m is a paramter that determines how closely
;;; to approximate the edges. You might try 1.5 or 2 here.
;;; In addition to the routines in interface.lisp, here are two routines that will not
;;; run because I haven't included any window interface, but which illustrate how one
;;; might look through the convex groups, picking out some of them by hand.
;;; This function, and the one below, will not run because they use the Allegro
;;; window system, and functions to access it that I have not included. The functions
;;; are given for illustrative purposes only. In particular, they show a couple of routines
;;; that would be useful if you wanted to implement functions like these. When this function works, it pops
;;; up a series of images, showing the convex groups, with a simple method for
;;; the user to select a subset of them by hand.
(defun SELECT-CONVEX-GROUP-LIST (cgs min-len image)
(let* ((background (dotted-edge-image image 4))
;; dotted-edge-image takes the edge map and displays it in an array as dotted.
(background-array (g:copy-array background))
(window (mw:make-array-window background-array "Convex Groups"))
;; This window code is not included.
(cgs (loop for cg in cgs when (< min-len (convex-group-length cg)) collect cg))
(collection (collect-separate-convex-groups-non-recursive cgs)))
;; collect-separate-convex-groups-non-recursive is a useful routine that
;; divides a list of convex groups into a list of lists, such that each
;; list contains convex groups that don't overlap when they are bounded
;; with an axial rectangle. That is, each list of convex groups can be
;; displayed in a single image, without being too confusing. See the
;; paper for examples of this.
(loop for coll in collection
for i from 0
for selected-cgs = (if (cg-list-selected?
coll (g::copy-into-bit-array background background-array)
window)
(if (null (cdr coll))
coll
(loop for cg in coll
when (cg-list-selected?
(list cg)
(g:copy-into-bit-array
background background-array)
window)
collect cg into res
finally (return res)))
nil)
append selected-cgs into result
until (if (= 0 (mod i 3)) (y-or-n-p "Quit?") nil)
finally (return result))))
;;; This routine also will not run, since it uses window code that is not included.
(defun CG-LIST-SELECTED? (cg-list image window)
(cw:clear window)
(mw::display-bit-array (2dg::array-convex-groups cg-list :raster image)
;; 2dg::array-convex-groups is a useful function that depicts a list
;; of convex groups into a binary array, each with a rectangle around it.
:window window)
(y-or-n-p "Select?"))
;;; *** If you loaded the region system, and want to look at groups, you should do something
;;; *** like the following:
(setq image (read-raw-canny-edges "/vision/images/regions/new_disket1.edge.raw"))
(progn (setq cgs
(remove-duplicate-answers
(CONVEX-LINES-FROM-EDGES-SPLIT image .8)))
nil)
(reg:SELECT-CONVEX-GROUP-LIST cgs 50 image)
f convex groups into a binary array, each with a rectangle around it.
:window window)
(y-or-n-p "Select?"))
;;; *** If you loaded the region system, and want to look at groups, you should do something
;;; *** like the following:
(setq image (read-raw-canny-edges "/vision/images/regions/new_disket1.edge.raw"))
(progn (setq cgs
loading-log000644 002223 000322 00000106440 06004232157 012433 0ustar00dwjCSI000000 000000 % cl
Allegro CL 4.1 [Silicon Graphics Iris 4D (R4000); R2] (3/16/93 12:08)
Copyright (C) 1985-1992, Franz Inc., Berkeley, CA, USA. All Rights Reserved.
;; Optimization settings: safety 1, space 1, speed 1, debug 2
;; For a complete description of all compiler switches given the current
;; optimization settings evaluate (EXPLAIN-COMPILER-SETTINGS).
USER(1): (load "~/group/group/system")
; Loading /ac/res/cs1/dwj/group/group/system.lisp.
; Loading /ac/res/cs1/dwj/group/geometry/x2dg/system.lisp.
; Loading /ac/res/cs1/dwj/group/geometry/2d/system.lisp.
; Loading /ac/res/cs1/dwj/group/geometry/general/system.lisp.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/general/constants.lisp ---
; While compiling (:TOP-LEVEL-FORM "constants.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/general/constants.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/general/constants.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/general/utils.lisp ---
; While compiling (:TOP-LEVEL-FORM "utils.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling SQ
; Compiling SQUARE
; Compiling ~=
; Fast loading /usr/local/lib/cl/code/loop.fasl.
; Compiling ~=X-Y
; Compiling ~ZEROP
; Compiling ~SIGNUM
; Compiling ~<
; Compiling ~<=
; Compiling ~>
; Compiling ~>=
; Compiling FILTER
; Compiling FLATTEN
; Compiling RANDOMIZE-LIST
; Compiling RANDOM-BETWEEN
; Compiling RANDOM-CHOOSE
; Compiling REMNTH
; Compiling NTHRDC
; Compiling NLAST
; Compiling AVERAGE
; Compiling XOR
; Compiling REMDUPS
; Compiling HELP
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/general/utils.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/general/utils.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/structs.lisp ---
; While compiling (:TOP-LEVEL-FORM "structs.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "structs.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling MAKE-POINT
; Compiling POINT-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 2) 0)
Warning: variable IGNORE is never used
; Compiling MUTATE-POINT
; Compiling MAKE-LINE-SEGMENT
; Compiling LINE-SEGMENT-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 4) 0)
Warning: variable IGNORE is never used
; Compiling MUTATE-LINE-SEGMENT
; Compiling MAKE-LINE
; Compiling LINE-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 6) 0)
Warning: variable IGNORE is never used
; Compiling MUTATE-LINE
; Compiling MAKE-POLYGON
; Compiling POLYGON-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 8) 0)
Warning: variable IGNORE is never used
; Compiling MUTATE-POLYGON
; Compiling MAKE-RECTANGLE
; Compiling RECTANGLE-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 10) 0)
Warning: variable IGNORE is never used
; Compiling MUTATE-RECTANGLE
; Compiling GEOMETRIC-TYPE
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/structs.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/structs.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/constants.lisp ---
; While compiling (:TOP-LEVEL-FORM "constants.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "constants.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/constants.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/constants.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/interface.lisp ---
; While compiling (:TOP-LEVEL-FORM "interface.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "interface.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling G-COERCE
; Compiling FIRST-POINT
; Compiling SECOND-POINT
; Compiling DEFINING-POINTS
; Compiling DEFINING-POINTS-LIST
; Compiling MAKE-FROM-DEFINING-POINTS
; Compiling DEFINING-POINT-COORDINATES-LIST
; Compiling DEFINING-POINT-COORDINATES
; Compiling OBJECT-EQUAL
; Note: doing tail merge
; Note: doing tail merge
; Compiling POINT-EQUAL
; Compiling POINT-COORDINATES
; Compiling POINT-COORDINATES-LIST
; Compiling MAKE-POLYGON-FROM-LINES
; Compiling POLYGON-LINE-SEGMENTS
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/interface.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/interface.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/general.lisp ---
; While compiling (:TOP-LEVEL-FORM "general.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "general.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling MULTIPLY
; Compiling DIVIDE
; Compiling BOUNDING-BOX
; Compiling EXTREME-POINT
; Compiling NORM
; Compiling NORM-SQUARED
; Compiling POINTS-BETWEEN
; Compiling LINE-SEGMENT-LENGTH
; Compiling AVERAGE-POINTS
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/general.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/general.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/vector.lisp ---
; While compiling (:TOP-LEVEL-FORM "vector.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "vector.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling NORMAL
; Compiling CROSS
; Compiling DOT
; Compiling DIFF
; Compiling ADD
; Compiling UNIT
; Compiling DIRECTED-DISTANCE
; Compiling NORMAL-DIRECTED-DISTANCE
; Compiling CART-TO-POLAR
; Compiling POLAR-TO-CART
; Compiling SIDE
; Compiling LEFT-TURN?
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/vector.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/vector.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/angle.lisp ---
; While compiling (:TOP-LEVEL-FORM "angle.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling DIRECTION
; Compiling PARALLEL?
; Compiling PARALLEL-VECTORS?
; Compiling VECTOR-ANGLE
; Compiling ORDERED-VECTOR-ANGLE
; Compiling CONNECTED-LINE-ANGLE
; Compiling ANGLE-0
; Compiling ANGLE-2PI
; Compiling ABS-ANGLE-DIFFERENCE
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/angle.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/angle.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/transform.lisp ---
; While compiling (:TOP-LEVEL-FORM "transform.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "transform.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling TRANSLATE
; Compiling ROTATE
; Compiling TRANSLATE-POINT
; Compiling ROTATE-POINT
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/transform.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/transform.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/colinear.lisp ---
; While compiling (:TOP-LEVEL-FORM "colinear.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "colinear.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling COLINEAR?
; Note: doing tail merge
; Note: doing tail merge
; Compiling THREE-POINTS-COLINEAR?
; Compiling COLINEAR-POINT-AND-LINE?
; Compiling COLINEAR-LINE-AND-LINE?
; Compiling COLINEAR-POINTS?
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/colinear.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/colinear.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/distance.lisp ---
; While compiling (:TOP-LEVEL-FORM "distance.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "distance.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling DISTANCE
; Note: doing tail merge
; Note: doing tail merge
; Compiling DISTANCE-BETWEEN-POINT-AND-POINT
; Compiling DISTANCE-BETWEEN-POINT-AND-LINE-SEGMENT
; Compiling DISTANCE-BETWEEN-POINT-AND-LINE
; Compiling DISTANCE-BETWEEN-LINE-SEGMENT-AND-LINE-SEGMENT
; Compiling DISTANCE-BETWEEN-LINE-SEGMENT-AND-LINE
; Compiling DISTANCE-BETWEEN-LINE-AND-LINE
; Compiling DISTANCE-SQUARED
; Note: doing tail merge
; Note: doing tail merge
; Compiling DISTANCE-SQUARED-BETWEEN-POINT-AND-POINT
; Compiling DISTANCE-SQUARED-BETWEEN-POINT-AND-LINE-SEGMENT
; Compiling DISTANCE-SQUARED-BETWEEN-POINT-AND-LINE
; Compiling DISTANCE-SQUARED-BETWEEN-LINE-AND-LINE
; Compiling DISTANCE-SQUARED-BETWEEN-LINE-SEGMENT-AND-LINE
; Compiling DISTANCE-SQUARED-BETWEEN-LINE-SEGMENT-AND-LINE-SEGMENT
; Compiling SQUARE-METRIC-DISTANCE-BETWEEN-POINT-AND-POINT
; Compiling SQUARE-METRIC-DISTANCE-SQUARED-BETWEEN-POINT-AND-POINT
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/distance.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/distance.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/intersect.lisp ---
; While compiling (:TOP-LEVEL-FORM "intersect.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "intersect.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling INTERSECT?
; Note: doing tail merge
; Note: doing tail merge
; Note: doing tail merge
; Compiling INTERSECT-POINT-AND-POINT?
; Compiling INTERSECT-POINT-AND-LINE-SEGMENT?
; Compiling INTERSECT-POINT-AND-LINE?
; Compiling INTERSECT-LINE-SEGMENT-AND-LINE?
; Compiling INTERSECT-LINE-AND-LINE?
; Compiling INTERSECT-LINE-SEGMENT-AND-LINE-SEGMENT?
; Compiling INTERSECT-RECTANGLE-AND-RECTANGLE?
; Compiling INTERSECTION-OBJECT
; Note: doing tail merge
; Note: doing tail merge
; Note: doing tail merge
; Compiling INTERSECTION-OF-POINT-AND-POINT
; Compiling INTERSECTION-OF-POINT-AND-LINE-SEGMENT
; Compiling INTERSECTION-OF-POINT-AND-LINE
; Compiling INTERSECTION-OF-LINE-SEGMENT-AND-LINE-SEGMENT
; Compiling INTERSECTION-OF-LINE-SEGMENT-AND-LINE
; Compiling INTERSECTION-OF-LINE-AND-LINE
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/intersect.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/intersect.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/polyrect.lisp ---
; While compiling (:TOP-LEVEL-FORM "polyrect.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "polyrect.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling INSIDE?
; Note: doing tail merge
; Compiling POINT-INSIDE-RECTANGLE?
; Compiling POINT-INSIDE-POLYGON?
; Compiling POINT-INSIDE-CONVEX-POLYGON?
; Compiling MONOTONIC?
; Compiling HORIZONTAL-INTERSECT
; Compiling POLYGON-DIAMETER
; Compiling INTERSECT-RECTANGLE-AND-CONVEX-POLYGON?
; Compiling INTERSECT-LINE-SEGMENT-AND-RECTANGLE?
; Compiling LINE-SEGMENT-CROSSES-RECTANGLE?
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/polyrect.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/polyrect.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/random.lisp ---
; While compiling (:TOP-LEVEL-FORM "random.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling *DEFAULT-SIDES-FUNCTION*
; Compiling *DEFAULT-SIZE-FUNCTION*
; Compiling *DEFAULT-ANGLE-FUNCTION*
; Compiling *DEFAULT-LENGTH-FUNCTION*
; Compiling RANDOM-POLYGON
; Compiling RANDOM-POLYGON-UNIFORM-VERTICES
; Compiling N-RANDOM-ROUND-POINTS
; Compiling CALCULATE-POLYGON
; Compiling CALCULATE-LINE
; Compiling ANGLE-FROM-SIDES
; Compiling LENGTHS-MAKE-TRIANGLE
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/random.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/random.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/linearfit.lisp ---
; While compiling (:TOP-LEVEL-FORM "linearfit.lisp" 0):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling LEAST-SQUARES-RHO-THETA
; Compiling LEAST-SQUARES-SLOPE-INTERCEPT
; Compiling RHO-THETA-TO-SLOPE-INTERCEPT
; Compiling SLOPE-INTERCEPT-TO-RHO-THETA
; Compiling LINE-FROM-RHO-THETA
; Compiling LINE-FROM-SLOPE-INTERCEPT
; Compiling LINE-INTERSECTION-RHO-THETA
; Compiling LINE-INTERSECTION-SLOPE-INTERCEPT
Warning: Symbol +1E declared special
Warning: Symbol -1E declared special
; Compiling CLOSEST-RHO-THETA-LINE-POINT
; Compiling DISTANCE-BETWEEN-POINT-AND-RHO-THETA-LINE
; Compiling DISTANCE-SQUARED-BETWEEN-POINT-AND-RHO-THETA-LINE
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/linearfit.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/linearfit.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/convex-hull.lisp ---
; While compiling (:TOP-LEVEL-FORM "convex-hull.lisp" 0):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling JARVIS-MARCH-CONVEX-HULL
Warning: tag EXCL::END-LOOP is never referenced
; Compiling MERGE-CONVEX-HULLS
; Compiling L-CONVEX-HULL-STRICT
Warning: tag EXCL::END-LOOP is never referenced
; Compiling L-CONVEX-HULL
Warning: tag EXCL::END-LOOP is never referenced
; Compiling FIND-L-CONVEX-HULL-POINT
; Compiling REMOVE-COLINEAR-VERTICES
; Compiling INTERSECT-SEGMENT-AND-HULL?
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/convex-hull.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/convex-hull.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/string.lisp ---
; While compiling (:TOP-LEVEL-FORM "string.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "string.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling EDGE-IMAGE-STRINGS
; Compiling MY-BITBLT
; Compiling SSIN
; Compiling SCOS
; Compiling NEXT
; Compiling PREVIOUS
; Compiling TRACE-TO-END
; Compiling GROW-STRING
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/string.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/string.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/straight.lisp ---
; While compiling (:TOP-LEVEL-FORM "straight.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling STRINGS-TO-LINE-SEGMENTS
; Compiling EDGES-TO-LINE-SEGMENTS
; Compiling DIST-X-Y
; Compiling DOT-X-Y
; Compiling BREAK-LINE
; Compiling MAKE-SPLIT-AND-MERGE-LINE
; Compiling SPLIT-AND-MERGE-LINE-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "straight.lisp" 19) 0)
Warning: variable IGNORE is never used
; Compiling SPLIT-AND-MERGE
; Compiling STRING-TO-LINES
; Compiling SPLIT-AND-MERGE-TO-SEGMENT
; Compiling POINT-ARRAY-FROM-STRING
; Compiling SPLIT-AND-MERGE-BREAK-LINE
; Compiling MAKE-LINE-FROM-POINTS
; Compiling FIND-LINE-MAX-ERROR
; Compiling MERGE-LINES
Warning: variable IGNORE is never used
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/straight.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/straight.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/theta-s.lisp ---
; While compiling (:TOP-LEVEL-FORM "theta-s.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "theta-s.lisp" 1):
Warning: in-package argument should not be quoted: 'G
; While compiling (:TOP-LEVEL-FORM "theta-s.lisp" 2):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; While compiling (:TOP-LEVEL-FORM "theta-s.lisp" 3):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "theta-s.lisp" 4):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling MAKE-THETA-S
; Compiling THETA-S-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "theta-s.lisp" 5) 0)
Warning: variable IGNORE is never used
Warning: variable THETA-S is never used
; Compiling SET-THETA-S-THETA
; Compiling SET-THETA-S-S
; Compiling THETA-S-THETA-LIST
; Compiling THETA-S-S
; Compiling THETA-S-THETA
; Compiling PRINT-THETA-S
; Compiling THETA-S-FROM-INTEGER-STRING
; Compiling (FLET THETA-S-FROM-INTEGER-STRING NEIGHBOR-DIRECTION)
; Compiling THETA-S-FROM-STRING
; Compiling (FLET THETA-S-FROM-STRING NEIGHBOR-DIRECTION)
; Compiling (FLET THETA-S-FROM-STRING DIRECTION-DIFFERENCE)
; Compiling STRING-FROM-THETA-S
; While compiling (:TOP-LEVEL-FORM "theta-s.lisp" 15):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling ROUND-POINT
; Compiling POINTS-NEIGHBORS?
; Compiling MUTATE-POINT-X
; Compiling MUTATE-POINT-Y
; Compiling GEOMETRIC-OBJECT?
; Compiling ATAN-0-2PI
; Compiling GROW-STRINGS
; Compiling STRING-CONNECTING-POINTS
; Compiling POINT-ENDPOINT?
; Compiling POINT-NEIGHBORS
; Compiling STRING-CIRCULAR?
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/theta-s.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/theta-s.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/2d/smooth-convolve.lisp ---
; While compiling (:TOP-LEVEL-FORM "smooth-convolve.lisp" 0):
Warning: in-package argument should not be quoted: '2DG
; While compiling (:TOP-LEVEL-FORM "smooth-convolve.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling GAUSSIAN-SMOOTH-UNIFORM-THETA-S
; Compiling GAUSSIAN-CONVOLVE-1D
; Compiling MAKE-REFLECTED-NUMS
; Compiling 1-2-1-CONVOLVE
; Compiling SPRING-2D-SMOOTH
; Compiling GAUSSIAN
; Compiling MAKE-1D-GAUSSIAN-FILTER
; Compiling NORMALIZE-FILTER
; Compiling DERIVATIVE-THETA-S
; Compiling DERIVATIVE-VECTOR
; Compiling CLEMENS-SMOOTH
; Compiling DEJAG-2D-SMOOTH
Warning: Symbol IGNORE declared special
; Compiling FIND-JAG-RUN
; Compiling FILL-JAG-RUN
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/2d/smooth-convolve.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/2d/smooth-convolve.fasl.
Warning: ignoring extra right parenthesis
Warning: COMPILE-LOAD, :OPERATOR was defined in
/ac/res/cs1/dwj/group/geometry/2d/system.lisp and is now being defined in
/ac/res/cs1/dwj/group/geometry/x2dg/system.lisp
; --- Compiling file /ac/res/cs1/dwj/group/geometry/x2dg/structs.lisp ---
; While compiling (:TOP-LEVEL-FORM "structs.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling MAKE-TRAIT
; Compiling TRAIT-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 2) 0)
Warning: variable IGNORE is never used
; Compiling MAKE-TLINE
; Compiling TLINE-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 3) 0)
Warning: variable IGNORE is never used
; Compiling TLINE-LENGTH
; Compiling TLINE-TO-SEGMENT
; Compiling MAKE-ANGLE-POINT
; Compiling ANGLE-POINT-POINT
; Compiling ANGLE-POINT-ANGLE
; Compiling ANGLE-POINT?
; Compiling MAKE-SQUARE
; Compiling SQUARE-CORNER
; Compiling SQUARE-WIDTH
; Compiling MAKE-AREA-INTERNAL
; Compiling AREA-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 13) 0)
Warning: variable IGNORE is never used
; Compiling AREA-SIZE
; Compiling AREA-FROM-POINTS
; Compiling AREA?
; Compiling AREA-MAX-X
; Compiling AREA-MAX-Y
; Compiling AREA-MIN-X
; Compiling AREA-MIN-Y
; Compiling MAKE-STRIP
; Compiling STRIP-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 21) 0)
Warning: variable IGNORE is never used
; Compiling STRIP?
; Compiling STRIP-MATCHING-POINT-POINT
; Compiling STRIP-MATCHING-POINT-NUMBER
; Compiling STRIP-MAX-X
; Compiling STRIP-MAX-Y
; Compiling STRIP-END-POINTS
; Compiling STRIP-POINTS
; Compiling STRING?
; Compiling STRING-MAX-X
; Compiling STRING-MAX-Y
; Compiling STRING-POINTS
; Compiling STRING-FROM-POINTS
; Compiling STRING-END-POINTS
; Compiling MAKE-EXTREMA
; Compiling EXTREMA-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 35) 0)
Warning: variable IGNORE is never used
; Compiling EXTREMA-TYPE-MAX?
; Compiling EXTREMA-TYPE-MIN?
; Compiling MAKE-CONVEX-GROUP-INTERNAL
; Compiling CONVEX-GROUP-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 39) 0)
Warning: variable IGNORE is never used
; Compiling CONVEX-GROUP-POINTS
; Compiling CONVEX-GROUP-END-POINTS
; Compiling CONVEX-GROUP-GAP-RATIO
; Compiling MAKE-C-LINE
; Compiling C-LINE-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 43) 0)
Warning: variable IGNORE is never used
; Compiling C-LINE-POINT-1
; Compiling C-LINE-POINT-2
; Compiling C-LINES-SAME?
; Compiling CONVEX-GROUP-LINE-SEGMENTS
; Compiling MAKE-CONVEX-CORNER
; Compiling CONVEX-CORNER-P
; Compiling (:INTERNAL (:TOP-LEVEL-FORM "structs.lisp" 48) 0)
Warning: variable IGNORE is never used
; Compiling LIST-OF-POINTS?
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/x2dg/structs.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/x2dg/structs.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/x2dg/utilities.lisp ---
; While compiling (:TOP-LEVEL-FORM "utilities.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling RESET-TIME
; Compiling TIME-TOTALS
; Compiling DEFTIME
; Compiling DEFTIME-BY-RESULT
; Compiling PROGNTIME
; Compiling TIME-DIFFERENCE
; Compiling ADD-TIME!
; Compiling CLEAR-MEMOIZED-FUNCTION
; Compiling DEFMEMO
; Compiling DIV
; Compiling SLICE-LIST
; Compiling RESLICE-LIST
; Compiling ONE
; Compiling AWRITE
; Compiling WRITE-ARRAY
; Compiling FIRST-N
; Compiling FIRST-TEST
; Note: doing tail merge
; Compiling ROTATE-LIST
; Compiling ALL-ROTATIONS
; Compiling MULTI-MEMBER
; Compiling SIGN
; Compiling REMLIST
Warning: Symbol ITEM declared special
Warning: Symbol LST declared special
; Compiling REMDUPS-AND-APPEND
; Compiling (FLET REMDUPS-AND-APPEND THING-IN-LIST-OF-LISTS)
; Compiling DIFFERENT-RANDOM-BETWEEN
; Compiling ALL-ORDERED-NTUPLES
; Compiling ALL-NTUPLES
; Compiling ALL-INSERTIONS
; Compiling ALL-PERMUTATIONS
; Compiling ALL-COMBINATIONS
; Compiling MERGE-PARTITIONS
; Compiling (LABELS MERGE-PARTITIONS ADD-SET-TO-PARTITIONS)
Warning: Symbol S2 declared special
Warning: Symbol S1 declared special
; Compiling PARTITION
; Compiling SORTED-INTERSECTION
; Note: doing tail merge
; Note: doing tail merge
; Compiling MAX-TEST
; Compiling RASTER-ARRAY-DIMENSIONS
; Compiling TIMED-SORT
; Compiling TIMED-REMOVE
; Compiling TIMED-AREF2
; Compiling FLET*
; Compiling COPY-ARRAY
; Compiling COPY-INTO-ARRAY
; Compiling COPY-INTO-BIT-ARRAY
; Compiling FLIP-ARRAY
; Compiling CONVERT-ARRAY
; Compiling CLEAR-ARRAY!
; Compiling ARRAY-NULL-VALUE
; Compiling ARRAY-BITBLTABLE?
; Compiling BITBLTABLE-DIMENSIONS
; Compiling OR-ARRAYS
; Compiling WRITE-4D-ARRAY-AS-BINARY
; Compiling FIND-ARRAY
; Note: doing tail merge
; Compiling PROJECT-ARRAY
; Compiling (LABELS PROJECT-ARRAY NEXT-INDICES)
; Compiling BITS-IN-ELEMENT-TYPE
; Compiling TIMES-N-IS-FACTOR
; Compiling WHOLE?
; Compiling LENGTH=
; Note: doing tail merge
; Compiling RESIZE-BINARY-RASTER
; Compiling REPEAT
; Compiling LIST?
; Compiling 2LENGTH?
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/x2dg/utilities.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/x2dg/utilities.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/geometry/x2dg/print.lisp ---
; While compiling (:TOP-LEVEL-FORM "print.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling DISPLAY-OBJECT?
; Compiling DISPLAY-BOUNDING-BOX
; Note: doing tail merge
; Note: doing tail merge
; Compiling DISPLAY-OBJECT-POINTS
; Compiling DISPLAY-OBJECT-TO-ARRAY
; Compiling DISPLAY-AREA-TO-ARRAY
Warning: variable GRAY is never used
Warning: variable ARRAY is never used
; Compiling DISPLAY-STRING-TO-ARRAY
; Compiling DISPLAY-LINE-SEGMENT-TO-ARRAY
; Compiling DISPLAY-STRIP-TO-ARRAY
; Compiling DISPLAY-EXTREMA-TO-ARRAY
Warning: variable ARRAY is never used
Warning: variable EXTREMA is never used
; Compiling DISPLAY-CONVEX-GROUP-TO-ARRAY
; Compiling DISPLAY-DISTINGUISHED-POINTS-TO-ARRAY
Warning: variable TYPE is never used
Warning: variable ARRAY is never used
Warning: variable PTS is never used
; Compiling AVERAGE-POINTS
Warning: AVERAGE-POINTS, :OPERATOR was defined in
/ac/res/cs1/dwj/group/geometry/2d/general.lisp and is now being defined in
/ac/res/cs1/dwj/group/geometry/x2dg/print.lisp
; Compiling PRINT-TRAITS
Warning: variable PRINTER is never used
Warning: variable NAME is never used
Warning: variable STRINGS is never used
Warning: variable TRAITS is never used
; Compiling CLASSIFY-TRAIT
; Compiling TRAIT-TYPE-LESS?
; Compiling TRAITS-MEET-UNARY-CONSTRAINT?
; Compiling TRAIT-TYPES-MEET-UNARY-CONSTRAINT?
; Compiling PRINT-CONVEX-GROUPS
Warning: variable PRINT-COVER-PAGES is never used
Warning: variable RASTER is never used
Warning: variable PRINTER is never used
Warning: variable NAME is never used
Warning: variable CGS is never used
; Compiling ARRAY-CONVEX-GROUPS
; Compiling FILE-CONVEX-GROUPS
; Compiling RECTANGLE-LINE-SEGMENTS
; Compiling PRINT-COMBINED-CONVEX-GROUPS
; Compiling ARRAY-COMBINED-CONVEX-GROUPS
; Compiling FILE-COMBINED-CONVEX-GROUPS
; Compiling PRINT-ORDERED-CONVEX-GROUPS
; Compiling COLLECT-SEPARATE-CONVEX-GROUPS
; Compiling (FLET COLLECT-SEPARATE-CONVEX-GROUPS BB-INTERSECTS)
; Compiling COLLECT-SEPARATE-CONVEX-GROUPS-NON-RECURSIVE
; Compiling (FLET COLLECT-SEPARATE-CONVEX-GROUPS-NON-RECURSIVE BB-INTERSECTS)
; Compiling PRINT-COMBINED-TRAITS
; Compiling PADDED-DISPLAY-BOUNDING-BOX
; Compiling DISPLAY-BOUNDING-BOX-LIST
; Compiling COLLECT-SEPARATE-TRAITS
; Compiling (FLET COLLECT-SEPARATE-TRAITS BB-INTERSECTS)
; Compiling PRINT-TRAIT-LIST
Warning: variable RASTER is never used
Warning: variable PRINTER is never used
Warning: variable NAME is never used
Warning: variable TRAITS is never used
; Compiling DOTTED-EDGE-IMAGE
; Compiling MY-PS-HARDCOPY-1-BIT-RASTER
Warning: variable PRINT-COVER-PAGES is never used
Warning: variable TITLE is never used
Warning: variable LANDSCAPE-MODE is never used
Warning: variable POSITION is never used
Warning: variable ZOOM is never used
Warning: variable PRINTER is never used
Warning: variable RASTER is never used
; Writing fasl file "/ac/res/cs1/dwj/group/geometry/x2dg/print.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/geometry/x2dg/print.fasl.
Warning: AVERAGE-POINTS, :OPERATOR was defined in
/ac/res/cs1/dwj/group/geometry/2d/general.lisp and is now being defined in
/ac/res/cs1/dwj/group/geometry/x2dg/print.lisp
; --- Compiling file /ac/res/cs1/dwj/group/group/convex.lisp ---
; While compiling (:TOP-LEVEL-FORM "convex.lisp" 16):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling MAKE-MATCH-INFORMATION
; Compiling MAKE-COMPATIBILITY-ARRAY
; Compiling MAKE-DISTANCE-ARRAY
; Compiling MAKE-MATCH-ARRAY
; Compiling MAKE-ANGLE-ARRAY
; Compiling MAKE-LENGTH-ARRAY
; Compiling CONVEX-LINES
; Compiling CONVEX-LINES-FROM-EDGES-SPLIT
; Compiling CONVEX-LINES-FROM-EDGES
; Compiling CONVEX-BACKTRACK
; Compiling (LABELS CONVEX-BACKTRACK ADD-LINE)
; Compiling (LABELS CONVEX-BACKTRACK NEXT)
; Compiling (LABELS CONVEX-BACKTRACK BACKTRACK)
; Compiling MAKE-C-LINE-MATCHES
; Compiling ADD-C-LINES-TO-TABLES
; Compiling REDUCED-LINES-LONG-ENOUGH?
; Compiling IGNORE-IT
; Compiling DISTANCE-SQUARED-BETWEEN-CONVEX-C-LINES
; Compiling POINT-ALONG-C-LINE
; Compiling COLINEAR-CONVEXITY
; Compiling C-LINES-COLINEAR
; Compiling LINE-COLINEAR-WRT-LINE
; Compiling (FLET LINE-COLINEAR-WRT-LINE SIGN-WITH-ERROR)
; Compiling (FLET LINE-COLINEAR-WRT-LINE SIGNS-DIFFERENT?)
; Compiling ANGLES-CONVEX?
; Compiling MAX-ANGLE-LINE-ERROR
; Compiling C-LINES-CONVEXITY
; Compiling C-LINES-CONVEXITY-SIMPLE
; Compiling C-LINES-CONVEXITY-FULL
; Compiling BIDIRECTIONAL-CONVEXITY-FROM-DOT-PRODUCTS
; Compiling CONVEXITY-FROM-DOT-PRODUCTS
; Compiling (FLET CONVEXITY-FROM-DOT-PRODUCTS FRAC-CUTOFF)
; Compiling (FLET CONVEXITY-FROM-DOT-PRODUCTS DIST-CUTOFF)
; Compiling ROUND-NEAR-0
; Compiling NO-CONNECTION-BETTER?
; Compiling LINE-DISTANCE-MAXIMIZING-GAP-RATIO
; Compiling MAKE-C-LINES
; Compiling C-LINES-EQUAL
; Compiling ADD-C-LINE-CONVEX-GROUP?!
; Compiling LINE-LENGTH-WORTH-ADDING?
; Compiling LINE-LENGTH-WORTH-ADDING?-FULL
; Compiling LINE-IMPROVES-GAP-RATIO
; Compiling LINE-IMPROVES-GAP-RATIO-FULL
; Compiling ANGLES-ACCEPTABLE?
; Compiling UPDATE-CONVEX-GROUP-MAX-GAP!
; Compiling CONVEX-GROUP-LAST-NORMAL
; Compiling NEW-GAP-ALLOWABLE?
; Compiling CONVEX-GROUP-ACCEPTABLE?
; Compiling COPY-TO-ANSWER
; Compiling COPY-CG
; Compiling MAKE-INITIAL-CONVEX-GROUP
; Compiling MAKE-CONVEX-GROUP
; Compiling MOCK-CONVEX-GROUP-FROM-LINE-SEGMENTS
; Compiling MAKE-SIMPLE-CONVEX-GROUP
; Compiling CONVEX-GROUP-SECOND-LAST-LINE
; Compiling CONVEX-GROUP-SECOND-LAST-FRONT-REDUCED
; Compiling CONVEX-GROUP-LAST-GAP
; Compiling ADD-C-LINE-CONVEX-GROUP!
; Compiling POP-CONVEX-GROUP!
; Compiling SET-LENGTH-REDUCTIONS
; Compiling MATCH-INFO-DISTANCE-ARRAY
; Compiling MATCH-INFO-MATCH-ARRAY
; Compiling MATCH-INFO-LENGTH-ARRAY
; Compiling MATCH-INFO-ANGLE-ARRAY
; Compiling SET-C-LINES-COMPATIBLE
; Compiling LENGTHS-REDUCED
; Compiling GET-C-LINE-MATCH-LIST
; Compiling POP-C-LINE-MATCH-LIST
; Compiling C-LINES-COMPATIBLE
; Compiling C-LINES-DISTANCE-SQUARED
; Compiling SET-ANGLE-ARRAY
; Compiling C-LINES-TURNING-ANGLE
; Compiling REMOVE-DUPLICATE-ANSWERS
; Compiling COMBINE-OVERLAPPING-ANSWERS
; Compiling CONVEX-GROUP-OVERLAPPING-SEQUENCE
; Compiling EQ-SEQUENCES-CIRCULAR
; Compiling (LABELS EQ-SEQUENCES-CIRCULAR EQ-SEQUENCES-2ND-CIRCULAR)
; Compiling (LABELS EQ-SEQUENCES-CIRCULAR EQ-SEQUENCE-2ND-CIRCULAR)
; Compiling PROPER-SUBSET-EQ
; Compiling SUBSET-EQ
; Compiling LINE-PROPER-SUBSET
; Compiling LINE-SUBSET
; Compiling REDUCED-LINE-SUBSET
; Writing fasl file "/ac/res/cs1/dwj/group/group/convex.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/group/convex.fasl.
; --- Compiling file /ac/res/cs1/dwj/group/group/convex-points.lisp ---
; While compiling (:TOP-LEVEL-FORM "convex-points.lisp" 1):
Warning: *VERY-LARGE-NUMBER*, :VARIABLE was defined in
/ac/res/cs1/dwj/group/geometry/x2dg/utilities.lisp and is now being defined
in /ac/res/cs1/dwj/group/group/convex-points.lisp
; Compiling CONVEX-GROUPS-WITH-SUPERSET-CORNERS
; Compiling (:INTERNAL CONVEX-GROUPS-WITH-SUPERSET-CORNERS 0)
; Compiling CONVEX-GROUPS-WITH-UNIQUE-CORNERS
; Compiling (:INTERNAL CONVEX-GROUPS-WITH-UNIQUE-CORNERS 0)
; Compiling (:INTERNAL CONVEX-GROUPS-WITH-UNIQUE-CORNERS 1)
; Compiling (:INTERNAL CONVEX-GROUPS-WITH-UNIQUE-CORNERS 2)
; Compiling UNORDERED-LIST-OF-CONVEX-CORNERS-ORDERING
; Compiling LIST-OF-CONVEX-CORNERS-SAME
; Compiling LIST-OF-CONVEX-CORNERS-SUBSET
; Compiling LIST-OF-CONVEX-CORNERS-PROPER-SUBSET
; Compiling COMPUTE-CONVEX-GROUPS-CORNERS
; Compiling ADJACENT-LINES-FEATURE-POINT
Warning: Symbol *STRAIGHT-LINE-APPROXIMATION-EXTRA-ERROR* declared special
; Compiling CONNECTED-LINE-ERROR
; Compiling CONVEX-CLS-LINE-SEGMENTS
; Compiling FLOAT-POINT
; Compiling RELATIVE-POINT-ERROR
; Compiling LINE-SEGMENT-ANGLE-ERROR
; Compiling RAY-INTERSECTION-ERROR
; Compiling INTERSECTION-OF-RAY-AND-RAY
; Compiling RAY-INTERSECTIONS@EXTREMAL-ERROR
; Compiling RAY-INTERSECTIONS@EXTREMAL-POINT-ERROR
; Compiling ANGLE-OF-VECTOR
; Compiling UNIT-VECTOR-FROM-ANGLE
; Compiling MERGE-CONVEX-GROUPS-NEARBY-CORNERS
; Compiling REMOVE-DUPLICATE-CORNERS
; Compiling (:INTERNAL REMOVE-DUPLICATE-CORNERS 0)
; Compiling MERGE-NEARBY-CONVEX-CORNERS
; Compiling MERGEABLE-CORNERS-AND-REPS
; Compiling CONVEX-CORNER-NEIGHBORHOOD-REPS
; Compiling BIGGEST-REPRESENTED-NEIGHBORHOOD
; Compiling ALL-PAIRS-AND-TRIPLES
; Compiling CIRCLE-CENTER-FROM-PERIMETER-POINTS
; Note: doing tail merge
; Compiling CONVEX-CORNER-NEIGHBORHOODS
; Compiling BUCKET-NEIGHBORHOODS
; Compiling CORNER-NEIGHBORHOOD
; Compiling (:INTERNAL CORNER-NEIGHBORHOOD 0)
; Compiling EXPAND-EQUIVALENCE-CLASS
; Compiling SORT-CORNERS-IN-BUCKETS
; Compiling ACCESS-CORNER-BUCKETS
; Compiling DELETE-CORNER-FROM-BUCKET
; Compiling ADD-CORNER-TO-BUCKET
; Compiling MAKE-BUCKETS
; Compiling POP-CORNER-BUCKETS
; Compiling GET-BUCKETS-INDICES
; Compiling (:INTERNAL GET-BUCKETS-INDICES 0)
Warning: variable IGNORE is never used
; Writing fasl file "/ac/res/cs1/dwj/group/group/convex-points.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/group/convex-points.fasl.
Warning: *VERY-LARGE-NUMBER*, :VARIABLE was defined in
/ac/res/cs1/dwj/group/geometry/x2dg/utilities.lisp and is now being defined
in /ac/res/cs1/dwj/group/group/convex-points.lisp
; --- Compiling file /ac/res/cs1/dwj/group/group/interface.lisp ---
; While compiling (:TOP-LEVEL-FORM "interface.lisp" 1):
Warning: compile-file found "EXPORT" at the top-level -- see the documentation for
comp:*cltl1-compile-file-toplevel-compatibility-p*
; Compiling EDGE-FILE-TO-CONVEX-GROUP-FILE
; Compiling READ-RAW-CANNY-EDGES
; Compiling N-LONGEST-LINES
; Compiling (:INTERNAL N-LONGEST-LINES 0)
; Compiling CONVEX-LINES-USING-LONGEST
; Compiling N-BEST-DISJOINT-CGS
; Compiling N-BEST-CGS
; Compiling (:INTERNAL N-BEST-CGS 0)
; Compiling CONVEX-GROUP-BOUNDING-LINE-SEGMENTS
; Compiling SORT-CONVEX-GROUPS-BY-LENGTH
; Compiling LINE-SEGMENTS-INNER-POLYGON-VERTICES
; Compiling CONVEX-GROUP-INNER-POLYGON-VERTICES
; Compiling LINE-SEGMENTS-OUTER-POLYGON-VERTICES
; Compiling CONVEX-GROUP-OUTER-POLYGON-VERTICES
; Compiling BEST-NON-OVERLAPPING-CGS
; Compiling (:INTERNAL BEST-NON-OVERLAPPING-CGS 0)
; Compiling LEAST-GAP-NON-OVERLAPPING-CGS
; Compiling (:INTERNAL LEAST-GAP-NON-OVERLAPPING-CGS 0)
; Compiling NON-OVERLAP-LIST
; Compiling NON-OVERLAP
; Writing fasl file "/ac/res/cs1/dwj/group/group/interface.fasl"
; Fasl write complete
; Fast loading /ac/res/cs1/dwj/group/group/interface.fasl.
T
USER(2): (group:edge-file-to-convex-group-file "/vision/images/regions/new_disket1.edge.raw" "~/testfile-cgs" .9)
NIL
USER(3):
ng BEST-NON-OVERLAPPING-CGS
; Compiling (:INTERNAL BEST-NON-OVERLAPPING-CGS 0)
; Compiling LEAST-GAP-NON-OVERLAPPING-CGS
; Compiling (:INTERNAL LEAST-GAP-NON-OVERLAPPING-CGS 0)
; Compiling NON-OVERLAP-LIST
; Compiling NO~~