;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: MU; Base: 10.; -*-

;;; Copyright (c) 1987, Massachusetts Institute of Technology
;;; Author: Mike Drumheller

;;;*****************************************************************************
;;; CHANGE HISTORY
;;;
;;; 9/17/87  MIKE  Created.
;;; 9/25/87  WEG   Changed the package to mu.  Recompiled for Release 7.
;;; 92MAR09  PAO   Ported to Lucid.
;;;
;;;*****************************************************************************

(in-package :Mu)


;;;  Read this documentation very carefully.
;;;
;;;  This file contains a couple of very useful macros:
;;;
;;;  WITH-PVARS-MOVING-IN-RECTANGLE is called like this:
;;;
;;;  (with-pvars-moving-in-rectangle
;;;    ((name-for-my-pvar-while-it-is-moving my-pvar)) dx dy 3 5
;;;       (*incf some-accumulator-pvar
;;;             (*!! (!! (+ (abs dx) (abs dy)))
;;;                  name-for-my-pvar-while-it-is-moving)))
;;;
;;;  That simple piece of code is equivalent to the following:
;;;
;;;  (loop for dx from -1 to 1 do ;;; <== This covers the WIDTH of a 3x5 rectangle.
;;;    (loop for dy from -2 to 2 do ;;; <== This covers the HEIGHT of a 3x5 rectangle.
;;;      (*let ((name-for-my-pvar-while-it-is-moving
;;;              (pref-grid-relative!! my-pvar (!! dx) (!! dy) :border-pvar (!! 0))))
;;;         (*incf some-accumulator-pvar
;;;                (*!! (!! (+ (abs dx) (abs dy))) name-for-my-pvar-while-it-is-moving)))))
;;;
;;;  Which may not seem like much, excpect you the macro does a neat
;;;  thing:  it move the pvar around EFFICIENTLY by implementing a
;;;  grey-code path through the rectangular area.
;;;
;;;  WITH-PVARS-MOVING-ACCORDING-TO-NEIGHBOR-LIST is analogous,
;;;  but it moves the pvars according to an arbitrary list-description
;;;  of a neighborhood;  I know that's vague, but I'll come back and
;;;  document this better some other time.
;;;
;;;  NOTE that I probably should not have added the feature of letting
;;;  the user establish a temporary renaming of the pvars that he wants
;;;  to move around.  It just makes the code more complicated.  But it
;;;  seemed like a good idea at the time.  --Mike

(defmacro WITH-PVARS-MOVING-IN-RECTANGLE
	  (moving-pvar-binding-list dx-name dy-name xdim ydim &body body)
  (let ((half-xdim-sym (gensym "HALF-XDIM-"))
	(half-ydim-sym (gensym "HALF-YDIM-"))
	(border-pvar-sym (gensym "BORDER-PVAR-"))
	(xdir-sym (gensym "XDIR-"))
	(xinc-sym (gensym "XINC-"))
	(yinc-sym (gensym "YINC-"))
	(notfirst-sym (gensym "NOTFIRST-"))
	(i-sym (gensym "I-"))
	(j-sym (gensym "j-")))
    (assert (every #'(lambda (binding) (symbolp (car binding))) moving-pvar-binding-list))
    `(if (not (and (oddp ,xdim) (oddp ,ydim)))
	 (error "The x- and y-dimensions of the rectangle must both be odd!")
	 (*let ,moving-pvar-binding-list
	   (let* ((,half-xdim-sym (floor ,xdim 2))
		  (,half-ydim-sym (floor ,ydim 2))
		  (,dx-name (- ,half-xdim-sym))
		  (,dy-name (- ,half-ydim-sym)))
	     (*let ((,border-pvar-sym (!! 0)))
	       ,@(mapcar #'(lambda (binding)
			     `(*set ,(car binding)
				    (news-border!! ,(car binding) ,border-pvar-sym
						   (- ,half-xdim-sym)
						   (- ,half-ydim-sym))))
			 moving-pvar-binding-list)
	       (let ((,xdir-sym 1) (,xinc-sym 1) (,yinc-sym 0) (,notfirst-sym nil))
		 (do ((,j-sym (- ,half-ydim-sym) (1+ ,j-sym)))
		     ((> ,j-sym ,half-ydim-sym))
		   (do ((,i-sym (- ,half-xdim-sym) (1+ ,i-sym)))
		       ((> ,i-sym ,half-xdim-sym))
		     (progn .,body)
		     (cond ((eql ,yinc-sym 1)
			    (setq ,yinc-sym 0 ,xdir-sym (* ,xdir-sym -1) ,xinc-sym ,xdir-sym)) 
			   ((and ,notfirst-sym
				 (or (eql ,dx-name (- ,half-xdim-sym))
				     (eql ,dx-name ,half-xdim-sym)))
			    (setq ,xinc-sym 0 ,yinc-sym 1)))
		     ,@(mapcar #'(lambda (binding)
				   `(*set ,(car binding)
					  (news-border!! ,(car binding)	,border-pvar-sym
								,xinc-sym ,yinc-sym)))
			       moving-pvar-binding-list)
		     (incf ,dx-name ,xinc-sym)
		     (incf ,dy-name ,yinc-sym)
		     (setq ,notfirst-sym t))))))))))

;(*defun TEST-RECTANGLE-MACRO (&optional (x 3) (y 3))
;  (*let ((pvar1 (!! 0))
;	 (accum (!! 0)))
;    (pset-grid 1 pvar1 x y)
;    (with-pvars-moving-in-rectangle
;      ((moving-pvar1 pvar1))
;      dx dy 3 3
;      (format t "~%~%X=~s, Y=~s" dx dy)
;;      (ppp moving-pvar1 :mode :grid)
;      (*incf accum moving-pvar1)
;      (format t "~%Accum:"))
;    (ppp-grid accum 0 0 10 10)))

;;; Constructs a list of (x . y) pairs describing a grey-code path
;;; through a circular region; to be used by the macro
;;; with-pvars-moving-according-to-neighbor-list, see below.
;;;
;;; Takes about 0.0165 seconds for radius = 10.
;;;   "     "   0.0028    "     "    "    "  4.
(defun MAKE-CIRCULAR-X-Y-DISK-LIST (radius)
  (if (minusp radius)
      (error "Radius must be non-negative"))
  (let ((list nil)
	(sqrad (* radius radius)))
    (loop for x from (- radius) to radius do
      (let ((temp (loop for y from 0 until (> (+ (* x x) (* y y)) sqrad)
			collecting (cons x y))))
	(if (oddp x) (setq temp (nreverse temp)))
	(setq list (nconc temp list))))
    (loop for x from (- radius) to radius do
      (let ((temp (loop for y from -1 by -1 until (> (+ (* x x) (* y y)) sqrad)
			collecting (cons x y))))
	(if (oddp x) (setq temp (nreverse temp)))
	(setq list (nconc temp list))))
    list))

#||
(defun SHOW-DISK (disk)
  (zl-user:send *terminal-io* :clear-window)
  (loop for point in disk
	for i from 0 do
    (cl-user::draw-number i (+ 5 300 (* 35 (car point))) (+ 0 300 (* 35 (cdr point))))
    (zl-user:send *terminal-io* :draw-filled-in-circle (+ 300 (* 35 (car point))) (+ 300 (* 35 (cdr point))) 3)))
||#

;;;  Defaults to a disk-shaped neighborhood.
;;;
;;;  NEIGHBOR-LIST-OR-NIL is best described by looking at what is
;;;  returned by (MAKE-CIRCULAR-X-Y-DISK-LIST 3).
;;;
;;;  Note to Eric Saund:  You will have to write something analogous
;;;  to MAKE-CIRCULAR-X-Y-DISK-LIST, but which constructs a list
;;;  describing just the perimeter of a circle, not the whole area.
(defmacro WITH-PVARS-MOVING-ACCORDING-TO-NEIGHBOR-LIST 
	  (moving-pvar-binding-list
	   dx-name
	   dy-name
	   radius-or-nil
	   neighbor-list-or-nil
	   border-pvar
	   &body body)
  (let ((lastx-sym (gensym "LASTX-"))
	(lasty-sym (gensym "LASTY-"))
	(circ-point-list-sym (gensym "circ-point-list-"))
	(x-inc-sym (gensym "X-INC-"))
	(y-inc-sym (gensym "Y-INC-")))
    (assert (every #'(lambda (binding) (symbolp (car binding))) moving-pvar-binding-list))
    `(if (and (numberp ,radius-or-nil) (minusp ,radius-or-nil))
	 (error "RADIUS-OR-NIL, if it is a number, must be non-negative!")
	 (*let ,moving-pvar-binding-list
	   (let* ((,circ-point-list-sym (if ,neighbor-list-or-nil
					    ,neighbor-list-or-nil
					    (make-circular-x-y-disk-list ,radius-or-nil)))
		  (,lastx-sym 0)
		  (,lasty-sym 0)
		  (,dx-name 0)
		  (,dy-name 0)
		  (,x-inc-sym 0)
		  (,y-inc-sym 0))
	     (loop for point in ,circ-point-list-sym do
	       (setq ,x-inc-sym (- (car point) ,lastx-sym)
		     ,y-inc-sym (- (cdr point) ,lasty-sym)
		     ,dx-name (incf ,dx-name ,x-inc-sym)
		     ,dy-name (incf ,dy-name ,y-inc-sym))
	       ,@(mapcar #'(lambda (binding)
			     `(*set ,(car binding)
				    (news-border!! ,(car binding) ,border-pvar
				      ,x-inc-sym ,y-inc-sym)))
			 moving-pvar-binding-list)
	       (progn .,body)
	       (setq ,lastx-sym (car point) ,lasty-sym (cdr point))))))))

;(*defun TEST-ARBITRARY-NEIGHBORHOOD-MACRO (&optional (x 3) (y 3))
;  (*let ((pvar1 (!! 0))
;	 (accum (!! 0)))
;    (pset-grid 1 pvar1 x y)
;    (with-pvars-moving-according-to-neighbor-list
;      ((moving-pvar1 pvar1))
;      dx dy 1 nil nil!!
;      (format t "~%~%X=~s, Y=~s" dx dy)
;      (*if (and!! accum moving-pvar1)
;	   (*incf accum moving-pvar1)
;	   (*set accum nil!!))
;      (format t "~%Accum:"))
;    (ppp-grid accum 0 0 10 10)))