home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
vis-ftp.cs.umass.edu
/
vis-ftp.cs.umass.edu.tar
/
vis-ftp.cs.umass.edu
/
pub
/
Software
/
ASCENDER
/
ascendMar8.tar
/
UMass
/
Epipolar
/
isr2-enhancements.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1996-02-21
|
20KB
|
448 lines
;;; -*- Mode:Common-Lisp; Package:isr2; Base:10; Fonts:(MEDFNT HL12B HL12BI) -*-
;;; ISR2-ENHANCEMENTS.LISP - extra goodies to make life easier
;;; Bob Collins 06/29/88
;;;
;;; 2/27/95 Bob Collins - fixed up to load under Lucid
;;;
;;;
(in-package 'isr2)
(export '(destroy* framep frame-featurep tokenp token-subsetp
create-subframe create-frame-feature create-token-feature
list-subframes list-frame-features list-token-features
token-feature-defined-p uncalculated-p
create-named-token named-token-index
get-canonical-pathname-string token-index
store-graph copy-feature-values copy-tokens
fetch-by-features disjunctive-fetch-by-features
filter-lines-by-extents
tss-to-file file-to-tss ))
;;;================================================================
;;; SUPER DESTROY FUNCTION
(defun destroy* (path)
(when (path? path)
(destroy* (destroy path))))
;;;================================================================
;;; HANDLE TYPE CHECKING - THIS STUFF IS IMPLEMENTATION DEPENDANT
(defmacro handle-type-p (path type)
"Returns t if the path is of the specified handle type"
`(let ((path-handle (handle ,path :error-p nil)))
(when path-handle (eq ,type (handle-type path-handle)))))
(defun framep (path) (handle-type-p path :frame))
(defun frame-featurep (path) (handle-type-p path :frame-feature))
(defun tokenp (path) (handle-type-p path :token))
(defun token-subsetp (path) (handle-type-p path :token-subset))
;;;================================================================
;;; SUBFRAMES, FRAME-FEATURES AND TOKEN-FEATURES
(defun create-subframe (path documentation &key frame-features token-features)
" Defines the frame specified by PATH, and set its DOCUMENTATION string.
Keyword arguments allow the initialization of its FRAME-FEATURES and TOKEN-FEATURES;
these are lists of the form
(featurename documentation datatype &key if-needed if-getting if-setting)
for token features, and
(featurename documentation datatype &key initial-value if-needed if-getting if-setting)
for frame features.
Value returned is a handle to the new frame."
(declare (arglist path documentation key frame-features token-features))
(let ((frame (create path)))
(setf (value (list frame "DOCUMENTATION")) documentation)
(dolist (feature-spec frame-features) (apply #'create-frame-feature frame feature-spec))
(dolist (feature-spec token-features) (apply #'create-token-feature frame feature-spec))
frame))
(defun create-frame-feature (frame-path featurename documentation datatype
&rest keyword-args &key (initial-value nil init-valp))
" Defines a frame feature of the given frame. Allows an optional initial value.
Value returned is a handle to the new feature."
(declare (arglist frame-path featurename documentation datatype
&key initial-value if-needed if-getting if-setting))
(let ((frame-handle (frame (handle frame-path))))
(prog1
(apply #'define-feature (list frame-handle featurename) documentation datatype
:allow-other-keys t keyword-args)
(when init-valp
(setf (value (list frame-handle featurename)) initial-value)))))
(defun create-token-feature (frame-path featurename documentation datatype &rest keyword-args)
" Defines a token feature of the given frame.
Value returned is a handle to the new feature."
(declare (arglist frame-path featurename documentation datatype &key if-needed if-getting if-setting))
(let ((frame-handle (frame (handle frame-path))))
(apply #'define-feature (list frame-handle "<?>" featurename) documentation datatype keyword-args)))
(defun list-subframes (frame-path &aux (result nil))
" Returns a list of the subframes attached to the given frame."
(let ((frame-handle (frame (handle frame-path))))
(dolist (feature (features frame-handle) result)
(when (framep (list frame-handle feature))
(push feature result)))))
(defun list-frame-features (frame-path &aux (result nil))
" Returns a list of the frame features of given frame."
(let ((frame-handle (frame (handle frame-path))))
(dolist (feature (features frame-handle) result)
(when (frame-featurep (list frame-handle feature))
(push feature result)))))
(defun list-token-features (frame-path)
" Returns a list of the token features of given frame."
(let ((frame-handle (frame (handle frame-path))))
(reverse (features (list frame-handle "<?>")))))
(defun token-feature-defined-p (featurename frame-path)
"returns t if the given token feature is defined"
(not (null (find (string-upcase featurename) (list-token-features frame-path) :test #'string-equal))))
(defun uncalculated-p (value-path)
"returns t if (isr2:value value-path) would invoke the if-needed feature demon."
(let* ((fhandle (handle value-path))
(fdescr (handle-fdescr fhandle)))
(equalp (vvref (fdescr-value fdescr) (handle-token fhandle))
(case (fdescr-type fdescr)
(#.*int* *int-undefined*)
(#.*real* *real-undefined*)
(t *ptr-undefined*)))))
;;;================================================================
;;; NAMED TOKENS
(defun create-named-token (frame token-name &key (token-init-list nil))
" Creates a new token and gives it a symbolic name that can be
passed to isr2:named-token-index to retrieve the token index."
(let* ((frame-handle (handle frame))
(alist-path (list frame-handle "NAMED-TOKEN-ALIST")))
(unless (path? alist-path)
(define-feature alist-path "alist of token names to token indices" :pointer)
(setf (value alist-path) nil))
(let ((name-string (string token-name))
(new-token (create-new-token frame-handle :token-init-list token-init-list)))
(push (cons name-string (token-index new-token)) (value alist-path))
new-token)))
(defun named-token-index (frame token-name &key (error-p t))
" Returns the index of a named token (made using isr2:create-named-token). If a token by
that name does not exist an error occurs, unless error-p is nil in which case nil is returned."
(let* ((alist-handle (handle (list frame "NAMED-TOKEN-ALIST")))
(index (cdr (assoc (string token-name) (value alist-handle) :test #'equalp))))
(or index
(when error-p (error "a token of frame ~s with name ~a cannot be found" frame token-name)))))
;;;================================================================
;;; PATHNAME PARSING
(defun get-canonical-pathname-string (path &aux (result ""))
"Returns the canonical pathname of PATH as a string."
(flet ((index-stringp (string) (when (> (length string) 0) (equal (aref string 0) #\<))))
(let ((string-list (handle-canonical-path (handle path)))
(dollar-sign? nil))
(dolist (string string-list result)
(cond
((index-stringp string) (setf result (format nil "~a~a" result string))
(setf dollar-sign? nil))
((not dollar-sign?) (setf result (format nil "~a~a" result string))
(setf dollar-sign? t))
(t (setf result (format nil "~a$~a" result string))))))))
(defun token-index (path)
" Returns the last token index in PATH as an integer or the symbol ?.
Returns nil if there is no token index in the pathname."
(unless (handle-p path) (setf path (handle path)))
(handle-token path))
#|
(defun token-index (path)
" Returns the last token index in PATH as an integer or the symbol ?.
Returns nil if there is no token index in the pathname."
(let* ((string (get-canonical-pathname-string path))
(position> (search ">" string :from-end t :test #'equal))
(position< (search "<" string :from-end t :test #'equal)))
(when position<
(read-from-string string nil nil :start (1+ position<) :end position>))))
|#
;;;================================================================
;;; STORING GRAPHS
(defun store-graph (root-path directory &optional (frames-not-to-store nil))
" Stores the whole tree having ROOT-PATH as its root in directory DIRECTORY.
The filename of a frame file is the frame's canonical pathname string, without
parent information, and the extension .ISR2 . Thus a root frame of 'foo$bar
with subframes of 'foo$bar$a and 'foo$bar$b would generate the three files
bar$a.isr2, bar$b.isr2, and bar.isr2 .
If the optional argument is given, any frame appearing within the list is
ignored, along with its descendants.
Returns a list of handles of the frames written out."
(let ((handles-not-to-store (mapcar #'handle frames-not-to-store))
(parent-prefix-length (1+ (length (get-canonical-pathname-string (parent root-path))))))
(set-difference
(store-graph-aux (frame (handle root-path)) (string directory)
parent-prefix-length handles-not-to-store)
handles-not-to-store
:test #'equalp)))
(defun store-graph-aux (frame-handle dir-string prefix-length handles-to-ignore)
"Stores the graph recursively. Returns an extended list of handles-to-ignore"
(unless (member frame-handle handles-to-ignore :test #'equalp)
;;mark this node as being taken care
(push frame-handle handles-to-ignore)
;;write out subframes first so that their sourcefile features get set
(dolist (feature (list-subframes frame-handle))
(setf handles-to-ignore
(store-graph-aux (handle (list frame-handle feature))
dir-string prefix-length handles-to-ignore)))
;;now write out this frame
(let ((filename (concatenate 'string
dir-string
(subseq (get-canonical-pathname-string frame-handle) prefix-length)
".ISR2")))
(store frame-handle filename)))
;;return possibly extended list of handles to ignore
handles-to-ignore)
;;;================================================================
;;; COPYING FEATURE VALUES FROM ONE PLACE TO ANOTHER
(defun copy-feature-values (from-path to-path &key (features :all))
" Copies feature values from FROM-PATH to TO-PATH. FEATURES can take
the value :ALL (the default), or a list of featurenames. If :ALL, the features
common to both the from and to objects will be copied. If from and to paths
both specify frames, then the values of frame features are copied, if they are
both token paths then token feature values are copied. Any other combination
of from and to paths is an error.
The return value is a list of the features copied."
(let ((from-handle (handle from-path))
(to-handle (handle to-path)))
(cond
((and (framep from-handle) (framep to-handle)) ;;both are frames
(when (eq features :all)
(setf features (intersection (frame-features from-handle)
(frame-features to-handle)
:test #'equal))))
((and (tokenp from-handle) (tokenp to-handle)) ;;both are tokens
(when (eq features :all)
(setf features (intersection (token-features (frame from-handle))
(token-features (frame to-handle))
:test #'equal))))
(t (error "paths must both be frame-paths, or both be token-paths.")))
;;now copy the feature values
(dolist (feat features features)
(let ((fhandle (handle (list from-handle feat))))
(unless (uncalculated-p fhandle)
(let ((value (value fhandle :if-undefined :undefined)))
(if (eq value :undefined)
(case (datatype-of (list from-handle feat))
(#.*int* (setf (value (list to-handle feat)) *int-undefinable*))
(#.*real* (setf (value (list to-handle feat)) *real-undefinable*))
(t (setf (value (list to-handle feat)) *ptr-undefinable*)))
(setf (value (list to-handle feat)) value))))))))
(defun copy-tokens (oldpath newpath &key (features :all) create? index-feature &aux newtok)
" Copies tokens and feature values from oldpath into newpath. If OLDPATH is a tss, only
the selected tokens will be copied. FEATURES is a list of feature names to copy, otherwise
it is :all which means all features. Token indices will be as compact as possible in newpath,
this a copied token will probably not have the same token index it once did. If specified,
INDEX-FEATURE is a feature of newpath in which the old token index will be stored. If CREATE?
is non-nil, then newpath will be created with the same feature definitions as oldpath, with
possibly the addition of the specified INDEX-FEATURE."
(when create?
(copy-definition (frame (handle oldpath)) newpath)
(when (and index-feature (not (token-feature-defined-p index-feature newpath)))
(create-token-feature newpath 'oldindex "old token index" :integer)))
(let* ((newframe (frame (handle newpath)))
(newtss (make-null-tss newframe)))
(for-every-token (oldtok oldpath)
(setf newtok (create-new-token newframe ))
(add-token! newtok newtss)
(when index-feature
(setf (value (list newtok index-feature)) (token-index oldtok)))
(copy-feature-values oldtok newtok :features features))
(values newframe newtss)))
;;;================================================================
;;; TOKENSET MODIFICATION TRACKING
#| COMMENT THIS STUFF OUT ON 2/27/95 -- Bob Collins
(defun get-date-string ()
(with-output-to-string (user::*standard-output*)
(time:print-current-time)))
(defun get-username-string ()
(user-name))
(defun init-modification-history (frame-path)
"Initialize a modification history subframe for the frame specified by FRAME-PATH."
(let ((frame-handle (frame (handle frame-path))))
(create-subframe (list frame-handle "HISTORY") "previous modifications"
:token-features `((date "date of modification" :string)
(name "name of user making modification" :string)
(description "description of modification" :string)))))
(defun note-modification (frame-path description-of-modification
&key (username (get-username-string)) (date (get-date-string)))
" Adds a new modification note to a frame's modification history. The description should
be a string suitable for use with the format command. The modification note is automatically
stamped with username, date and time, or these values can be optionally provided."
(let ((mod-handle (handle (list (frame (handle frame-path)) "HISTORY"))))
(create-new-token mod-handle
:token-init-list `((name ,(string username))
(date ,(string date))
(description ,(string description-of-modification))))))
(defun print-modification-history (frame-path &key (stream user::*standard-output*) (last-n nil))
" Prints out the modification history of the given frame on a specified stream. If
LAST-N is specified, then only the last n modifications will be printed. For example,
to see only the most recent modification, use a last-n value of 1."
(let* ((mod-handle (handle (list (frame (handle frame-path)) "HISTORY")))
(num-mods (token-count mod-handle))
(num-to-ignore (if last-n (min 0 (- num-mods last-n)) 0)))
(do ((i num-to-ignore (1+ i)))
((>= i num-mods) nil)
(format stream "~%;~a by ~a"
(value (list mod-handle i "DATE"))
(value (list mod-handle i "NAME")))
;;nicely indent lines of the description
(let ((string (value (list mod-handle i "DESCRIPTION")))
(indentation "; ")
(newline (string #\newline))
(end nil) (newstart nil))
(do* ((start 0 newstart)
(end1 (search newline string) (search newline string :start2 start))
(end2 (search "~%" string) (search "~%" string :start2 start)))
((null (or end1 end2)) (format t "~%~a~a" indentation (subseq string start)))
(cond
((and end1 end2)
(setf end (min end1 end2))
(setf newstart (if (< end1 end2) (+ end 1) (+ end 2))))
(end1 (setf end end1) (setf newstart (+ end 1)))
(end2 (setf end end2) (setf newstart (+ end 2)))
(t (error "should never get here")))
(format t "~%~a~a" indentation (subseq string start end)))))))
|#
;;;================================================================
;;; ASSOCIATIVE ACCESS
(defun make-set-description (range-spec)
(if (string-equal (string-upcase (car range-spec)) "EXTENTS")
(make-tss-extents :minrow (second range-spec) :mincol (third range-spec)
:maxrow (fourth range-spec) :maxcol (fifth range-spec))
(make-range :feature (first range-spec)
:min (second range-spec) :max (third range-spec))))
(defun fetch-by-features (tokenset range-spec-list)
" Same as fetch by features function in the first ISR. Each range spec is
of the form (feature minval maxval) or (EXTENTS minrow mincol maxrow maxcol).
Result is a tokenset of tokens which pass all the range tests."
(let ((conjunction (make-tss tokenset)))
(dolist (range-spec range-spec-list conjunction)
(tss-intersection! conjunction (make-set-description range-spec)))))
(defun disjunctive-fetch-by-features (tokenset range-spec-list)
" Same as isr2:fetch-by-features but range specs are disjunctive rather
than conjunctive, that is, the result is a tokenset of tokens which pass
at least on of the range tests."
(let ((disjunction (make-null-tss tokenset)))
(dolist (range-spec range-spec-list disjunction)
(tss-union! disjunction (make-set-description range-spec)))))
(defun point-in-boxp (row col minrow mincol maxrow maxcol)
(and (<= minrow row maxrow)
(<= mincol col maxcol)))
(defun filter-lines-by-extents (tokenset minrow mincol maxrow maxcol &key (num-endpts-in-box 1)
(row1-feature "ROW1") (row2-feature "ROW2")
(col1-feature "COL1") (col2-feature "COL2"))
"Returns all lines that have at least num-endpts-in-box in the extents box."
(tss-intersection
tokenset
(make-predicate
:function (if (= num-endpts-in-box 1)
#'(lambda (ignore1 ignore2 row1 col1 row2 col2)
ignore1 ignore2
(or (point-in-boxp row1 col1 minrow mincol maxrow maxcol)
(point-in-boxp row2 col2 minrow mincol maxrow maxcol)))
#'(lambda (ignore1 ignore2 row1 col1 row2 col2)
ignore1 ignore2
(and (point-in-boxp row1 col1 minrow mincol maxrow maxcol)
(point-in-boxp row2 col2 minrow mincol maxrow maxcol))))
:features (list row1-feature col1-feature row2-feature col2-feature))))
;;;================================================================
;;; ADDITIONAL TOKENSUBSET FUNCTIONS
(defun list-tokens (tss-or-path &aux (token-list nil))
" Conses up a list of the tokens in the (possibly implicit) tokensubset."
(for-every-token (tok (make-tss tss-or-path))
(push (copy-handle tok) token-list))
token-list)
(defvar isr2::$tss-indices nil "for use with tss-to-file and file-to-tss")
(defun tss-to-stream (tss-or-tokenlist stream &aux (count 1))
" Writes tokensubset indices out the given stream. This is the inverse of stream-to-tss."
(format stream "(")
(if (listp tss-or-tokenlist)
(dolist (var tss-or-tokenlist)
(when (zerop (setf count (mod count 15)))
(terpri stream))
(incf count)
(format stream " ~d" (token-index var)))
(for-every-token (var tss-or-tokenlist)
(when (zerop (setf count (mod count 15)))
(terpri stream))
(incf count)
(format stream " ~d" (token-index var))))
(format stream " )"))
(defun tss-to-file (tss filename &aux (count 1))
" Writes tokensubset indices out to a file. This is the inverse of file-to-tss."
(with-open-file (file filename :direction :output)
(format file "(setf isr2::$tss-indices '(")
(for-every-token (var tss)
(when (zerop (setf count (mod count 15)))
(terpri file))
(incf count)
(format file " ~d" (token-index var)))
(format file " ))")))
(defun index-list-to-tss (tokenset list &optional tss)
" Makes a tss of tokenset using indices in the given list. If tss is given, this is destructive."
(let ((tss (if tss (make-null-tss! tss) (make-null-tss tokenset)))
(handle (handle (list tokenset "<?>"))))
(mapc #'(lambda (index)
(setf (handle-token handle) index)
(add-token! handle tss))
list)
tss))
(defun stream-to-tss (tokenset stream)
" Makes a tss of tokenset using indices read from the given stream. This is
the inverse of tss-to-stream."
(index-list-to-tss tokenset (read stream)))
(defun file-to-tss (tokenset filename)
" Makes a tss of tokenset using indices read from the given file. This is
the inverse of tss-to-file."
(load filename)
(index-list-to-tss tokenset isr2::$tss-indices))
;;;================================================================
(provide :isr2-enhancements)