[cells-cvs] CVS cells-gtk3/pod-utils

Update of /project/cells/cvsroot/cells-gtk3/pod-utils In directory clnet:/tmp/cvs-serv5005/pod-utils

Added Files: kt-trace.lisp pod-utils.asd utils.lisp Log Message: cells-gtk3 initial.

--- /project/cells/cvsroot/cells-gtk3/pod-utils/kt-trace.lisp 2008/04/13 10:59:26 NONE +++ /project/cells/cvsroot/cells-gtk3/pod-utils/kt-trace.lisp 2008/04/13 10:59:26 1.1

;;; Copyright (c) 2004 Kenny Tilton ;;; ;;; 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. ;;;-----------------------------------------------------------------------

;;; ;;; Kenny Tilton trace stuff. ;;; (in-package :pod-utils)

(defparameter *trcdepth* 0) (defvar *count* nil) (defvar *counting* nil) (defvar *dbg*) (defvar *stop* nil)

(defun utils-kt-reset () (setf *count* nil *stop* nil *dbg* nil *trcdepth* 0))

;----------- trc -------------------------------------------

(defmacro count-it (&rest keys) `(when *counting* (call-count-it ,@keys)))

(defmacro trc (tgt-form &rest os &aux (wrapper (if (macro-function 'without-c-dependency) 'without-c-dependency 'progn))) (if (eql tgt-form 'nil) '(progn) (if (stringp tgt-form) `(,wrapper (call-trc t ,tgt-form ,@os)) (let ((tgt (gensym))) `(,wrapper (bif (,tgt ,tgt-form) (if (trcp ,tgt) (progn (assert (stringp ,(car os))) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn ;;(break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval)))))))

(defun call-trc (stream s &rest os) (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) (format stream "~&")) (format stream "~a" s) (let (pkwp) (dolist (o os) (format stream (if pkwp " ~s" " | ~s") o) (setf pkwp (keywordp o)))) (values))

(defun call-count-it (&rest keys) (declare (ignorable keys)) ;;; (when (eql :TGTNILEVAL (car keys))(break)) (let ((entry (assoc keys *count* :test #'equal))) (if entry (setf (cdr entry) (1+ (cdr entry))) (push (cons keys 1) *count*))))

;(export '(trc)) ; trc is now in cells--- /project/cells/cvsroot/cells-gtk3/pod-utils/pod-utils.asd 2008/04/13 10:59:26 NONE +++ /project/cells/cvsroot/cells-gtk3/pod-utils/pod-utils.asd 2008/04/13 10:59:26 1.1

(asdf:defsystem :pod-utils :name "pod-utils" :components ((:file "utils") (:file "kt-trace"))) --- /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/13 10:59:26 NONE +++ /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/13 10:59:26 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 tree-search depth-first-search prepend breadth-first-search update with-stack-size pprint-without-strings chop setx reuse-cons intersect-predicates defmemo system-clear-memoized-fns system-add-memoized-fn system-list-memoized-fns system-forget-memoized-fns with-gensyms fail)) ; ph: removed last1 new-reslist reslist-pop reslist-push reslist-fillptr now

(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* ,(cdr 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))

[405 lines skipped]