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 / ascender.tar.Z / ascender.tar / Epipolar / isr2-enhancements.lisp < prev    next >
Lisp/Scheme  |  1996-02-21  |  20KB  |  448 lines
  1. ;;; -*- Mode:Common-Lisp; Package:isr2; Base:10; Fonts:(MEDFNT HL12B HL12BI) -*-
  2.  
  3. ;;; ISR2-ENHANCEMENTS.LISP  - extra goodies to make life easier
  4. ;;; Bob Collins  06/29/88
  5. ;;;
  6. ;;; 2/27/95 Bob Collins - fixed up to load under Lucid
  7. ;;;
  8. ;;;
  9.  
  10. (in-package 'isr2)
  11.  
  12. (export '(destroy* framep frame-featurep tokenp token-subsetp
  13.     create-subframe create-frame-feature create-token-feature
  14.     list-subframes list-frame-features list-token-features
  15.     token-feature-defined-p uncalculated-p 
  16.     create-named-token named-token-index 
  17.     get-canonical-pathname-string token-index
  18.     store-graph copy-feature-values copy-tokens
  19.     fetch-by-features disjunctive-fetch-by-features
  20.     filter-lines-by-extents
  21.     tss-to-file file-to-tss    ))
  22.  
  23. ;;;================================================================
  24. ;;; SUPER DESTROY FUNCTION
  25.  
  26. (defun destroy* (path)
  27.   (when (path? path) 
  28.    (destroy* (destroy path))))
  29.  
  30. ;;;================================================================
  31. ;;; HANDLE TYPE CHECKING - THIS STUFF IS IMPLEMENTATION DEPENDANT
  32.  
  33. (defmacro handle-type-p (path type)
  34.   "Returns t if the path is of the specified handle type"
  35.   `(let ((path-handle (handle ,path :error-p nil)))
  36.      (when path-handle (eq ,type (handle-type path-handle)))))
  37.  
  38. (defun framep (path) (handle-type-p path :frame))
  39. (defun frame-featurep (path) (handle-type-p path :frame-feature))
  40. (defun tokenp (path) (handle-type-p path :token))
  41. (defun token-subsetp (path) (handle-type-p path :token-subset))
  42.  
  43. ;;;================================================================
  44. ;;; SUBFRAMES, FRAME-FEATURES AND TOKEN-FEATURES
  45.  
  46. (defun create-subframe (path documentation &key frame-features token-features)
  47.   "  Defines the frame specified by PATH, and set its DOCUMENTATION string.
  48.   Keyword arguments allow the initialization of its FRAME-FEATURES and TOKEN-FEATURES;
  49.   these are lists of the form
  50.      (featurename documentation datatype &key if-needed if-getting if-setting)
  51.   for token features, and
  52.      (featurename documentation datatype &key initial-value if-needed if-getting if-setting)
  53.   for frame features.
  54.   Value returned is a handle to the new frame."
  55.   (declare (arglist path documentation key frame-features token-features))
  56.   (let ((frame (create path)))
  57.     (setf (value (list frame "DOCUMENTATION")) documentation)
  58.     (dolist (feature-spec frame-features) (apply #'create-frame-feature frame feature-spec))
  59.     (dolist (feature-spec token-features) (apply #'create-token-feature frame feature-spec))
  60.     frame))
  61.  
  62. (defun create-frame-feature (frame-path featurename documentation datatype 
  63.                  &rest keyword-args &key (initial-value nil init-valp))
  64.   "  Defines a frame feature of the given frame.  Allows an optional initial value.
  65.   Value returned is a handle to the new feature."
  66.   (declare (arglist frame-path featurename documentation datatype
  67.             &key initial-value if-needed if-getting if-setting))
  68.   (let ((frame-handle (frame (handle frame-path))))
  69.     (prog1
  70.       (apply #'define-feature (list frame-handle featurename) documentation datatype
  71.          :allow-other-keys t keyword-args)
  72.       (when init-valp
  73.     (setf (value (list frame-handle featurename)) initial-value)))))
  74.  
  75. (defun create-token-feature (frame-path featurename documentation datatype &rest keyword-args)
  76.   "  Defines a token feature of the given frame. 
  77.   Value returned is a handle to the new feature."
  78.   (declare (arglist frame-path featurename documentation datatype &key if-needed if-getting if-setting))
  79.   (let ((frame-handle (frame (handle frame-path))))
  80.     (apply #'define-feature (list frame-handle "<?>" featurename) documentation datatype keyword-args)))
  81.  
  82. (defun list-subframes (frame-path &aux (result nil))
  83.   "  Returns a list of the subframes attached to the given frame."
  84.   (let ((frame-handle (frame (handle frame-path))))
  85.     (dolist (feature (features frame-handle) result)
  86.       (when (framep (list frame-handle feature))
  87.     (push feature result)))))
  88.  
  89. (defun list-frame-features (frame-path &aux (result nil))
  90.   "  Returns a list of the frame features of given frame."
  91.   (let ((frame-handle (frame (handle frame-path))))
  92.     (dolist (feature (features frame-handle) result)
  93.       (when (frame-featurep (list frame-handle feature))
  94.     (push feature result)))))
  95.  
  96. (defun list-token-features (frame-path)
  97.   "  Returns a list of the token features of given frame."
  98.   (let ((frame-handle (frame (handle frame-path))))
  99.     (reverse (features (list frame-handle "<?>")))))
  100.  
  101. (defun token-feature-defined-p (featurename frame-path)
  102.   "returns t if the given token feature is defined"
  103.   (not (null (find (string-upcase featurename) (list-token-features frame-path) :test #'string-equal))))
  104.  
  105. (defun uncalculated-p (value-path)
  106.   "returns t if (isr2:value value-path) would invoke the if-needed feature demon."
  107.   (let* ((fhandle (handle value-path))
  108.      (fdescr (handle-fdescr fhandle)))
  109.     (equalp (vvref (fdescr-value fdescr) (handle-token fhandle))
  110.         (case (fdescr-type fdescr)
  111.           (#.*int* *int-undefined*)
  112.           (#.*real* *real-undefined*)
  113.           (t *ptr-undefined*)))))
  114.  
  115.  
  116. ;;;================================================================
  117. ;;; NAMED TOKENS
  118.  
  119. (defun create-named-token (frame token-name &key (token-init-list nil))
  120.   "  Creates a new token and gives it a symbolic name that can be
  121.   passed to isr2:named-token-index to retrieve the token index."
  122.   (let* ((frame-handle (handle frame))
  123.      (alist-path (list frame-handle "NAMED-TOKEN-ALIST")))
  124.     (unless (path? alist-path)
  125.       (define-feature alist-path "alist of token names to token indices" :pointer)
  126.       (setf (value alist-path) nil))
  127.     (let ((name-string (string token-name))
  128.       (new-token (create-new-token frame-handle :token-init-list token-init-list)))
  129.       (push (cons name-string (token-index new-token)) (value alist-path))
  130.       new-token)))
  131.  
  132. (defun named-token-index (frame token-name &key (error-p t))
  133.   "  Returns the index of a named token (made using isr2:create-named-token).  If a token by 
  134.   that name does not exist an error occurs, unless error-p is nil in which case nil is returned."
  135.   (let* ((alist-handle (handle (list frame "NAMED-TOKEN-ALIST")))
  136.      (index (cdr (assoc (string token-name) (value alist-handle) :test #'equalp))))
  137.     (or index
  138.     (when error-p (error "a token of frame ~s with name ~a cannot be found" frame token-name)))))
  139.     
  140.     
  141.  
  142. ;;;================================================================
  143. ;;; PATHNAME PARSING
  144.  
  145. (defun get-canonical-pathname-string (path &aux (result ""))
  146.   "Returns the canonical pathname of PATH as a string." 
  147.   (flet ((index-stringp (string) (when (> (length string) 0) (equal (aref string 0) #\<))))
  148.     (let ((string-list (handle-canonical-path (handle path)))
  149.       (dollar-sign? nil))
  150.       (dolist (string string-list result)
  151.     (cond 
  152.       ((index-stringp string) (setf result (format nil "~a~a" result string))
  153.                   (setf dollar-sign? nil))
  154.       ((not dollar-sign?) (setf result (format nil "~a~a" result string))
  155.                   (setf dollar-sign? t))
  156.       (t (setf result (format nil "~a$~a" result string))))))))
  157.  
  158. (defun token-index (path)
  159.   "  Returns the last token index in PATH as an integer or the symbol ?.
  160.   Returns nil if there is no token index in the pathname."
  161.   (unless (handle-p path) (setf path (handle path)))
  162.   (handle-token path))
  163.  
  164. #|
  165. (defun token-index (path)
  166.   "  Returns the last token index in PATH as an integer or the symbol ?.
  167.   Returns nil if there is no token index in the pathname."
  168.   (let* ((string (get-canonical-pathname-string path))
  169.      (position> (search ">" string :from-end t :test #'equal))
  170.      (position< (search "<" string :from-end t :test #'equal)))
  171.     (when position<
  172.       (read-from-string string nil nil :start (1+ position<) :end position>))))
  173. |#
  174.  
  175.  
  176. ;;;================================================================
  177. ;;; STORING GRAPHS
  178.  
  179. (defun store-graph (root-path directory &optional (frames-not-to-store nil))
  180.   "  Stores the whole tree having ROOT-PATH as its root in directory DIRECTORY.
  181.   The filename of a frame file is the frame's canonical pathname string, without
  182.   parent information, and the extension .ISR2 .  Thus a root frame of 'foo$bar
  183.   with subframes of 'foo$bar$a and 'foo$bar$b would generate the three files
  184.   bar$a.isr2, bar$b.isr2, and bar.isr2 .
  185.   If the optional argument is given, any frame appearing  within the list is 
  186.   ignored, along with its descendants.
  187.   Returns a list of handles of the frames written out."
  188.   (let ((handles-not-to-store (mapcar #'handle frames-not-to-store))
  189.     (parent-prefix-length (1+ (length (get-canonical-pathname-string (parent root-path))))))
  190.     (set-difference
  191.       (store-graph-aux (frame (handle root-path)) (string directory)
  192.                parent-prefix-length handles-not-to-store)
  193.       handles-not-to-store
  194.       :test #'equalp)))
  195.  
  196. (defun store-graph-aux (frame-handle dir-string prefix-length handles-to-ignore)
  197.   "Stores the graph recursively.  Returns an extended list of handles-to-ignore"
  198.   (unless (member frame-handle handles-to-ignore :test #'equalp)
  199.     ;;mark this node as being taken care
  200.     (push frame-handle handles-to-ignore)
  201.     ;;write out subframes first so that their sourcefile features get set
  202.     (dolist (feature (list-subframes frame-handle))
  203.       (setf handles-to-ignore
  204.         (store-graph-aux (handle (list frame-handle feature)) 
  205.                  dir-string prefix-length handles-to-ignore)))
  206.     ;;now write out this frame
  207.     (let ((filename (concatenate 'string 
  208.                  dir-string
  209.                  (subseq (get-canonical-pathname-string frame-handle) prefix-length)
  210.                  ".ISR2")))
  211.       (store frame-handle filename)))
  212.   ;;return possibly extended list of handles to ignore
  213.   handles-to-ignore)
  214.  
  215.  
  216. ;;;================================================================
  217. ;;; COPYING FEATURE VALUES FROM ONE PLACE TO ANOTHER
  218.  
  219. (defun copy-feature-values (from-path to-path &key (features :all))
  220.   "  Copies feature values from FROM-PATH to TO-PATH.  FEATURES can take
  221.   the value :ALL (the default), or a list of featurenames.  If :ALL, the features
  222.   common to both the from and to objects will be copied.  If from and to paths
  223.   both specify frames, then the values of frame features are copied, if they are
  224.   both token paths then token feature values are copied.  Any other combination
  225.   of from and to paths is an error. 
  226.   The return value is a list of the features copied."
  227.   (let ((from-handle (handle from-path))
  228.     (to-handle (handle to-path)))
  229.     (cond
  230.       ((and (framep from-handle) (framep to-handle))  ;;both are frames
  231.          (when (eq features :all)
  232.        (setf features (intersection (frame-features from-handle)
  233.                     (frame-features to-handle)
  234.                     :test #'equal))))
  235.       ((and (tokenp from-handle) (tokenp to-handle))  ;;both are tokens
  236.          (when (eq features :all)
  237.        (setf features (intersection (token-features (frame from-handle))
  238.                     (token-features (frame to-handle))
  239.                     :test #'equal))))
  240.       (t (error "paths must both be frame-paths, or both be token-paths.")))
  241.     ;;now copy the feature values
  242.     (dolist (feat features features)
  243.       (let ((fhandle (handle (list from-handle feat))))
  244.     (unless (uncalculated-p fhandle)
  245.       (let ((value (value fhandle :if-undefined :undefined)))
  246.         (if (eq value :undefined)
  247.         (case (datatype-of (list from-handle feat))
  248.           (#.*int*  (setf (value (list to-handle feat)) *int-undefinable*))
  249.           (#.*real* (setf (value (list to-handle feat)) *real-undefinable*))
  250.           (t        (setf (value (list to-handle feat)) *ptr-undefinable*)))
  251.         (setf (value (list to-handle feat)) value))))))))
  252.  
  253. (defun copy-tokens (oldpath newpath &key (features :all) create? index-feature &aux newtok)
  254.   "  Copies tokens and feature values from oldpath into newpath.  If OLDPATH is a tss, only
  255.   the selected tokens will be copied.  FEATURES is a list of feature names to copy, otherwise
  256.   it is :all which means all features.  Token indices will be as compact as possible in newpath,
  257.   this a copied token will probably not have the same token index it once did.  If specified,
  258.   INDEX-FEATURE is a feature of newpath in which the old token index will be stored.  If CREATE?
  259.   is non-nil, then newpath will be created with the same feature definitions as oldpath, with
  260.   possibly the addition of the specified INDEX-FEATURE."
  261.   (when create?
  262.     (copy-definition (frame (handle oldpath)) newpath)
  263.     (when (and index-feature (not (token-feature-defined-p index-feature newpath)))
  264.       (create-token-feature newpath 'oldindex "old token index" :integer)))
  265.   (let* ((newframe (frame (handle newpath)))
  266.      (newtss (make-null-tss newframe)))
  267.     (for-every-token (oldtok oldpath)
  268.       (setf newtok (create-new-token newframe ))
  269.       (add-token! newtok newtss)
  270.       (when index-feature
  271.     (setf (value (list newtok index-feature)) (token-index oldtok)))
  272.       (copy-feature-values oldtok newtok :features features))
  273.     (values newframe newtss)))
  274.  
  275. ;;;================================================================
  276. ;;; TOKENSET MODIFICATION TRACKING
  277.  
  278. #|  COMMENT THIS STUFF OUT ON 2/27/95  -- Bob Collins
  279.  
  280. (defun get-date-string () 
  281.   (with-output-to-string (user::*standard-output*)
  282.     (time:print-current-time)))
  283.  
  284. (defun get-username-string ()
  285.   (user-name))
  286.  
  287. (defun init-modification-history (frame-path)
  288.   "Initialize a modification history subframe for the frame specified by FRAME-PATH."
  289.   (let ((frame-handle (frame (handle frame-path))))
  290.     (create-subframe (list frame-handle "HISTORY") "previous modifications"
  291.      :token-features `((date "date of modification" :string)
  292.                (name "name of user making modification" :string)
  293.                (description "description of modification" :string)))))
  294.  
  295. (defun note-modification (frame-path description-of-modification
  296.               &key (username (get-username-string)) (date (get-date-string)))
  297.   "  Adds a new modification note to a frame's modification history.  The description should
  298.   be a string suitable for use with the format command.  The modification note is automatically
  299.   stamped with username, date and time, or these values can be optionally provided." 
  300.   (let ((mod-handle (handle (list (frame (handle frame-path)) "HISTORY"))))
  301.     (create-new-token mod-handle
  302.          :token-init-list `((name ,(string username))
  303.                 (date ,(string date))
  304.                 (description ,(string description-of-modification))))))
  305.  
  306. (defun print-modification-history (frame-path &key (stream user::*standard-output*) (last-n nil))
  307.   "  Prints out the modification history of the given frame on a specified stream.  If
  308.   LAST-N is specified, then only the last n modifications will be printed.  For example,
  309.   to see only the most recent modification,  use a last-n value of 1."
  310.   (let* ((mod-handle (handle (list (frame (handle frame-path)) "HISTORY")))
  311.      (num-mods (token-count mod-handle))
  312.      (num-to-ignore (if last-n (min 0 (- num-mods last-n)) 0)))
  313.     (do ((i num-to-ignore (1+ i)))
  314.     ((>= i num-mods) nil)
  315.       (format stream "~%;~a by ~a" 
  316.           (value (list mod-handle i "DATE")) 
  317.           (value (list mod-handle i "NAME")))
  318.       ;;nicely indent lines of the description
  319.       (let ((string (value (list mod-handle i "DESCRIPTION")))
  320.         (indentation ";   ")
  321.         (newline (string #\newline))
  322.         (end nil) (newstart nil))
  323.     (do* ((start 0 newstart)
  324.           (end1 (search newline string) (search newline string :start2 start))
  325.           (end2 (search "~%" string) (search "~%" string :start2 start)))
  326.          ((null (or end1 end2)) (format t "~%~a~a" indentation (subseq string start)))
  327.       (cond
  328.         ((and end1 end2) 
  329.             (setf end (min end1 end2))
  330.         (setf newstart (if (< end1 end2) (+ end 1) (+ end 2))))
  331.         (end1  (setf end end1) (setf newstart (+ end 1)))
  332.         (end2  (setf end end2) (setf newstart (+ end 2)))
  333.         (t (error "should never get here")))
  334.       (format t "~%~a~a" indentation (subseq string start end)))))))
  335.  
  336. |#
  337. ;;;================================================================
  338. ;;; ASSOCIATIVE ACCESS
  339.  
  340. (defun make-set-description (range-spec)
  341.   (if (string-equal (string-upcase (car range-spec)) "EXTENTS")
  342.       (make-tss-extents :minrow (second range-spec) :mincol (third range-spec)
  343.             :maxrow (fourth range-spec) :maxcol (fifth range-spec))
  344.       (make-range :feature (first range-spec)
  345.           :min (second range-spec) :max (third range-spec))))
  346.  
  347. (defun fetch-by-features (tokenset range-spec-list)
  348.   "  Same as fetch by features function in the first ISR.  Each range spec is
  349.   of the form (feature minval maxval) or (EXTENTS minrow mincol maxrow maxcol).
  350.   Result is a tokenset of tokens which pass all the range tests."
  351.   (let ((conjunction (make-tss tokenset)))
  352.     (dolist (range-spec range-spec-list conjunction)
  353.       (tss-intersection! conjunction (make-set-description range-spec)))))
  354.  
  355. (defun disjunctive-fetch-by-features (tokenset range-spec-list)
  356.   "  Same as isr2:fetch-by-features but range specs are disjunctive rather
  357.   than conjunctive, that is, the result is a tokenset of tokens which pass 
  358.   at least on of the range tests."
  359.   (let ((disjunction (make-null-tss tokenset)))
  360.     (dolist (range-spec range-spec-list disjunction)
  361.       (tss-union! disjunction (make-set-description range-spec)))))
  362.  
  363. (defun point-in-boxp (row col minrow mincol maxrow maxcol)
  364.   (and (<= minrow row maxrow)
  365.        (<= mincol col maxcol)))
  366.  
  367. (defun filter-lines-by-extents (tokenset minrow mincol maxrow maxcol &key (num-endpts-in-box 1)
  368.                      (row1-feature "ROW1") (row2-feature "ROW2")
  369.                      (col1-feature "COL1") (col2-feature "COL2"))    
  370.   "Returns all lines that have at least num-endpts-in-box in the extents box."
  371.   (tss-intersection 
  372.     tokenset 
  373.     (make-predicate
  374.       :function (if (= num-endpts-in-box 1)
  375.             #'(lambda (ignore1 ignore2 row1 col1 row2 col2)
  376.             ignore1 ignore2
  377.             (or (point-in-boxp row1 col1 minrow mincol maxrow maxcol)
  378.                 (point-in-boxp row2 col2 minrow mincol maxrow maxcol)))
  379.             #'(lambda (ignore1 ignore2 row1 col1 row2 col2)
  380.             ignore1 ignore2
  381.             (and (point-in-boxp row1 col1 minrow mincol maxrow maxcol)
  382.                  (point-in-boxp row2 col2 minrow mincol maxrow maxcol))))
  383.       :features (list row1-feature col1-feature row2-feature col2-feature))))
  384.  
  385. ;;;================================================================
  386. ;;; ADDITIONAL TOKENSUBSET FUNCTIONS
  387.  
  388. (defun list-tokens (tss-or-path  &aux (token-list nil))
  389.   "  Conses up a list of the tokens in the (possibly implicit) tokensubset."
  390.   (for-every-token (tok (make-tss tss-or-path))
  391.     (push (copy-handle tok) token-list))
  392.   token-list)
  393.  
  394. (defvar isr2::$tss-indices nil "for use with tss-to-file and file-to-tss")
  395.  
  396. (defun tss-to-stream (tss-or-tokenlist stream &aux (count 1))
  397.   "  Writes tokensubset indices out the given stream.  This is the inverse of stream-to-tss."
  398.   (format stream "(")
  399.   (if (listp tss-or-tokenlist)
  400.       (dolist (var tss-or-tokenlist)
  401.     (when (zerop (setf count (mod count 15)))
  402.       (terpri stream))
  403.     (incf count)
  404.     (format stream " ~d" (token-index var)))
  405.       (for-every-token (var tss-or-tokenlist)
  406.     (when (zerop (setf count (mod count 15)))
  407.       (terpri stream))
  408.     (incf count)
  409.     (format stream " ~d" (token-index var))))
  410.   (format stream " )"))
  411.  
  412. (defun tss-to-file (tss filename &aux (count 1))
  413.   "  Writes tokensubset indices out to a file.  This is the inverse of file-to-tss."
  414.   (with-open-file (file filename :direction :output)
  415.     (format file "(setf isr2::$tss-indices '(")
  416.     (for-every-token (var tss)
  417.       (when (zerop (setf count (mod count 15)))
  418.     (terpri file))
  419.       (incf count)
  420.       (format file " ~d" (token-index var)))
  421.     (format file " ))")))
  422.  
  423. (defun index-list-to-tss (tokenset list &optional tss)
  424.   "  Makes a tss of tokenset using indices in the given list.  If tss is given, this is destructive."
  425.   (let ((tss (if tss (make-null-tss! tss) (make-null-tss  tokenset)))
  426.     (handle (handle (list tokenset "<?>"))))
  427.     (mapc #'(lambda (index) 
  428.           (setf (handle-token handle) index)
  429.           (add-token! handle tss))
  430.       list)
  431.     tss))
  432.  
  433. (defun stream-to-tss (tokenset stream)
  434.   "  Makes a tss of tokenset using indices read from the given stream.  This is
  435.   the inverse of tss-to-stream."
  436.   (index-list-to-tss tokenset (read stream)))
  437.  
  438. (defun file-to-tss (tokenset filename)
  439.   "  Makes a tss of tokenset using indices read from the given file.  This is
  440.   the inverse of tss-to-file."
  441.   (load filename)
  442.   (index-list-to-tss tokenset isr2::$tss-indices))
  443.  
  444. ;;;================================================================
  445.  
  446.  
  447. (provide :isr2-enhancements)
  448.