[cells-cvs] CVS cells-gtk/pod-utils
ktilton
ktilton at common-lisp.net
Mon Jan 28 23:59:58 UTC 2008
Update of /project/cells/cvsroot/cells-gtk/pod-utils
In directory clnet:/tmp/cvs-serv9292/pod-utils
Added Files:
kt-trace.lisp pod-utils.asd pod-utils.lpr utils.lisp
Log Message:
--- /project/cells/cvsroot/cells-gtk/pod-utils/kt-trace.lisp 2008/01/28 23:59:50 NONE
+++ /project/cells/cvsroot/cells-gtk/pod-utils/kt-trace.lisp 2008/01/28 23:59:50 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 , at 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 , at os))
(let ((tgt (gensym)))
`(,wrapper
(bif (,tgt ,tgt-form)
(if (trcp ,tgt)
(progn
(assert (stringp ,(car os)))
(call-trc t , at 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)) ;; clashes with cells:trc (trc back in cells for cells3)
--- /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.asd 2008/01/28 23:59:58 NONE
+++ /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.asd 2008/01/28 23:59:58 1.1
(asdf:defsystem :pod-utils
:name "pod-utils"
:components
((:file "utils")
(:file "kt-trace")))
--- /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.lpr 2008/01/28 23:59:58 NONE
+++ /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.lpr 2008/01/28 23:59:58 1.1
;; -*- lisp-version: "8.1 [Windows] (Dec 2, 2007 6:32)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
(define-project :name :pod-utils
:modules (list (make-instance 'module :name "utils.lisp")
(make-instance 'module :name "kt-trace.lisp"))
:projects nil
:libraries nil
:distributed-files nil
:internally-loaded-files nil
:project-package-name :common-graphics-user
:main-form nil
:compilation-unit t
:verbose nil
:runtime-modules (list :cg-dde-utils :cg.acache :cg.base
:cg.bitmap-pane :cg.bitmap-pane.clipboard
:cg.bitmap-stream :cg.button :cg.caret
:cg.chart-or-plot :cg.chart-widget
:cg.check-box :cg.choice-list
:cg.choose-printer :cg.class-grid
:cg.class-slot-grid :cg.class-support
:cg.clipboard :cg.clipboard-stack
:cg.clipboard.pixmap :cg.color-dialog
:cg.combo-box :cg.common-control :cg.comtab
:cg.cursor-pixmap :cg.curve :cg.dialog-item
:cg.directory-dialog :cg.directory-dialog-os
:cg.drag-and-drop :cg.drag-and-drop-image
:cg.drawable :cg.drawable.clipboard
:cg.dropping-outline :cg.edit-in-place
:cg.editable-text :cg.file-dialog
:cg.fill-texture :cg.find-string-dialog
:cg.font-dialog :cg.gesture-emulation
:cg.get-pixmap :cg.get-position
:cg.graphics-context :cg.grid-widget
:cg.grid-widget.drag-and-drop :cg.group-box
:cg.header-control :cg.hotspot :cg.html-dialog
:cg.html-widget :cg.icon :cg.icon-pixmap
:cg.ie :cg.item-list :cg.keyboard-shortcuts
:cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
:cg.lisp-text :cg.lisp-widget :cg.list-view
:cg.mci :cg.menu :cg.menu.tooltip
:cg.message-dialog
:cg.multi-line-editable-text
:cg.multi-line-lisp-text
:cg.multi-picture-button
:cg.multi-picture-button.drag-and-drop
:cg.multi-picture-button.tooltip
:cg.object-editor :cg.object-editor.layout
:cg.ocx :cg.os-widget :cg.os-window
:cg.outline :cg.outline.drag-and-drop
:cg.outline.edit-in-place :cg.palette
:cg.paren-matching :cg.picture-widget
:cg.picture-widget.palette :cg.pixmap
:cg.pixmap-widget :cg.pixmap.file-io
:cg.pixmap.printing :cg.pixmap.rotate
:cg.printing :cg.progress-indicator
:cg.project-window :cg.property
:cg.radio-button :cg.rich-edit
:cg.rich-edit-pane
:cg.rich-edit-pane.clipboard
:cg.rich-edit-pane.printing
:cg.sample-file-menu :cg.scaling-stream
:cg.scroll-bar :cg.scroll-bar-mixin
:cg.scrolling-static-text :cg.selected-object
:cg.shortcut-menu :cg.static-text
:cg.status-bar :cg.string-dialog
:cg.tab-control :cg.template-string
:cg.text-edit-pane :cg.text-edit-pane.file-io
:cg.text-edit-pane.mark :cg.text-or-combo
:cg.text-widget :cg.timer :cg.toggling-widget
:cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
:cg.up-down-control :cg.utility-dialog
:cg.web-browser :cg.web-browser.dde
:cg.wrap-string :cg.yes-no-list
:cg.yes-no-string :dde)
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
:include-flags (list :top-level :debugger)
:build-flags (list :allow-runtime-debug)
:autoload-warning nil
:full-recompile-for-runtime-conditionalizations nil
:include-manifest-file-for-visual-styles t
:default-command-line-arguments "+M +t \"Console for Debugging\""
:additional-build-lisp-image-arguments (list :read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
:on-initialization 'default-init-function
:on-restart 'do-default-restart)
;; End of Project Definition
--- /project/cells/cvsroot/cells-gtk/pod-utils/utils.lisp 2008/01/28 23:59:58 NONE
+++ /project/cells/cvsroot/cells-gtk/pod-utils/utils.lisp 2008/01/28 23:59:58 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))
(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).
[495 lines skipped]
More information about the Cells-cvs
mailing list