Artifact 61489b62fd16604d3d5a1a39c81ed93a7693c2c34e2c83bb2e1dd5abc120897b:

• File psl-1983/nmode/browser.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12998) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% 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))
      ))