On Mon, 03 Aug 2009 09:17:47 -0700 "Fred M. Gilham" gilham@AI.SRI.COM wrote:
Anyway I've attached some code that I think does what you want, from an old repository of CLIM code. It will probably require some hacking to make work.
Good luck.
-- Fred Gilham
thanks .. but it really does require some hacking. i'm not familier (enough) with the mcclim-internals. when trying to run the example (view-directory "~") as suggested in the comments, i get the following error:
#<COMMAND-TABLE-NOT-FOUND GROUP-VIEWER {B113131}> [Condition of type COMMAND-TABLE-NOT-FOUND]
i really come to like mcclim, but unfortunately i dont have time to hack around deep down.
alex
Am 03.08.2009 um 21:41 schrieb Alexander Ekart:
On Mon, 03 Aug 2009 09:17:47 -0700 "Fred M. Gilham" gilham@AI.SRI.COM wrote:
Anyway I've attached some code that I think does what you want, from an old repository of CLIM code. It will probably require some hacking to make work.
Good luck.
-- Fred Gilham
thanks .. but it really does require some hacking. i'm not familier (enough) with the mcclim-internals. when trying to run the example (view-directory "~") as suggested in the comments, i get the following error:
#<COMMAND-TABLE-NOT-FOUND GROUP-VIEWER {B113131}> [Condition of type COMMAND-TABLE-NOT-FOUND]
i really come to like mcclim, but unfortunately i dont have time to hack around deep down.
Would you mind forwarding the code to the list. I'd be quite intrigued to take a look at it.
Regards, Niko
P.S.: Why is the reply-to Header for this mailing list not the list, but the sender?
On Mon, 3 Aug 2009 21:47:39 +0200 Nikolaus Demmel demmeln@in.tum.de wrote:
Am 03.08.2009 um 21:41 schrieb Alexander Ekart:
On Mon, 03 Aug 2009 09:17:47 -0700 "Fred M. Gilham" gilham@AI.SRI.COM wrote:
Anyway I've attached some code that I think does what you want, from an old repository of CLIM code. It will probably require some hacking to make work.
Good luck.
-- Fred Gilham
thanks .. but it really does require some hacking. i'm not familier (enough) with the mcclim-internals. when trying to run the example (view-directory "~") as suggested in the comments, i get the following error:
#<COMMAND-TABLE-NOT-FOUND GROUP-VIEWER {B113131}> [Condition of type COMMAND-TABLE-NOT-FOUND]
i really come to like mcclim, but unfortunately i dont have time to hack around deep down.
Would you mind forwarding the code to the list. I'd be quite intrigued to take a look at it.
Regards, Niko
P.S.: Why is the reply-to Header for this mailing list not the list, but the sender?
sure, i just added a naiv draw-triangle* function, because it doesnt seem to be available in the clim-namespace (anymore).
here is the code:
;;; -*- 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.
;; added: 3.8.3009 ;; reason: not available by default? (defun draw-triangle* (stream x1 y1 x2 y2 x3 y3 &key filled) (declare (ignore filled)) (draw-line stream x1 y1 x2 y2) (draw-line stream x2 y2 x3 y3) (draw-line stream x3 y3 x1 y1))
(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) (directory pathname) #+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))
Alexander Ekart wrote:
;; added: 3.8.3009 ;; reason: not available by default? (defun draw-triangle* (stream x1 y1 x2 y2 x3 y3 &key filled) (declare (ignore filled)) (draw-line stream x1 y1 x2 y2) (draw-line stream x2 y2 x3 y3) (draw-line stream x3 y3 x1 y1))
Hi,
Apart from mailer/wrapping issues, the above should probably be
(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))
Your code gives me an error when I run it in Franz CLIM (which is what I have handy right now).
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))
Fred M. Gilham wrote:
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
Sorry for the noise, but to make the directory listing work right, the code I sent should be changed as follows. The "read-directory" defun should be
(defun read-directory (pathname) (directory (merge-pathnames pathname (make-pathname :name :wild :type :wild :version :wild))))
With that change, the files will show up as well as directories.
One thing that doesn't work is that the scroll bar won't change when you open and close directories.
Perhaps someone else can hack it some more.
-- Fred
On Mon, 03 Aug 2009 21:43:44 -0700 "Fred M. Gilham" gilham@AI.SRI.COM wrote:
Fred M. Gilham wrote:
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
Sorry for the noise, but to make the directory listing work right, the code I sent should be changed as follows. The "read-directory" defun should be
(defun read-directory (pathname) (directory (merge-pathnames pathname (make-pathname :name :wild :type :wild :version :wild))))
With that change, the files will show up as well as directories.
One thing that doesn't work is that the scroll bar won't change when you open and close directories.
Perhaps someone else can hack it some more.
-- Fred
nice. but when i run the code, i just see a window with the text "local" and a black triangle in front of it. if i click on the triangle, the triangle rotated by 90 degrees counter-clockwise, but nothing else happens. any suggestions? i'm using sbcl 1.0.11 on linux.
Am 04.08.2009 um 11:49 schrieb Alexander Ekart:
On Mon, 03 Aug 2009 21:43:44 -0700 "Fred M. Gilham" gilham@AI.SRI.COM wrote:
Fred M. Gilham wrote:
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
Sorry for the noise, but to make the directory listing work right, the code I sent should be changed as follows. The "read-directory" defun should be
(defun read-directory (pathname) (directory (merge-pathnames pathname (make-pathname :name :wild :type :wild :version :wild))))
With that change, the files will show up as well as directories.
One thing that doesn't work is that the scroll bar won't change when you open and close directories.
Perhaps someone else can hack it some more.
-- Fred
nice. but when i run the code, i just see a window with the text "local" and a black triangle in front of it. if i click on the triangle, the triangle rotated by 90 degrees counter-clockwise, but nothing else happens. any suggestions? i'm using sbcl 1.0.11 on linux.
It works fine over here (sbcl 1.0.29 + macos + latest mcclim).
Tried a different directory? Maybe update SBCL (1.0.30 is latest).
Regards, Niko
On Tue, 4 Aug 2009 12:17:58 +0200 Nikolaus Demmel demmeln@in.tum.de wrote:
It works fine over here (sbcl 1.0.29 + macos + latest mcclim).
Tried a different directory? Maybe update SBCL (1.0.30 is latest).
Regards, Niko
i'm proud to say that it works now :) it would be nice to have additional features like having actions that are associated with every tree-entry. but it already is a nice starting-point (well, it already was in 1992).
k.r., alex
-
Alexander Ekart -
Fred Gilham -
Fred M. Gilham
-
Nikolaus Demmel