Lots more has happened.

[sod] / utilities.lisp

;;; -*-lisp-*-
;;;
;;; Various handy utilities
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; List utilities.

(defun mappend (function list &rest more-lists)
  "Like a nondestructive MAPCAN.

   Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
   and return the result of appending all of the resulting lists."
  (reduce #'append (apply #'mapcar function list more-lists) :from-end t))

(define-condition inconsistent-merge-error (error)
  ((candidates :initarg :candidates
	       :reader merge-error-candidates))
  (:documentation
   "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
  (:report (lambda (condition stream)
	     (format stream "Merge inconsistency: failed to decide among ~A."
		     (merge-error-candidates condition)))))

(defun merge-lists (lists &key pick (test #'eql))
  "Return a merge of the given LISTS.

   The resulting LIST contains the items of the given lists, with duplicates
   removed.  The order of the resulting list is consistent with the orders of
   the input LISTS in the sense that if A precedes B in some input list then
   A will also precede B in the output list.  If the lists aren't consistent
   (e.g., some list contains A followed by B, and another contains B followed
   by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.

   Item equality is determined by TEST.

   If there is an ambiguity at any point -- i.e., a choice between two or
   more possible next items to emit -- then PICK is called to arbitrate.
   PICK is called with two arguments: the list of candidate next items, and
   the current output list.  It should return one of the candidate items.  If
   PICK is omitted then an arbitrary choice is made.

   The primary use of this function is in computing class precedence lists.
   By building the input lists and selecting the PICK function appropriately,
   a variety of different CPL algorithms can be implemented."

  ;; In this loop, TAIL points to the last cons cell in the list.  This way
  ;; we can build the list up forwards, so as not to make the PICK function
  ;; interface be weird.  HEAD is a dummy cons cell inserted before the list,
  ;; which gives TAIL something to point to initially.  (If we had locatives,
  ;; I'd have TAIL point to the thing holding the final NIL, but we haven't;
  ;; instead, it points to the cons cell whose cdr holds the final NIL --
  ;; which means that we need to invent a cons cell if the list is empty.)
  (do* ((head (cons nil nil))
        (tail head))
       ((null lists) (cdr head))

    ;; The candidate items are the ones at the front of the input lists.
    ;; Gather them up, removing duplicates.  If a candidate is somewhere in
    ;; one of the other lists other than at the front then we reject it.  If
    ;; we've just rejected everything, then we can make no more progress and
    ;; the input lists were inconsistent.
    (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
           (leasts (remove-if (lambda (item)
                                (some (lambda (list)
                                        (member item (cdr list) :test test))
                                      lists))
                              candidates))
           (winner (cond ((null leasts)
                          (error 'inconsistent-merge-error
				 :candidates candidates))
                         ((null (cdr leasts))
                          (car leasts))
                         (pick
                          (funcall pick leasts (cdr head)))
			 (t (car leasts))))
           (new (cons winner nil)))

      ;; Check that the PICK function isn't conning us.
      (assert (member winner leasts :test test))

      ;; Update the output list and remove the winning item from the input
      ;; lists.  We know that it must be at the front of each input list
      ;; containing it.  At this point, we discard input lists entirely when
      ;; they run out of entries.  The loop ends when there are no more input
      ;; lists left, i.e., when we've munched all of the input items.
      (setf (cdr tail) new
            tail new
            lists (delete nil (mapcar (lambda (list)
					(if (funcall test winner (car list))
					    (cdr list)
					    list))
				      lists))))))

;;;--------------------------------------------------------------------------
;;; Strings and characters.

(defun frob-case (string)
  "Twiddles the case of STRING.

   If all the letters in STRING are uppercase, switch them to lowercase; if
   they're all lowercase then switch them to uppercase.  If there's a mix
   then leave them all alone.  This is an invertible transformation."

  ;; Given that this operation is performed by the reader anyway, it's
  ;; surprising that there isn't a Common Lisp function to do this built
  ;; in.
  (let ((flags (reduce (lambda (state ch)
			 (logior state
				 (cond ((upper-case-p ch) 1)
				       ((lower-case-p ch) 2)
				       (t 0))))
		       string
		       :initial-value 0)))

    ;; Now FLAGS has bit 0 set if there are any upper-case characters, and
    ;; bit 1 if there are lower-case.  So if it's zero there were no letters
    ;; at all, and if it's three then there were both kinds; either way, we
    ;; leave the string unchanged.  Otherwise we know how to flip the case.
    (case flags
      (1 (string-downcase string))
      (2 (string-upcase string))
      (t string))))

(declaim (inline whitespace-char-p))
(defun whitespace-char-p (char)
  "Returns whether CHAR is a whitespace character.

   Whitespaceness is determined relative to the compile-time readtable, which
   is probably good enough for most purposes."
  (case char
    (#.(loop for i below char-code-limit
	     for ch = (code-char i)
	     unless (with-input-from-string (in (string ch))
		      (peek-char t in nil))
	     collect ch) t)
    (t nil)))

;;;--------------------------------------------------------------------------
;;; Symbols.

(defun symbolicate (&rest symbols)
  "Return a symbol named after the concatenation of the names of the SYMBOLS.

   The symbol is interned in the current *PACKAGE*.  Trad."
  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))

;;;--------------------------------------------------------------------------
;;; Object printing.

(defmacro maybe-print-unreadable-object
    ((object stream &rest args) &body body)
  "Print helper for usually-unreadable objects.

   If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
   Otherwise just print using BODY."
  (let ((func (gensym "PRINT")))
    `(flet ((,func () ,@body))
       (if *print-escape*
	   (print-unreadable-object (,object ,stream ,@args)
	     (,func))
	   (,func)))))

;;;--------------------------------------------------------------------------
;;; Keyword arguments and lambda lists.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun transform-otherkeys-lambda-list (bvl)
    "Process a simple lambda-list BVL which might contain &OTHER-KEYS.

   &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
   (which must also be present); &ALLOW-OTHER-KEYS must not be present.

   The behaviour is that

     * the presence of non-listed keyword arguments is permitted, as if
       &ALLOW-OTHER-KEYS had been provided, and

     * a list of the keyword arguments other than the ones explicitly listed
       is stored in the VAR.

   The return value is a replacement BVL which binds the &OTHER-KEYS variable
   as an &AUX parameter if necessary.

   At least for now, fancy things like destructuring lambda-lists aren't
   supported.  I suspect you'll get away with a specializing lambda-list."

    (prog ((new-bvl nil)
	   (rest-var nil)
	   (keywords nil)
	   (other-keys-var nil)
	   (tail bvl))

     find-rest
       ;; Scan forwards until we find &REST or &KEY.  If we find the former,
       ;; then remember the variable name.  If we find the latter first then
       ;; there can't be a &REST argument, so we should invent one.  If we
       ;; find neither then there's nothing to do.
       (when (endp tail)
	 (go ignore))
       (let ((item (pop tail)))
	 (push item new-bvl)
	 (case item
	   (&rest (when (endp tail)
		    (error "Missing &REST argument name"))
		  (setf rest-var (pop tail))
		  (push rest-var new-bvl))
	   (&aux (go ignore))
	   (&key (unless rest-var
		   (setf rest-var (gensym "REST"))
		   (setf new-bvl (nconc (list '&key rest-var '&rest)
					(cdr new-bvl))))
		 (go scan-keywords)))
	 (go find-rest))

     scan-keywords
       ;; Read keyword argument specs one-by-one.  For each one, stash it on
       ;; the NEW-BVL list, and also parse it to extract the keyword, which
       ;; we stash in KEYWORDS.  If we don't find &OTHER-KEYS then there's
       ;; nothing for us to do.
       (when (endp tail)
	 (go ignore))
       (let ((item (pop tail)))
	 (push item new-bvl)
	 (case item
	   ((&aux &allow-other-keys) (go ignore))
	   (&other-keys (go fix-tail)))
	 (let ((keyword (if (symbolp item)
			    (intern (symbol-name item) :keyword)
			    (let ((var (car item)))
			      (if (symbolp var)
				  (intern (symbol-name var) :keyword)
				  (car var))))))
	   (push keyword keywords))
	 (go scan-keywords))

     fix-tail
       ;; We found &OTHER-KEYS.  Pick out the &OTHER-KEYS var.
       (pop new-bvl)
       (when (endp tail)
	 (error "Missing &OTHER-KEYS argument name"))
       (setf other-keys-var (pop tail))
       (push '&allow-other-keys new-bvl)

       ;; There should be an &AUX next.  If there isn't, assume there isn't
       ;; one and provide our own.  (This is safe as long as nobody else is
       ;; expecting to plumb in lambda keywords too.)
       (when (and (not (endp tail)) (eq (car tail) '&aux))
	 (pop tail))
       (push '&aux new-bvl)

       ;; Add our shiny new &AUX argument.
       (let ((keys-var (gensym "KEYS"))
	     (list-var (gensym "LIST")))
	 (push `(,other-keys-var (do ((,list-var nil)
				      (,keys-var ,rest-var (cddr ,keys-var)))
				     ((endp ,keys-var) (nreverse ,list-var))
				   (unless (member (car ,keys-var)
						   ',keywords)
				     (setf ,list-var
					   (cons (cadr ,keys-var)
						 (cons (car ,keys-var)
						       ,list-var))))))
	       new-bvl))

       ;; Done.
       (return (nreconc new-bvl tail))

     ignore
       ;; Nothing to do.  Return the unmolested lambda-list.
       (return bvl))))

(defmacro lambda-otherkeys (bvl &body body)
  "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
  `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))

(defmacro defun-otherkeys (name bvl &body body)
  "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
  `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))

(defmacro defmethod-otherkeys (name &rest stuff)
  "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
  (do ((quals nil)
       (stuff stuff (cdr stuff)))
      ((listp (car stuff))
       `(defmethod ,name ,@(nreverse quals)
	    ,(transform-otherkeys-lambda-list (car stuff))
	  ,@(cdr stuff)))
    (push (car stuff) quals)))

;;;--------------------------------------------------------------------------
;;; Iteration macros.

(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body)
  "Macro for iterating over general sequences.

   Iterates over a (sub)sequence SEQ, delimited by START and END (which are
   evaluated).  For each item of SEQ, BODY is invoked with VAR bound to the
   item, and INDEXVAR (if requested) bound to the item's index.  (Note that
   this is different from most iteration constructs in Common Lisp, which
   work by mutating the variable.)

   The loop is surrounded by an anonymous BLOCK and the loop body forms an
   implicit TAGBODY, as is usual.  There is no result-form, however."

  (let ((seqvar (gensym "SEQ"))
	(startvar (gensym "START"))
	(endvar (gensym "END"))
	(ivar (gensym "INDEX"))
	(bodyfunc (gensym "BODY")))

    (flet ((loopguts (indexp listp use-endp)
	     ;; Build a DO-loop to do what we want.
	     (let* ((do-vars nil)
		    (end-condition (if use-endp
				       `(endp ,seqvar)
				       `(>= ,ivar ,endvar)))
		    (item (if listp
			      `(car ,seqvar)
			      `(aref ,seqvar ,ivar)))
		    (body-call `(,bodyfunc ,item)))
	       (when listp
		 (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar))
		       do-vars))
	       (when indexp
		 (push `(,ivar ,startvar (1+ ,ivar)) do-vars))
	       (when indexvar
		 (setf body-call (append body-call (list ivar))))
	       `(do ,do-vars (,end-condition) ,body-call))))

      `(block nil
	 (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
		  (tagbody ,@body)))
	   (let* ((,seqvar ,seq)
		  (,startvar ,start))
	     (etypecase ,seqvar
	       (vector
		(let ((,endvar (or ,end (length ,seqvar))))
		  ,(loopguts t nil nil)))
	       (list
		(let ((,endvar ,end))
		  (if ,endvar
		      ,(loopguts t t nil)
		      ,(loopguts indexvar t t)))))))))))

;;;--------------------------------------------------------------------------
;;; Meta-object hacking.

(defgeneric copy-instance-using-class (class object &rest initargs)
  (:documentation
   "Return a copy of OBJECT.

   OBJECT is assumed to be an instance of CLASS.  The copy returned is a
   fresh instance whose slots have the same values as OBJECT except where
   overridden by INITARGS.")

  (:method ((class standard-class) object &rest initargs)
    (let ((copy (apply #'allocate-instance class initargs)))
      (dolist (slot (class-slots class))
	(if (slot-boundp-using-class class object slot)
	    (setf (slot-value-using-class class copy slot)
		  (slot-value-using-class class object slot))
	    (slot-makunbound-using-class class copy slot)))
      (apply #'shared-initialize copy nil initargs)
      copy)))

(defun copy-instance (object &rest initargs)
  "Return a copy of OBJECT.

   The copy returned is a fresh instance whose slots have the same values as
   OBJECT except where overridden by INITARGS."
  (apply #'copy-instance-using-class (class-of object) object initargs))

(defmacro default-slot ((instance slot) &body value &environment env)
  "If INSTANCE's SLOT is unbound, set it to VALUE.

   Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
   evaluated if it's needed."

  (let* ((quotep (constantp slot env))
	 (instancevar (gensym "INSTANCE"))
	 (slotvar (if quotep slot (gensym "SLOT"))))
    `(let ((,instancevar ,instance)
	   ,@(and (not quotep) `((,slotvar ,slot))))
       (unless (slot-boundp ,instancevar ,slotvar)
	 (setf (slot-value ,instancevar ,slotvar)
	       (progn ,@value))))))

;;;----- That's all, folks --------------------------------------------------