reduce-historical/psl-1983/nmode/browser.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Browser.SL - Browser object definition
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        4 February 1983
% Revised:     14 February 1983
%
% This file implements browser objects.  These objects form the basis of
% a general browser support mechanism.  See Browser-Support.SL for additional
% support functions and Buffer-Browser.SL for an example of a browser
% using this mechanism.
%
% 14-Feb-83 Alan Snyder
%  Fix bug in filter application (was trying to apply a macro).
% 11-Feb-83 Alan Snyder
%  Fix &remove-current-item to reset the display buffer's modified flag.
%  Improve comments.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load fast-vectors fast-int))
(load gsort)

(de create-browser (display-buffer view-buffer header-text items current-sorter)

  % Create a brower.  DISPLAY-BUFFER is the buffer to use for displaying the
  % items.  VIEW-BUFFER is the buffer to use for viewing an item; if NIL, the
  % item is expected to provide its own buffer.  HEADER-TEXT is a vector of
  % strings to display at the top of the display buffer; it may be NIL.  ITEMS
  % is a list or vector containing the set of items to display (this data
  % structure will not be modified).  CURRENT-SORTER may be NIL or a function
  % ID.  If non-NIL, the function will be used to sort the initial set of
  % items.

  (make-instance 'browser
		 'display-buffer display-buffer
		 'view-buffer view-buffer
		 'header-text header-text
		 'items items
		 'current-sorter current-sorter
		 ))

(defflavor browser
  (
   (display-buffer NIL)		% buffer used to display items
   (view-buffer NIL)		% buffer used to view items (NIL => ask item)
   (viewed-item NIL)		% the item most recently viewed
   (header-text	NIL)		% text displayed at top of buffer
   items			% vector of visible items (may have junk at end)
   first-item-linepos		% line number of first item in display
   last-item-index		% index of last item in ITEMS vector
   (filtered-items ())		% list of lists of items removed by filtering
   (current-sorter NIL)		% sorter used if items are un-filtered
   )
  ()
  (initable-instance-variables display-buffer view-buffer header-text items
			       current-sorter)
  )

% Methods provided by items:
%
% (=> item display-text)
%   Return string used to display the item.
%
% (=> item delete)
%   Mark the item as deleted.  May do nothing if deletion is not supported.
%   May change the display-text.  This method need not be provided if no
%   delete commands are provided in the particular browser.
%
% (=> item undelete)
%   Mark the item as not deleted.  May do nothing if deletion is not
%   supported.  May change the display-text.  This method need not be provided
%   if no delete commands are provided in the particular browser.
%
% (=> item deleted?)
%   Return T if the item has been marked for deletion.  This method need not
%   be provided if no delete commands are provided in the particular browser.
%
% (=> item kill)
%   Kill the real item.  (Instead of just marking the item for deletion, this
%   should actually dispose of the item, if that action is supported.)  May do
%   nothing if killing is not supported.  Return T if the item is actually
%   killed, NIL otherwise.  This method need not be provided if no delete
%   commands are provided in the particular browser.
%
% (=> item view-buffer buffer)
%   Return a buffer containing the item for viewing.  If the buffer argument
%   is non-NIL, then that buffer should be used for viewing.  Otherwise, the
%   item must provide its own buffer.
%
% (=> item cleanup)
%   Throw away any unneeded stuff, such as a buffer created for viewing.  This
%   method is invoked when an item is no longer being viewed, or when the item
%   is being filtered out, or when the browser is being exited.
%
% (=> item apply-filter filter)
%   The item should apply the filter to itself and return T if the filter
%   matches the item and NIL otherwise.

(defmethod (browser current-item) ()
  % Return the current item, which is the item that is displayed on the
  % display-buffer's current line, or NIL, if there is no such item.

  (let ((index (- (=> display-buffer line-pos) first-item-linepos)))
    (when (and (>= index 0) (<= index last-item-index))
      (vector-fetch items index)
      )))

(defmethod (browser current-item-index) ()
  % Return the index of the current item, which is the item that is displayed
  % on the display-buffer's current line, or NIL, if there is no such item.

  (let ((index (- (=> display-buffer line-pos) first-item-linepos)))
    (when (and (>= index 0) (<= index last-item-index))
      index
      )))

(defmethod (browser kill-item) ()
  % Kill the current item, if any.  Return T if the item is killed,
  % NIL otherwise.

  (let ((item (=> self current-item)))
    (when (=> item kill)
      (=> self &remove-current-item)
      )))

(defmethod (browser kill-deleted-items) ()
  % Attempts to KILL all items that have been marked for deletion.
  % Returns a list of the items actually killed.
  (=> self &keep-items '&browser-item-not-killed ())
  )

(defmethod (browser delete-item) ()
  % Mark the current item as deleted, if any.  Return T if the item exists,
  % NIL otherwise.

  (let ((item (=> self current-item)))
    (when item
      (=> item delete)
      (=> self &update-current-item)
      T
      )))

(defmethod (browser undelete-item) ()
  % Mark the current item as not deleted, if any.  Return T if the item exists,
  % NIL otherwise.

  (let ((item (=> self current-item)))
    (when item
      (=> item undelete)
      (=> self &update-current-item)
      T
      )))

(defmethod (browser view-item) ()
  % View the current item, if any, in a separate buffer.
  % Return the buffer if the item exists, NIL otherwise.

  (let ((item (=> self current-item)))
    (when item
      (when viewed-item
	(=> viewed-item cleanup))
      (setf viewed-item item)
      (=> item view-buffer view-buffer) % return the buffer
      )))

(defmethod (browser ignore-item) ()
  % Ignore the current item, if any.  Return T if the item exists.
  % Ignoring an item is like running a filter that accepts every item
  % except the current one, except that multiple successive ignores
  % coalesce into one filtered-item-set for undoing purposes.

  (let ((item (=> self &remove-current-item)))
    (when item
      (cond ((and filtered-items (eqcar (car filtered-items) 'IGNORE-COMMAND))
	     % add this item to the previous list of ignored items
	     (let ((filter-set (car filtered-items)))
	       (setf (cdr filter-set) (cons item (cdr filter-set)))
	       ))
	    (t (setf filtered-items
		 (cons (list 'IGNORE-COMMAND item) filtered-items))
	       )))))

(defmethod (browser filter-items) (filter)
  % Remove those items that do not match the specified filter.
  % If some items are removed, then they are added as a set to the
  % list of filtered items, so that this step can be undone, and T
  % is returned.  Otherwise, no new set is created, and NIL is returned.

  (let ((filtered-list (=> self &keep-items 'ev-send
			   (list 'apply-filter (list filter)))))
    (when filtered-list
      (setf filtered-list (cons filter filtered-list))
      (setf filtered-items (cons filtered-list filtered-items))
      T
      )))

(defmethod (browser undo-filter) ()
  % Undo the effect of the most recent active filtering step.
  % Return the filter or NIL if there are no active filtering steps.

  (when filtered-items
    (let ((filter (car (car filtered-items)))
	  (the-items (cdr (car filtered-items)))
	  (current-item (=> self current-item))
	  )
      (setf filtered-items (cdr filtered-items))
      (while the-items
	(let ((item (car the-items)))
	  (setf the-items (cdr the-items))
	  (setf last-item-index (+ last-item-index 1))
	  (vector-store items last-item-index item)
	  ))
      (=> self &sort-items)
      (=> self &update-display)
      (=> self select-item current-item)
      filter
      )))

(defmethod (browser exit) ()
  (setf viewed-item NIL)
  (for (from i 0 last-item-index)
       (do (=> (vector-fetch items i) cleanup)))
  )

(defmethod (browser items) ()
  % Return a list of the items.
  (for (from i 0 last-item-index)
       (collect (vector-fetch items i)))
  )

(defmethod (browser sort) (sorter)
  (let ((current-item (=> self current-item)))
    (setf current-sorter sorter)
    (=> self &sort-items)
    (=> self &update-display)
    (=> self select-item current-item)
    ))

(defmethod (browser send-item) (msg args)
  % Send the current item, if any, the specified message with the specified
  % arguments.  Return NIL if there is no current item; otherwise, return
  % the result of sending the message to the item.

  (let ((item (=> self current-item)))
    (when item
      (prog1
       (lexpr-send item msg args)
       (=> self &update-current-item)
       ))))

(defmethod (browser select-item) (item)
  % If ITEM is not NIL, then adjust the buffer pointer to point to
  % that item.

  (for (from i 0 last-item-index)
       (do (when (eq item (vector-fetch items i))
	     (=> display-buffer goto (+ i first-item-linepos) 0)
	     (exit)
	     ))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Private methods:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmethod (browser init) (init-plist)
  (=> display-buffer put 'browser self)
  (setf items (cond ((ListP items) (List2Vector items))
		    ((VectorP items) (CopyVector items))
		    (t (List2Vector ()))
		    ))
  (setf last-item-index (vector-upper-bound items))
  (=> self &sort-items)
  (=> self &update-display)
  )

(defmethod (browser &update-display) ()
  % Update the display.  The cursor is moved to the first item.
  (=> display-buffer reset)
  (when header-text
    (=> display-buffer insert-text header-text)
    (=> display-buffer insert-eol)
    )
  (setf first-item-linepos (=> display-buffer line-pos))
  (for (from i 0 last-item-index)
       (do (let ((item (vector-fetch items i)))
	     (=> display-buffer insert-line (=> item display-text))
	     )))
  (=> display-buffer set-modified? NIL)
  (=> display-buffer goto first-item-linepos 0)
  )

(defmethod (browser &sort-items) ()
  % Sort the items according to the current sorter, if any.
  % Do not update the display buffer.

  (when current-sorter
    (let ((list ()))
      (for (from i 0 last-item-index)
	   (do (setf list (cons (vector-fetch items i) list)))
	   )
      (setf list (GSort list current-sorter))
      (for (from i 0 last-item-index)
	   (do (vector-store items i (car list))
	       (setf list (cdr list))
	       ))
      )))

(defmethod (browser &remove-current-item) ()
  % Remove the current item from ITEMS and the display.
  % Return the item or NIL if there is no current item.

  (let ((index (=> self current-item-index)))
    (when index
      (let ((item (vector-fetch items index)))
	(for (from i (+ index 1) last-item-index)
	     (do (vector-store items (- i 1) (vector-fetch items i))
		 ))
	(vector-store items last-item-index NIL)
	(setf last-item-index (- last-item-index 1))
	(=> display-buffer move-to-start-of-line)
	(let ((start-pos (=> display-buffer position)))
	  (=> display-buffer move-to-next-line)
	  (=> display-buffer extract-region T start-pos
	      (=> display-buffer position))
	  (=> display-buffer set-modified? NIL)
	  )
	item
	))))

(defmethod (browser &update-current-item) ()
  % Update the display for the current item.
  (let ((index (=> self current-item-index)))
    (when index
      (let ((item (vector-fetch items index)))
	(=> display-buffer store-line (+ index first-item-linepos)
	    (=> item display-text))
	(=> display-buffer set-modified? NIL)
	))))

(defmethod (browser &keep-items) (fcn args)
  % Apply the function FCN once for each item.  The first argument to FCN
  % is the item; the remaining items are ARGS (a list).
  % Remove those items for which FCN returns NIL and return them
  % in a list of items.

  (let ((removed-items ())
	(ptr 0)
	(current-item-index (=> self current-item-index))
	(new-current-item-index 0)
	)
    (for (from i 0 last-item-index)
	 (do (let ((item (vector-fetch items i))
		   (this-ptr ptr)
		   )
	       (cond ((apply fcn (cons item args)) % keep it
		      (vector-store items ptr item)
		      (setf ptr (+ ptr 1))
		      )
		     (t % remove it
		      (setf removed-items (cons item removed-items))
		      (=> item cleanup)
		      ))
	       (when (and current-item-index (= i current-item-index))
		 (setf new-current-item-index this-ptr))
	       )))
    (setf last-item-index (- ptr 1))
    (=> self &update-display)
    (=> display-buffer goto (+ new-current-item-index first-item-linepos) 0)
    removed-items
    ))

(de &browser-item-not-killed (item)
  (or (not (=> item deleted?))
      (not (=> item kill))
      ))