;-*- Mode:Common-Lisp; Package:SI; Base:8 -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved.

;A PLANE is an array whose bounds, in each dimension,
;are plus-infinity and minus-infinity.  All integers are legal as indices.
;Planes are distinguished not by size and shape, but by number of dimensions alone.
;When a plane is created, a "default value" must be specified.
;At that moment, every component of the plane has that value.
;As you can't ever change more than a finite number of components,
;only a finite region of the plane need actually be stored.

;You can use MAKE-PLANE to create a plane,
;PLANE-REF or PLANE-AR-N to get the value of a component,
;PLANE-STORE or PLANE-AS-N to store into a component.
;ARRAY-#-DIMS will work on a plane.

;A plane is actually stored as an array with a leader.
;The array corrsponds to a rectangular, aligned region of the plane,
;containing all the components in which a PLANE-STORE has been done
;(and others, in general, whcih have never been altered).
;The lowest-co-ordinate corner of that rectangular region is
;given by the PLANE-ORIGIN in the array leader.
;The highest co-ordinate corner can be found by adding the PLANE-ORIGIN
;to the ARRAY-DIMENSIONS of the array.
;The PLANE-DEFAULT is the contents of all the
;elements of the plane which are not actually stored in the array.
;The PLANE-EXTENSION is the amount to extend a plane by in any direction
;when the plane needs to be extended.  The default is 32.

(DEFSUBST PLANE-ORIGIN (PLANE)
  "Return the list of lowest-possible indices in each dimension."
  (ARRAY-LEADER PLANE 0))

(DEFSUBST PLANE-DEFAULT (PLANE)
  "Return the default element value for a plane.
This is the element which we pretend is stored
at all the locations which no storage is allocated for."
  (ARRAY-LEADER PLANE 1))

(DEFSUBST PLANE-EXTENSION (PLANE)
  "Return the distance to extend this plane by.
When it is necessary to make the plane's storage larger,
allocate this much extra in each dimension that needs to be extended."
  (ARRAY-LEADER PLANE 2))

(DEFUN PLANE-AREF (PLANE &REST POINT)
  "Return the value stored in PLANE for indices in POINT."
  (PLANE-REF PLANE POINT))

(DEFUN PLANE-ASET (DATUM PLANE &REST POINT)
  "Store DATUM into PLANE at indices POINT."
  (PLANE-STORE DATUM PLANE POINT))

(DEFF PLANE-AR-N 'PLANE-AREF)
(DEFF PLANE-AS-N 'PLANE-ASET)

;Access the element of PLANE at co-ordinates POINT.
;Absolutely any point is legal.
(DEFUN PLANE-REF (PLANE POINT)
  "Return the value stored in PLANE at the indices in the list POINT."
  (DO ((PT POINT (CDR PT))
       (PO (PLANE-ORIGIN PLANE) (CDR PO)))
      ((NULL PT))
    (RPLACA PT (- (CAR PT) (CAR PO))))
  (COND ((APPLY 'ARRAY-IN-BOUNDS-P PLANE POINT)
	  (APPLY 'AREF PLANE POINT))
	(T (PLANE-DEFAULT PLANE))))

;Store DATUM in PLANE at co-ordinates POINT.
;PLANE is extended if necessary.
(DEFUN PLANE-STORE (DATUM PLANE POINT)
  "Store DATUM into PLANE at the indices in the list POINT."
  (LET ((POINT1 (MAPCAR #'- POINT (PLANE-ORIGIN PLANE))))
    (COND ((NOT (APPLY 'ARRAY-IN-BOUNDS-P PLANE POINT1))
	   (PLANE-EXTEND PLANE POINT)
	   (SETF (APPLY 'AREF  PLANE (MAPCAR #'- POINT (PLANE-ORIGIN PLANE))) DATUM))
	  (T (SETF (APPLY 'AREF PLANE POINT1) DATUM)))))

(DEFUN PLANE-EXTEND (PLANE POINT)
  "Make PLANE's storage larger so that storage is allocated for POINT.
POINT is a list of numerical indices."
  (LET* ((MIN (PLANE-EXTENSION PLANE))
	 (OLD-DIMS (ARRAY-DIMENSIONS PLANE))
	 (BOTTOM-EXTEND (MAPCAR #'(LAMBDA (PT OLD-BOT)
				    (LET ((TEM (- OLD-BOT PT)))
				      (COND ((<= TEM 0) 0)
					    (T (MAX TEM MIN)))))
				POINT
				(PLANE-ORIGIN PLANE)))
	 (TOP-EXTEND (MAPCAR #'(LAMBDA (PT OLD-BOT OLD-LEN)
				 (LET ((TEM (1+ (- PT OLD-BOT OLD-LEN))))
				   (COND ((<= TEM 0) 0)
					 (T (MAX TEM MIN)))))
			     POINT
			     (PLANE-ORIGIN PLANE)
			     OLD-DIMS))
	
	 NEW-PLANE)
    (COND ((AND (ZEROP (APPLY '+ BOTTOM-EXTEND))
		(ZEROP (APPLY '+ TOP-EXTEND))))
	  (T
	   (SETQ NEW-PLANE (MAKE-PLANE-INTERNAL
			     (ARRAY-TYPE PLANE)
			     (MAPCAR #'+
				     OLD-DIMS
				     BOTTOM-EXTEND
				     TOP-EXTEND)
			     (MAPCAR #'-
				     (PLANE-ORIGIN PLANE)
				     BOTTOM-EXTEND)
			     (PLANE-DEFAULT PLANE)
			     T
			     (PLANE-EXTENSION PLANE)))
	   (PLANE-COPY PLANE NEW-PLANE)
	   (STRUCTURE-FORWARD PLANE NEW-PLANE)))
    PLANE))

;Make a new plane, for the user.  Specify the number of dimensions,
;and optionally the array type, default value, and extension.
(DEFUN MAKE-PLANE (RANK &KEY &OPTIONAL (TYPE 'ART-Q) (DEFAULT-VALUE NIL DEFAULT-P)
		   (EXTENSION 32.) INITIAL-DIMENSIONS INITIAL-ORIGINS)
  "Create an infinite plane of RANK dimensions, all elements containing DEFAULT-VALUE.
(You can only alter finitely many of the elements, of course).
If you do not specify DEFAULT-VALUE, it defaults according to the type of array.
TYPE is the array type.  EXTENSION is the minimum amount to extend
the allocated storage by, in any dimension, when it needs to be extended.
Use PLANE-AREF and PLANE-ASET to access the plane.

You can use the arguments INITIAL-ORIGINS and INITIAL-DIMENSIONS to specify
which part of the plane storage should initially be allocated for.
Each element of INITIAL-ORIGINS is the first index, in one dimension,
for which space is allocated.  The corresponding element of INITIAL-DIMENSIONS
specifies how much space is allocated in that dimension.
The origins default to a list of RANK zeros, and the dimensions to
a list of RANK ones."
  (CHECK-ARG RANK INTEGERP "an integer")
  (MAKE-PLANE-INTERNAL TYPE
		       ;; SIZE is a list of 1's, as many as there are dimensions.
		       (OR INITIAL-DIMENSIONS (MAKE-LIST RANK ':INITIAL-VALUE 1))
		       ;; ORIGIN gets a similar list of zeroes.
		       (OR INITIAL-ORIGINS (MAKE-LIST RANK ':INITIAL-VALUE 0))
		       DEFAULT-VALUE
		       DEFAULT-P
		       EXTENSION))

;Create a new plane of specified type (an array type) and default value,
;with a specified region in actual existence.
(DEFUN MAKE-PLANE-INTERNAL (TYPE SIZE ORIGIN DEFAULT DEFAULT-P EXTENSION)
  (LET ((PLANE (IF DEFAULT-P
		   (MAKE-ARRAY SIZE :TYPE TYPE :LEADER-LENGTH 3 :INITIAL-VALUE DEFAULT)
		   (MAKE-ARRAY SIZE :TYPE TYPE :LEADER-LENGTH 3))))
    (SETQ DEFAULT (AR-1-FORCE PLANE 0))
    (SETF (PLANE-DEFAULT PLANE) DEFAULT)
    (SETF (PLANE-ORIGIN PLANE) ORIGIN)
    (SETF (PLANE-EXTENSION PLANE) EXTENSION)
    PLANE))

(DEFUN PLANE-COPY (OLD NEW)
  "Copy all the allocated contents of the plane OLD into the plane NEW.
Assumes that storage is already allocated in NEW
for the range of indices that correspond to OLD."
  ;; OLD-ORIGIN and NEW-ORIGIN are the origins (lowest corners) of the planes.
  ;; OLD-DIMS is the list of actual dimensions of the old plane. 
  (LET ((OLD-ORIGIN (PLANE-ORIGIN OLD))
	(NEW-ORIGIN (PLANE-ORIGIN NEW))
	(OLD-DIMS (ARRAY-DIMENSIONS OLD)))
    (WHEN (ZEROP (APPLY '+ OLD-DIMS))
      (RETURN-FROM PLANE-COPY NEW))
    ;; OLD-INDICES has the real indices in the old plane of a point.
    ;; NEW-INDICES has the corresponding indices in the new plane.
    ;; We update both lists simultaneously by RPLACA to avoid consing.
    (LET ((OLD-INDICES (MAPCAR #'- OLD-ORIGIN OLD-ORIGIN))
	  (NEW-INDICES (MAPCAR #'- OLD-ORIGIN NEW-ORIGIN)))
      (DO () (NIL)
	(SETF (APPLY 'AREF  NEW NEW-INDICES) (APPLY 'AREF OLD OLD-INDICES))
	(OR (DO ((OI OLD-INDICES (CDR OI))
		 (NI NEW-INDICES (CDR NI))
		 (DIMS OLD-DIMS (CDR DIMS))
		 (NEW-ORIGIN NEW-ORIGIN (CDR NEW-ORIGIN))
		 (OLD-ORIGIN OLD-ORIGIN (CDR OLD-ORIGIN)))
		((NULL OI))
	      (RPLACA OI (1+ (CAR OI)))
	      (OR (< (CAR OI) (CAR DIMS))
		  (RPLACA OI 0))
	      (RPLACA NI (+ (- (CAR OI) (CAR NEW-ORIGIN)) (CAR OLD-ORIGIN)))
	      (OR (ZEROP (CAR OI))
		  (RETURN T)))
	    (RETURN NEW))))))