CLIM mail archive
[Prev][Next][Index][Thread]
indented-lists.lisp
Date: Thu, 17 Dec 92 17:22:50 PST
From: bha <@ada3.ca.boeing.com:bha@gumby.boeing.com>
Any plans for a filename picker gadget for CLIM 2.0?
Thanks for reminding me. I just contributed a file called
indented-lists.lisp to the clim library to do just this.
It is similar to a Mac System-7 style directory browser.
It displays the elements of a directory, one element per
line. Elements that are themselves directories have a
triangle in the left column that will show/hide its contents.
Indentation accumulates in relation to tree depth.
It could be extended to become a chooser dialog box, but that
was beyond my immediate purpose in writing this code.
Here it is.
jeff morrill
;;; -*- 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.
(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 t)
(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)))
(: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 #-GENERA :UNSPECIFIC #+GENERA :NEWEST))
(defun read-directory (pathname)
#-genera
(directory pathname :directories-are-files nil)
#+genera
(mapcar #'(lambda (list)
(let ((path (car list)))
(if (second (member :directory (cdr list)))
(scl:send path :pathname-as-directory)
path)))
(cdr (fs:directory-list 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))
0,,
Follow-Ups:
Main Index |
Thread Index