1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 (in-package :clim-internals
)
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.
12 ;; Spacing -- COMPOSE-SPACE: slightly worrying because I don't really
13 ;; understand how layout works, but seems generally ok
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.
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
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
40 :format
:xpm
:port nil
))))
41 (slot-value button
'icon
))
42 (defclass icon-push-button-pane
(icon-push-button push-button-pane
)
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
)))
50 (* 2 (+ *3d-border-thickness
*
51 (or (pane-x-spacing gadget
)
53 (h (+ ph
(* 2 (+ *3d-border-thickness
*
54 (or (pane-y-spacing gadget
)
56 (make-space-requirement
61 (defmethod draw-label* ((pane icon-push-button
) x1 y1 x2 y2
63 (declare (ignore ink
))
64 (draw-pattern* pane
(icon pane
) x1 y1
))
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
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
)
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
)
88 (h (+ dh
(* 2 (+ *3d-border-thickness
*
89 (or (pane-y-spacing gadget
)
91 (make-space-requirement
96 (defmethod draw-label* ((pane drawn-push-button
) x1 y1 x2 y2
98 (declare (ignore ink
))
99 (funcall (button-drawing-function pane
) pane x1 y1
))
101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 ;;; File dialogue stuff
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).
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
119 (defparameter *file-text-style
*
120 (make-text-style :sans-serif
:roman
:small
))
121 ;; Transport for holding pathname info between application frame and
123 (defstruct filespec
(pathname))
124 ;; FIXME: way to pass initargs to application gadget
125 (defparameter *init-info
* "")
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
))
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
*)
137 (setf (current-path *application-frame
*)
138 (make-pathname :directory
(pathname-directory new-path
))))
139 (redraw-file-browser-windows *application-frame
*)))
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
"")))
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
158 :text-style
*file-text-style
*
159 :command-table
'file-browser
160 :display-function
'display-folder
))
162 :push-button
:label
"Ok"
165 (declare (ignore gadget
))
166 (setf (filespec-pathname (final-file *application-frame
*))
168 (gadget-value (find-pane-named *application-frame
*
170 (frame-exit *application-frame
*)))
172 :push-button
:label
"Cancel"
175 (declare (ignore gadget
))
176 (setf (filespec-pathname (final-file *application-frame
*)) "")
177 (frame-exit *application-frame
*))))
182 (scrolling () browser
)
183 (horizontally () ok-button cancel-button
+fill
+)))))
185 (defun redraw-file-browser-windows (frame)
186 (redisplay-frame-pane frame
187 (find-pane-named frame
'browser
)
189 (redisplay-frame-pane frame
190 (find-pane-named frame
'path-input
)
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
200 ;; (clim-listener::show-directory-pathnames (current-path frame))
202 :show-hidden
(show-hidden frame
)
203 :sort-predicate
(sort-predicate frame
))))
205 (defun dir-parent (path)
206 (merge-pathnames (make-pathname :directory
'(:relative
:back
))
209 (defun parent-dir (path)
210 (let ((dirs (pathname-directory path
)))
211 (make-pathname :directory
(subseq dirs
0 (1- (length dirs
))))))
213 (defun hiddenp (path)
214 (char= (elt (if (clim-listener::directoryp path
)
215 (directory-name path
)
216 (pathname-name path
))
219 (defun directory-name (path)
220 (car (last (pathname-directory path
))))
222 (defun directory-alpha-sort (p1 p2
)
223 (let ((d1 (clim-listener::directoryp p1
))
224 (d2 (clim-listener::directoryp p2
)))
227 (string-lessp (directory-name p1
) (directory-name p2
))
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
))))))))
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
)))
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)
246 (unless (> (+ (* 3 i
) j
) (length dir
))
247 (formatting-cell (pane)
250 (with-output-as-presentation
251 (pane parent
'clim
:pathname
:single-box t
)
252 (clim-listener::draw-icon
254 (clim-listener::standard-icon
"up-folder.xpm")
256 (princ "Parent directory" pane
))
257 (with-drawing-options
259 (if (or (clim-listener::directoryp
(aref dir
(+ (* 3 i
) j -
1)))
260 (file-filter (aref dir
(+ (* 3 i
) j -
1))
261 *application-frame
*))
264 (clim-listener::pretty-pretty-pathname
265 (aref dir
(+ (* 3 i
) j -
1)) pane path
)))))))))))
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
*))
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
))
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
)
283 (define-file-browser-command (com-toggle-hidden :name t
:menu t
286 (setf (show-hidden *application-frame
*) (not (show-hidden *application-frame
*)))
287 (redraw-file-browser-windows *application-frame
*))
289 (define-presentation-to-command-translator select-file
290 (clim-listener::pathname com-select-file file-browser
291 :documentation
"select file"
293 (file-filter object
*application-frame
*)))
297 (define-presentation-to-command-translator force-select-file
298 (clim-listener::pathname com-select-file file-browser
300 :documentation
"select file"
302 (not (clim-listener::directoryp object
))))
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
*)))))
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
*)
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
*))))
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
)))
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
))
346 (defun gui-get-pathname (&key initial-path extensions
)
347 ;; clunky way of getting default values into gadgets
349 (setf initial-path
(directory-of-current-buffer)))
350 (let* ((filespec (make-filespec :pathname
""))
351 (frame (make-application-frame-with-gadgets
353 :gadget-vars
(list :path-input
(princ-to-string initial-path
))
354 :frame-vars
(list :width
600 :path initial-path
356 :extensions extensions
))))
357 (run-frame-top-level frame
)
358 (filespec-pathname filespec
)))