(in-package :stumpwm)

(export '(*input-history-ignore-duplicates*

*input-candidate-selected-hook*

*input-refine-candidates-fn*

*input-completion-style*

*input-map*

*numpad-map*

register-altgr-as-modifier

completing-read

input-delete-region

input-goto-char

input-insert-char

input-insert-string

input-point

input-refine-prefix

input-refine-fuzzy

input-refine-regexp

input-substring

input-validate-region

read-one-char

read-one-line))



(defun take (n list)

"Returns a list with the first n elements of the given list, and the

(loop for l on list

repeat n

collect (car l) into result

finally (return (values result l))))

(defun longest-common-prefix (seqs &key (test #'eql))

"Returns the length of the longest common prefix of the sequences."

(flet ((longest-common-prefix-2 (seq1 seq2)

(if-let ((i (mismatch seq1 seq2 :test test)))

i

(length seq1))))

(apply #'min (map-product #'longest-common-prefix-2 seqs seqs))))

(defstruct input-line

string position history history-bk password most-recent-dead-key)



(defgeneric input-completion-reset (completion-style completions)

(:documentation "A completion style should implement this function

and reset its state when called."))

(defgeneric input-completion-complete (completion-style input direction)

(:documentation "A completion style should implement this function

and complete the input by mutating it."))

(defclass input-completion-style-cyclic ()

((completions :initform nil :type list)

(idx :initform 0 :type fixnum)))

(defmethod input-completion-reset ((cs input-completion-style-cyclic) completions)

(setf (slot-value cs 'completions) completions

(slot-value cs 'idx) 0))

(defmethod input-completion-complete ((cs input-completion-style-cyclic) input direction)

(with-slots (completions idx) cs

(let ((completion-count (length completions)))

(if completions

(progn

(let ((elt (nth idx completions)))

(input-delete-region input 0 (input-point input))

(input-insert-string input (if (listp elt) (first elt) elt))

(input-insert-char input #\Space))

;; Prepare the next completion

(setf idx (mod (+ idx (if (eq direction :forward) 1 -1)) completion-count))

:error)))))

(defun make-input-completion-style-cyclic ()

(make-instance 'input-completion-style-cyclic))

(defclass input-completion-style-unambiguous ()

((display-limit :initarg :display-limit :initform 64 :type fixnum)

(completions :initform nil :type list)))

(defmethod input-completion-reset ((cs input-completion-style-unambiguous) completions)

(setf (slot-value cs 'completions)

(take (slot-value cs 'display-limit) completions)))

(defmethod input-completion-complete ((cs input-completion-style-unambiguous) input direction)

(declare (ignore direction))

(with-slots (completions) cs

(if (null completions)

:error

(let ((n (longest-common-prefix completions)))

(input-delete-region input 0 (input-point input))

(input-insert-string input (subseq (first completions) 0 n))

(if (null (rest completions))

(unmap-message-window (current-screen))

(echo-string-list (current-screen) completions))))))

(defun make-input-completion-style-unambiguous (&key (display-limit 64))

(make-instance 'input-completion-style-unambiguous

:display-limit display-limit))

(defun input-refine-prefix (str candidates)

(remove-if-not (lambda (elt)

(when (listp elt)

(setf elt (car elt)))

(and (<= (length str) (length elt))

(string= str elt

:end1 (length str)

:end2 (length str))))

candidates))

(defun input-refine-fuzzy (str candidates)

(remove-if-not (lambda (elt)

(when (listp elt)

(setf elt (car elt)))

(and (<= (length str) (length elt))

(every (lambda (part)

(search part elt))

(uiop:split-string str))))

candidates))

(defun input-refine-regexp (str candidates)

(remove-if-not (lambda (elt)

(when (listp elt)

(setf elt (car elt)))

(match-all-regexps str elt))

candidates))

(defvar *input-map*

(let ((map (make-sparse-keymap)))

(define-key map (kbd "DEL") 'input-delete-backward-char)

(define-key map (kbd "S-DEL") 'input-delete-backward-char)

(define-key map (kbd "M-DEL") 'input-backward-kill-word)

(define-key map (kbd "C-DEL") 'input-backward-kill-word)

(define-key map (kbd "C-d") 'input-delete-forward-char)

(define-key map (kbd "M-d") 'input-forward-kill-word)

(define-key map (kbd "Delete") 'input-delete-forward-char)

(define-key map (kbd "C-f") 'input-forward-char)

(define-key map (kbd "Right") 'input-forward-char)

(define-key map (kbd "M-f") 'input-forward-word)

(define-key map (kbd "C-b") 'input-backward-char)

(define-key map (kbd "Left") 'input-backward-char)

(define-key map (kbd "M-b") 'input-backward-word)

(define-key map (kbd "C-a") 'input-move-beginning-of-line)

(define-key map (kbd "Home") 'input-move-beginning-of-line)

(define-key map (kbd "C-e") 'input-move-end-of-line)

(define-key map (kbd "End") 'input-move-end-of-line)

(define-key map (kbd "C-k") 'input-kill-line)

(define-key map (kbd "C-u") 'input-kill-to-beginning)

(define-key map (kbd "C-p") 'input-history-back)

(define-key map (kbd "Up") 'input-history-back)

(define-key map (kbd "C-n") 'input-history-forward)

(define-key map (kbd "Down") 'input-history-forward)

(define-key map (kbd "RET") 'input-submit)

(define-key map (kbd "C-g") 'input-abort)

(define-key map (kbd "ESC") 'input-abort)

(define-key map (kbd "C-y") 'input-yank-selection)

(define-key map (kbd "C-Y") 'input-yank-clipboard)

(define-key map (kbd "C-v") 'input-yank-clipboard)

(define-key map (kbd "TAB") 'input-complete-forward)

(define-key map (kbd "C-i") 'input-complete-forward)

(define-key map (kbd "ISO_Left_Tab") 'input-complete-backward)

(define-key map t 'input-self-insert)

map)

"This is the keymap containing all input editing key bindings.")

(defvar *input-history* nil

"History for the input line.")

(defvar *input-shell-history* nil

"History for shell lines.")

(defvar *input-last-command* nil

"The last input command.")

(defvar *input-completions* nil

"The list of completions")

(defvar *input-refine-candidates-fn* #'input-refine-prefix

"A function used to filter completions based on input. The function receives

return a list of completions, possibly filtered and/or sorted.")

(defvar *input-completion-style* (make-input-completion-style-cyclic)

"The completion style to use.

@end table")

(defvar *input-completion-show-empty* nil

"If t, show completion candidates even if the input is empty.")

(defvar *input-history-ignore-duplicates* nil

"Do not add a command to the input history if it's already the first in the list.")

(defvar *numpad-map* '((87 10 . 16) (88 11 . 16) (89 12 . 16) (106 61 . 16)

(83 13 . 16) (84 14 . 16) (85 15 . 16) (86 21 . 17)

(79 16 . 16) (80 17 . 16) (81 18 . 16) (63 17 . 17)

(82 20 . 16) (104 36 . 16) (91 60 . 16) (90 19 . 16))

"A keycode to keycode map to re-wire numpads when the numlock key is active")

(defun is-modifier (keycode)

"Return t if keycode is a modifier"

(or (find keycode *all-modifiers* :test 'eql)

;; Treat No Symbol keys as modifiers (and therefore ignorable)

(= (xlib:keycode->keysym *display* keycode 0) 0)))

(defun register-altgr-as-modifier ()

"Register the keysym(s) for ISO_Level3_Shift as modifiers."

(setf *all-modifiers*

(append (multiple-value-list

(xlib:keysym->keycodes *display*

(keysym-name->keysym "ISO_Level3_Shift")))

*all-modifiers*)))

(defun keycode->character (code mods)

(let ((idx (if (member :shift mods) 1 0)))

(xlib:keysym->character *display* (xlib:keycode->keysym *display* code idx) 0)))

(defun setup-input-window (screen prompt input)

"Set the input window up to read input"

(let* ((height (+ (font-height (screen-font screen))

(* *message-window-y-padding* 2)))

(win (screen-input-window screen)))

;; Window dimensions

(xlib:with-state (win)

(setf (xlib:window-priority win) :above

(xlib:drawable-height win) height))

(xlib:map-window win)

(draw-input-bucket screen prompt input)))

(defun shutdown-input-window (screen)

(xlib:unmap-window (screen-input-window screen)))

(defun input-handle-key-press-event (&rest event-slots

&key event-key code state

&allow-other-keys)

(declare (ignore event-slots))

(let ((numlock-on-p (= 2 (logand 2 (nth-value 4 (xlib:keyboard-control *display*)))))

(numpad-key (assoc code *numpad-map*)))

(when (and numlock-on-p numpad-key)

(setf code (first (rest numpad-key))

state (rest (rest numpad-key))))

(list* event-key code state)))

(defun input-handle-selection-event (&key window selection property &allow-other-keys)

(declare (ignore selection))

(if property

(xlib:get-property window property :type :string :result-type 'string :transform #'xlib:card8->char :delete-p t)

""))

(defun input-handle-click-event (&key root-x root-y &allow-other-keys)

(list :button-press root-x root-y))

(defun read-key-handle-event (&rest event-slots &key event-key &allow-other-keys)

(case event-key

((or :key-release :key-press)

(apply 'input-handle-key-press-event event-slots))

(t nil)))

(defun read-key-or-selection-handle-event (&rest event-slots &key event-key &allow-other-keys)

(case event-key

((or :key-release :key-press)

(apply 'input-handle-key-press-event event-slots))

(:selection-notify

(apply 'input-handle-selection-event event-slots))

(t nil)))

(defun read-key-or-click-handle-event (&rest event-slots &key event-key &allow-other-keys)

(case event-key

((or :key-release :key-press)

(apply 'input-handle-key-press-event event-slots))

(:button-press

(apply 'input-handle-click-event event-slots))

(t nil)))

(defun read-key ()

"Return a dotted pair (code . state) key."

(loop for ev = (xlib:process-event *display* :handler #'read-key-handle-event :timeout nil) do

(when (and (consp ev)

(eq (first ev) :key-press))

(return (rest ev)))))

(defun read-key-or-click ()

(loop for ev = (xlib:process-event *display* :handler #'read-key-or-click-handle-event :timeout nil)

do

(when (consp ev)

(when (eq (first ev) :key-press)

(return (values nil (rest ev) nil nil)))

(when (eq (first ev) :button-press)

(return (values t nil (second ev) (third ev)))))))

(defun read-key-no-modifiers ()

"Like read-key but never returns a modifier key."

(loop for k = (read-key)

while (is-modifier (car k))

finally (return k)))

(defun read-key-no-modifiers-or-click ()

(loop

(multiple-value-bind (has-click k x y)

(read-key-or-click)

(if has-click

(return (values t nil x y))

(unless (is-modifier (car k))

(return (values nil k nil nil)))))))

(defun read-key-or-selection ()

(loop for ev = (xlib:process-event *display* :handler #'read-key-or-selection-handle-event :timeout nil) do

(cond ((stringp ev)

(return ev))

((and (consp ev)

(eq (first ev) :key-press))

(return (rest ev))))))

(defun make-input-string (initial-input)

(make-array (length initial-input) :element-type 'character :initial-contents initial-input

:adjustable t :fill-pointer t))

(defun completing-read (screen prompt completions &key (initial-input "") require-match)

"Read a line of input through stumpwm and return it with TAB

(check-type completions (or list function symbol))

(let ((line (read-one-line screen prompt

:completions completions

:initial-input initial-input

:require-match require-match)))

(when line (string-trim " " line))))

(defvar *input-candidate-selected-hook* nil)

(defun read-one-line (screen prompt &key completions (initial-input "") require-match password)

"Read a line of input through stumpwm and return it. Returns nil if the user aborted."

(let ((*input-last-command* nil)

(*input-completions* (if (or (functionp completions)

(and (symbolp completions)

(fboundp completions)))

(funcall completions initial-input)

completions))

(input (make-input-line :string (make-input-string initial-input)

:position (length initial-input)

:history -1

:password password)))

(labels ((match-input ()

(let* ((in (string-trim " " (input-line-string input)))

(compls (input-find-completions in completions)))

(and (consp compls)

(string= in (if (consp (car compls))

(caar compls)

(car compls))))))

(key-loop ()

(with-focus (screen-input-window screen)

(loop for key = (read-key-or-selection)

do

(cond ((stringp key)

;; handle selection

(input-insert-string input key)

(draw-input-bucket screen prompt input))

;; skip modifiers

((is-modifier (car key)))

((process-input screen prompt input (car key) (cdr key))

(if (or (not require-match)

(match-input))

(return (input-line-string input))

(draw-input-bucket screen prompt input "[No match]" t))))))))

(draw-input-bucket screen prompt input)

(setup-input-window screen prompt input)

(catch :abort

(unwind-protect

(let ((input (key-loop)))

(run-hook-with-args *input-candidate-selected-hook* input)

input)

(shutdown-input-window screen))))))

(defun read-one-char (screen)

"Read a single character from the user."

(with-focus (screen-key-window screen)

(let ((k (read-key-no-modifiers)))

(keycode->character (car k) (xlib:make-state-keys (cdr k))))))

(defun read-one-char-or-click (group)

"Read a single character from the user or a click."

(with-focus (screen-key-window (group-screen group))

(multiple-value-bind (has-click k x y)

(read-key-no-modifiers-or-click)

(if has-click

(values t nil x y)

(values nil (keycode->character (car k) (xlib:make-state-keys (cdr k))) nil nil)))))

(defun prompt-text-y (index font y-padding)

"Calculate the y position of text in a prompt."

(+ y-padding

(* (font-height font) index)

(font-ascent font)))

(defun get-completion-preview-list (input-line all-completions)

(if (and (string= "" input-line) (not *input-completion-show-empty*))

'()

(multiple-value-bind (completions more)

(take *maximum-completions* (input-find-completions input-line all-completions))

(if more

(append (butlast completions)

(list (format nil "... and ~D more" (1+ (length more)))))

completions))))

(defun draw-input-bucket (screen prompt input &optional (tail "") errorp)

"Draw to the screen's input window the contents of input."

(let* ((gcontext (screen-message-gc screen))

(win (screen-input-window screen))

(font (screen-font screen))

(prompt-lines (ppcre:split #\Newline prompt))

(prompt-lines-length (length prompt-lines))

(input-line (input-line-string input))

(completions (get-completion-preview-list input-line *input-completions*))

(completions-length (length completions))

(prompt-offset (text-line-width font

(first (last prompt-lines))

:translate #'translate-id))

(line-content (input-line-string input))

(string (if (input-line-password input)

(make-string (length line-content) :initial-element #\*)

line-content))

(string-width (loop for char across string

summing (text-line-width (screen-font screen)

(string char)

:translate #'translate-id)))

(space-width (text-line-width (screen-font screen) " " :translate #'translate-id))

(tail-width (text-line-width (screen-font screen) tail :translate #'translate-id))

(full-string-width (+ string-width space-width))

(pos (input-line-position input))

(width (max (loop :for line :in (append prompt-lines completions)

:maximize (text-line-width font line :translate #'translate-id))

(+ prompt-offset

(max 100 (+ full-string-width space-width tail-width))))))

(when errorp (rotatef (xlib:gcontext-background gcontext)

(xlib:gcontext-foreground gcontext)))

(xlib:with-state (win)

(xlib:with-gcontext (gcontext :foreground (xlib:gcontext-background gcontext))

(xlib:draw-rectangle win gcontext 0 0

(xlib:drawable-width win)

(xlib:drawable-height win) t))

(setf (xlib:drawable-width win) (+ width (* *message-window-padding* 2)))

(setf (xlib:drawable-height win) (+ (* prompt-lines-length (font-height font))

(* *message-window-y-padding* 2)

(* completions-length (font-height font))))

(setup-win-gravity screen win *input-window-gravity*)

;; Display the input window text.

(loop for i from 0 below (+ prompt-lines-length completions-length)

if (< i prompt-lines-length)

do (draw-image-glyphs win gcontext font

*message-window-padding*

(prompt-text-y i font *message-window-y-padding*)

(nth i prompt-lines)

:translate #'translate-id

:size 16)

else

do (draw-image-glyphs win gcontext font

*message-window-padding*

(prompt-text-y i font *message-window-y-padding*)

(nth (- i prompt-lines-length) completions)

:translate #'translate-id

:size 16))

;; Pad the input to the left.

(loop with x = (+ *message-window-padding* prompt-offset)

for char across string

for i from 0 below (length string)

for char-width = (text-line-width (screen-font screen) (string char) :translate #'translate-id)

if (= pos i)

do (xlib:with-gcontext (gcontext :foreground (xlib:gcontext-background gcontext)

:background (xlib:gcontext-foreground gcontext))

(draw-image-glyphs win gcontext (screen-font screen)

x

(prompt-text-y (1- prompt-lines-length)

font

*message-window-y-padding*)

(string char)

:translate #'translate-id

:size 16))

else

do (draw-image-glyphs win gcontext (screen-font screen)

x

(prompt-text-y (1- prompt-lines-length)

font

*message-window-y-padding*)

(string char)

:translate #'translate-id

:size 16)

end

do (incf x char-width)

finally (when (>= pos (length string))

(xlib:with-gcontext (gcontext :foreground (xlib:gcontext-background gcontext)

:background (xlib:gcontext-foreground gcontext))

(draw-image-glyphs win gcontext (screen-font screen)

x

(prompt-text-y (1- prompt-lines-length)

font

*message-window-y-padding*)

" "

:translate #'translate-id

:size 16))))

(draw-image-glyphs win gcontext (screen-font screen)

(+ *message-window-padding* prompt-offset full-string-width space-width)

(prompt-text-y (1- prompt-lines-length)

font

*message-window-y-padding*)

tail

:translate #'translate-id

:size 16))

(when errorp

(sleep 0.05)

(rotatef (xlib:gcontext-background gcontext)

(xlib:gcontext-foreground gcontext))

(draw-input-bucket screen prompt input tail))))

(defun code-state->key (code state)

(let* ((mods (xlib:make-state-keys state))

(shift-p (and (find :shift mods) t))

(altgr-p (and (intersection (modifiers-altgr *modifiers*) mods) t))

(base (if altgr-p *altgr-offset* 0))

(sym (xlib:keycode->keysym *display* code base))

(upsym (xlib:keycode->keysym *display* code (+ base 1))))

;; If a keysym has a shift modifier, then use the uppercase keysym

;; and remove remove the shift modifier.

(make-key :keysym (if (and shift-p (not (eql sym upsym)))

upsym

sym)

:control (and (find :control mods) t)

:shift (and shift-p (eql sym upsym))

:meta (and (intersection mods (modifiers-meta *modifiers*)) t)

:alt (and (intersection mods (modifiers-alt *modifiers*)) t)

:hyper (and (intersection mods (modifiers-hyper *modifiers*)) t)

:super (and (intersection mods (modifiers-super *modifiers*)) t)

:altgr altgr-p)))



(defun input-submit (input key)

(declare (ignore input key))

:done)

(defun input-abort (input key)

(declare (ignore input key))

(throw :abort nil))

(defun input-goto-char (input point)

"Move the cursor to the specified point in the string"

(setf (input-line-position input) (min (max 0 point)

(length (input-line-string input)))))

(defun input-insert-string (input string)

"Insert @var{string} into the input at the current

(check-type string string)

(loop for c across string

do (input-insert-char input c)))

(defun input-point (input)

"Return the position of the cursor."

(check-type input input-line)

(input-line-position input))

(defun input-validate-region (input start end)

"Return a value pair of numbers where the first number is < the

(values (max 0 (min start end))

(min (length (input-line-string input))

(max start end))))

(defun input-delete-region (input start end)

"Delete the region between start and end in the input string"

(check-type input input-line)

(check-type start fixnum)

(check-type end fixnum)

(multiple-value-setq (start end) (input-validate-region input start end))

(replace (input-line-string input) (input-line-string input)

:start2 end :start1 start)

(decf (fill-pointer (input-line-string input)) (- end start))

(cond

((< (input-line-position input) start))

((< (input-line-position input) end)

(setf (input-line-position input) start))

(t

(decf (input-line-position input) (- end start)))))

(defun input-insert-char (input char)

"Insert @var{char} into the input at the current

(vector-push-extend #\_ (input-line-string input))

(replace (input-line-string input) (input-line-string input)

:start2 (input-line-position input) :start1 (1+ (input-line-position input)))

(setf (char (input-line-string input) (input-line-position input)) char)

(incf (input-line-position input)))

(defun input-substring (input start end)

"Return a the substring in INPUT bounded by START and END."

(subseq (input-line-string input) start end))



(defun input-find-completions (str completions)

(let ((candidates (if (or (functionp completions)

(and (symbolp completions)

(fboundp completions)))

(funcall completions str)

completions)))

(remove-duplicates

(funcall *input-refine-candidates-fn* str candidates)

:test #'equal)))

(defun input-complete (input direction)

(unless (find *input-last-command* '(input-complete-forward

input-complete-backward))

(input-completion-reset *input-completion-style* (input-find-completions (input-substring input 0 (input-point input)) *input-completions*)))

(input-completion-complete *input-completion-style* input direction))

(defun input-complete-forward (input key)

(declare (ignore key))

(input-complete input :forward))

(defun input-complete-backward (input key)

(declare (ignore key))

(input-complete input :backward))

(defun input-delete-backward-char (input key)

(declare (ignore key))

(let ((pos (input-line-position input)))

(cond ((or (<= (length (input-line-string input)) 0)

(<= pos 0))

:error)

(t

(replace (input-line-string input) (input-line-string input)

:start2 pos :start1 (1- pos))

(decf (fill-pointer (input-line-string input)))

(decf (input-line-position input))))))

(defun input-delete-forward-char (input key)

(declare (ignore key))

(let ((pos (input-line-position input)))

(cond ((>= pos

(length (input-line-string input)))

:error)

(t

(replace (input-line-string input) (input-line-string input)

:start1 pos :start2 (1+ pos))

(decf (fill-pointer (input-line-string input)))))))

(defun input-forward-kill-word (input key)

(declare (ignore key))

(let* ((p1 (position-if 'alphanumericp (input-line-string input) :start (input-line-position input)))

(p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :start p1))))

(input-delete-region input (input-point input) (or p2 (length (input-line-string input))))))

(defun input-backward-kill-word (input key)

(declare (ignore key))

(let* ((p1 (position-if 'alphanumericp (input-line-string input) :end (input-line-position input) :from-end t))

(p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :end p1 :from-end t))))

(input-delete-region input (input-point input) (or (and p2 (1+ p2)) 0))))

(defun input-forward-word (input key)

(declare (ignore key))

(let* ((p1 (position-if 'alphanumericp (input-line-string input) :start (input-line-position input)))

(p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :start p1))))

(setf (input-line-position input) (or p2 (length (input-line-string input))))))

(defun input-backward-word (input key)

(declare (ignore key))

(let* ((p1 (position-if 'alphanumericp (input-line-string input) :end (input-line-position input) :from-end t))

(p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :end p1 :from-end t))))

(setf (input-line-position input) (or (and p2 (1+ p2))

0))))

(defun input-forward-char (input key)

(declare (ignore key))

(incf (input-line-position input))

(when (> (input-line-position input)

(length (input-line-string input)))

(setf (input-line-position input) (length (input-line-string input)))))

(defun input-backward-char (input key)

(declare (ignore key))

(decf (input-line-position input))

(when (< (input-line-position input) 0)

(setf (input-line-position input) 0)))

(defun input-move-beginning-of-line (input key)

(declare (ignore key))

(setf (input-line-position input) 0))

(defun input-move-end-of-line (input key)

(declare (ignore key))

(setf (input-line-position input) (length (input-line-string input))))

(defun input-kill-line (input key)

(declare (ignore key))

(unless (= (input-line-position input) (length (input-line-string input)))

(set-x-selection (subseq (input-line-string input) (input-line-position input))))

(setf (fill-pointer (input-line-string input)) (input-line-position input)))

(defun input-kill-to-beginning (input key)

(declare (ignore key))

(unless (= (input-line-position input) 0)

(set-x-selection (subseq (input-line-string input) 0 (input-line-position input))))

(replace (input-line-string input) (input-line-string input)

:start2 (input-line-position input) :start1 0)

(decf (fill-pointer (input-line-string input)) (input-line-position input))

(setf (input-line-position input) 0))

(defun input-history-back (input key)

(declare (ignore key))

(when (= (input-line-history input) -1)

(setf (input-line-history-bk input) (input-line-string input)))

(incf (input-line-history input))

(if (>= (input-line-history input)

(length *input-history*))

(progn

(decf (input-line-history input))

:error)

(setf (input-line-string input) (make-input-string (elt *input-history* (input-line-history input)))

(input-line-position input) (length (input-line-string input)))))

(defun input-history-forward (input key)

(declare (ignore key))

(decf (input-line-history input))

(cond ((< (input-line-history input) -1)

(incf (input-line-history input))

:error)

((= (input-line-history input) -1)

(setf (input-line-string input) (input-line-history-bk input)

(input-line-position input) (length (input-line-string input))))

(t

(setf (input-line-string input) (make-input-string (elt *input-history* (input-line-history input)))

(input-line-position input) (length (input-line-string input))))))

(defun dead-key-character (keysym)

"Given a dead key keysym, return the corresponding non-dead character"

(let ((symname (subseq (gethash keysym *dead-key-sym->name*) 5)))

;; Some sym names are different from their non-dead name, patch those here.

(cond ((string= symname "tilde")

(setf symname "asciitilde"))

((string= symname "circumflex")

(setf symname "asciicircum")))

(xlib:keysym->character *display*

(gethash symname *name-keysym-translations*))))

(defun dead-key-p (keysym)

"Check if KEYSYM is dead"

(gethash keysym *dead-key-sym->name*))

(defun make-combined-character (keysym dead-keysym)

"Try to modify KEYSYM with DEAD-KEYSYM by concatenating the keysym names

(let ((charname (keysym->keysym-name keysym))

(deadstr (ignore-errors

(subseq (gethash dead-keysym *dead-key-sym->name*) 5))))

(xlib:keysym->character *display*

(keysym-name->keysym

(concatenate 'string charname deadstr)))))

(defun find-character-for-keysym (input key)

"Find a character for the given key with support for dead keys."

(cond ((dead-key-p (key-keysym key))

(if (and (input-line-most-recent-dead-key input)

(= (input-line-most-recent-dead-key input) (key-keysym key)))

(progn (setf (input-line-most-recent-dead-key input) nil)

(dead-key-character (key-keysym key)))

(setf (input-line-most-recent-dead-key input) (key-keysym key))))

(t (let ((char (make-combined-character

(key-keysym key)

(input-line-most-recent-dead-key input))))

(setf (input-line-most-recent-dead-key input) nil)

char))))

(defun input-self-insert (input key)

(let* ((%char (ignore-errors (find-character-for-keysym input key)))

(char (or %char (xlib:keysym->character *display* (key-keysym key)))))

(if (or (key-mods-p key) (null char)

(not (characterp char)))

:error

(prog1 (input-insert-char input char)

(setf (input-line-most-recent-dead-key input) nil)))))

(defun input-yank-selection (input key)

(declare (ignore key))

;; if we own the selection then just insert it.

(if (getf *x-selection* :primary)

(input-insert-string input (getf *x-selection* :primary))

(xlib:convert-selection :primary

:string (screen-input-window (current-screen))

:stumpwm-selection)))

(defun input-yank-clipboard (input key)

(declare (ignore key))

(if (getf *x-selection* :clipboard)

(input-insert-string input (getf *x-selection* :clipboard))

(xlib:convert-selection :clipboard

:string (screen-input-window (current-screen))

:stumpwm-selection)))



(defun process-input (screen prompt input code state)

"Process the key (code and state), given the current input

(labels ((process-key (code state)

"Call the appropriate function based on the key

(let* ((key (code-state->key code state))

(command (and key (lookup-key *input-map* key t))))

(if command

(prog1

(funcall command input key)

(setf *input-last-command* command)

(draw-input-bucket screen prompt input))

:error))))

(case (process-key code state)

(:done

(unless (or (input-line-password input)

(and *input-history-ignore-duplicates*

(string= (input-line-string input) (first *input-history*))))

(push (input-line-string input) *input-history*))

:done)

(:abort

(throw :abort t))

(:error

;; FIXME draw inverted text

(draw-input-bucket screen prompt input "" t)

nil)

(t

(draw-input-bucket screen prompt input)

nil))))

(defun all-modifier-codes ()

"Return all the keycodes that are associated with a modifier."

(flatten (multiple-value-list (xlib:modifier-mapping *display*))))

(defun get-modifier-map ()

(labels ((find-mod (mod codes)

(let* ((keysym (keysym-name->keysym mod))

(keycodes (multiple-value-list (xlib:keysym->keycodes *display* keysym))))

(intersection keycodes codes))))

(let ((modifiers (make-modifiers)))

(multiple-value-bind

(shift-codes lock-codes control-codes mod1-codes mod2-codes mod3-codes mod4-codes mod5-codes)

(xlib:modifier-mapping *display*)

(declare (ignore shift-codes lock-codes control-codes))

(loop for mod in '(:mod-1 :mod-2 :mod-3 :mod-4 :mod-5)

for codes in (list mod1-codes mod2-codes mod3-codes mod4-codes mod5-codes)

do

(cond ((or (find-mod "Meta_L" codes)

(find-mod "Meta_R" codes))

(push mod (modifiers-meta modifiers)))

((or (find-mod "Alt_L" codes)

(find-mod "Alt_R" codes))

(push mod (modifiers-alt modifiers)))

((or (find-mod "Super_L" codes)

(find-mod "Super_R" codes))

(push mod (modifiers-super modifiers)))

((or (find-mod "Hyper_L" codes)

(find-mod "Hyper_R" codes))

(push mod (modifiers-hyper modifiers)))

((find-mod "Num_Lock" codes)

(push mod (modifiers-numlock modifiers)))

((find-mod "ISO_Level3_Shift" codes)

(push mod (modifiers-altgr modifiers)))))

;; If alt is defined but meta isn't set meta to alt and clear alt

(when (and (modifiers-alt modifiers)

(null (modifiers-meta modifiers)))

(setf (modifiers-meta modifiers) (modifiers-alt modifiers)

(modifiers-alt modifiers) nil))

modifiers))))

(defun update-modifier-map ()

(setf *modifiers* (get-modifier-map)

*all-modifiers* (all-modifier-codes)))

(defun mod->string (state)

"Convert a stump modifier list to a string."

(let ((alist '((:alt . "A-") (:meta . "M-") (:hyper . "H-") (:super . "S-"))))

(apply #'concatenate 'string (mapcar (lambda (x) (cdr (assoc x alist))) state))))

(defun y-or-n-p (message)

"Ask a \"y or n\" question on the current screen and return T if the

(message "~a(y or n) " message)

(eql (read-one-char (current-screen))

#\y))

(defun yes-or-no-p (message)

"ask a \"yes or no\" question on the current screen and return T if the

(loop for line = (string-trim

'(#\Space)

(read-one-line (current-screen)

(format nil "~a(yes or no) " message)

:completions

'("yes" "no")))

until (find line '("yes" "no") :test 'string-equal)

do (message "Please answer yes or no.")

(sleep 1)

finally (return (string-equal line "yes"))))