;;; 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 ~A>" (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: ~A ~A>" (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: ~A>" (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 ~A> <MATCHING-POINTS ~A>>"
					(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 ~A) (LENGTH ~A) ~A>"
					(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: ~A ~A>" (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 "#<CONVEX-CORNER: ~A ~A>"
					(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))))
  