1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Query utility
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; --------------------------------------------------------------------------
29 (defparameter *query-window
* nil
)
30 (defparameter *query-font
* nil
)
31 (defparameter *query-gc
* nil
)
33 (defparameter *query-history
* (list ""))
34 (defparameter *query-complet-list
* nil
)
35 (defparameter *query-completion-state
* nil
)
37 (defparameter *query-message
* nil
)
38 (defparameter *query-string
* nil
)
39 (defparameter *query-pos
* nil
)
40 (defparameter *query-return
* nil
)
43 (defun add-char-in-query-string (char)
44 (setf *query-string
* (ensure-printable
46 (when (<= *query-pos
* (length *query-string
*))
47 (subseq *query-string
* 0 *query-pos
*))
49 (when (< *query-pos
* (length *query-string
*))
50 (subseq *query-string
* *query-pos
*)))))
54 (defun query-show-paren (orig-string pos dec
)
55 "Replace matching parentheses with brackets"
56 (let ((string (copy-seq orig-string
)))
57 (labels ((have-to-find-right?
()
58 (and (< pos
(length string
)) (char= (aref string pos
) #\
()))
59 (have-to-find-left?
()
60 (and (> (1- pos
) 0) (char= (aref string
(1- pos
)) #\
))))
62 (loop :for p
:from
(1+ pos
) :below
(length string
)
63 :with level
= 1 :for c
= (aref string p
)
64 :do
(when (char= c
#\
() (incf level
))
65 (when (char= c
#\
)) (decf level
))
66 (when (= level
0) (return p
))))
68 (loop :for p
:from
(- pos
2) :downto
0
69 :with level
= 1 :for c
= (aref string p
)
70 :do
(when (char= c
#\
() (decf level
))
71 (when (char= c
#\
)) (incf level
))
72 (when (= level
0) (return p
))))
73 (draw-bloc (p &optional
(color *query-parent-color
*))
74 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color color
))
75 (xlib:draw-rectangle
*pixmap-buffer
* *query-gc
*
76 (+ 10 (* p
(xlib:max-char-width
*query-font
*)) dec
)
77 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*) 7)
78 (xlib:max-char-width
*query-font
*)
79 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))
81 (cond ((have-to-find-left?
) (let ((p (pos-left)))
83 (progn (draw-bloc p
) (draw-bloc (1- pos
)))
84 (draw-bloc (1- pos
) *query-parent-error-color
*))))
85 ((have-to-find-right?
) (let ((p (pos-right)))
87 (progn (draw-bloc p
) (draw-bloc pos
))
88 (draw-bloc pos
*query-parent-error-color
*))))))))
91 (defun clear-query-history ()
92 "Clear the query-string history"
93 (setf *query-history
* (list "")))
97 (defun leave-query-mode (&optional
(return :Escape
))
98 "Leave the query mode"
99 (setf *query-return
* return
)
100 (throw 'exit-query-loop nil
))
103 (defun leave-query-mode-valid ()
104 (leave-query-mode :Return
))
106 (add-hook *binding-hook
* 'init-
*query-keys
*)
110 (defun query-find-complet-list ()
111 (let* ((pos (1+ (or (position-if-not #'extented-alphanumericp
*query-string
*
112 :end
*query-pos
* :from-end t
)
114 (str (subseq *query-string
* pos
*query-pos
*)))
115 (when (or (> (length str
) (1- *query-min-complet-char
*))
116 (< (length *query-complet-list
*) *query-max-complet-length
*))
117 (values (string-match str
*query-complet-list
*) pos
))))
120 (defun query-print-string ()
121 (let ((dec (min 0 (- (- (x-drawable-width *query-window
*) 10)
122 (+ 10 (* *query-pos
* (xlib:max-char-width
*query-font
*))))))
123 (complet (if *query-completion-state
*
124 (first *query-completion-state
*)
125 (query-find-complet-list))))
126 (clear-pixmap-buffer *query-window
* *query-gc
*)
127 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color *query-message-color
*))
128 (xlib:draw-glyphs
*pixmap-buffer
* *query-gc
* 5 (+ (xlib:max-char-ascent
*query-font
*) 5)
129 (format nil
"~A ~{~A~^, ~}" *query-message
*
130 (if (< (length complet
) *query-max-complet-length
*)
132 (when (< *query-pos
* 0)
133 (setf *query-pos
* 0))
134 (when (> *query-pos
* (length *query-string
*))
135 (setf *query-pos
* (length *query-string
*)))
136 (query-show-paren *query-string
* *query-pos
* dec
)
137 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color *query-foreground
*))
138 (xlib:draw-glyphs
*pixmap-buffer
* *query-gc
*
140 (+ (* 2 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))) 5)
141 (ensure-printable *query-string
*))
142 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color *query-cursor-color
*))
143 (xlib:draw-line
*pixmap-buffer
* *query-gc
*
144 (+ 10 (* *query-pos
* (xlib:max-char-width
*query-font
*)) dec
)
145 (+ (* 2 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))) 6)
146 (+ 10 (* *query-pos
* (xlib:max-char-width
*query-font
*)) dec
)
147 (+ (* 1 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))) 7))
148 (copy-pixmap-buffer *query-window
* *query-gc
*)))
152 (defun query-enter-function ()
153 (setf *query-font
* (xlib:open-font
*display
* *query-font-string
*))
154 (let ((width (- (screen-width) 2))
155 (height (* 3 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*)))))
156 (with-placement (*query-mode-placement
* x y width height
)
157 (setf *query-window
* (xlib:create-window
:parent
*root
*
161 :background
(get-color *query-background
*)
162 :border-width
*border-size
*
163 :border
(get-color *query-border
*)
164 :colormap
(xlib:screen-default-colormap
*screen
*)
165 :event-mask
'(:exposure
:key-press
))
166 *query-gc
* (xlib:create-gcontext
:drawable
*query-window
*
167 :foreground
(get-color *query-foreground
*)
168 :background
(get-color *query-background
*)
171 (setf (window-transparency *query-window
*) *query-transparency
*)
172 (map-window *query-window
*)
174 (wait-no-key-or-button-press))))
178 (defun query-leave-function ()
179 (xlib:destroy-window
*query-window
*)
180 (xlib:close-font
*query-font
*)
181 (wait-no-key-or-button-press))
185 (labels ((generic-backspace (del-pos)
187 (setf *query-string
* (concatenate 'string
188 (subseq *query-string
* 0 del-pos
)
189 (subseq *query-string
* *query-pos
*))
190 *query-pos
* del-pos
))))
191 (defun query-backspace ()
192 "Delete a character backward"
193 (generic-backspace (1- *query-pos
*)))
195 (defun query-backspace-word ()
196 "Delete a word backward"
197 (generic-backspace (or (position #\Space
*query-string
* :from-end t
:end
*query-pos
*) 0)))
199 (defun query-backspace-clear ()
200 "Delete backwards until beginning"
201 (generic-backspace 0)))
203 (labels ((generic-delete (del-pos)
204 (when (<= del-pos
(length *query-string
*))
205 (setf *query-string
* (concatenate 'string
206 (subseq *query-string
* 0 *query-pos
*)
207 (subseq *query-string
* del-pos
))))))
208 (defun query-delete ()
209 "Delete a character forward"
210 (generic-delete (1+ *query-pos
*)))
212 (defun query-delete-word ()
213 "Delete a word forward"
214 (generic-delete (1+ (or (position #\Space
*query-string
* :start
*query-pos
*)
215 (1- (length *query-string
*)))))))
220 "Move cursor to line begining"
221 (setf *query-pos
* 0))
224 "Move cursor to line end"
225 (setf *query-pos
* (length *query-string
*)))
229 "Move cursor to left"
230 (when (> *query-pos
* 0)
231 (setf *query-pos
* (1- *query-pos
*))))
233 (defun query-left-word ()
234 "Move cursor to left word"
235 (when (> *query-pos
* 0)
236 (setf *query-pos
* (let ((p (position #\Space
*query-string
*
237 :end
(min (1- *query-pos
*) (length *query-string
*))
241 (defun query-right ()
242 "Move cursor to right"
243 (when (< *query-pos
* (length *query-string
*))
244 (setf *query-pos
* (1+ *query-pos
*))))
246 (defun query-right-word ()
247 "Move cursor to right word"
248 (when (< *query-pos
* (length *query-string
*))
249 (setf *query-pos
* (let ((p (position #\Space
*query-string
*
250 :start
(min (1+ *query-pos
*) (length *query-string
*)))))
251 (if p p
(length *query-string
*))))))
253 (defun query-previous-history ()
254 "Circulate backward in history"
255 (setf *query-string
* (first *query-history
*)
256 *query-pos
* (length *query-string
*)
257 *query-history
* (rotate-list *query-history
*)))
260 (defun query-next-history ()
261 "Circulate forward in history"
262 (setf *query-string
* (first *query-history
*)
263 *query-pos
* (length *query-string
*)
264 *query-history
* (anti-rotate-list *query-history
*)))
268 (defun query-delete-eof ()
269 "Delete the end of the line"
270 (setf *query-string
* (subseq *query-string
* 0 *query-pos
*)))
273 (defun query-mode-complet ()
274 (multiple-value-bind (complet pos
)
275 (query-find-complet-list)
277 (if (= (length complet
) 1)
278 (setf *query-string
* (concatenate 'string
279 (subseq *query-string
* 0 pos
)
281 (subseq *query-string
* *query-pos
*))
282 *query-pos
* (+ pos
(length (first complet
)) 1))
283 (let ((common (find-common-string (subseq *query-string
* pos
*query-pos
*) complet
)))
285 (setf *query-string
* (concatenate 'string
286 (subseq *query-string
* 0 pos
)
288 (subseq *query-string
* *query-pos
*))
289 *query-pos
* (+ pos
(length common
)))))))))
291 (defun query-mode-complete-suggest ()
292 (flet ((complete (completions completion-pos pos initial-pos
)
294 (let ((completion (if (equal completion-pos
(list-length completions
))
295 (subseq *query-string
* pos initial-pos
)
296 (nth completion-pos completions
))))
297 (setf *query-string
* (concatenate 'string
298 (subseq *query-string
* 0 pos
)
300 (subseq *query-string
* *query-pos
*))
301 *query-pos
* (+ pos
(length completion
))))
302 (setf *query-completion-state
*
303 (list completions completion-pos pos initial-pos
)))))
304 (if *query-completion-state
*
305 (complete (first *query-completion-state
*)
306 (mod (1+ (second *query-completion-state
*))
307 (1+ (list-length (first *query-completion-state
*))))
308 (third *query-completion-state
*)
309 (fourth *query-completion-state
*))
310 (multiple-value-bind (comps pos
) (query-find-complet-list)
311 (complete comps
0 pos
*query-pos
*)))))
313 (add-hook *query-key-press-hook
* 'query-mode-complete-suggest-reset
)
315 (defun query-mode-complete-suggest-reset (code state
)
316 "Reset the query-completion-state if another key was pressed than a key
317 that calls query-mode-complete-suggest."
318 (unless (equal 'query-mode-complete-suggest
319 (first (find-key-from-code *query-keys
* code state
)))
320 (setf *query-completion-state
* nil
)
321 (query-print-string)))
323 (add-hook *binding-hook
* 'set-default-query-keys
)
325 (defun set-default-query-keys ()
326 (define-query-key ("Return") 'leave-query-mode-valid
)
327 (define-query-key ("Escape") 'leave-query-mode
)
328 (define-query-key ("g" :control
) 'leave-query-mode
)
329 (define-query-key ("Tab") 'query-mode-complet
)
330 (define-query-key ("BackSpace") 'query-backspace
)
331 (define-query-key ("BackSpace" :control
) 'query-backspace-word
)
332 (define-query-key ("BackSpace" :control
:shift
) 'query-backspace-clear
)
333 (define-query-key ("u" :control
) 'query-backspace-clear
)
334 (define-query-key ("Delete") 'query-delete
)
335 (define-query-key ("Delete" :control
) 'query-delete-word
)
336 (define-query-key ("Home") 'query-home
)
337 (define-query-key ("a" :control
) 'query-home
)
338 (define-query-key ("End") 'query-end
)
339 (define-query-key ("e" :control
) 'query-end
)
340 (define-query-key ("Left") 'query-left
)
341 (define-query-key ("Left" :control
) 'query-left-word
)
342 (define-query-key ("Right") 'query-right
)
343 (define-query-key ("Right" :control
) 'query-right-word
)
344 (define-query-key ("Up") 'query-previous-history
)
345 (define-query-key ("Down") 'query-next-history
)
346 (define-query-key ("k" :control
) 'query-delete-eof
)
347 (define-query-key ("KP_Insert" :mod-2
) 'add-char-in-query-string
"0")
348 (define-query-key ("KP_End" :mod-2
) 'add-char-in-query-string
"1")
349 (define-query-key ("KP_Down" :mod-2
) 'add-char-in-query-string
"2")
350 (define-query-key ("KP_Page_Down" :mod-2
) 'add-char-in-query-string
"3")
351 (define-query-key ("KP_Left" :mod-2
) 'add-char-in-query-string
"4")
352 (define-query-key ("KP_Begin" :mod-2
) 'add-char-in-query-string
"5")
353 (define-query-key ("KP_Right" :mod-2
) 'add-char-in-query-string
"6")
354 (define-query-key ("KP_Home" :mod-2
) 'add-char-in-query-string
"7")
355 (define-query-key ("KP_Up" :mod-2
) 'add-char-in-query-string
"8")
356 (define-query-key ("KP_Page_Up" :mod-2
) 'add-char-in-query-string
"9")
357 (define-query-key ("KP_Delete" :mod-2
) 'add-char-in-query-string
".")
358 (define-query-key ("KP_Add" :mod-2
) 'add-char-in-query-string
"+")
359 (define-query-key ("KP_Subtract" :mod-2
) 'add-char-in-query-string
"-")
360 (define-query-key ("KP_Multiply" :mod-2
) 'add-char-in-query-string
"*")
361 (define-query-key ("KP_Divide" :mod-2
) 'add-char-in-query-string
"/")
362 (define-query-key ("KP_Enter" :mod-2
) 'leave-query-mode-valid
))
366 (defun add-in-query-string (code state
)
367 (let* ((modifiers (state->modifiers state
))
368 (keysym (keycode->keysym code modifiers
))
369 (char (xlib:keysym-
>character
*display
* keysym state
)))
370 (when (and char
(characterp char
))
371 (add-char-in-query-string char
))))
375 (define-handler query-mode
:key-press
(code state
)
376 (unless (funcall-key-from-code *query-keys
* code state
)
377 (add-in-query-string code state
))
379 (call-hook *query-key-press-hook
* code state
))
381 (define-handler query-mode
:button-press
(code state x y
)
382 (call-hook *query-button-press-hook
* code state x y
))
386 (defun query-string (message &optional
(default "") complet-list
)
387 "Query a string from the keyboard. Display msg as prompt"
388 (setf *query-message
* message
389 *query-string
* default
390 *query-pos
* (length default
)
391 *query-complet-list
* complet-list
392 *query-completion-state
* nil
)
393 (with-grab-keyboard-and-pointer (92 93 66 67 t
)
394 (generic-mode 'query-mode
'exit-query-loop
395 :enter-function
#'query-enter-function
396 :leave-function
#'query-leave-function
397 :original-mode
'(main-mode)))
398 (when (equal *query-return
* :Return
)
399 (pushnew default
*query-history
* :test
#'equal
)
400 (push *query-string
* *query-history
*))
401 (values *query-string
*
406 (defun query-number (msg &optional
(default 0))
407 "Query a number from the query input"
408 (multiple-value-bind (string return
)
409 (query-string msg
(format nil
"~A" default
))
410 (values (if (equal return
:Return
)
411 (or (parse-integer (or string
"") :junk-allowed t
) default
)