;;; Copyright (c) 2017-2020 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen
;;; Author: John Carroll
;;; Version: 20-Mar-2020
;;; Distributed as part of the LKB System, under the MIT License
;;; see LICENSE file and http://moin.delph-in.net/LkbCopyright for conditions

(require
  #+(and :allegro (not :mswindows)) :climxm
  #+(and :allegro :mswindows) :climnt
  #+:lispworks "clim"
  #-(or :allegro :lispworks) :mcclim)

;;; If it's not already present, pick up some version of FAD - old versions should be OK

#-(or :fad :cl-fad)
(eval-when (:compile-toplevel :load-toplevel :execute) (require :cl-fad))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (fboundp (intern "PATHNAME-ROOT-P" :fad))
    ;; old version missing some of the latest functions
    (pushnew :fad-old-version *features*)))


(defpackage :select-file
  (:nicknames #:sf)
  (:use :clim-lisp :clim :clim-sys)
  (:export #:select-file #:file-selector #:list-directory #:list-places #:list-devices))

(in-package :select-file)


;;; A file selector for CLIM 2, including some programmable customization features.
;;; The API is inspired by select-file in the Franz Inc CLIM 2 User Guide, but is
;;; intended to be more usable than the Franz implementation, and to provide a facility
;;; that's missing from McCLIM (there is no select-file in the CLIM 2 Specification).
;;;
;;; Successfully tested in McCLIM master branch of 6-Mar-2024 with SBCL 2.4.1, and in
;;; Allegro CLIM 2.1 / Allegro CL 10.0. Not (yet) tested in clim-tos or LispWorks CLIM.
;;; Takes inspiration and some implementation ideas from the nice file browsers in the
;;; McCLIM Lisp Listener, Gsharp, and Ernestine.
;;;
;;;   select-file &rest args
;;;               &key (frame-name 'file-selector)
;;;                    title
;;;                    (prompt "Name:")
;;;                    (directory (user-homedir-pathname))
;;;                    (dialog-type :save)
;;;                    show-hidden-p
;;;                    (ok-label "OK")
;;;               &allow-other-keys
;;;
;;; Other keyword arguments are passed through to make-application-frame, so the programmer
;;; may also call select-file with arguments accepted by that function. These include:
;;;
;;;   left top right bottom
;;;   width height
;;;   icon properties
;;;   user-specified-position-p user-specified-size-p (only in Allegro CLIM)
;;;   text-style foreground background (only relevant for Allegro CLIM, since it passes these
;;;     arguments down to gadget panes)
;;;
;;; A calling program may specialize the file-selector class and pass the new class name via
;;; the :frame-name argument. The generic functions list-directory, list-places and list-devices
;;; can be specialised on this new file selector class. E.g.
;;;
;;;   (defclass my-file-selector (sf:file-selector) ())
;;;   (defmethod sf:list-places ((frame my-file-selector))
;;;     (append (call-next-method) (list #P"~/common-lisp/mcclim/")))
;;;   (sf:select-file :frame-name 'my-file-selector)
;;;
;;; The following potential issues have been tested: unreadable directories, 'hidden' files
;;; and directories, large directories (e.g. /usr/bin/), filenames containing non-printing
;;; characters, reentrancy (more than one concurrent dialog), 'places' that are files
;;; not directories, and larger/smaller default font sizes. It would have been good to have
;;; a drop-down menu containing the path to the directory being displayed, but unfortunately
;;; the obvious choice of using an option-list pane doesn't work since CLIM does not provide
;;; a standard way to dynamically update the items in an option-list.
;;;
;;; Distinctive features:
;;;
;;; * When dialog-type is :save, the user may type in a file name (for use as a "save file"
;;; dialog), when it is :open the user may only select existing files, and when it is
;;; :directory the user may only select existing directories.
;;; * If the user resizes the dialog, the files/directories pane updates its layout to make
;;; best use of the horizontal space.
;;; * The programmer can change the pre-supplied lists of files/directories, places and
;;; devices in the left-hand pane.
;;;
;;; Bugs:
;;;
;;; * In Allegro CLIM, clicking in the left or right browsing pane and then typing causes
;;; the characters to be written into the left browsing pane rather than the filename text
;;; input field.
;;;
;;; Examples:
;;;
;;; (sf:select-file)
;;; (sf:select-file :title "Open" :prompt "File:" :dialog-type :open :ok-label "Open")
;;; (sf:select-file :dialog-type :save :show-hidden-p t)
;;; (sf:select-file :dialog-type :directory)
;;; (sf:select-file :directory "/usr/bin/" :left 300 :top 200 :width 400 :height 600)

(defun select-file (&rest args
                    &key (frame-name 'file-selector)
                         title
                         (prompt "Name:") ; "Save As:" is appropriate for dialog-type :save
                         (directory (user-homedir-pathname)) 
                         (dialog-type :save)
                         show-hidden-p
                         (ok-label "OK") ; "Open", "Load" or "Save" may also be appropriate
                    &allow-other-keys)
  (check-type frame-name symbol)
  (check-type title (or string null))
  (check-type prompt (or string null))
  (check-type directory (or string pathname))
  (check-type dialog-type (member :open :save :directory))
  (check-type ok-label (or string null))
  (unless title
    (setq title
      (ecase dialog-type
        (:open "Select File")
        (:save "Specify File Name")
        (:directory "Select Directory"))))
  (unless prompt (setq prompt "Name:"))
  (setq directory
    (if directory
        (cl-fad:pathname-as-directory (pathname directory))
        (user-homedir-pathname)))
  (unless ok-label (setq ok-label "OK"))
  (setq args
    (loop for (k v) on args by #'cddr
        unless (or (eq k :frame-name) (eq k :title))
        nconc (list k v)))
  (let ((frame
          (apply #'make-application-frame frame-name
                                          :pretty-name title
                                          :prompt prompt
                                          :directory directory
                                          :dialog-type dialog-type
                                          :show-hidden-p show-hidden-p
                                          :ok-label ok-label
                                          args)))
    (setf (file-selector-files-dirs frame)
      (list-directory frame directory show-hidden-p))
    (run-frame-top-level frame)
    (file-selector-result frame)))


(defgeneric list-directory (frame dir &optional show-hidden-p)
  (:documentation "Returns a list of pathnames, the first being the parent directory of dir (or NIL if dir is the root of a file system) and the rest being the contents of dir. The show-hidden-p argument is passed through from the top-level call, and may be interpreted to filter out file names starting with a period."))

(defgeneric list-places (frame)
  (:documentation "Returns a list of pathnames, each of which is a regularly-used directory in which the user might want to select files."))

(defgeneric list-devices (frame)
  (:documentation "Returns a list of pathnames, each of which is the root of a currently mounted file system - either local or via a network."))


;;;

(defparameter +outline-gray+ #+:mcclim climi::*3d-dark-color* #-:mcclim (make-gray-color 0.59))

(defparameter +text-gray+ (make-gray-color 0.66))

(defparameter *cancel-button-string* "  Cancel  ")

(defclass places-devices-application-pane (application-pane)
  ())

(defclass files-dirs-application-pane (application-pane)
  ())

(define-application-frame file-selector ()
  ((prompt :initform nil
           :initarg :prompt
           :reader file-selector-prompt)
   (directory :initform ""
              :initarg :directory
              :reader file-selector-directory)
   (dialog-type :initform nil
                :initarg :dialog-type
                :reader file-selector-dialog-type)
   (show-hidden-p :initform nil
                  :initarg :show-hidden-p
                  :reader file-selector-show-hidden-p)
   (ok-label :initform nil
             :initarg :ok-label
             :reader file-selector-ok-label)
   (files-dirs :initform nil
               :accessor file-selector-files-dirs)
   (last-margin :initform nil
                :accessor file-selector-last-margin)
   (no-redisplay-bounds :initform '(0 . 0)
                        :accessor file-selector-no-redisplay-bounds)
   (result :initform nil
           :accessor file-selector-result))                  
  (:menu-bar nil)
  (:panes 
    (places-devices-pane
      (make-pane 'places-devices-application-pane
        :foreground +black+
        :background +white+
        :text-cursor nil ; needed in Allegro CLIM
        :display-time t
        :display-function #'display-places-devices))
    (files-dirs-pane
      (make-pane 'files-dirs-application-pane
        :foreground +black+
        :background +white+
        :text-cursor nil
        :display-time t
        :display-function #'display-files-dirs))
    (prompt-pane
      (make-pane 'label-pane
        :label (file-selector-prompt *application-frame*)
        #+:mcclim :max-width #+:mcclim '(:relative 0))) ; prevent the label stretching
    (selection-pane
      (make-pane 'text-field
        :foreground +black+
        :background +white+
        :editable-p
        (if (member (file-selector-dialog-type *application-frame*) '(:open :directory)) nil t)
        :value (namestring (file-selector-directory *application-frame*))
        :value-changed-callback
        #'(lambda (gadget new-value)
            (declare (ignore gadget))
            (with-application-frame (frame) (update-ok-button frame new-value)))
        :max-width +fill+))
    (ok-button
      (make-pane 'push-button
        :label
        (concatenate 'string "   " (file-selector-ok-label *application-frame*) "   ")
        :align-x :center
        #-:mcclim :show-as-default #+:mcclim :show-as-default-p t ; incorrect initarg in McCLIM
        :activate-callback #'ok-callback))
    (cancel-button
      (make-pane 'push-button
        :label *cancel-button-string*
        :align-x :center
        :activate-callback #'close-callback)))
  (:geometry :left 100 :top 100 :width 600 :height 400) ; default placement and size
  (:layouts
    (default
      (spacing (:thickness 15)
        (vertically (:y-spacing 15)
          (horizontally (:x-spacing 10 :equalize-height t)
            (1/4
              ;; in Allegro CLIM, outlining is grey by default - and indeed if we specify
              ;; the colour then the scroll bar also picks it up, which we don't want
              (clim:outlining (:thickness 1 #+:mcclim :background #+:mcclim +outline-gray+)
                (scrolling (:max-width 175
                            :scroll-bar :vertical :scroll-bars :vertical) ; CLIM spec ambiguous
                  places-devices-pane)))
            (3/4
              (clim:outlining (:thickness 1 #+:mcclim :background #+:mcclim +outline-gray+)
                (scrolling (:scroll-bar :vertical :scroll-bars :vertical)
                  files-dirs-pane))))
          (horizontally (:x-spacing 10 :align-y :center :equalize-height nil)
            prompt-pane
            ;; in McCLIM only, wrap whitespace and outline around text-field gadget, otherwise
            ;; it looks very cramped and the appearance is too flat
            #+:mcclim
            (outlining (:thickness 1 :background +outline-gray+)
              (outlining (:thickness 3 :background +white+) selection-pane))
            #-:mcclim selection-pane)
          ;; For two push-buttons of equal width on the left side of the frame, an approach
          ;; that works in Allegro CLIM is an hbox-pane split 50-50 inside another hbox
          ;; with a right fill. Unfortunately, this doesn't work in McCLIM since the button
          ;; with the narrower label fails to expand to its allotted half. Instead, we use
          ;; a grid-pane (not present in Allegro CLIM), using hboxes to add spacing since
          ;; the McCLIM grid-pane doesn't implement :x-spacing.
          (horizontally ()
            #+:mcclim
            (make-pane 'grid-pane
              :contents
              (list (list (horizontally () ok-button 5) (horizontally () 5 cancel-button))))
            #-:mcclim
            (horizontally (:x-spacing 10) (1/2 ok-button) (1/2 cancel-button))
            :fill)
          )))))

#+:mcclim
(defmethod clim-extensions:find-frame-type ((frame file-selector))
  ;; make file selector have more dialog-like window controls (e.g. no maximize button)
  :dialog)


;;; If the selected filename pane should be editable then keep keyboard focus on it so
;;; that user can edit it without first having to click on it - improves usability since
;;; keypresses have no role in the places/devices or files/directories panes.
;;; In McCLIM, we can reset focus to the filename pane at the start of every iteration of
;;; the CLIM command loop. Unfortunately, Allegro CLIM's command reader undoes this focus
;;; reset by calling stream-set-input-focus on the first application pane. We therefore
;;; stop stream-set-input-focus from doing anything when called on that pane; this at
;;; least prevents characters erroneously appearing there - but going further and resetting
;;; the focus at that point doesn't work for some reason.

#+:mcclim
(defmethod clim:read-frame-command :before ((frame file-selector) &key stream)
  (declare (ignore stream))
  (unless (member (file-selector-dialog-type frame) '(:open :directory))
    (let ((selection-pane (find-pane-named frame 'selection-pane)))
      (when selection-pane
        (setf (clim:port-keyboard-input-focus (clim:port frame)) selection-pane)))))
#-:mcclim
(defmethod clim:stream-set-input-focus ((stream places-devices-application-pane))
  (clim:port-keyboard-input-focus (clim:port (clim:pane-frame stream))))


(defmethod run-frame-top-level :before ((frame file-selector) &key &allow-other-keys)
  (update-ok-button
    frame (gadget-value (find-pane-named frame 'selection-pane))))

(defun update-ok-button (frame new-value)
  (let ((ok-button
          (find-pane-named frame 'ok-button))
        (directory-selected-p ; t/nil
          (if (cl-fad:directory-pathname-p new-value) t nil))
        (directory-required-p ; t/nil
          (eq (file-selector-dialog-type frame) :directory)))
    (when ok-button ; the gadget might not be associated with this frame yet
      (if (eq directory-selected-p directory-required-p)
          ;; avoid unnecessary redrawing of button gadget, which can be distracting
          (unless (gadget-active-p ok-button) (activate-gadget ok-button))
          (when (gadget-active-p ok-button) (deactivate-gadget ok-button))))))

(defun ok-callback (button)
  (declare (ignore button))
  (with-application-frame (frame)
    (setf (file-selector-result frame)
      (pathname (gadget-value (find-pane-named frame 'selection-pane))))
    (frame-exit frame)))

(defun close-callback (button)
  (declare (ignore button))
  (with-application-frame (frame) (frame-exit frame)))


;;; Detect resizing of the dialog by an :after method on allocate-space. A more direct
;;; solution might be be a handle-event method on window-configuration-event; however
;;; handle-event is called on the frame's top level sheet and it doesn't seem possible to
;;; specialise that sheet portably.

(define-file-selector-command com-resize-panes ((frame 'file-selector))
  (display-files-dirs
    frame (find-pane-named frame 'files-dirs-pane) t))

(defmethod allocate-space :after ((pane files-dirs-application-pane) width height)
  (declare (ignore width height))
  (let ((margin (stream-text-margin pane)))
    (with-application-frame (frame)
      (with-slots (last-margin) frame
        (cond
          ((null last-margin) ; a brand new frame, not a resize?
            (setf last-margin margin))
          ((> (abs (- margin last-margin)) 10) ; significant change since last redisplay attempt?
            (setf last-margin margin)
            (execute-frame-command frame `(com-resize-panes ,frame))))))))


;;; Files, folders and devices icon patterns

(defparameter +folder-icon+
  (make-pattern
#2A((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
    (0 1 2 2 2 2 1 0 0 0 0 0 0 0 0 0)
    (1 2 2 2 2 2 2 1 1 1 1 1 1 1 1 0)
    (1 3 3 3 3 3 3 3 3 3 3 3 3 3 1 4)
    (1 3 3 3 3 3 3 3 3 3 3 3 3 3 1 4)
    (1 5 5 5 5 5 5 5 5 5 5 5 5 5 1 4)
    (1 5 5 5 5 5 5 5 5 5 5 5 5 5 1 4)
    (6 5 5 5 5 5 5 5 5 5 5 5 5 5 6 4)
    (6 7 7 7 7 7 7 7 7 7 7 7 7 7 6 4)
    (6 7 7 7 7 7 7 7 7 7 7 7 7 7 6 4)
    (8 7 7 7 7 7 7 7 7 7 7 7 7 7 8 4)
    (8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 4)
    (0 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
    (list
      #+:mcclim +transparent-ink+ #-:mcclim +white+ ; Allegro CLIM pattern limitation
      (make-rgb-color 160/255 153/255 123/255)
      (make-rgb-color 239/255 229/255 186/255)
      (make-rgb-color 239/255 227/255 174/255)
      (make-rgb-color 173/255 173/255 173/255)
      (make-rgb-color 237/255 224/255 158/255)
      (make-rgb-color 145/255 138/255 103/255)
      (make-rgb-color 234/255 223/255 147/255)
      (make-rgb-color 119/255 113/255 85/255))))

(defparameter +document-icon+
  (make-pattern
#2A((0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0)
    (0 0 1 2 2 2 2 2 2 2 1 1 0 0 0 0)
    (0 0 1 2 2 2 2 2 2 2 1 3 1 0 0 0)
    (0 0 1 2 2 2 2 2 2 2 1 3 3 1 0 0)
    (0 0 1 2 2 2 2 2 2 2 1 1 1 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 4 4 5 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 2 2 2 2 2 2 2 2 2 2 1 4 0)
    (0 0 1 1 1 1 1 1 1 1 1 1 1 1 4 0)
    (0 0 0 4 4 4 4 4 4 4 4 4 4 4 4 0))
    (list
      #+:mcclim +transparent-ink+ #-:mcclim +white+ ; Allegro CLIM pattern limitation
      (make-rgb-color 112/255 112/255 112/255)
      (make-rgb-color 232/255 232/255 232/255)
      (make-rgb-color 255/255 255/255 255/255)
      (make-rgb-color 137/255 137/255 137/255)
      (make-rgb-color 99/255 99/255 99/255))))

(defparameter +up-folder-icon+
  (make-pattern
#2A((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
    (0 1 2 2 2 2 1 0 0 0 0 0 0 0 0 0)
    (1 2 2 2 2 2 2 1 1 1 1 1 1 1 1 0)
    (1 3 3 3 4 3 3 3 3 3 3 3 3 3 1 5)
    (1 3 3 4 4 4 3 3 3 3 3 3 3 3 1 5)
    (1 6 4 6 4 6 4 6 6 6 6 6 6 6 1 5)
    (1 6 6 6 4 6 6 6 6 6 6 6 6 6 1 5)
    (7 6 6 6 4 6 6 6 6 6 6 6 6 6 7 5)
    (7 8 8 8 8 4 8 8 8 8 8 8 8 8 7 5)
    (7 8 8 8 8 8 4 4 4 4 4 8 8 8 7 5)
    (9 8 8 8 8 8 8 8 8 8 8 8 8 8 9 5)
    (9 9 9 9 9 9 9 9 9 9 9 9 9 9 9 5)
    (0 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
    (list
      #+:mcclim +transparent-ink+ #-:mcclim +white+ ; Allegro CLIM pattern limitation
      (make-rgb-color 109/255 158/255 176/255)
      (make-rgb-color 189/255 232/255 252/255)
      (make-rgb-color 176/255 229/255 253/255)
      (make-rgb-color 0/255 0/255 0/255)
      (make-rgb-color 188/255 188/255 188/255)
      (make-rgb-color 154/255 219/255 253/255)
      (make-rgb-color 81/255 133/255 152/255)
      (make-rgb-color 140/255 211/255 251/255)
      (make-rgb-color 58/255 96/255 109/255))))

(defparameter +device-icon+
  (make-pattern
#2A((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0)
    (0 0 1 4 4 4 4 4 4 4 4 4 1 6 0 0)
    (0 1 3 3 3 3 3 3 3 3 3 3 3 1 6 0)
    (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 6)
    (1 2 2 2 2 2 2 2 2 2 2 2 2 2 1 6)
    (1 2 2 2 2 2 2 2 2 2 2 5 5 2 1 6)
    (1 2 2 2 2 2 2 2 2 2 2 5 5 2 1 6)
    (1 2 2 2 2 2 2 2 2 2 2 2 2 2 1 6)
    (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 6)
    (0 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
    (list
      #+:mcclim +transparent-ink+ #-:mcclim +white+ ; Allegro CLIM pattern limitation
      (make-rgb-color 112/255 112/255 112/255)
      (make-rgb-color 190/255 190/255 190/255)
      (make-rgb-color 220/255 220/255 220/255)
      (make-rgb-color 240/255 240/255 240/255)
      (make-rgb-color 48/255 240/255 48/255)
      (make-rgb-color 173/255 173/255 173/255))))


;;; Files and directories list pane

(eval-when (:load-toplevel :compile-toplevel :execute)
  (define-presentation-type file-dir-namestring ()))

(define-file-selector-command com-select-file-dir
    ((data 'file-dir-namestring :gesture (:select :menu nil)))
  (select-file-dir data))

(defun select-file-dir (data &optional relist-if-file-p)
  (let ((p (cadr data))
        (parent *application-frame*))
    (when (and relist-if-file-p (not (cl-fad:directory-pathname-p p)))
      (setq p (cl-fad:pathname-as-directory p)))
    (when (cl-fad:directory-pathname-p p)
      (with-slots (files-dirs show-hidden-p) parent
        (setf files-dirs
          (list-directory parent p show-hidden-p)))
      (display-files-dirs parent (find-pane-named parent 'files-dirs-pane)))
    (setf (gadget-value (find-pane-named parent 'selection-pane)) (namestring p))
    (update-ok-button parent p)))

(defun display-files-dirs (frame stream &optional lazyp)
  ;; if the lazyp flag is set and the right margin is between the end of the rightmost column
  ;; and what would be the start of the next rightmost column if there was enough room for one,
  ;; then don't attempt redisplay
  (let ((margin (stream-text-margin stream))
        (bounds (file-selector-no-redisplay-bounds frame)))
    (unless (and lazyp (< (car bounds) margin (cdr bounds)))
      (let*
        ((files-dirs (file-selector-files-dirs frame))
         (items
           (nconc
             (if (car files-dirs)
                 (list (list* "Parent directory" (car files-dirs) 'parent))
                 nil)
             (mapcar
               #'(lambda (p)
                   (list* (file-dir-namestring p) p
                     (if (cl-fad:directory-pathname-p p) 'folder 'document)))
               (cdr files-dirs)))))
        (display-fs-items items stream 'file-dir-namestring t)))))


;;; Draw the contents of the places/devices and directories/files panes. Each item to
;;; be drawn is either a sub-heading string or a list of the form
;;; (namestring pathname . type) where type is one of {device, parent, folder, document}.
;;; After display, compute the range of right margin values for which there would be no
;;; point in attempting to redisplay the table, since the number of columns would not
;;; change.

(defun display-fs-items (items stream presentation-type mcolumnsp)
  (let ((x-offset 2) (x-spacing (text-size stream "M")) (y-spacing 3))
    (window-clear stream)
    (setf (stream-cursor-position stream)
          (values x-offset (stream-vertical-spacing stream)))
    (formatting-table (stream :x-spacing x-spacing :y-spacing y-spacing
                       :multiple-columns mcolumnsp :equalize-column-widths t
                       :move-cursor nil)
      (formatting-column (stream)
        (dolist (item items)
          (formatting-cell (stream :align-y :top)
            (multiple-value-bind (x y)
                (stream-cursor-position stream)
              (etypecase item
                (string (draw-heading stream item x y))
                (cons
                  (with-output-as-presentation (stream item presentation-type :single-box t)
                    (let ((icon
                            (ecase (cddr item)
                              (device +device-icon+)
                              (parent +up-folder-icon+)
                              (folder +folder-icon+)
                              (document +document-icon+))))
                      (draw-namestring stream icon (car item) x y))))))))))
    ;; since this is a :display-time t pane, we are in charge of redisplay so we can't
    ;; expect the frame's top-level function to notice and act on a change in the size of
    ;; the pane's content - we must do it ourselves
    (let ((hist (stream-output-history stream)))
      (change-space-requirements stream
        :width (bounding-rectangle-max-x hist)
        :height (+ (bounding-rectangle-max-y hist) y-spacing))
      (setf (file-selector-no-redisplay-bounds (pane-frame stream))
        (compute-no-redisplay-bounds hist x-offset x-spacing)))
    #+:mcclim ; force scroll bar thumb to adjust its size if necessary
    (clim:dispatch-repaint (clim:pane-scroller stream) clim:+everywhere+)))

(defun draw-heading (stream text x y)
  (draw-text* stream text x y
    :align-y :top :ink +text-gray+
    :text-style
    (merge-text-styles (make-text-style nil :bold :smaller) (medium-text-style stream))))

(defun draw-namestring (stream icon label x y)
  (flet
    ((backup/lock-namestring-p (s) ; avoid dependency on regexp for such trivial matching
       (or (some #'(lambda (prefix) (eql (mismatch prefix s) (length prefix)))
                 '("~$" ".~lock."))
           (some #'(lambda (suffix) (eql (mismatch suffix s :from-end t) 0))
                 '("~" "#" ".bak")))))
    ;; in this context, standard presentation highlighting looks too tight horizontally,
    ;; so draw invisible points just beyond left and right ends to force it outwards
    (draw-point* stream (1- x) (1- y) :line-thickness 1 :ink +white+)
    ;; for large fonts scale up icons to match
    (let ((lh (stream-line-height stream)))
      (setq icon
        (cond ((> lh 24) (transform-region (make-scaling-transformation 1.5 1.5) icon))
              ((> lh 20) (transform-region (make-scaling-transformation 1.25 1.25) icon))
              (t icon))))
    (draw-pattern* stream icon x 
      (+ y (- (floor (stream-line-height stream) 2) (floor (pattern-height icon) 2))))
    (incf x (+ (pattern-width icon) 4))
    (draw-text* stream label x y
      :align-y :top
      :ink (if (or (backup/lock-namestring-p label)
                   ;; in save dialogs de-emphasize existing documents
                   (and (eq icon +document-icon+)
                        (eq (file-selector-dialog-type (pane-frame stream)) :save)))
               +text-gray+ +black+))
    (draw-point* stream (+ x (text-size stream label) #+:mcclim 2 #-:mcclim 1) (1- y)
      :line-thickness 1 :ink +white+)))

(defun compute-no-redisplay-bounds (history x-offset x-spacing)
  ;; compute range of right margin values for which the number of columns can't differ
  ;; from the number currently being displayed
  (let ((max-left 0) (max-right 0) (max-width 0))
    (labels ((traverse (rec)
               (clim:map-over-output-records 
                 #'(lambda (r)
                     (when (cell-output-record-p r)
                       (let ((left (bounding-rectangle-min-x r))
                             (right (bounding-rectangle-max-x r)))
                         (setq max-left (max left max-left)
                               max-right (max right max-right)
                               max-width (max (- right left) max-width))))
                     (traverse r))
                 rec)))
      (traverse history)
      (cons
        (if (> max-left x-offset) (+ max-right x-spacing) 0)
        (+ max-left (* (+ max-width x-spacing) 2))))))


;;; Return a list of pathnames in directory dir, headed by the pathname of the parent
;;; of this directory (or nil if we're at the root of this file system).

(defmethod list-directory ((frame file-selector) dir &optional show-hidden-p)
  ;; we need list-directory to follow symlinks otherwise it's not possible to follow a
  ;; symbolic link to a directory (e.g. tmp -> private/tmp, since in this case tmp
  ;; looks like a normal file)
  (flet
    ((sorted-filtered-ls (d)
        ;; macOS always encodes file names as Unicode NFD no matter what the locale setting
        ;; is, so avoid a possible error here (in sbcl it's sb-int:c-string-decoding-error)
        ;; by ignoring a possibly misleading setting
        (let* (#+(and :sbcl :darwin) (sb-alien::*default-c-string-external-format* :utf-8)
               (items (cl-fad:list-directory d)))
          (sort
            (if show-hidden-p
                items
                (remove-if #'(lambda (p) (eql (char (file-dir-namestring p) 0) #\.)) items))
            #'string<
            :key #'file-dir-namestring))))
    (cons
      (if (pathname-root-p dir) nil (pathname-parent-directory dir))
      (handler-case
          (sorted-filtered-ls dir)
        (error (e)
          (warn "Unable to list directory ~A: ~A" dir e)
          nil)))))

(defun file-dir-namestring (x &optional homedir-tilde-p)
  (cond
    ((not (cl-fad:directory-pathname-p x))
      (file-namestring x))
    ((pathname-root-p x) ; NB could encounter root here via a symbolic link
      (directory-namestring x))
    ((and homedir-tilde-p (equal x (user-homedir-pathname)))
      (let ((dir (car (last (pathname-directory x)))))
        (concatenate 'string #+:unix "~" (if (and dir (stringp dir)) dir "home"))))
    (t
      (car (last (pathname-directory x))))))

(defun pathname-root-p (p)
  ;; this function is missing from old versions of cl-fad
  #-:fad-old-version
  (cl-fad:pathname-root-p p)
  #+:fad-old-version
  (equal (pathname-directory p) '(:absolute)))

(defun pathname-parent-directory (p)
  ;; this function is missing from old versions of cl-fad
  ;; p known not to be root
  #-:fad-old-version
  (cl-fad:pathname-parent-directory p)
  #+:fad-old-version
  (make-pathname :directory (butlast (pathname-directory p)) :defaults p))


;;; Places and devices list pane: contains user home directory, any useful files or directories
;;; (achieved by specialising list-places), and roots of file systems on mounted devices.

(eval-when (:load-toplevel :compile-toplevel :execute)
  (define-presentation-type place-device-namestring ()))

(define-file-selector-command com-select-place-device-namestring
    ((data 'place-device-namestring :gesture (:select :menu nil)))
  (display-places-devices
    *application-frame*
    (find-pane-named *application-frame* 'places-devices-pane))
  (select-file-dir data t))

(defun display-places-devices (frame stream)
  (display-fs-items
    (nconc
      (list "PLACES")
      (mapcar
        #'(lambda (p)
           (list* (file-dir-namestring p t) p 
             (if (cl-fad:directory-pathname-p p) 'folder 'document)))
        (list-places frame))
      (list " " "DEVICES")
      (mapcar
        #'(lambda (p) (list* (place-device-namestring p) p 'device))
        (list-devices frame)))
    stream 'place-device-namestring nil))

(defun place-device-namestring (x)
  ;; return name containing pathname device and last component of directory (if any) - to
  ;; look like a "device" as might be shown to the user on the desktop
  (let ((dev (pathname-device x))
        (dir (car (last (pathname-directory x)))))
    (when dir
      (unless (stringp dir) (setq dir nil)))
    (cond
      ((and dev
         (or (stringp dev) (symbolp dev) (characterp dev))
         (not (member dev '(:unspecific :unc))))
        (concatenate 'string (string dev) ":" dir))
      (dir)
      (t (directory-namestring x)))))


;;; Return a list of pathnames representing common places (= directories) in which the user
;;; might want to select files.

(defmethod list-places ((frame file-selector))
  (list (user-homedir-pathname)))


;;; Return a sorted list of pathnames representing roots of all mounted file systems. In
;;; Allegro CL on Windows there is a built-in function that does most of the work; on macOS,
;;; file systems are available under /Volumes/; and so on for other operating system / CL
;;; implementation combinations.

(defmethod list-devices ((frame file-selector))
  (sort
    (progn
      #+(and :mswindows :allegro)
      (mapcar
        #'(lambda (dev) (make-pathname :device (string dev) :directory '(:absolute)))
        (windows:file-systems)) ; Allegro CL only, defined in the :winapi module
      #+(and :mswindows (not :allegro))
      (list (make-pathname :device "C" :directory '(:absolute)))
      #+:darwin ; = macOS
      (cl-fad:list-directory "/Volumes/")
      #+:linux
      (append (list (make-pathname :directory '(:absolute)))
              (cl-fad:list-directory "/mnt/")
              (cl-fad:list-directory "/media/"))
      #+(and :bsd (not :darwin))
      (cons (make-pathname :directory '(:absolute)) (cl-fad:list-directory "/mnt/"))
      #-(or :mswindows :darwin :linux :bsd)
      (list (make-pathname :directory '(:absolute))))
    #'(lambda (p1 p2)
        (let ((p1-dev (pathname-device p1)) (p1-dir (car (last (pathname-directory p1))))
              (p2-dev (pathname-device p2)) (p2-dir (car (last (pathname-directory p2)))))
          (cond
            ((and p1-dev (null p2-dev)) t)
            ((and p2-dev (null p1-dev)) nil)
            ((or p1-dev p2-dev) (string< (string p1-dev) (string p2-dev)))
            ((and p1-dir (symbolp p1-dir)) t)
            ((and p2-dir (symbolp p2-dir)) nil)
            (t (string< (string p1-dir) (string p2-dir))))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :select-file-lkb *features*))