Update of /project/cells-gtk/cvsroot/root/pod-utils In directory common-lisp:/tmp/cvs-serv14536/root/pod-utils

Added Files: pod-utils.asd utils.lisp Log Message: New files

--- /project/cells-gtk/cvsroot/root/pod-utils/pod-utils.asd 2006/02/19 20:09:12 NONE +++ /project/cells-gtk/cvsroot/root/pod-utils/pod-utils.asd 2006/02/19 20:09:12 1.1

(asdf:defsystem :pod-utils :name "pod-utils" :components ((:file "utils"))) --- /project/cells-gtk/cvsroot/root/pod-utils/utils.lisp 2006/02/19 20:09:12 NONE +++ /project/cells-gtk/cvsroot/root/pod-utils/utils.lisp 2006/02/19 20:09:12 1.1

;;; Copyright (c) 2004 Peter Denno ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, ;;; merge, publish, distribute, sublicense, and/or sell copies of the ;;; Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ;;; ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ;;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;;-----------------------------------------------------------------------

;;; ;;; Peter Denno ;;; Date: 12/2/95 - on going. ;;; ;;; Generally applicable utilities. Some from Norvig's "Paradigms of ;;; Artificial Programming," Some from Kiczales et. al. "The Art of the ;;; Metaobject Protocol," some from Graham's "On Lisp," some from Sam Steingold. ;;; (in-package :cl-user)

(defpackage pod-utils (:nicknames pod) (:use cl) (:export combinations flatten kintern sintern mapappend pairs memo debug-memo memoize clear-memoize defun-memoize VARS mac mac2 load-ht when-bind if-bind when-bind* substring remove-extra-spaces break-line-at read-string-to-list split name2initials c-name2lisp lisp-name2c single-p mklist longer group prune find2 before duplicate split-if mvb mvs dbind decode-time-interval strcat now tree-search depth-first-search prepend breadth-first-search update with-stack-size pprint-without-strings chop setx new-reslist reslist-pop reslist-push reslist-fillptr reuse-cons intersect-predicates defmemo system-clear-memoized-fns system-add-memoized-fn system-list-memoized-fns system-forget-memoized-fns with-gensyms last1 fail trc))

(in-package :pod-utils)

;;; Purpose: Return the combinations possible when selecting one item ;;; from each of the argument sets. ;;; Example: (combinations '(a) '(b c) '(d e)) ;;; => ((A B D) (A B E) (A C D) (A C E)) ;;; Arg: sets - lists ;;; Value: a list of lists. If the argument is nil, it returns nil. (defun combinations (&rest sets) (cond ((null sets) nil) (t (flet ((combinations-aux (aset bset) (cond ((not aset) bset) ((not bset) aset) (t (loop for a in aset append (loop for b in bset collect (list a b))))))) (loop for set in (reduce #'combinations-aux sets) collect (flatten set))))))

(defun flatten (input &optional accumulator) "Return a flat list of the atoms in the input. Ex: (flatten '((a (b (c) d))) => (a b c d))" (cond ((null input) accumulator) ((atom input) (cons input accumulator)) (t (flatten (first input) (flatten (rest input) accumulator)))))

(declaim (inline kintern)) (defun kintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the KEYWORD package." (intern (string-upcase (apply #'format nil (string string) args)) (find-package "KEYWORD")))

(declaim (inline sintern)) (defun sintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the current (*PACKAGE*) package." (intern (string-upcase (apply #'format nil (string string) args))))

(defun mapappend (fun &rest args) (loop until (some #'null args) append (apply fun (loop for largs on args collect (pop (first largs))))))

(defun mapnconc (fun &rest args) (loop until (some #'null args) nconc (apply fun (loop for largs on args collect (pop (first largs))))))

;;; Purpose: Return a list of pairs of elements from the argument list: ;;; Ex: (pairs '(a b c d)) => ((a b) (a c) (a d) (b c) (b d) (c d)) ;;; ;;; Args: inlist - a list (defun pairs (inlist) (loop for sublist on inlist while (cdr sublist) append (loop for elem in (cdr sublist) collect `(,(first sublist) ,elem))))

;;; Purpose: Called by memoize, below. This returns ;;; the memoized function. Norvig, Page 270. ;;; When you want to use this on &rest args use :test #'equal :key #'identity ;;; Args: fn - the function object. ;;; name - the function symbol. ;;; key - On what argument the result is indexed. ;;; test - Either eql or equal, the :test of the hash table. (defun memo (fn name key test) "Return a memo-function of fn." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p val (setf (gethash k table) (apply fn args))))))))

(defun debug-memo (fn name key test) "Like memo but prints *hit* on every hit." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p (progn (princ " *HIT*") val) (progn (princ " *miss*") (setf (gethash k table) (apply fn args)))))))))

;;; Purpose: memoize the argument function. ;;; Arguments as those in memo. (defun memoize (fn-name &key (key #'first) (test #'eql) (debug nil)) "Replace fn-name's global definition with a memoized version." #-Allegro-V4.3 (format t "~%;;; Memoizing (~a) ~a ****" test fn-name) #+Allegro-V4.3 (format t "~%;;; Memoizing ~a ****" fn-name) (if debug (setf (symbol-function fn-name) (debug-memo (symbol-function fn-name) fn-name key test)) (setf (symbol-function fn-name) (memo (symbol-function fn-name) fn-name key test))))

;;; Clear the hash table from the function. (defun clear-memoize (fn-name) "Clear the hash table from a memo function." (let ((table (get fn-name 'memo))) (when table (clrhash table))))

;;; Purpose: define a function and memoize it. ;;; Limitations: only useful for default arguments, i.e., ;;; key on first and test eql. In all other ;;; cases call (memoize <fn> :key <key> :test <test>). (defmacro defun-memoize (fn args &body body) `(memoize (defun ,fn ,args ,body)))

;;; Stuff to use when you have a serious number of memoized functions, ;;; and you have a notion of "starting over." (defmacro defmemo (fname &body body) `(progn (defun ,fname ,@body) (eval-when (:load-toplevel) (memoize ',fname) (system-add-memoized-fn ',fname))))

(let ((+memoized-fns+ nil)) (defun system-clear-memoized-fns () (mapcar #'(lambda (x) (warn "Clearing memoized ~A" x) (clear-memoize x)) +memoized-fns+)) (defun system-add-memoized-fn (fname) (pushnew fname +memoized-fns+)) (defun system-list-memoized-fns () +memoized-fns+) (defun system-forget-memoized-fns () (setf +memoized-fns+ nil)) )

;;; Purpose: Diagnostic (From Howard Stearns) that does ;;; (vars a b c) => (FORMAT *TRACE-OUTPUT* "~&a = ~S b = ~S c = ~S ~%" A B C) (defmacro VARS (&rest variables) `(format *trace-output* ,(loop with result = "~&" for var in variables do (setf result (if (and (consp var) (eq (first var) 'quote)) (concatenate 'string result " ~S ") (concatenate 'string result (string-downcase var) " = ~S "))) finally (return (concatenate 'string result "~%"))) ,@variables))

;;; The most essential macro building tool. (defmacro mac (macro) `(pprint (macroexpand-1 ',macro)))

;;; Similar, but used on 'subtype' macros. (defmacro mac2 (macro) `(pprint (macroexpand-1 (macroexpand-1 ',macro))))

;;; Dirk H.P. Gerrits' "Lisp Code Walker" slides, ALU Meeting, Amsterdam, 2003. ;;; With additional corrections (beyond that in his notes). (defvar *mea-hooks* (make-hash-table :test #'eq)) (defun macroexpand-all (form &optional env) "Macroexpand FORM recursively until none of its subforms can be further expanded." (multiple-value-bind (expansion macrop) (macroexpand-1 form env) (declare (ignore macrop)) (let* ((key (and (consp form) (car form))) (hook (gethash key *mea-hooks*))) (cond (hook (funcall hook form env)) ((and (consp form) (symbolp (car form)) (macro-function (car form))) (macroexpand-all expansion env)) ((consp form) (cons (car form) (mapcar #'(lambda (arg) (macroexpand-all arg env)) (cdr form)))) (t expansion)))))

(defun load-ht (ht key-value-pairs) "Load the argument hash table with the argument values provided in a flat list of <key> <value>. " (loop while key-value-pairs do (setf (gethash (pop key-value-pairs) ht) (pop key-value-pairs))) ht)

(defmacro when-bind ((var expr) &body body) "Paul Graham ON LISP pg 145. when+let" `(let ((,var ,expr)) (when ,var ,@body)))

(defmacro if-bind ((var expr) then else) `(let ((,var ,expr)) (if ,var ,then ,else)))

(defmacro when-bind* (binds &body body) "Paul Graham ON LISP pg 145. when+let*" (if (null binds) `(progn @body) `(let (,(car binds)) (if ,(caar binds) (when-bind* ,(car binds) ,@body)))))

(defmacro with-gensyms (syms &body body) "Paul Graham ON LISP pg 145. Used in macros to avoid variable capture." `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) ,@body))

(declaim (inline substring)) (defun substring (str1 str2) "Returns the place in str1 where str2 begins or nil if str2 is not in str1" (search str2 str1 :test #'string=))

(defun remove-extra-spaces (string) "Leave only one space between non-space characters of argument string." (let* ((len (length string)) (new-string (make-array len :element-type 'character :fill-pointer 0))) (vector-push (char string 0) new-string) (loop for i from 1 to (1- len) unless (and (char= #\Space (char string i)) (char= #\Space (char string (1- i)))) do (vector-push (char string i) new-string)) new-string))

(defun break-line-at (string break-bag position) "Return the argument STRING with linefeeds inserted at some position past POSITION where a character in the break-bag is encountered." (let* ((len (length string)) (new-string (make-array (* 2 len) :element-type 'character :fill-pointer 0))) (loop for ix from 0 to (1- (length string)) with count = 0 do (vector-push (char string ix) new-string) (incf count) when (and (> count position) (find (char string ix) break-bag)) do (vector-push #\Linefeed new-string) (setf count 0) finally (return new-string))))

(defun read-string-to-list (string) (loop with val = nil and start = 0 do (multiple-value-setq (val start) (read-from-string string nil :eof :start start)) until (eql val :eof) collect val))

;;; (cl-ppcre:split "\s+" "foo bar baz frob") ;;; ("foo" "bar" "baz" "frob") ;;; http://weitz.de/cl-ppcre/#split (defun split (string c &key min-size) "Like the perl split, split the string using the character. Return a list of substrings." (let ((result (loop for i from 0 to (1- (length string)) with start = 0 with size = 0 do (incf size) when (and (char= c (char string i)) (or (not min-size) (> size min-size))) collect (subseq string start i) into result and do (setf start (1+ i) size 0) finally (return (append result (list (subseq string start))))))) (if (zerop (length (first (last result)))) (butlast result) result)))

(defun name2initials (string) "For 'abc' return 'a'. For 'product_definition_formation' return 'pdf', etc." (let ((result (make-array 31 :element-type 'character :fill-pointer 0)) (len (length string))) (vector-push (char string 0) result) (loop for i from 1 to (1- len) when (and (char= (char string i) #_) (< i (1- len))) do (vector-push (char string (+ i 1)) result) (incf i)) result))

(defun c-name2lisp (c-string) "aNameLikeThis --> a-name-like-this" (let* ((len (length c-string)) (result (make-array (* 2 len) :element-type 'character :fill-pointer 0))) (vector-push (char c-string 0) result) (loop for i from 1 to (1- len) for char = (char c-string i) do (when (upper-case-p char) (vector-push #- result)) (vector-push char result)) (string-downcase result)))

(defun lisp-name2c (in-string &aux (lisp-string (string-downcase in-string))) "a-name-like-this --> aNameLikeThis" (let* ((len (length lisp-string)) (result (make-array len :element-type 'character :fill-pointer 0))) (vector-push (char lisp-string 0) result) (loop for i from 1 to (1- len) for char = (char lisp-string i) with upper-next = nil do (cond ((char= char #-) (setf upper-next t)) (t (vector-push (if upper-next (char-upcase char) char) result) (setf upper-next nil)))) result))

;;;============================================= ;;; A bunch more from Paul Grahams's "On Lisp." ;;;============================================= (declaim (inline single-p last1 mklist))

(defun single-p (lst) "List contains just one thing." (and (consp lst) (not (cdr lst))))

(defun last1 (lst) (car (last lst)))

(defun mklist (obj) "Make the argument a list if it isn't already." (if (listp obj) obj (list obj)))

(defun longer (x y) "Return true if x longer than y -- only for lists." (labels ((compare (x y) (and (consp x) (or (null y) (compare (cdr x) (cdr y)))))) (if (and (listp x) (listp y)) (compare x y) (> (length x) (length y)))))

(defun group (source n) (if (zerop n) (error "zero length")) (labels ((rec (source acc) (let ((rest (nthcdr n source))) (if (consp rest) (rec rest (cons (subseq source 0 n) acc)) (nreverse (cons source acc)))))) (if source (rec source nil) nil)))

[374 lines skipped]