I hacked the thing a bit so it sort of works under McClim / SBCL.
Code is attached. To try it out do something along the lines of
(view-directory "/usr/local/")
(SBCL won't understand "~" as a directory path).
-- Fred Gilham
;;; -*- Syntax: Common-lisp; Package: clim-user -*-
(in-package :clim-user)
;;; Indented lists are a way of displaying hierarchical (tree) structure. ;;; Each non-terminal tree node is prefixed by an icon that shows whether ;;; the item is "open" or "closed". If open, the inferiors of the node ;;; are displayed directly below it, with indentation accumulating ;;; in relation to tree depth. For terminal nodes, there is no icon. ;;; ;;; Try: ;;; (view-directory "~") ; unix ;;; (view-directory "disneyland:>mickey-mouse>*.*.*") ; lispm ;;; ;;; Written by Jeff Morrill (jmorrill@bbn.com), December 92. ;;; It is provided "as is" without express or implied warranty. ;;; Thanks to Scott McKay for solving an incremental redisplay problem. ;;; ;;; ************************************************************
;;; The basic protocol. Non-terminal nodes are called "groups." ;;; Everything that is not a group is considered to be a terminal node.
(defun draw-triangle* (stream x1 y1 x2 y2 x3 y3 &key filled) (clim:draw-polygon* stream (list x1 y1 x2 y2 x3 y3) :filled filled))
(defclass essential-group () ((display-contents :initform nil :initarg :display-contents :accessor display-contents)))
(defmethod group-p ((self t)) nil) (defmethod group-p ((self essential-group)) t) (defmethod group-contents ((group t)) nil) (defmethod group-name ((group t)) group)
(defmethod toggle-open ((group t)) (setf (display-contents group) (not (display-contents group))))
(defmethod indented-list-presentation-type ((group t) default) default) (defmethod indented-list-indentation ((group t)) 3)
(defmethod display-indented-list ((group t) presentation-type stream indentation) ;; This presents the "name" part of both groups and nongroups. (updating-output (stream :unique-id group :cache-value group) (multiple-value-bind (x y) (stream-cursor-position stream) (declare (ignore x)) (stream-set-cursor-position stream (+ (* (stream-character-width stream #\m) indentation) (stream-line-height stream)) y) (present (group-name group) presentation-type :stream stream) (terpri stream))))
(defmethod display-indented-list :around ((group essential-group) presentation-type stream indentation) ;; This displays the icon and the group-contents of a group. (updating-output (stream :unique-id group) (draw-indented-list-handle group stream) (call-next-method) (when (display-contents group) (let ((i (indented-list-indentation group)) (type (indented-list-presentation-type group presentation-type))) (dolist (child (group-contents group)) (display-indented-list child type stream (+ indentation i)))))))
(defun draw-indented-list-handle (group stream) "Draw the opened/closed icon (a triangle)" (updating-output (stream :unique-id 'list-handle :cache-value (display-contents group)) (with-output-as-presentation (stream group 'indented-list :single-box t) (let* ((open-p (display-contents group)) (h (- (stream-line-height stream) 2)) (h/2 (truncate h 2))) (multiple-value-bind (x y) (stream-cursor-position stream) (incf y 1) (incf x h/2) (let* ((x1 (+ x h/2)) (y1 (+ y h/2)) (x2 x) (y2 y) (x3 (if open-p (+ x h) x)) (y3 (if open-p y (+ y h)))) (draw-triangle* stream x1 y1 x2 y2 x3 y3 :filled t) (draw-point* stream (+ x h) (+ y h) :ink +background-ink+) (draw-point* stream (if open-p x (+ x h)) (if open-p (+ y h) y) :ink +background-ink+ )) (stream-set-cursor-position stream (+ x h h) y))))))
;;; ************************************************************
;;; A presentation type and an action for open/close operations.
(define-presentation-type indented-list (&optional presentation-type))
(define-presentation-method accept ((type indented-list) stream (view textual-view) &key) (accept presentation-type :stream stream :prompt nil))
(define-presentation-method describe-presentation-type ((type indented-list) stream plural-count) (declare (ignore plural-count)) (describe-presentation-type presentation-type stream))
(define-presentation-method present (object (type indented-list) stream (view textual-view) &key) (display-indented-list object presentation-type stream (indented-list-indentation object)))
(define-command-table :indented-lists)
(define-presentation-action com-toggle-open (indented-list command :indented-lists :gesture :select :documentation "Reveal/Hide Contents" :menu nil) (object window) (progn (toggle-open object) (redisplay-frame-pane *application-frame* window)))
;;;************************************************************
;;; A generic application for viewing groups.
(define-application-frame group-viewer () ((group-viewer-group :initform nil :accessor group-viewer-group) (group-viewer-ptype :initform nil :accessor group-viewer-ptype) (displayer :initform nil :accessor group-viewer-displayer)) (:command-table (:group-viewer :inherit-from (:indented-lists))) (:menu-bar nil) (:panes (display (scrolling () (make-pane 'application-pane :display-function 'display-viewer-group :display-time :no-clear)))) (:layouts (default (vertically () display))))
(defun display-or-redisplay-group (group presentation-type stream displayer) (cond ((not displayer) (window-clear stream) (with-end-of-line-action (stream :allow) (with-end-of-page-action (stream :allow) (setq displayer (updating-output (stream :unique-id :top-level) (display-indented-list group presentation-type stream (indented-list-indentation group))))))) (t (redisplay displayer stream))) displayer)
(defun display-viewer-group (program stream) (setf (group-viewer-displayer program) (display-or-redisplay-group (group-viewer-group program) (group-viewer-ptype program) stream (group-viewer-displayer program))))
(defvar *viewer* nil)
(defun view-group (group presentation-type) (let ((frame (or *viewer* (setq *viewer* (make-application-frame 'group-viewer :left 0 :top 0 :right 400 :bottom 400)))))
(setf (group-viewer-group frame) group (group-viewer-ptype frame) presentation-type (group-viewer-displayer frame) nil) (run-frame-top-level frame)))
;;;************************************************************
;;; An application for viewing file directories.
(defun directory-p (pathname) (not (pathname-name pathname)))
(defun directory-name (pathname) (let ((list (pathname-directory pathname))) (when (consp list) (string (car (last list))))))
(defun file-name (pathname) (file-namestring pathname))
(defun make-directory-pathname (directory) (make-pathname :defaults directory :name nil :type nil :version :UNSPECIFIC))
(defun read-directory (pathname) (let ((pathname-directory (pathname-directory pathname))) (directory (make-pathname :directory (append pathname-directory (list :wild)) :defaults pathname))))
(defclass directory-display (essential-group) ((pathname :initarg :pathname :accessor encapsulated-pathname) (contents :accessor group-contents)))
(defmethod print-object ((self directory-display) stream) (format stream "#<~A>" (group-name self)))
(defmethod group-name ((self directory-display)) (directory-name (encapsulated-pathname self)))
(defmethod group-contents :around ((self directory-display)) (if (not (slot-boundp self 'contents)) (let* ((stuff (read-directory (encapsulated-pathname self)))) (setf (group-contents self) (append (mapcar #'(lambda (p) (make-instance 'directory-display :pathname (make-directory-pathname p))) (sort (remove-if-not #'directory-p stuff) #'string-lessp :key #'directory-name)) (sort (mapcar #'file-name (remove-if #'directory-p stuff)) #'string-lessp)))) (call-next-method self)))
(defun view-directory (directory) (view-group (make-instance 'directory-display :pathname (make-directory-pathname directory) :display-contents t) 'string))