Check-ins Using Download Hex

Artifact 0027d508366366403d49c6f46667ecfed8a0e1c9771ecf97a85a49c347b7a349:

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Browser.SL - Browser object definition
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        4 February 1983
% Revised:     14 March 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-Mar-83 Alan Snyder
%  New methods: enter, select, display-documentation, set-items, update-items,
%  filter-count, get, put.  New documentation fields, etc.  Create-Browser
%  changed incompatibly.
% 4-Mar-83 Alan Snyder
%  New methods: add-item and add-items.
% 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 numeric-operators))
(on fast-integers)
(load gsort)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% External variables:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(fluid '(nmode-top-window
	 nmode-bottom-window
	 nmode-current-window
	 nmode-current-buffer
	 browser-split-screen
	 read-only-text-mode
	 ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de create-browser (browser-kind
		    browser-kind-string
		    browser-info-string
		    display-buffer-mode
		    view-buffer
		    header-text
		    documentation-text
		    help-text
		    items
		    current-sorter
		    )

  % Create a brower.  BROWSER-KIND should be an ID that identifies the kind of
  % browser this is.  This ID is provided for optional use by the creator of
  % the browser to locate existing browsers of its kind.  BROWSER-KIND-STRING
  % should be a string that identifies the kind of browser this is.  This
  % STRING is used in the browser browser display.  BROWSER-INFO-STRING should
  % be a string that identifies this particular browser, as differentiated
  % from others of the same kind.  This STRING is used in the browser browser
  % display.

  % DISPLAY-BUFFER-MODE is the mode to use for the browser display buffer.
  % 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.
  % DOCUMENTATION-TEXT is a vector of strings to display in the documentation
  % buffer, which is displayed in the bottom window when there is no
  % currently-viewed item; it may be NIL.  HELP-TEXT is a vector of strings to
  % display at the bottom of the screen; it may be NIL.  The HELP-TEXT should
  % briefly list the available commands.  (Currently the HELP-TEXT should
  % consist of at most one string, which will be displayed in the message
  % window.)  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.

  (let ((browser (make-instance 'browser
				'browser-kind browser-kind
				'browser-kind-string browser-kind-string
				'browser-info-string browser-info-string
				'display-buffer-mode display-buffer-mode
				'view-buffer view-buffer
				'header-text header-text
				'documentation-text documentation-text
				'help-text help-text
				'items items
				'current-sorter current-sorter
				'display-width (=> nmode-top-window width)
				)))
    (nmode-register-browser browser)
    browser
    ))

(defflavor browser
  ((browser-kind NIL)		% ID identifying kind of browser
   (browser-kind-string "")	% string identifying kind of browser
   (browser-info-string "")	% string describing this particular browser

   (select-function NIL)	% function to invoke when selected (arg: self)
   (update-function NIL)	% function to invoke when updated (arg: self)

   display-width
   (display-buffer-mode NIL)	% mode of browser display buffer
   display-buffer		% buffer used to display items
   (view-buffer NIL)		% buffer used to view items (NIL => ask item)
   documentation-buffer		% buffer used to display documentation

   (header-text NIL)		% text displayed at top of buffer
   first-item-linepos		% line number of first item in display
   (documentation-text NIL)	% text displayed in documentation buffer
   (help-text NIL)		% text displayed in help line

   items			% vector of visible items (may have junk at end)
   last-item-index		% index of last valid item in ITEMS vector
   (viewed-item NIL)		% the item most recently viewed (or NIL)
   filtered-items		% list of lists of items removed by filtering
   (current-sorter NIL)		% sorter used if items are un-filtered

   (p-list NIL)			% association list of properties
   )
  ()
  (gettable-instance-variables
   browser-kind browser-kind-string display-width
   display-buffer help-text documentation-buffer
   )
  (settable-instance-variables
   browser-info-string
   select-function
   update-function
   )
  (initable-instance-variables
   browser-kind browser-kind-string display-width
   display-buffer-mode view-buffer header-text
   documentation-text help-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 update)
%   The item should check for any changes in the object that it represents and
%   update itself accordingly.  This method should return NIL if and only if
%   the object no longer exists, in which case it will be removed.  (The item
%   should clean itself up in this case.)  Updating is performed on active
%   items by the update-items method; in addtion, items that are unfiltered
%   are also updated at that time.
%
% (=> item apply-filter filter)
%   The item should apply the filter to itself and return T if the filter
%   matches the item and NIL otherwise.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Public methods for browsers:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmethod (browser select) ()
  % This method is invoked when the browser buffer is newly selected.
  (=> self &display-viewed-item)
  (=> self display-help)
  (when select-function (apply select-function (list self)))
  )
      
(defmethod (browser enter) ()
  % Entering a browser means selecting its display buffer in the current
  % window.

  (when (not (eq display-buffer nmode-current-buffer))
    (=> display-buffer set-previous-buffer nmode-current-buffer))
  (buffer-select display-buffer)
  )

(defmethod (browser exit) ()
  % Exiting a browser means to clean up its items and detach any of its
  % buffers from any windows.  It is still an active browser and may be
  % reentered later.

  (for (from i 0 last-item-index)
       (do (=> (vector-fetch items i) cleanup)))
  (if display-buffer
    (buffer-kill-and-detach display-buffer))
  (if documentation-buffer
    (buffer-kill-and-detach documentation-buffer))
  (if view-buffer
    (buffer-kill-and-detach view-buffer))
  )

(defmethod (browser display-help) ()
  (when (and help-text (not (vector-empty? help-text)))
    (write-message (vector-fetch help-text 0))
    ))

(defmethod (browser display-documentation) ()
  (=> documentation-buffer move-to-buffer-start)
  (=> self &set-viewed-item NIL)
  (cond (browser-split-screen
	 (=> nmode-bottom-window set-line-position 0)
	 (=> nmode-bottom-window adjust-window)
	 )
	(t
	 (browser-view-buffer documentation-buffer NIL)
	 )))

(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 add-item) (new-item)
  % Add the specified item to the set of items.  If a sort function is
  % currently defined, it will be used to sort the set of items.  The new item
  % becomes the current item.

  (=> self add-items (list new-item))
  )

(defmethod (browser add-items) (new-item-list)
  % Add the specified items to the set of items.  If a sort function is
  % currently defined, it will be used to sort the set of items.  The first
  % new item becomes the current item.

  (when new-item-list
    (let ((new-current-item (first new-item-list)))
      (=> self &insert-items new-item-list)
      (=> self &sort-items)
      (=> self &update-display)
      (=> self select-item new-current-item)
      )))

(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
      (=> self &set-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 update-items) ()
  % Ask all active items to update themselves.  Items that report that they
  % are no longer meaningful will be removed.  Then, the update-function
  % is called.  This function may choose to add new items for objects that
  % have been created since the browser was created.

  (=> self &keep-items 'ev-send '(update))
  (when update-function
    (apply update-function (list self))
    ))

(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.  All unfiltered
  % items are asked to update themselves.  Items that report that they are no
  % longer meaningful will be removed.

  (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))
	  (when (=> item update)
	    (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 filter-count) ()
  % Return the number of active filters.
  (length filtered-items)
  )

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

(defmethod (browser set-items) (new-items)
  % Replace the entire existing set of items (both active items and filtered
  % items) with a new set of items.  NEW-ITEMS may be a list or a vector.

  (for (from i 0 last-item-index)
       (do (=> (vector-fetch items i) cleanup)))
  (setf items (cond ((ListP new-items) (List2Vector new-items))
		    ((VectorP new-items) (CopyVector new-items))
		    (t (Vector))
		    ))
  (setf last-item-index (vector-upper-bound items))
  (setf filtered-items ())
  (=> self &set-viewed-item NIL)
  (=> self &sort-items)
  (=> self &update-display)
  )

(defmethod (browser sort) (sorter)
  % Specify a new sorting function and sort the items accordingly.
  (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)
	     ))))

(defmethod (browser get) (property-name)
  % Return the object associated with the specified property name (ID).
  % Returns NIL if named property has not been defined.

  (let ((pair (atsoc property-name p-list)))
    (if (PairP pair) (cdr pair))))

(defmethod (browser put) (property-name property)
  % Associate the specified object with the specified property name (ID).
  % GET on that property-name will henceforth return the object.

  (let ((pair (atsoc property-name p-list)))
    (if (PairP pair)
      (rplacd pair property)
      (setf p-list (cons (cons property-name property) p-list))
      )))

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

(defmethod (browser init) (init-plist)
  (setf last-item-index -1)
  (when (not display-buffer-mode)
    (setf display-buffer-mode Read-Only-Text-Mode))
  (setf display-buffer (create-unnamed-buffer display-buffer-mode))
  (when (and browser-info-string (not (string-empty? browser-info-string)))
    (=> display-buffer set-label-string
	(string-concat "(" browser-info-string ")")
	))
  (setf documentation-buffer (create-unnamed-buffer Read-Only-Text-Mode))
  (when documentation-text
    (=> documentation-buffer insert-text documentation-text)
    (=> documentation-buffer insert-eol)
    (=> documentation-buffer set-modified? NIL)
    (=> documentation-buffer move-to-buffer-start)
    (=> documentation-buffer set-label-string
	(string-concat "(Documentation on " browser-kind-string " browser)"))
    )
  (let ((old-browser (=> display-buffer get 'browser)))
    (when old-browser
      (=> old-browser exit)
      ))
  (=> display-buffer put 'browser self)
  (=> self set-items items)
  )

(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 &set-viewed-item) (item)
  (when (not (eq item viewed-item))
    (if viewed-item (=> viewed-item cleanup))
    (setf viewed-item item)
    (when (not viewed-item) (=> self &display-viewed-item))
    ))

(defmethod (browser &display-viewed-item) ()
  % This method causes the viewed item to be displayed in the bottom window,
  % if the browser is selected in the top window and the split-screen option
  % is selected.  If there is no viewed item, then the documentation buffer is
  % displayed.

  (when (and (eq nmode-current-window nmode-top-window) browser-split-screen)
    (let ((b (if viewed-item
	       (=> viewed-item view-buffer view-buffer)
	       documentation-buffer
	       )))
      (when b
	(=> b set-previous-buffer nmode-current-buffer)
	(window-select-buffer (nmode-other-window) b)
	(nmode-2-windows)
	))))

(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 &insert-items) (item-list)
  % Add the specified items to the end of the current set of items.  The
  % vector size is increased to ensure there is room for all items, including
  % any that may have been filtered out.

  (let ((new-items (mkvect (+ (vector-upper-bound items) (length item-list)))))
    (for (from i 0 last-item-index)
	 (do (vector-store new-items i (vector-fetch items i))))
    (for (in item item-list)
	 (do (setf last-item-index (+ last-item-index 1))
	     (vector-store new-items last-item-index item)
	     ))
    (setf items new-items)
    ))

(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)))
	(when (eq item viewed-item) (=> self &set-viewed-item NIL))
	(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 (eq item viewed-item) (=> self &set-viewed-item NIL))
		      ))
	       (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))
      ))
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]