;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  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
;;;

(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))))

(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)))))

;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Max/min
;;;

(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)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  BIND
;;;
(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)))))

(defmacro bind (bindings &body body)
  (when (and bindings (symbolp bindings))
    (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 (eql (elt (symbol-name var) 0) #\$)
                              `((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)))))))

(defmacro pbind (bindings &body body)
  (bind (bindings (loop for (var val) on bindings by #'cddr collect (list var val)))
    `(let ,bindings (declare (special ,@(find-specials bindings))) ,@body)))

;;; Binding Block
(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)