array.l

;;; -*- Mode: Lisp; Package: LISP -*-
;;;
;;; This file is part of xyzzy.
;;;

(provide "array")

(in-package "lisp")

(export '(make-vector make-array vector array-dimensions array-in-bounds-p
	  upgraded-array-element-type adjust-array))

(defun upgraded-array-element-type (type)
  (cond ((or (eq type 't)
	     (null type))
	 't)
	((member type '(character base-character standard-char
			extended-character) :test #'eq)
	 'character)
	(t
	 (setq type (car (si:canonicalize-type type)))
	 (cond ((or (eq type 't)
		    (null type))
		't)
	       ((member type '(character base-character standard-char
			       extended-character) :test #'eq)
		'character)
	       (t 't)))))

(defun check-array-initialize-option (ies-p ics-p displaced-to)
  (let ((x 0))
    (and ies-p (incf x))
    (and ics-p (incf x))
    (and displaced-to (incf x))
    (when (> x 1)
      (error ":initial-element, :initial-contents, :displaced-toは同時に指定できません"))))

(defun make-vector (length &key
			   (element-type t)
			   (initial-element nil ies-p)
			   (initial-contents nil ics-p)
			   fill-pointer
			   adjustable
			   displaced-to
			   (displaced-index-offset 0))
  (setq element-type (upgraded-array-element-type element-type))
  (check-array-initialize-option ies-p ics-p displaced-to)
  (let ((vector (si:*make-vector length element-type initial-element adjustable
				 fill-pointer displaced-to displaced-index-offset)))
    (when ics-p
      (si:*copy-into-seq vector initial-contents))
    vector))

(defun make-array (dimensions &rest rest
			      &key
			      (element-type t)
			      (initial-element nil ies-p)
			      (initial-contents nil ics-p)
			      fill-pointer
			      adjustable
			      displaced-to
			      (displaced-index-offset 0))
  (cond ((integerp dimensions)
	 (apply #'make-vector dimensions rest))
	((= (length dimensions) 1)
	 (apply #'make-vector (car dimensions) rest))
	(t
	 (setq element-type (upgraded-array-element-type element-type))
	 (check-array-initialize-option ies-p ics-p displaced-to)
	 (when fill-pointer
	   (error ":fill-pointerはベクタ以外には指定できません"))
	 (let ((array (si:*make-array dimensions element-type
				      initial-element adjustable
				      displaced-to displaced-index-offset)))
	   (when ics-p
	     (let ((dims (make-list (array-rank array)
				    :initial-element 0))
		   (stack (list initial-contents))
		   (rank (1- (array-rank array))))
	       (dolist (x dims)
		 (push (elt (car stack) 0) stack))
	       (dotimes (i (array-total-size array))
		 (setf (row-major-aref array i) (car stack))
		 (do ((x dims (cdr x))
		      (j rank (1- j)))
		     ((null x))
		   (pop stack)
		   (incf (car x))
		   (when (< (car x) (array-dimension array j))
		     (do ((r (- rank j) (1- r)))
			 ((< r 0))
		       (push (elt (car stack) (nth r dims)) stack))
		     (return))
		   (setf (car x) 0)))))
	   array))))

(defun vector (&rest list)
  (make-vector (length list) :element-type t :initial-contents list))

(defun array-dimensions (array)
  (do ((i (1- (array-rank array)) (1- i))
       (dims '()))
      ((minusp i) dims)
    (push (array-dimension array i) dims)))

(defun array-in-bounds-p (array &rest subscripts)
  (let ((r (array-rank array)))
    (when (/= r (length subscripts))
      (error "subscriptsの個数が配列のランクと異なります: ~S" subscripts))
    (do ((i 0 (1+ i))
	 (s subscripts (cdr s)))
	((= i r) t)
      (unless (<= 0 (car s) (1- (array-dimension array i)))
	(return nil)))))

(defun adjust-array (old-array
		     dimensions
		     &rest rest
		     &key
		     (element-type nil ets-p)
		     initial-element
		     (initial-contents nil ics-p)
		     (fill-pointer nil fps-p)
		     displaced-to
		     displaced-index-offset)
  (when (/= (length dimensions) (array-rank old-array))
    (error "配列のランクが異なります"))
  (unless ets-p
    (push (array-element-type old-array) rest)
    (push :element-type rest))
  (when (adjustable-array-p old-array)
    (push t rest)
    (push :adjustable rest))
  (cond (fps-p
	 (unless (array-has-fill-pointer-p old-array)
	   (error "フィルポインタを持たない配列にフィルポインタが指定されました")))
	(t
	 (when (array-has-fill-pointer-p old-array)
	   (push (fill-pointer old-array) rest)
	   (push :fill-pointer rest))))
  (when (eq old-array displaced-to)
    (error "自分自身を共有することはできません"))
  (let ((new-array (apply #'make-array dimensions rest)))
    (or ics-p displaced-to
	(copy-array-partially old-array new-array))
    (cond ((adjustable-array-p old-array)
	   (si:*replace-array old-array new-array)
	   old-array)
	  (t
	   new-array))))

(defun copy-array-partially (src dst)
  (let* ((dims (mapcar #'min (array-dimensions src) (array-dimensions dst)))
	 (r (array-rank src))
	 (s (make-list r :initial-element 0)))
    (setq r (1- r))
    (dotimes (x (apply #'* dims))
      (setf (apply #'aref dst s) (apply #'aref src s))
      (do ((i r (1- i)))
	  ((minusp i))
	(incf (nth i s))
	(when (< (nth i s) (nth i dims))
	  (return))
	(setf (nth i s) 0)))))