;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Ron's utilities
;;;
;;;  Copyright (c) 2008 by Ron Garret.  This code is may be
;;;  freely distributed, modified and used for any purpose provided
;;;  this copyright notice is retained.
;;;

;;;;;;;;;;;;;;;;;
;;;
;;; Stuff with system dependencies
;;;

#+CLISP (use-package :clos)
#+SBCL (use-package :sb-mop)

#+CCL
(defun dir (p)
  (values (directory p) (directory p :directories t :files nil)))

;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  General utilities
;;;

(defun concatenate-symbol (&rest symbols)
  (let ( (*print-case* (readtable-case *readtable*)) )
    (intern (format nil "~{~A~}" symbols))))

(defmacro iterate (name args &rest body)
  `(labels ((,name ,(mapcar #'car args) ,@body))
     (,name ,@(mapcar #'cadr args))))

(defmacro receive (vars form &body body)
  (if (atom vars)
    `(let ( (,vars (multiple-value-list ,form)) )
       ,@body)
    `(multiple-value-bind ,vars ,form ,@body)))

; Does not handle SETF methods properly
(defmacro define-synonym (s1 s2)
  `(progn
     (defun ,s1 (&rest args) (declare (ignore args)))
     (setf (symbol-function ',s1) (function ,s2))))

(define-synonym sym= string=)
(define-synonym sym-equal string-equal)

(defun convert-args (args)
  (cond ( (null args) nil )
        ( (atom args) (list '&rest args) )
        (t (cons (car args) (convert-args (cdr args))))))

(defmacro fn (args &body body)
  `(lambda ,(convert-args args) ,@body))

#+CLISP(shadow 'with-gensyms)

(defmacro with-gensyms (syms &body body)
  `(let (,@(mapcar (fn (s) (list s `(gensym ,(symbol-name s)))) syms)) ,@body))

(defmacro with-gensym (sym &body body)
  `(with-gensyms (,sym) ,@body))

(defun hex (n)
  (format t "#x~X" n) (values))

(defun sqr (x) (* x x))

(defun rsq (&rest numbers) ; Root of the sum of the squares
  (let ( (result 0) )
    (dolist (n numbers) (incf result (* n n)))
    (sqrt result)))

(defmacro deletef (thing place &rest args)
  `(setf ,place (delete ,thing ,place ,@args)))

(defmacro spawn (&rest body)
  `(process-run-function (symbol-name (gensym "SPAWNED-TASK"))
                         #+LISPWORKS nil
                         (fn () ,@body)))

(defun every-other (list &optional (n 2))
  (and list (cons (car list) (every-other (nthcdr n list) n))))

(defmacro n-of (form n)
  `(loop for #.(gensym "I") from 1 to ,n collect ,form))

(define-synonym fst car)
(define-synonym rst cdr)
(define-synonym ffst caar)
(define-synonym frst cadr)
(define-synonym rfst cdar)
(define-synonym rrst cddr)
(define-synonym nthrst nthcdr)


(defsetf fst (l) (v) `(progn (rplaca ,l ,v) ,v))
(defsetf rst (l) (v) `(progn (rplacd ,l ,v) ,v))

;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  CLOS utilities
;;;

;;; DEFINE-CLASS is a wrapper around DEFCLASS whose syntax is a little easier to
;;; remember, at least for me.  It is inspired by the syntax of Oaklisp.  The syntax is:
;;;
;;;   (DEFINE-CLASS (class-name superclass*) . slot-specs)
;;;
;;; If there are no superclasses, then the parens can be removed from around CLASS-NAME.
;;;
;;; Each SLOT-SPEC is:
;;;
;;;   (slot-name [type] [initial-value])
;;;
;;; If neither an initial value nor a type are given then the parens can be eliminated.
;;;
;;; So in the simplest case, (define-class foo x y z) defines a class named FOO with slots
;;; X, Y and Z.
;;;
;;; DEFINE-CLASS automatically defines slot accessors for all slots.  The slot accessor
;;; for slot S in class C is called C-S.  It also defines a constructor named MAKE-C.
;;;
(defmacro define-class (name &rest slots)
  (let ( (id (if (atom name) name (car name))) )
    `(progn
       (defclass ,id
         ,(if (atom name) '() (cdr name))
         ,(mapcar #'(lambda (slot)
                      (if (symbolp slot) (setf slot (list slot)))
                      (let ( (name (first slot))
                             (initform (second slot))
                             (type (third slot)) )
                        `(,name :initarg ,(intern (symbol-name name) 'keyword)
                                :accessor ,(concatenate-symbol id '- name)
                                :initform ,initform
                                ,@(if type `(:type ,type)))))
                  slots))
       ,@(mapcar #'(lambda (slot)
                     (when (and (listp slot) (third slot))
                       (let ( (type (third slot)) )
                         (unless (typep (second slot) type)
                           (error "Initial value for ~A must be of type ~A"
                                  (first slot) type))
                         `(defmethod (setf ,(concatenate-symbol name '- (first slot)))
                                     :before
                                     (new-value (c ,name))
                            (unless (typep new-value ',type)
                              (error "Value ~S must be of type ~S" new-value ',type))))))
                 slots)
       (defun ,(concatenate-symbol 'make- id) (&rest args)
         (apply #'make-instance ',id args))
       (defun ,(concatenate-symbol id '?) (arg)
         (typep arg ',id))
       (setf (get ',id :class-slot-specs) ',slots)
       (find-class ',id))))

(defun extract-declarations (body)
  (iterate loop1 ( (declarations nil) (body body) )
    (if (and (consp body)
             (or (stringp (car body))
                 (and (consp (car body))
                      (eq (caar body) 'declare))))
      (loop1 (cons (car body) declarations) (cdr body))
      (values declarations body))))

;;; DEFINE-METHOD is a combination of DEFMETHOD and WITH-SLOTS designed to make
;;; method definition a little more convenient for the common case where a method
;;; is qualified over a single class and you want easy access to all the slots in
;;; that class.  The syntax is:
;;;
;;;  (define-method ((method-name . qualifiers) (arg1 class . slot-names) . args) . body)
;;;
;;; If there are no qualifiers the parens around method-name can be omitted.  So, for
;;; example:
;;;
;;;   (define-method (m1 (x c s1 s2 s3) y z) ...)
;;; is the same as:
;;;
;;;   (defmethod m1 ((x c) y z) (with-slots (s1 s2 s3) x ...))
;;;
;;; The (arg class . slots) syntax can actually be used for arguments other than the
;;; first one, so DEFINE-METHOD can be used to define multimethods.  However, there is
;;; no way to disambiguate slots with the same name in different arguments.
;;;
(defmacro define-method (&whole code
                         (operation (selfarg type &rest instance-vars) &rest args)
                         &body body)
  (setf (getf (get type :class-method-specs) operation) code)
  (multiple-value-bind (declarations body) (extract-declarations body)
    `(defmethod ,@(if (atom operation) (list operation) operation)
                ((,selfarg ,type) ,@(convert-args args))
       ,@declarations
       ,(if instance-vars
          `(with-slots ,instance-vars ,selfarg ,@body)
          `(with-slots ,(mapcar (fn (slot)
                                  (list (concatenate-symbol
                                         selfarg "." (slot-definition-name slot))
                                        (slot-definition-name slot)))
                                (class-slots (find-class type)))
             ,selfarg
             ,@body)))))

(defmacro define-print-method ((class &rest ivars) &rest args)
  `(define-method (print-object (self ,class ,@ivars) stream)
     (format stream ,@args)))

(defmacro define-standard-print-method (class)
  `(define-print-method (,class) "#<~:(~A~) #x~X>" ',class (sxhash self)))

(define-synonym make make-instance)

#+CCL
(define-method (make-load-form (c class) &optional env)
  (declare (ignore env))
  (let ( (name (class-name c)) )
    `(progn
       (define-class (,name ,@(mapcar 'class-name (class-direct-superclasses c)))
         ,@(get name :class-slot-specs))
       ,@(every-other (cdr (get name :class-method-specs)))
       ',name)))


;;;;;;;;;;;;;;;;;;;;
;;;
;;; Collectors
;;;
(defmacro with-collector (var &body body)
  (with-gensym resultvar
    `(let ( (,resultvar '()) )
       (flet ( (,var (&rest items) (for item in items do (push item ,resultvar))) )
         ,@body)
       (nreverse ,resultvar))))

;;; This is a lot faster than with-output-to-string
(defmacro with-char-collector (var &rest body)
  (with-gensym svar
    `(let ( (,svar (make-array 0 :element-type 'character
                               :fill-pointer t :adjustable t)) )
       (labels ( (,var (thing)
		   (cond ( (characterp thing) (vector-push-extend thing ,svar) )
			 ( (stringp thing)
                           (loop for c across thing do
                             (vector-push-extend c ,svar)) )
			 ( (consp thing) (dolist (elt thing) (,var elt)) )
			 (t (,var (princ-to-string thing))))) )
	 ,@body
         ,svar))))

;;;;;;;;;;;;;;;;;;;
;;;
;;; Iterators
;;;
(defconstant +iterend+ (make-symbol "ITERATION_END"))

(defmacro for (var in thing &body body)
  (unless (sym= in :in) (warn "expected keyword 'in', got ~A instead" in))
  (with-gensym itervar
    `(let ( (,itervar (iterator ,thing)) )
       ,(if (consp var)
	  `(loop for ,var = (multiple-value-list (funcall ,itervar))
	         until (eq ,(fst var) +iterend+)
	     ,@body)
	  `(loop for ,var = (funcall ,itervar)
	         until (eq ,var +iterend+)
	     ,@body)))))

(define-method (iterator (l list)) (fn () (if l (pop l) +iterend+)))

(define-method (iterator (v vector))
  (let ( (len (length v)) (cnt 0) )
    (fn () (if (< cnt len)
             (multiple-value-prog1 (values (elt v cnt) cnt) (incf cnt))
             +iterend+))))

(define-method (iterator (f function)) f)

(define-method (iterator (s stream)) (fn () (read-char s nil +iterend+)))

(define-class lines stream)
(define-method (iterator (l lines stream)) (fn () (read-line stream nil +iterend+)))
(define-method (lines (s stream)) (make-lines :stream s))
(define-method (lines (s string)) (make-lines :stream (make-string-input-stream s)))

(define-method (iterator (h hash-table))
  (let ( (keys (loop for x being the hash-keys of h collect x)) )
    (fn ()
      (if keys (let ( (k (pop keys)) ) (values k (gethash k h))) +iterend+))))

(defun zip (&rest things)
  (let ( (iterators (mapcar 'iterator things)) )
    (fn () (apply 'values (mapcar 'funcall iterators)))))

(defun counter (&optional (start 0)) (fn () (incf start)))

(defun n-at-a-time (n thing)
  (let ( (iter (iterator thing)) )
    (fn ()  (apply 'values (n-of (funcall iter) n)))))

#|
Examples:

(for (elt cnt) in (zip '(a b c) (counter)) collect (list elt cnt))
(for c in "abc" do (print c))
(for l in (lines "abc
def
ghi") do (print l))
|#

;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Split and join
;;;
(define-method (split (l list) elt &key (test 'eql) (key 'identity) (max -1))
  (iterate loop1 ( (l l) (result '()) (result1 '()) (max max) )
    (cond ( (null l) (reverse (cons (reverse result1) result)) )
	  ( (zerop max) (reverse (cons l result)) )
	  ( (funcall test elt (funcall key (fst l)))
	    (loop1 (rst l) (cons (reverse result1) result) '() (1- max)) )
	  (t (loop1 (rst l) result (cons (fst l) result1) max)))))

(define-method (split (v vector) elt &key (test 'eql) (key 'identity) (max -1))
  (with-collector collect
    (do* ( (i 0 (1+ j))
           (j (position elt v :test test :key key)
	      (position elt v :test test :key key :start i))
	   (max max (1- max)) )
	 ( (or (null j) (zerop max)) (collect (subseq v i)) )
      (collect (subseq v i j)))))

(define-method (split (s1 string) (s2 string) &key test key (max -1))
  (declare (ignore test key))
  (with-collector collect
    (do* ( (i 0 (+ j (length s2)))
	   (j (search s2 s1) (search s2 s1 :start2 i))
	   (max max (1- max)) )
	 ( (or (null j) (zerop max)) (collect (subseq s1 i)) )
      (collect (subseq s1 i j)))))

(defun join (strings &optional (delim ""))
  (with-char-collector collect
    (if strings (collect (first strings)))
    (if (rst strings)
      (reduce (fn (x y)
		  (declare (ignore x))
		  (collect delim)
		  (collect y))
	      strings))))

(defun strsubst (s1 s2 s3) (join (split s1 s2) s3))

;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Mappers
;;;
(define-synonym walk mapc)

;;;  MAP-EXTEND works like mapcar except that its termination condition is when all
;;;  of its argument lists are nil.
(defun map-extend (fn &rest lists)
  (if (every #'null lists)
    nil
    (cons (apply fn (mapcar #'car lists))
          (apply #'map-extend fn (mapcar #'cdr lists)))))

;;;  MMAP is a generalized version of MAP for mapping functions which return
;;;  multiple values.
(defun mmap (fn &rest lists)
  (if (some #'null lists)
    nil
    (let* ( (cars (multiple-value-list (apply fn (mapcar #'car lists))))
            (cdrs (multiple-value-list (apply #'mmap fn (mapcar #'cdr lists)))) )
      (apply #'values (map-extend #'cons cars cdrs)))))

;;;  The following mapping functions map only their first arguments.  All their
;;;  subsequent arguements are passed unaltered to the mapping function.
;;;  e.g. (map1 + '(1 2 3) 4) => (5 6 7)
(defun map1 (fn mapped-arg &rest unmapped-args)
  (mapcar #'(lambda (arg) (apply fn arg unmapped-args)) mapped-arg))

(defun walk1 (fn mapped-arg &rest unmapped-args)
  (mapc #'(lambda (arg) (apply fn arg unmapped-args)) mapped-arg))

(defun mmap1 (fn args1 &rest unmapped-args)
  (mmap #'(lambda (arg) (apply fn arg unmapped-args)) args1))

;;; Leaf mappers
(defun walkleaves (fn tree)
  (iterate loop1 ( (tree tree) )
    (if (atom tree)
      (funcall fn tree)
      (progn (loop1 (car tree)) (and (cdr tree) (loop1 (cdr tree)))))))

(defmacro doleaves ((var tree) &body body)
  `(walkleaves (fn (,var) ,@body) ,tree))

(defun mapleaves (fn tree)
  (iterate loop1 ( (tree tree) )
    (if (atom tree)
      (funcall fn tree)
      (cons (loop1 (car tree)) (and (cdr tree) (loop1 (cdr tree)))))))

(defun mapleaves! (fn tree)
  (iterate loop1 ( (tree tree) )
    (if (atom tree)
      (funcall fn tree)
      (progn
        (setf (car tree) (loop1 (car tree)))
        (setf (cdr tree) (and (cdr tree) (loop1 (cdr tree))))
        tree))))

(defun map-array (fn array &rest arrays)
  (let ( (result (make-array (array-dimensions array))) )
    (apply 'map-into (linear-overlay result) fn (linear-overlay array)
           (mapcar 'linear-overlay arrays))
    result))

;;; Misc. mappers
(defun mappend (fn &rest lists) (apply #'append (apply #'mapcar fn lists)))
(define-synonym mappend! mapcan)
(defun mappend1 (fn &rest lists) (apply #'append (apply #'map1 fn lists)))

(define-synonym mapcdr maplist)
(define-synonym walkcdr mapl)

(defun map! (fn l)
  (walkcdr #'(lambda (l) (setf (car l) (funcall fn (car l)))) l))

(defmacro maplet (bindings &body body)
  `(mapcar (fn ,(mapcar #'car bindings) ,@body) ,@(mapcar #'second bindings)))

(defmacro walklet (bindings &body body)
  `(walk (fn ,(mapcar #'car bindings) ,@body) ,@(mapcar #'second bindings)))

;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  File iterators
;;;
(defmacro dofile ((charvar filename) &body body)
  (with-gensym stream
    `(with-open-file (,stream ,filename)
       (for ,charvar in ,stream do (progn ,@body)))))

(defmacro do-file-lines ((linevar filename) &body body)
  (with-gensym stream
    `(with-open-file (,stream ,filename)
       (for ,linevar in (lines ,stream) do (progn ,@body)))))

;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Extended max/min -- these return not only the extremum element, but also its
;;; location, and the value of the key function.
;;;
(define-method (extremum (lst list) comparison &key (key 'identity))
  (let* ( (exelt (fst lst))
          (exval (funcall key exelt))
          (exloc lst) )
    (loop for loc on (rst lst) do
      (let* ( (elt (fst loc))
	      (val (funcall key elt)) )
	(if (funcall comparison val exval)
	  (setf exelt elt exval val exloc loc))))
    (values exelt exval exloc)))

(define-method (extremum (v vector) comparison &key (key 'identity))
  (let* ( (exelt (elt v 0))
          (exval (funcall key exelt))
          (exloc 0) )
    (for (elt cnt) in (zip v (counter)) do
      (let ( (val (funcall key elt)) )
	(if (funcall comparison val exval)
	  (setf exelt elt exval val exloc cnt))))
    (values exelt exval exloc)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Binding forms
;;;
(defun dynamic-variable? (v)
  (and (symbolp v)
       (let ( (c (elt (symbol-name v) 0)) )
         (or (eql c #\$) (eql c #\*)))))

(defun find-specials (vars)
  (with-collector c
    (doleaves (v vars)
      (if (dynamic-variable? v) (c v)))))

;;; BIND is a universal binding form that subsumes LET, MULTIPLE-VALUE-BIND, and
;;; DESTRUCTURING-BIND.  It has two syntaxes:
;;;
;;;   (bind (varspec initform) . body)
;;;   (bind [varspec {=} initform]* :in . body)
;;;
;;; If VARSPEC is a list then BIND acts like DESTRUCTURING-BIND.  If VARSPEC is a list
;;; whose first element is the keyword :VALUES then BIND acts like MULTIPLE-VALUE-BIND.
;;;
;;; The second syntax uses keywords (= and :in) instead of parens to make code a
;;; a little more friendly-looking for parenthophobes,  particularly when BIND is used
;;; for destructuring, e.g.:
;;;
;;;   (bind (x (y) z) = (foo) :in ...)
;;;
;;; instead of
;;;
;;;   (bind (((x (y) z)) (foo)) ...)
;;;
;;; Note that when using this alternative syntax, the = markers are optional, but the
;;; :in keyword is required.  That's how BIND disambiguates the case where the first
;;; form after the BIND is a list.  Also, the second syntax can be used to replace
;;; more than one binding form at once.
;;;
(defmacro bind (bindings &body body)
  (when (and body (member :in body))
    (setf body (split body :in))
    (if (/= (length body) 2) (error "Keyword :IN must appear exactly once"))
    (setf bindings (cons bindings (first body)))
    (setf body (second body)))
  (if (null bindings)
    `(progn ,@body)
    (let* ( (var (pop bindings))
            (val (pop bindings)) )
      (if (eq val '=) (setf val (pop bindings)))
      (cond
       ( (symbolp var) `(let ( (,var ,val) )
                          ,@(if (dynamic-variable? var) `((declare (special, var))) '())
                          (bind ,bindings ,@body)) )
       ( (atom var) (error "Illegal variable: ~S" var) )
       ( (eq (car var) ':values) `(multiple-value-bind ,(cdr var) ,val
                                    (declare (special ,@(find-specials var)))
                                    (bind ,bindings ,@body)) )
       (t `(destructuring-bind ,var ,val
             (declare (special ,@(find-specials var)))
             (bind ,bindings ,@body)))))))

;;; PBDIND is like BIND except that it bings in parallel rather than sequentially.
;;; This implementation is not complete.
;;;
(defmacro pbind (bindings &body body)
  (warn "PBDIND is not yet ready for prime time.  Use at your own risk.")
  (bind (bindings (loop for (var val) on bindings by #'cddr collect (list var val)))
    `(let ,bindings (declare (special ,@(find-specials bindings))) ,@body)))

;;; Binding Block -- This is a binding construct that supports a programming style
;;; that allows deeply nested bindings without having the code crawl off the right
;;; side of the screen.  The syntax is:
;;;
;;; (bb [binding-spec|form]* form)
;;;
;;; A binding spec is one of the following:
;;;
;;;   varname initform     ; Regular binding
;;;   :db (vars) initform  ; Destructing-bind
;;;   :mv (vars) initform  ; Multiple-value-bind
;;;   :with spec initform  ; WITH-binding (experimental -- see below)
;;;
;;; BB returns the value of the final FORM.
;;;
;;; So, for example, this code:
;;; (let ((x 1))
;;;   (destructuring-bind ((y z) (foo))
;;;     (multiple-value-bind ((a b c) (bar))
;;;       (do-something)
;;;       (with-open-file (f "foo")
;;;          (do-something-else)))))
;;;
;;; Can be rewritten as:
;;;
;;; (bb
;;;  x 1
;;;  :db (y z) (foo)
;;;  :mv (a b c) (bar)
;;;  (do-something)
;;;  :with open-file f "foo"
;;;  (do-something-else))
;;;
;;; Note that the :with clause currently assumes that it is a stand-in for a form
;;; that looks like (with-FOO (var initform) . body).  This assumption fails for e.g.
;;; with-slots and with-gensyms.  I have not yet decided how to handle this.
;;;
(defmacro bb (&rest body)
  (cond
   ((null (rst body)) (fst body))
   ((consp (1st body))
    `(progn ,(1st body) (bb ,@(rst body))))
   ((not (symbolp (1st body)))
    (error "~S is not a valid variable name" (1st body)))
   ((eq (1st body) ':mv)
    (if (symbolp (2nd body))
      `(let ((,(2nd body) (multiple-value-list ,(3rd body))))
         (bb ,@(rrrst body)))
      `(multiple-value-bind ,(2nd body) ,(3rd body)
         (bb ,@(rrrst body)))))
   ((eq (1st body) :db)
    `(destructuring-bind ,(2nd body) ,(3rd body)
       (declare (special ,@(find-specials (2nd body))))
       (bb ,@(rrrst body))))
   ; BUG: 1-arg assumption fails for with-slots
   ((eq (1st body) :with)
    `(,(intern (format nil "WITH-~A" (2nd body)) (symbol-package (2nd body)))
      ,(3rd body) (bb ,@(rrrst body))))
   ((keywordp (1st body))
    (error "~S is not a valid binding keyword" (1st body)))
   (t `(let ((,(1st body) ,(2nd body)))
         (declare (special ,@(find-specials (1st body))))
         (bb ,@(rrst body))))))

;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  AIF/ACOND
;;;

(defmacro aif (condition &optional (then nil then-p) &rest more)
  (if then-p
    `(bb it ,condition (if it ,then ,(if more `(aif ,@more))))
    condition))

(defmacro acond (&rest clauses)
  (warn "ACOND is deprecated.  Use AIF instead.")
  (if (null clauses)
    nil
    `(aif ,(caar clauses)
       (progn ,@(cdar clauses))
       (acond ,@(cdr clauses)))))

;;;;;;;;;;;;;;;;;;;
;;;
;;;  TRY
;;;
(defmacro try (&rest stuff)
  (bind ((forms-and-handlers finally . extra) (split stuff :finally))
    (if extra (error "TRY form can only have one :finally clause"))
    (if (rst (split finally :except))
      (error "All :except clauses in a TRY form must precede the :finally clause"))
    (bind ((forms . handlers) (split forms-and-handlers :except))
      `(unwind-protect
           (handler-case (progn ,@forms)
             ,@handlers)
           ,@finally))))

;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FST/RST
(define-synonym fst car)
(define-synonym rst cdr)
(define-synonym rrst cddr)
(define-synonym rrrst cdddr)
(define-synonym 1st first)
(define-synonym 2nd second)
(define-synonym 3rd third)
(define-synonym 4th fourth)
(define-synonym 5th fifth)

;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Array/matrix utilities
;;;

; Maybe put in dictionary.lisp?
(defmacro ref (map key &optional (default nil default-supplied-p))
  (if default-supplied-p `(refd ,map ,key ,default) `(ref1 ,map ,key)))

(defsetf ref setref)

(define-method (ref1 (a array) index) (apply 'aref a index))
(define-method (refd (a array) index default)
  (if (apply 'array-in-bounds-p a index) (apply 'aref a index) default))
(define-method (setref (a array) index value)
  (setf (apply #'aref a index) value))

(define-method (ref1 (v vector) n) (aref v n))
(define-method (setref (v vector) n value) (setf (aref v n) value))

(defun linear-overlay (array)
  (make-array (apply '* (array-dimensions array))
              :element-type (array-element-type array)
              :displaced-to array))

(defun inverse-row-major-index (n dimensions)
  (if (null (rst dimensions))
    (list n)
    (bind (p (apply '* (rst dimensions)))
      (cons (truncate n p)
            (inverse-row-major-index (mod n p) (rst dimensions))))))

(define-method (iterator (a array))
   (bind (iter (iterator (linear-overlay a))
          d (array-dimensions a))
      (fn () (receive (elt index) (funcall iter)
                (if (eq elt +iterend+)
                  +iterend+
                  (values elt (inverse-row-major-index index d)))))))

(defun sub-array (a &rest specs)
  (bind (d (array-dimensions a)
         specs (map-extend (fn (spec d) (or spec (list 0 d))) specs d)
         d1 (for spec in specs if (consp spec) collect (- (apply '- spec)))
         a1 (make-array d1 :element-type (array-element-type a)))
    (flet ((sub-index (i)
             (if (numberp i) (setf i (list i)))
             (iterate loop1 ((i i) (specs specs))
               (cond ((null specs) nil)
                     ((atom (fst specs))
                      (cons (fst specs) (loop1 i (rst specs))))
                     (t (cons (+ (ffst specs) (fst i))
                              (loop1 (rst i) (rst specs))))))))
      (for (v i) in a1 do (setf (ref a1 i) (ref a (sub-index i))))
      a1)))



(provide 'utilities)