clim-utils.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;;; New button types
   4
   5 (in-package :clim-internals)
   6
   7 ;; These are specialised PUSH-BUTTON implementations. PUSH-BUTTON
   8 ;; deals with behaviour and with drawing and animating the button. In
   9 ;; the CLIM specs, it also has a label string which it prints. The
  10 ;; label is used at two points: space calculation and drawing.
  11 ;;
  12 ;; Spacing -- COMPOSE-SPACE: slightly worrying because I don't really
  13 ;; understand how layout works, but seems generally ok
  14 ;;
  15 ;; Drawing is handled by two functions -- DRAW-LABEL*, which is a
  16 ;; generic function, specialised here easily enouth, and
  17 ;; DRAW-ENGRAVED-LABEL*, which handles pressed buttons by calling
  18 ;; DRAW-LABEL* twice, with different settings positions and inks. This
  19 ;; isn't a generic, so I can't do anything about it. Since my
  20 ;; DRAW-LABEL* ignores ink, the 3d effect is lost.
  21
  22 ;;; ICON-PUSH-BUTTON
  23 ;; Push button that shows an icon *instead* of text. Perhaps this
  24 ;; should be optionally with text. The icon must be in XPM format, but
  25 ;; not for any readily apparent reason (more readers are in /Extensions)
  26 (defclass icon-push-button (push-button)
  27   ((icon-path :initarg :icon-path :accessor icon-path)
  28    (icon :initarg :icon :initform nil)))
  29 (defgeneric icon (button))
  30 (defmethod icon ((button icon-push-button))
  31   ;; Once an icon file has been imported once, just return the
  32   ;; object. Perhaps it'd be better to do this when the object is
  33   ;; initialised.
  34   (unless (and (slot-boundp button 'icon)
  35                (slot-value button 'icon))
  36     (when (probe-file (icon-path button))
  37       (setf (slot-value button 'icon)
  38             (make-pattern-from-bitmap-file
  39              (icon-path button)
  40              :format :xpm :port nil))))
  41   (slot-value button 'icon))
  42 (defclass icon-push-button-pane (icon-push-button push-button-pane)
  43   ())
  44 (define-abstract-pane-mapping 'icon-push-button 'icon-push-button-pane)
  45 (defmethod compose-space ((gadget icon-push-button-pane) &key width height)
  46   ;; FIXME: I don't really know what these values should be
  47   (let* ((pw (pattern-width (icon gadget)))
  48          (ph (pattern-height (icon gadget)))
  49          (w (+ pw
  50                (* 2 (+ *3d-border-thickness*
  51                        (or (pane-x-spacing gadget)
  52                            0)))))
  53          (h (+ ph (* 2 (+ *3d-border-thickness*
  54                           (or (pane-y-spacing gadget)
  55                               0))))))
  56     (make-space-requirement
  57      :width (or width w)
  58      :min-width w
  59      :height (or height h)
  60      :min-height h)))
  61 (defmethod draw-label* ((pane icon-push-button) x1 y1 x2 y2
  62                         &key ink)
  63   (declare (ignore ink))
  64   (draw-pattern* pane (icon pane) x1 y1))
  65
  66 ;;; DRAWN-PUSH-BUTTON
  67 ;; A push button whose image is created using DRAWING-FUNCTION (which
  68 ;; takes (STREAM X Y). I'm presetting width and height, because I
  69 ;; don't understand CLIM layout functionality. Alternatives include
  70 ;; storing a funcall to use in COMPOSE-SPACE or just making the
  71 ;; drawing function work with whatever size it's given. I'm also
  72 ;; making it a full CLIM-STREAM-PANE, because it works. Is it
  73 ;; necessary?
  74
  75 (defclass drawn-push-button (push-button)
  76   ((drawing-function :initarg :drawing-function :accessor button-drawing-function)
  77    (drawing-width :initarg :drawing-width :accessor drawing-width)
  78    (height :initarg :drawing-height :accessor drawing-height)))
  79 (defclass drawn-push-button-pane (drawn-push-button push-button-pane clim-stream-pane)
  80   ())
  81 (define-abstract-pane-mapping 'drawn-push-button 'drawn-push-button-pane)
  82 (defmethod compose-space ((gadget drawn-push-button-pane) &key width height)
  83   (let* ((dw (drawing-width  gadget))
  84          (dh (drawing-height gadget))
  85          (w (+ dw (* 2 (+ *3d-border-thickness*
  86                           (or (pane-x-spacing gadget)
  87                               0)))))
  88          (h (+ dh (* 2 (+ *3d-border-thickness*
  89                           (or (pane-y-spacing gadget)
  90                               0))))))
  91     (make-space-requirement
  92      :width (or width w)
  93      :min-width w
  94      :height (or height h)
  95      :min-height h)))
  96 (defmethod draw-label* ((pane drawn-push-button) x1 y1 x2 y2
  97                         &key ink)
  98   (declare (ignore ink))
  99   (funcall (button-drawing-function pane) pane x1 y1))
 100
 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103 ;;
 104 ;;; File dialogue stuff
 105 ;;
 106 ;; Dialogue box for file browing operations. Takes an object and puts
 107 ;; the resulting pathname into it (for now, this means we can only
 108 ;; handle single files). User can optionally provide acceptable file
 109 ;; extensions, which will disallow clicking on other files (the user
 110 ;; can override this by ctrl-clicking).
 111 ;;
 112 ;; This really ought to go somewhere in CLIM, but it uses code from
 113 ;; CLIM-LISTENER, so would probably need a package that doesn't exist
 114 ;; or for some of the listener functionality to be moved somewhere
 115 ;; useful.
 116
 117 (in-package :gsharp)
 118
 119 (defparameter *file-text-style*
 120   (make-text-style :sans-serif :roman :small))
 121 ;; Transport for holding pathname info between application frame and
 122 ;; caller
 123 (defstruct filespec (pathname))
 124 ;; FIXME: way to pass initargs to application gadget
 125 (defparameter *init-info* "")
 126
 127 (define-command-table path-input)
 128 ;; (defclass file-browser-pane (esa-pane-mixin application-pane) ())
 129 (define-gesture-name :adjust :pointer-button (:left :control))
 130 (define-gesture-name :hidden :keyboard (#\h :control))
 131
 132 (defun read-text-path (gadget)
 133   (let ((new-path (pathname (gadget-value gadget))))
 134     (if (clim-listener::directoryp new-path)
 135         (setf (current-path *application-frame*)
 136               new-path)
 137         (setf (current-path *application-frame*)
 138               (make-pathname :directory (pathname-directory new-path))))
 139     (redraw-file-browser-windows *application-frame*)))
 140
 141 (define-application-frame file-browser (standard-application-frame)
 142   ((current-path :initarg :path :accessor current-path)
 143    (extensions :initarg :extensions :accessor extensions :initform nil)
 144    (show-hidden :initarg :hidden :accessor show-hidden :initform nil)
 145    (sort-predicate :initarg :sort :accessor sort-predicate :initform
 146                    #'directory-alpha-sort)
 147    (final-file :initarg :file :accessor final-file
 148                :initform (make-filespec :pathname "")))
 149   (:menu-bar nil)
 150   (:panes
 151    (path-input :text-field :text-style *file-text-style*
 152                :command-table 'file-browser
 153                :value (get-gadget-value :path-input)
 154                :activate-callback #'read-text-path)
 155    (browser (make-pane 'application-pane
 156                        :width 800
 157                        :height 300
 158                        :text-style *file-text-style*
 159                        :command-table 'file-browser
 160                        :display-function 'display-folder))
 161    (ok-button
 162     :push-button :label "Ok"
 163     :activate-callback
 164     #'(lambda (gadget)
 165         (declare (ignore gadget))
 166         (setf (filespec-pathname (final-file *application-frame*))
 167               (pathname
 168                (gadget-value (find-pane-named *application-frame*
 169                                               'path-input))))
 170         (frame-exit *application-frame*)))
 171    (cancel-button
 172     :push-button :label "Cancel"
 173     :activate-callback
 174     #'(lambda (gadget)
 175         (declare (ignore gadget))
 176         (setf (filespec-pathname (final-file *application-frame*)) "")
 177         (frame-exit *application-frame*))))
 178   (:layouts
 179    (default
 180        (vertically ()
 181          path-input
 182          (scrolling () browser)
 183          (horizontally () ok-button cancel-button +fill+)))))
 184
 185 (defun redraw-file-browser-windows (frame)
 186   (redisplay-frame-pane frame
 187                         (find-pane-named frame 'browser)
 188                         :force-p t)
 189   (redisplay-frame-pane frame
 190                         (find-pane-named frame 'path-input)
 191                         :force-p t))
 192
 193 (defmethod display-folder (frame pane)
 194   (let* ((main-path (current-path frame))
 195          (path (if (clim-listener::directoryp main-path)
 196                    (clim-listener::show-directory-pathnames main-path)
 197                    (clim-listener::show-directory-pathnames (directory-name main-path)))))
 198     (browser-show-directory
 199      pane
 200      ;;   (clim-listener::show-directory-pathnames (current-path frame))
 201      path
 202      :show-hidden (show-hidden frame)
 203      :sort-predicate (sort-predicate frame))))
 204
 205 (defun dir-parent (path)
 206   (merge-pathnames (make-pathname :directory '(:relative :back))
 207                    path))
 208
 209 (defun parent-dir (path)
 210   (let ((dirs (pathname-directory path)))
 211     (make-pathname :directory (subseq dirs 0 (1- (length dirs))))))
 212
 213 (defun hiddenp (path)
 214   (char= (elt (if (clim-listener::directoryp path)
 215                   (directory-name path)
 216                   (pathname-name path))
 217               0)
 218          #\.))
 219 (defun directory-name (path)
 220   (car (last (pathname-directory path))))
 221
 222 (defun directory-alpha-sort (p1 p2)
 223   (let ((d1 (clim-listener::directoryp p1))
 224         (d2 (clim-listener::directoryp p2)))
 225     (if d1
 226         (if d2
 227             (string-lessp (directory-name p1) (directory-name p2))
 228             t)
 229         (if d2
 230             nil
 231             (or (string-lessp (pathname-name p1) (pathname-name p2))
 232                 (and (string-equal (pathname-name p1) (pathname-name p2))
 233                      (string-lessp (pathname-type p1) (pathname-type p2))))))))
 234
 235 (defun browser-show-directory (pane path
 236                                &key (show-hidden nil)
 237                                (sort-predicate #'directory-alpha-sort))
 238   (let* ((dir (coerce (directory path) 'simple-vector))
 239          (parent (parent-dir path)))
 240     (unless show-hidden
 241       (setf dir (sort (remove-if #'hiddenp dir) sort-predicate)))
 242     (formatting-table (pane)
 243       (dotimes (i (ceiling (/ (length dir) 3)))
 244         (formatting-row (pane)
 245           (dotimes (j 3)
 246             (unless (> (+ (* 3 i) j) (length dir))
 247               (formatting-cell (pane)
 248                 (if (= i 0 j)
 249                     ;; fixme: root dir
 250                     (with-output-as-presentation
 251                         (pane parent 'clim:pathname :single-box t)
 252                       (clim-listener::draw-icon
 253                        pane
 254                        (clim-listener::standard-icon "up-folder.xpm")
 255                        :extra-spacing 3)
 256                       (princ "Parent directory" pane))
 257                     (with-drawing-options
 258                         (pane :ink
 259                               (if (or (clim-listener::directoryp (aref dir (+ (* 3 i) j -1)))
 260                                       (file-filter (aref dir (+ (* 3 i) j -1))
 261                                                    *application-frame*))
 262                                   +black+
 263                                   +gray+))
 264                       (clim-listener::pretty-pretty-pathname
 265                        (aref dir (+ (* 3 i) j -1)) pane path)))))))))))
 266
 267 (define-file-browser-command (com-change-to-directory :name t :menu t)
 268     ((pathname 'clim:pathname :prompt "pathname"))
 269   (change-to-directory pathname *application-frame*))
 270
 271 (defun change-to-directory (pathname frame)
 272   (setf (current-path frame) pathname
 273         (gadget-value (find-pane-named frame 'path-input))
 274         (princ-to-string pathname))
 275   (redraw-file-browser-windows frame))
 276
 277 (defun file-filter (path frame)
 278   (when (pathname-type path)
 279     (if (extensions frame)
 280         (member (pathname-type path) (extensions frame)
 281                 :test #'string-equal)
 282         t)))
 283 (define-file-browser-command (com-toggle-hidden :name t :menu t
 284                                                :keystroke :hidden)
 285     ()
 286   (setf (show-hidden *application-frame*) (not (show-hidden *application-frame*)))
 287   (redraw-file-browser-windows *application-frame*))
 288
 289 (define-presentation-to-command-translator select-file
 290     (clim-listener::pathname com-select-file file-browser
 291                              :documentation "select file"
 292                              :tester ((object)
 293                                       (file-filter object *application-frame*)))
 294     (object)
 295   (list object))
 296
 297 (define-presentation-to-command-translator force-select-file
 298     (clim-listener::pathname com-select-file file-browser
 299                              :gesture :adjust
 300                              :documentation "select file"
 301                              :tester ((object)
 302                                       (not (clim-listener::directoryp object))))
 303     (object)
 304   (list object))
 305
 306 (define-file-browser-command (com-select-file :name t :menu t)
 307     ((pathname 'clim:pathname :prompt "pathname"))
 308   (let ((path (find-pane-named *application-frame* 'path-input)))
 309     (if (string= (gadget-value path) (princ-to-string pathname))
 310         (progn (setf (filespec-pathname (final-file *application-frame*)) pathname)
 311                (frame-exit *application-frame*))
 312         (progn (setf (gadget-value path) (princ-to-string pathname))
 313                (redraw-file-browser-windows *application-frame*)))))
 314
 315 (define-file-browser-command (com-load-file :name t :menu t)
 316     ((pathname 'clim:pathname :prompt "pathname"))
 317   (if (equal (filespec-pathname (final-file *application-frame*)) pathname)
 318       (frame-exit *application-frame*)
 319       (progn
 320         (setf (filespec-pathname (final-file *application-frame*)) pathname
 321               (gadget-value (find-pane-named *application-frame* 'path-input))
 322               (princ-to-string pathname))
 323         (redraw-file-browser-windows *application-frame*))))
 324
 325 (define-presentation-to-command-translator change-to-directory
 326     (clim-listener::pathname com-change-to-directory file-browser
 327                    :documentation  "change-to-directory"
 328                    :tester ((object) (clim-listener::directoryp object)))
 329     (object)
 330   (list object))
 331
 332 (defparameter *gadget-init-hash* (make-hash-table))
 333 (defun get-gadget-value (keyword)
 334   (gethash keyword *gadget-init-hash*))
 335 (defun set-gadget-defaults (gadget-pairs)
 336   (setf *gadget-init-hash* (make-hash-table))
 337   (do* ((gadget-pairs gadget-pairs (cddr gadget-pairs))
 338         (key (first gadget-pairs) (first gadget-pairs))
 339         (val (second gadget-pairs) (second gadget-pairs)))
 340        ((null gadget-pairs))
 341     (setf (gethash key *gadget-init-hash*) val)))
 342 (defun make-application-frame-with-gadgets (type &key gadget-vars frame-vars)
 343   (set-gadget-defaults gadget-vars)
 344   (apply #'make-application-frame type frame-vars))
 345
 346 (defun gui-get-pathname (&key initial-path extensions)
 347   ;; clunky way of getting default values into gadgets
 348   (unless initial-path
 349     (setf initial-path (directory-of-current-buffer)))
 350   (let* ((filespec (make-filespec :pathname ""))
 351          (frame (make-application-frame-with-gadgets
 352                  'file-browser
 353                  :gadget-vars (list :path-input (princ-to-string initial-path))
 354                  :frame-vars (list :width 600 :path initial-path
 355                                    :file filespec
 356                                    :extensions extensions))))
 357     (run-frame-top-level frame)
 358     (filespec-pathname filespec)))