;;; -*- Mode: Lisp; Package: DESIGN; Syntax: Ansi-common-lisp -*-


(defclass BASIC-EDGE ()
    ((endpoint1 :initform nil :accessor endpoint1 :initarg :endpoint1)
     (endpoint2 :initform nil :accessor endpoint2 :initarg :endpoint2)))

(defmethod endpoint-of-edge-p ((edge basic-edge) pt)
  (with-slots (endpoint1 endpoint2) edge
    (or (eq pt endpoint1)
	(eq pt endpoint2))))

(defmethod other-endpoint ((edge basic-edge) endpoint)
  (with-slots (endpoint1 endpoint2) edge
    (if (eql endpoint1 endpoint) endpoint2 endpoint1)))

(defun edges-share-endpoint-p (seg1 seg2)
  (or (eq (endpoint1 seg1) (endpoint1 seg2))
      (eq (endpoint1 seg1) (endpoint2 seg2))
      (eq (endpoint2 seg1) (endpoint1 seg2))
      (eq (endpoint2 seg1) (endpoint2 seg2))))

(defun edges-share-equal-endpoint-p (seg1 seg2)
  (or (point-equal (endpoint1 seg1) (endpoint1 seg2))
      (point-equal (endpoint1 seg1) (endpoint2 seg2))
      (point-equal (endpoint2 seg1) (endpoint1 seg2))
      (point-equal (endpoint2 seg1) (endpoint2 seg2))))

(defmethod endpoints ((edge basic-edge))
  (with-slots (endpoint1 endpoint2) edge
    `(,endpoint1 ,endpoint2)))

(defmethod endpoints ((edges list))
  (mapappend #'endpoints edges)) 

(defmethod edge-equal ((s1 basic-edge) (s2 basic-edge))
  (null (set-difference (endpoints s1) (endpoints s2) :test #'point-equal)))


(defmethod print-object ((edge basic-edge) stream)
  (with-slots (endpoint1 endpoint2) edge
    (format stream "<EDGE: ~a ~a>" (point-x-y endpoint1) (point-x-y endpoint2))))

(defun make-basic-edge (pt1 pt2)
  (let ((seg (make-instance 'basic-edge :endpoint1 pt1 :endpoint2 pt2)))
    (add-edge pt1 seg)
    (add-edge pt2 seg)
    seg))


;; Got tiresome instantiating design objects just for holding properties of edges, so add
;; plist to edges and check there first (e.g. for visibility)


;;; Maybe separate model-specific mixins

(defclass EDGE (basic-edge plist-mixin)
    ())

(defun make-edge (pt1 pt2 &optional plist)
  (let ((seg (make-instance 'edge :endpoint1 pt1 :endpoint2 pt2 :plist plist)))
    (add-edge pt1 seg)
    (add-edge pt2 seg)
    seg))


;; Do edges store edge-model?  territory-model?

(defclass MODEL-EDGE (edge derived-mixin edge-model-mixin
			   multiple-territory-model-mixin)
    ())

(defun make-model-edge (pt1 pt2 &optional object derivation plist)
  (let ((seg (make-instance 'model-edge :endpoint1 pt1 :endpoint2 pt2 :plist plist)))
    (add-derivation-info seg object derivation)
    (add-edge pt1 seg)
    (add-edge pt2 seg)
    seg))

(defmethod name ((edge model-edge))
  (let ((design-element (design-element edge))
	(regions (territories edge)))
    (cond (design-element (format nil "~a" (name design-element)))
	  ((voidp edge) (format nil "~a~@[~{~a~}~]" (name (car regions))
				   (mapcar #'name (cdr regions))))
	  (t (format nil "~a~@[~{+~a~}~]" (name (car regions))
		     (mapcar #'name (cdr regions)))))))


(defun find-edge (element territory-model)
  (find element (edges territory-model) :key #'design-element))

(defmethod save-form ((edge model-edge))
  (with-slots (endpoint1 endpoint2) edge
    `(,(point-x endpoint1) ,(point-y endpoint1) ,(point-x endpoint2) ,(point-y endpoint2)
      ,(name (design-element edge))
      ,(plist edge))))

(defmethod neighbors ((edge model-edge) &key predicate &allow-other-keys)
  ;; use predicate to pass in type info; e.g. #'(lambda (x) (typep x 'space))
  (let ((neighbors nil))
    (dolist (edge2 (remove edge (edges (territory-model edge))))
      (when (shared-edges edge edge2) (push edge2 neighbors)))
    (if predicate (remove-if-not predicate neighbors)
	neighbors)))

#+ignore
(defmethod add-edge :after ((model territory-model) (edge model-edge))
    (setf (territory-model edge) model)
    edge)


;; drawing edges

(clim:define-presentation-type edge ())

(defvar *draw-voids* t)

(defun draw-edge (x1 y1 x2 y2 stream &optional ink)
  (clim:draw-line* stream x1 y1 x2 y2 :ink ink))

(defvar *edge-color* clim::+foreground-ink+)

;; version that draws voids differently
(defun draw-edge+ (x1 y1 x2 y2 stream &optional line-dashes (ink *edge-color*))
  (clim:draw-line* stream x1 y1 x2 y2 :line-dashes line-dashes :ink ink))

(defvar *draw-dashed-openings* t)

(defun draw-dashed-openings-p ()
  *draw-dashed-openings*)

(defun toggle-open-segment-drawing ()
  (setq *draw-dashed-openings* (not *draw-dashed-openings*)))

(defmethod draw-self- ((edge basic-edge) stream)
  ;; no endpoints drawn
  (with-slots (endpoint1 endpoint2) edge
    (clim:with-output-as-presentation (stream edge 'edge)
      (draw-edge+ (point-x endpoint1) (point-y endpoint1)
		    (point-x endpoint2) (point-y endpoint2) stream
		    (when (draw-dashed-openings-p) (line-dashes-for-thing edge))))))

(defmethod draw-self ((edge basic-edge) stream)
  ;; endpoints drawn
  (with-slots (endpoint1 endpoint2) edge
    (draw-self endpoint1 stream)
    (draw-self endpoint2 stream)
    (draw-self- edge stream)))


(defvar *interior-edge-color* clim::+green+)
(defvar *show-interior-edges* t)

(defun show-interiorp ()
  *show-interior-edges*)

(defvar *show-modified-edges* nil)
(defvar *modified-edge-color* clim::+magenta+)

(defun show-modifiedp ()
  *show-modified-edges*)

(defun toggle-interior-segment-drawing ()
  (setq *show-interior-edges* (not *show-interior-edges*)))

#+ignore
(defmethod draw-self ((edge model-edge) stream)
  (with-slots (endpoint1 endpoint2) edge
    (draw-self endpoint1 stream)
    (draw-self endpoint2 stream)
    (clim:with-output-as-presentation (stream edge 'edge)
      (draw-edge+ (point-x endpoint1) (point-y endpoint1)
		    (point-x endpoint2) (point-y endpoint2) stream
		    (when (draw-dashed-voids-p) (line-dashes-for-thing edge))
		    (if (and (show-interiorp)
			     (completely-interiorp edge)) *interior-edge-color*
			*edge-color*)))))


;; +++ fix modified-edge-p; default for now

(defmethod modified-edge-p ((x t))
  nil)

#+ignore
(defmethod modified-edge-p ((edge model-edge))
  (find edge (modified-objects (territory-model edge))))

(defmethod draw-self- ((edge model-edge) stream)
  ;; no endpoints
  (with-slots (endpoint1 endpoint2) edge
    (clim:with-output-as-presentation (stream edge 'edge)
      (draw-edge+ (point-x endpoint1) (point-y endpoint1)
		    (point-x endpoint2) (point-y endpoint2) stream
		    (when (draw-dashed-openings-p) (line-dashes-for-thing edge))
		    (if (and (show-modifiedp) (modified-edge-p edge))
				*modified-edge-color*
				(if (and (show-interiorp) (completely-interiorp edge))
				    *interior-edge-color*
				    *edge-color*))))))

(defmethod draw-self ((edge model-edge) stream)
  (with-slots (endpoint1 endpoint2) edge
    (draw-self endpoint1 stream)
    (draw-self endpoint2 stream)
    (draw-self- edge stream)))


(defclass BASIC-POINT ()
    ((x :initform nil :accessor point-x :initarg :x)
     (y :initform nil :accessor point-y :initarg :y)))


(defun make-basic-point (x y)
  (make-instance 'basic-point :x x :y y))

(defmethod x ((p basic-point))
  (with-slots (x y) p
    x))

(defmethod y ((p basic-point))
  (with-slots (x y) p
    y))

(defmethod print-object ((pt basic-point) stream)
  (with-slots (x y) pt
    (format stream "<POINT: ~a ~a>" x y)))

(defmethod point-x-y ((pt basic-point))
  (with-slots (x y) pt
    `(,x ,y)))

(defmethod point-x-y* ((pt basic-point))
  (with-slots (x y) pt
    (values x y)))


(defun point-equal (pt1 pt2)
  (and (= (point-x pt1) (point-x pt2))
       (= (point-y pt1) (point-y pt2))))



(defclass EDGES-MIXIN ()
  ((edges :initform nil :initarg :edges :accessor edges)))

(defmethod edges ((thing (eql nil)))
  nil)

(defmethod number-of-edges ((thing edges-mixin))
  (with-slots (edges) thing
    (length edges)))

(defmethod add-edge ((thing edges-mixin) seg)
  (with-slots (edges) thing
    (pushnew seg edges :test #'eq)
    seg))

(defmethod add-edges ((x edges-mixin) new-edges)
  (setf (edges x) (remove-duplicates (append (edges x) new-edges))))

(defmethod remove-edge ((thing edges-mixin) seg)
  (with-slots (edges) thing
    (setf edges (remove seg edges))))

(defmethod remove-edges ((thing edges-mixin) segs)
  (dolist (seg segs)
    (remove-edge thing seg)))				;need :after method to run

(defmethod find-bad-edges ((thing edges-mixin))
  (loop for x in (edges thing)
	when (= (segment-length x) 0) collect x))

(defmethod remove-bad-edges ((thing edges-mixin))
  (loop for x in (edges thing)
	when (= (segment-length x) 0)
	  do (remove-edge thing x)))

(defun bounding-rectangle-for-edges (edges)
  (loop for edge in edges
	  as p1 = (endpoint1 edge)
	  as p2 = (endpoint2 edge)
	  minimize (min (point-x p1) (point-x p2)) into min-x
	  maximize (max (point-x p1) (point-x p2)) into max-x
	  minimize (min (point-y p1) (point-y p2)) into min-y
	  maximize (max (point-y p1) (point-y p2)) into max-y
	  finally (return (values min-x min-y max-x max-y))))

(defmethod bounding-rectangle ((thing edges-mixin))
  ;; returns min-x min-y max-x max-y
  (with-slots (edges) thing
    (bounding-rectangle-for-edges edges)))

(defun bounding-rectangle+ (x)
  (multiple-value-list (bounding-rectangle x)))

(defmethod bounding-dimensions ((thing edges-mixin))
  ;; returns length-x length-y
  (multiple-value-bind (min-x min-y max-x max-y)
      (bounding-rectangle thing)
    (list (- max-x min-x) (- max-y min-y))))

(defmethod bounding-dimensions+ ((thing edges-mixin))
  ;; returns length-x length-y
  (multiple-value-bind (min-x min-y max-x max-y)
      (bounding-rectangle thing)
    (values (- max-x min-x) (- max-y min-y))))

#+ignore
(defmethod bounding-area ((thing edges-mixin))
  (apply #'* (bounding-dimensions thing)))

(defmethod bounding-area ((thing edges-mixin))
  (multiple-value-bind (min-x min-y max-x max-y)
      (bounding-rectangle-for-edges (edges thing))
    (* (- max-x min-x) (- max-y min-y))))

(defmethod bounding-area ((edges list))
  (multiple-value-bind (min-x min-y max-x max-y)
      (bounding-rectangle-for-edges edges)
    (* (- max-x min-x) (- max-y min-y))))

;;; for now...
(defmethod area ((thing edges-mixin))
  (bounding-area thing))

(defmethod area ((edges list))
  (bounding-area edges))

(defmethod dimensions ((thing edges-mixin))
  (bounding-dimensions thing))

(defmethod draw-self ((thing edges-mixin) stream)
  (with-slots (edges) thing
    (dolist (edge edges)
      (draw-self edge stream))))

(defmethod shared-edges ((x1 edges-mixin) (x2 edges-mixin)
			    &optional ignore)
  ignore
  (intersection (edges x1) (edges x2)))

(defmethod shared-edges (x1 x2 &optional ignore)
  ;; args might be nil
  x1 x2 ignore
  nil)

(defmethod shared-void-edges ((x1 edges-mixin) (x2 edges-mixin)
				 &optional ignore)
  ignore
  (loop for edge in (intersection (edges x1) (edges x2))
	    when (voidp edge) collect edge))

(defmethod void-edges ((x edges-mixin))
  (with-slots (edges) x
    (loop for edge in edges
	  when (voidp edge) collect edge)))

(defvar *min-opening-width* 2.0)				; feet

(defun edge-long-enough-p (edge)
  (>= (edge-length edge) *min-opening-width*))

(defmethod void-edges-for-circulation ((x edges-mixin))
  (with-slots (edges) x
    (loop for edge in edges
	  when (and (voidp edge) (edge-long-enough-p edge))
		    collect edge)))

(defmethod nonvoid-edges ((x edges-mixin))
  (with-slots (edges) x
    (loop for edge in edges
	  unless (voidp edge) collect edge)))

(defmethod shared-void-edges (x1 x2 &optional ignore)
  ;; args might be nil
  x1 x2 ignore
  nil)



(defclass POINT (basic-point edges-mixin)
  ()) 

(defun make-point (x y)
  (make-instance 'point :x x :y y))

(defmethod remove-edge :after ((thing point) seg)
  (with-slots (points) thing
    (let ((pt1 (endpoint1 seg))
	  (pt2 (endpoint2 seg)))
    (remove-edge pt1 seg)
    (remove-edge pt2 seg)
    (unless (edges pt1) (remove-point thing pt1))
    (unless (edges pt2) (remove-point thing pt2)))))

;; drawing points

(clim:define-presentation-type point ())

(defun draw-point (x y stream &optional ink)					
  (let ((trans (clim:medium-transformation stream)))
    (multiple-value-bind (sx sy)
	(clim:transform-position trans x y)			; hack to not scale point
      (clim-utils:with-identity-transformation (stream)
	(clim:draw-circle* stream sx sy 2 :ink ink)))))			

(defmethod draw-self ((point basic-point) stream)
  (with-slots (x y) point
    (clim:with-output-as-presentation (stream point 'point)
      (draw-point x y stream))))


(defclass POINTS-MIXIN ()
    ((points :initform nil :initarg :points :accessor points)))

(defmethod add-point ((thing points-mixin) pt)
  (with-slots (points) thing
    (pushnew pt points)
    pt))

(defmethod remove-point ((thing points-mixin) pt)
  (with-slots (points) thing
    (setf points (remove pt points))))



(defclass BASIC-GRAPH (edges-mixin points-mixin)
  ())

(defmethod nodes ((graph basic-graph))
  (points graph))

(defmethod links ((graph basic-graph))
  (edges graph))

(defmethod draw-self ((graph basic-graph) stream)
  (dolist (point (points graph)) (draw-self point stream))	
  (dolist (edge (edges graph)) (draw-self- edge stream)))	;no endpoints

(defun copy-basic-graph (graph &rest plist)
  (let ((new-graph (apply #'make-instance (type-of graph) plist))
	(table (make-hash-table :test #'eq))
	(point-type (type-of (car (points graph))))
	(edge-type (type-of (car (edges graph)))))
    (flet ((save-it (old new)
	     (setf (gethash old table) new))
	   (find-it (old)
	     (gethash old table)))
      (dolist (point (points graph))
	(save-it point
		 (add-point new-graph (make-instance point-type
					     :x (point-x point) :y (point-y point)))))
      (dolist (edge (edges graph))
	(save-it edge
		 (add-edge new-graph
			      (make-instance edge-type
				     :endpoint1 (find-it (endpoint1 edge))
				     :endpoint2 (find-it (endpoint2 edge))))))
      new-graph)))


;; Keep this simple for now: use for footprints (i.e. list of edges) for design elements and
;; territories.  

(defclass GEOMETRY-OBJECT (edges-mixin)				
  ((height :initarg :height :initform nil :accessor height)))

(defun make-geometry-object (edges &optional height)
  (make-instance 'geometry-object :edges edges :height height))

;; Things that have geometry should mixin geometry-mixin.  Geometry information is kept in
;; separate geometry object (so representation can easily change).


(defclass GEOMETRY-MIXIN ()
  ((geometry :initarg :geometry :initform (make-instance 'geometry-object)
	     :accessor geometry)))

(defmethod add-edge ((form geometry-mixin) edge)
  (add-edge (geometry form) edge))

(defmethod edges ((form geometry-mixin))
  (with-slots (geometry) form
    (edges geometry)))

(defmethod (setf edges) ((edges list) (form geometry-mixin))
  (with-slots (geometry) form
    (if geometry (setf (edges geometry) edges)
	(setf (geometry form) (make-geometry-object edges)))))

(defmethod height ((form geometry-mixin))
  (with-slots (geometry) form
    (height geometry)))

(defmethod footprint ((form geometry-mixin))
  (edges form))

(defmethod void-edges ((x geometry-mixin))
  (with-slots (geometry) x
    (void-edges geometry)))

(defmethod void-edges-for-circulation ((x geometry-mixin))
  (with-slots (geometry) x
    (void-edges-for-circulation geometry)))

(defmethod bounding-rectangle ((form geometry-mixin))
  ;; returns min-x min-y max-x max-y
  (with-slots (geometry) form
    (bounding-rectangle geometry)))

(defmethod bounding-dimensions ((form geometry-mixin))
  ;; returns length-x length-y as a list
  (with-slots (geometry) form
    (bounding-dimensions geometry)))

(defmethod bounding-dimensions+ ((form geometry-mixin))
  ;; returns length-x length-y
  (with-slots (geometry) form
    (bounding-dimensions+ geometry)))


(defclass GEOMETRIC-FORM (geometry-mixin)
    ())