;;; 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)))
