;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Ron's general utilities
;;;
;;;  Written by Ron Garret, released into the public domain.
;;;
;;;  Revision history:
;;;
;;;  6/9/09 - rg - Added MCOND, changed API for define-class to support keyword args
;;;                for shared slots and metaclass
;;;  6/10/09 - rg - Integrated new define-class, general cleanup
;;;

(in-package :cl-user)

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

#+CLISP (use-package :clos)
#+SBCL (use-package :sb-mop)
#+CCL (shadowing-import '(ccl::while ccl::until))

;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  General utilities
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro eval-always (&body body)
    `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)))

(eval-always

(require :globals)

(defun flatten (l)
  (cond ((null l) l)
        ((atom l) (list l))
        (t (append (flatten (car l)) (flatten (cdr l))))))

(defun strcat (&rest strings)
  (if (every 'stringp strings)
    (apply 'concatenate 'string strings)
    (format nil "~{~A~}" strings)))

(defun concatenate-symbol (&rest symbols)
  (let ( (*print-case* (readtable-case *readtable*)) )
    (intern (apply 'strcat symbols))))

(defmacro iterate (name args &rest body)
  `(labels ((,name ,(mapcar 'first args) ,@body))
     (,name ,@(mapcar 'second args))))

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

(defun ignorevar? (v)
  (and (symbolp v) (string= v "_")))

(defun convert-args (args &optional destructure)
  (let (ignore specials)
    (flet ((convert-arg (arg)
             (cond ((ignorevar? arg)
                    (push (gensym "DUMMY") ignore)
                    (car ignore))
                   ((dynamic-variable? arg)
                    (push arg specials)
                    arg)
                   (t arg))))
      (values
       (iterate loop ((args args))
         (cond ((null args) nil)
               ((atom args) (list '&rest (convert-arg args)))
               ((and destructure (consp (car args)))
                (cons (loop (car args)) (loop (cdr args))))
               (t (cons (convert-arg (car args)) (loop (cdr args))))))
       `(declare (ignore ,@ignore) (special ,@specials))))))

(defmacro fn (args &body body)
  (multiple-value-bind (args decls) (convert-args args)
    `(lambda ,args ,decls ,@body)))

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

(defmacro mvbind (vars form &body body)
  `(receive ,vars ,form ,@body))

(defmacro dsbind (args form &body body)
  (mvbind (args decls) (convert-args args t)
    `(destructuring-bind ,args ,form ,decls ,@body)))

(defmacro λ (args &body body)
  "Scheme-style pseudo Lisp-1 lambda"
  (multiple-value-bind (args1 decls) (convert-args args)
    (let ((args2 (remove-if (lambda (x) (eql #\& (elt (symbol-name x) 0))) (flatten args))))
      `(lambda ,args1
         ,decls
         (flet ,(mapcar (lambda (arg) `(,arg (&rest args) (apply ,arg args))) args2)
           ,@body)))))

(defmacro define (name &rest body)
  (if (and (atom name) (cdr body))
    (error "Syntax error: multiple body forms are only allowed when defining a function"))
  (if (atom name)
    `(progn
       (defv ,name ,(car body))
       (defun ,name (&rest args) (apply ,name args)))
    `(macrolet ((define1 ((name . args) . body)
                  `(progn
                     (defun ,name ,(convert-args args) ,@body)
                     (define-symbol-macro ,name (function ,name)))))
       (define1 ,name ,@body))))

(defmacro def (name args &body body)
  (if (and (atom name) body)
    `(define (,name ,@args) ,@body)
    `(define ,name ,args)))

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

#+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))

(defun reload (module)
  (deletef module *modules* :test 'string-equal)
  (require module))

;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FST/RST
(define-synonym fst car)
(define-synonym ffst caar)
(define-synonym fffst caaar)
(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)
(define-synonym 6th sixth)
(define-synonym 7th seventh)
(define-synonym 8th eighth)
(define-synonym 9th ninth)
(define-synonym 10th tenth)

(defsetf fst (l) (v) `(progn (rplaca ,l ,v) ,v))
(defsetf 1st (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.
;;;
;;; DEFINE-CLASS has a facility for specifying METACLASS and other class options, but it's
;;; all screwed up at the moment.
;;;

(defun kw-split (l)
  (labels ((prefix (l suffix)
             (if (eq l suffix) '() (cons (1st l) (prefix (rst l) suffix)))))
    (let ((suffix (member-if 'keywordp (rst l))))
      (if suffix (cons (prefix l suffix) (kw-split suffix)) (list l)))))

(defun make-slotspec (slot classname &optional shared?)
  (let ((slot (if (consp slot) slot (list slot))))
    (destructuring-bind (slotname &optional initform type) slot
      `(,slotname :initarg ,(intern (symbol-name slotname) 'keyword)
                  :accessor ,(concatenate-symbol classname '- slotname)
                  :initform ,initform
                  ,@(if type `(:type ,type))
                  ,@(if shared? '(:allocation :class))))))

(defmacro define-class (name &rest args)
  (let* ((id (if (consp name) (1st name) name))
         (superclasses (if (consp name) (rst name) '()))
         (args (kw-split args))
         (metaclass (2nd (assoc :metaclass args)))
         (instance-slots (mapcar (fn (arg) (make-slotspec arg id)) (1st args)))
         (shared-slots (mapcar (fn (arg) (make-slotspec arg id t))
                               (rst (assoc :shared args))))
         
         (slotspecs (append instance-slots shared-slots))
         (methods (loop for spec in slotspecs
                    if (eq (7th spec) :type) collect
             (let* ((initform (7th spec))
                    (type (9th spec)))
               `(progn
                  ; This doesn't quite do the right thing
                  (unless (typep ,initform ',type)
                    (error "Initial value for ~A must be of type ~A" ',(1st spec) ',type))
                  (defmethod (setf ,(concatenate-symbol name '- (1st spec)))
                             :before
                    (new-value (c ,name))
                    (unless (typep new-value ',type)
                      (error "Value ~S must be of type ~S" new-value ',type))))))))
   `(eval-always
      (defclass ,id ,superclasses ,slotspecs ,@(if metaclass `((:metaclass ,metaclass))))
      ,@methods
      (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) ',slotspecs)
      (find-class ',id))))

#+APPLE-OBJC
(defmacro define-objc-class (name &rest slots)
  (unless (consp name) (setf name (list name 'ns:ns-object)))
  `(define-class ,name ,@slots :metaclass ns:+ns-object))


;;; 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.  To distinguish
;;; slots from different arguments with the same name, the slot name can be specified
;;; as argname.slotname, e.g.:
;;;
;;; (define-method (m1 (c1 class1 c1.x c1.y) (c2 class1 c2.x c2.y) ...) ...)
;;;
(defun extract-declarations (body)
  (iterate loop1 ( (declarations nil) (body body) )
    (if (and (consp body)
             (cdr body)
             (or (stringp (car body))
                 (and (consp (car body))
                      (eq (caar body) 'declare))))
      (loop1 (cons (car body) declarations) (cdr body))
      (values declarations body))))

(defun munge-slot (slot)
  (let* ((s (symbol-name slot))
         (n (position #\. s)))
    (if (null n) slot (list slot (intern (subseq s (1+ n)) (symbol-package slot))))))

(defun munge-method-args (args)
  (iterate loop1 ((args args) (munged-args '()) (slotspecs '()))
    (cond ((null args) (values (reverse munged-args) slotspecs))
          ((atom args) (loop1 nil (list* args '&rest munged-args) slotspecs))
          ((member (car args) lambda-list-keywords)
           (values (append (reverse munged-args) args) slotspecs))
          ((atom (car args)) (loop1 (cdr args) (cons (car args) munged-args) slotspecs))
          ((null (cdr (car args)))
           (error "Bad method lambda-list element: ~S" (car args)))
          ((null (cddr (car args)))
           (loop1 (cdr args) (cons (car args) munged-args)
                  (cons (cons (caar args)
                              (mapcar (fn (slot)
                                        (list (concatenate-symbol
                                               (caar args) "." (slot-definition-name slot))
                                              (slot-definition-name slot)))
                                      (class-slots (find-class (2nd (car args))))))
                        slotspecs)))
          (t (loop1 (cdr args)
                    (cons (list (1st (car args)) (2nd (car args))) munged-args)
                    (cons (cons (caar args) (mapcar 'munge-slot (cddar args)))
                          slotspecs))))))

(defun assemble-slot-bindings (slotspecs body)
  (if (null slotspecs)
    `(progn ,@body)
    `(with-slots ,(cdar slotspecs) ,(caar slotspecs)
       ,(assemble-slot-bindings (cdr slotspecs) body))))

(defmacro define-method ((operation &rest args) &body body)
  (if (atom operation) (setf operation (list operation)))
  (receive (declarations body) (extract-declarations body)
    (receive (arglist slotspecs) (munge-method-args args)
      `(defmethod ,@operation ,arglist
         ,@declarations
         ,(assemble-slot-bindings slotspecs 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 (item) (push item ,resultvar) item) )
         ,@body)
       (nreverse ,resultvar))))

(defmacro with-vcollector (var &body body)
  (with-gensym resultvar
    `(let ( (,resultvar (make-array 0 :fill-pointer t :adjustable t)) )
       (flet ( (,var (item) (vector-push-extend item ,resultvar) item) )
         ,@body)
       ,resultvar)))

;;; Because with-output-to-string is soooooo sloooooowwww

(defvar *str-stream* (make-string-output-stream))

(defun str (thing)
  (princ thing *str-stream*)
  (get-output-stream-string *str-stream*))

(defv renderer 'princ-to-string)

(defmacro render (thing) `(funcall renderer ,thing))

(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)) )
			 (t (,var (render thing))))) )
	 ,@body
         ,svar))))

(defmacro collect (expr for var in seq &optional if condition)
  (unless (string-equal for 'for)
    (error "Unexpected keyword: expected FOR, got ~A" for))
  (unless (or (null if) (and (symbolp if) (string-equal if 'if)))
    (error "Unexpected keyword: expected IF, got ~A" if))
  `(for ,var ,in ,seq ,@(if if `(if ,condition)) collect ,expr))

;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Anaphoric conditionals
;;;

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

(defmacro awhile (condition &body body)
  `(let ((it ,condition))
     (while it ,@body (setf it ,condition))))

;;; MCOND is named for John McCarthy, who always thought COND had too many parens
(defmacro mcond (&rest clauses)
  (if (null clauses)
    nil
    `(aif ,(1st clauses) ,(2nd clauses) (mcond ,@(rrst clauses)))))

;;;;;;;;;;;;;;;;;;;
;;;
;;; Iterators
;;;
(defconstant +iterend+ :\#iteration-end\#)

(defun iterend () +iterend+)
(defun iterend? (x) (eq x +iterend+))

(defmacro for (var in thing &body body)
  (unless (sym= in :in) (warn "expected keyword 'in', got ~A instead" in))
  (if (consp (1st body)) (push 'do body))
  (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 (tails (l list)) (fn () (if l (prog1 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 ()
    (let ((c (read-char s nil +iterend+)))
      (if (eq c +iterend+) (close s))
      c)))

(define-method (iterator (p pathname))
  (let ((s (open p)))
    ; BUG: this will still leak because (open-file-streams) keeps a pointer to
    ; all open streams
    (terminate-when-unreachable s 'close)
    (iterator s)))

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

(define-method (lines (p pathname))
  (let ((l (make-lines :stream (open p))))
    (terminate-when-unreachable l)
    l))
(define-method (ccl:terminate (l lines stream)) (close stream))

(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) end (step 1))
  (fn ()
    (if (and end (<= 0 (* (signum step) (- start end))))
        +iterend+
        (prog1 start (incf start step)))))

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

(defun read-all (stream)
  (with-char-collector collect (for c in stream do (collect c))))

(defun file-contents (path) (with-open-file (f (pathname path)) (read-all f)))

;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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)))
    (dolist (s (rst strings))
      (collect delim)
      (collect s))))

(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 loop ( (tree tree) )
    (if (atom tree)
      (funcall fn tree)
      (cons (loop (car tree)) (and (cdr tree) (loop (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))))

;;; 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.
;;;
;;; NOTE: BIND will probably be deprecated some day in favor of BB (see below)
;;;
(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)))))))

;;; 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:
;;;
;;; (binding-block [binding-spec|form]* form)
;;;
;;; or
;;;
;;; (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.
;;;
;;; More thgins to fix:
;;; 1. Declarations
;;; 2. Fix dynamic bindings (currently $ prefix indicated dynamic binding)
;;;
(defmacro binding-block (&rest stuff) `(block nil (%bb ,@stuff)))

(defmacro bb (&rest stuff) `(binding-block ,@stuff))

(defv $binding-block-clauses nil)

(defmacro %bb (&rest body)
  (mcond
   (null (rst body)) (1st body)
   (consp (1st body)) `(progn ,(1st body) (%bb ,@(rst body)))
   (not (symbolp (1st body))) (error "~S is not a valid variable name" (1st body))
   (getf $binding-block-clauses (1st body)) (funcall it 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)))))

(defmacro def-bb-clause (name args expansion)
  `(progn
     (setf (getf $binding-block-clauses ',name)
           (fn (body) (dsbind ,args (rst body) ,expansion)))
     ',name))

(def-bb-clause :mv (args form &body body)
  `(mvbind ,args ,form (%bb ,@body)))

(def-bb-clause :db (args form &body body)
  `(dsbind ,args ,form (%bb ,@body)))

(def-bb-clause :with (var init cleanup &body body)
  `(let ((,var ,init)) (unwind-protect (%bb ,@body) ,cleanup)))

(def-bb-clause :with-file (spec &body body)
  `(with-open-file ,spec (%bb ,@body)))

(def-bb-clause :with-slots (vars instance &body body)
  `(with-slots ,vars ,instance (%bb ,@body)))

(def-bb-clause :fn (name args fbody &body body)
  `(labels ((,name ,args ,fbody)) (%bb ,@body)))

(def-bb-clause :tr (var form &body body)
  `(let ((,var ,form))
     (declare (special ,@(find-specials var)))
     (format t "~&BB: ~A = ~S" ',var ,var)
     (%bb ,@body)))

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

;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  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 (if (< n 0) (+ (length v) n) n)))

(define-method (setref (v vector) n val)
  (setf (aref v (if (< n 0) (+ (length v) n) n)) val))

(define-method (ref1 (h hash-table) k) (gethash k h))
(define-method (setref (h hash-table) k v) (setf (gethash k h) v))

(define-method (ref1 (o standard-object) key)
  (slot-value o key))

(define-method (setref (o standard-object) key val)
  (setf (slot-value o key) val))

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

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

) ; END EVAL-ALWAYS

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Unix utils
;;;

(defun system (cmd &optional stdin (external-format :utf-8))
  (if (typep stdin 'string) (setf stdin (make-string-input-stream stdin)))
  (if (typep cmd 'string) (setf cmd (split cmd #\Space)))
  (bb p (run-program (fst cmd) (rst cmd) :output :stream :input stdin :wait nil
                     :external-format external-format)
      s (read-all (external-process-output-stream p))
      (when (ccl::external-process-pid p)
        (with-interrupts-enabled
            (wait-on-semaphore (ccl::external-process-completed p))))
      (values s (nth-value 1 (external-process-status p)))))

(defun cat (string path)
  (with-open-file (f (pathname path) :direction :output :if-exists :supersede)
    (princ string f)))

(defun cc (path)
  (setf path (namestring (pathname path)))
  (system (format nil "gcc ~A.c -o ~A" path path)))

(defun rm (path) (delete-file (pathname path)))

(defun ls (&optional dir all)
  (directory (make-pathname :directory (pathname-directory (pathname (or dir (current-directory))))
                            :name "*" :type "*")
             :directories t :all all))

(defun b64encode (thing) (system "openssl base64" thing :latin1))
(defun b64decode (thing)
  (system "openssl base64 -d" (format nil "~A~%" thing) :latin1))

(defun aes256-encrypt (thing key)
  (system (format nil "openssl enc -e -aes256 -k ~A" key) thing :latin1))
(defun aes256-decrypt (thing key)
  (system (format nil "openssl enc -d -aes256 -k ~A" key) thing :latin1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Slice
;;;
(define-method (slice (s sequence) start &optional end step)
  (bb n (length s)
      start (if (< start 0) (+ n start) start)
      (if (null end) (return (subseq s start)))
      end (if (< end 0) (+ n end) end)
      (if (null step) (return (subseq s start end)))
      (error "Step argument to subseq is not yet implemented")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Date and time
;;;

(defun now () (get-universal-time))

(defc long-month-names '(january february march april may june july
                                 august september october november december))
(defc short-month-names '(jan feb mar apr may jun jul aug sep oct nov dec))

(defmacro with-decoded-universal-time (ut &body body)
  `(receive (s m h d mo y) (decode-universal-time ,ut)
     (declare (ignorable s m h d mo y))
     ,@body))

(defun format-date-time (&optional (ut (now)))
  (with-decoded-universal-time ut
    (format nil "~d/~d/~d ~d:~2,'0d:~2,'0d" mo d y h m s)))

(defun format-date (&optional (ut (now)))
  (with-decoded-universal-time ut
    (format nil "~d ~a ~d" d (ref short-month-names (1- mo)) y)))

;;; DELETEF & FILTER
(define-modify-macro _deletef (&rest args)
  (lambda (place item &rest args) (apply 'delete item place args)))

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

(define-modify-macro _deletef-if (&rest args)
  (lambda (place test &rest args) (apply 'delete-if test place args)))

(defmacro deletef-if (test place &rest args) `(_delete-if ,test ,place ,@args))

(defun filter (test seq &rest args)
  (apply 'remove-if-not test seq args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Unicode
;;;
(defun bytes-to-string (bytes &optional (encoding :utf-8))
  (decode-string-from-octets (coerce bytes '(vector (unsigned-byte 8)))
                             :external-format encoding))

(defun string-to-bytes (s &optional (encoding :utf-8))
  (encode-string-to-octets s :external-format encoding))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Spawn
;;;
(defmacro spawn (&rest body)
  (if (stringp (first body))
    `(gui:background-process-run-function ,(first body) (lambda () ,@(rest body)))
    `(gui:background-process-run-function ,(symbol-name (gensym "SPAWNED-PROCESS"))
                                          (lambda () ,@body))))

;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Chain
;;;
(defun chain (arg &rest functions)
  (if (null functions) arg (apply 'chain (funcall (car functions) arg) (cdr functions))))

(provide 'rg-utils)