[cells-gtk-cvs] CVS root/pod-utils
pdenno
pdenno at common-lisp.net
Sun Feb 19 20:09:12 UTC 2006
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 , at 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 "~%")))
, at 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
, at 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) , at 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)
, at 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]
More information about the Cells-gtk-cvs
mailing list