346 lines
12 KiB
Scheme
346 lines
12 KiB
Scheme
;; the window for the question is mapped at the bottom of parent, or
|
|
;; in the middle of the root-window if parent is #f.
|
|
|
|
;; if answers is a list of strings then that are the valid answers and
|
|
;; one of it is returned. if it is #f then the string terminated by RETURN
|
|
;; is returned. ..... list of chars
|
|
;; if ESC is pressed #f is returned.
|
|
|
|
(define-options-spec prompt-options-spec
|
|
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
|
(font-color color "black")
|
|
(background-color color "#cccccc")
|
|
(edit-font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
|
(edit-font-color color "black")
|
|
(edit-background-color color "white")
|
|
(border-width int 4))
|
|
|
|
(define options #f)
|
|
|
|
(define line-spacing 1)
|
|
|
|
(define xk-escape 65307) ;; 0xFF1B
|
|
(define xk-return 65293) ;; 0xFF0D
|
|
(define xk-left 65361) ;; 0xFF51
|
|
(define xk-right 65363) ;; 0xFF53
|
|
(define xk-home 65360) ;; 0xFF50
|
|
(define xk-end 65367) ;; 0xFF57
|
|
(define xk-delete 65535) ;; 0xFFFF
|
|
(define xk-backspace 65288) ;; 0xFF08
|
|
(define xk-up 65362) ;; 0xFF52
|
|
(define xk-down 65364) ;; 0xFF54
|
|
(define xk-tab 65289) ;; 0xFF09
|
|
|
|
;; complete is a function (lambda (string cursor-pos) ...) returning
|
|
;; either a new (string . cursor-pos) pair or a string list that is
|
|
;; displayed as possible completions.
|
|
|
|
(define (prompt dpy parent question answers complete)
|
|
(if (not options)
|
|
(set! options
|
|
(create-options dpy (screen:default-colormap
|
|
(display:default-screen dpy))
|
|
prompt-options-spec '())))
|
|
(let* ((root-window (default-root-window dpy))
|
|
(need-edit? (not (and answers (not (null? answers))
|
|
(every char? answers))))
|
|
(rects (calc-rects dpy parent question need-edit? #f options))
|
|
(win-r (first rects))
|
|
(window (create-simple-window
|
|
dpy (or parent root-window)
|
|
(rectangle:x win-r) (rectangle:y win-r)
|
|
(rectangle:width win-r) (rectangle:height win-r)
|
|
0 (black-pixel dpy)
|
|
(get-option-value options 'background-color))))
|
|
(set-window-override-redirect! dpy window #t)
|
|
|
|
;; maybe grab-pointer
|
|
(call-with-event-channel
|
|
dpy window (event-mask exposure key-press)
|
|
(lambda (event-channel)
|
|
(map-window dpy window)
|
|
(grab-keyboard dpy window #f (grab-mode async) (grab-mode async)
|
|
current-time)
|
|
(set-input-focus dpy window (revert-to parent) current-time)
|
|
(let* ((gc (create-gc dpy window (make-gc-value-alist)))
|
|
(result (do-input dpy parent question answers complete need-edit?
|
|
window gc options event-channel)))
|
|
(ungrab-keyboard dpy current-time)
|
|
(free-gc dpy gc)
|
|
(destroy-window dpy window)
|
|
result)))))
|
|
|
|
(define (do-input dpy parent question answers complete need-edit?
|
|
window gc options event-channel)
|
|
(let* ((matched-answer
|
|
(lambda (s)
|
|
(if answers
|
|
(let ((l (filter (lambda (a)
|
|
(or (and (char? a) (not (equal? s ""))
|
|
(eq? a (string-ref s 0)))
|
|
(equal? a s)))
|
|
answers)))
|
|
(and (not (null? l)) (car l)))
|
|
s)))
|
|
(last-input #f) (last-cursor #f)
|
|
(last-completions #t)
|
|
(rects #f)
|
|
(completions-rect #f)
|
|
(question-rect #f)
|
|
(edit-rect #f))
|
|
(let loop ((input "")
|
|
(cursor 0)
|
|
(completions #f))
|
|
(if (not (eq? completions last-completions))
|
|
(begin
|
|
(set! rects (calc-rects dpy parent question need-edit? completions
|
|
options))
|
|
(move-resize-window* dpy window (first rects))
|
|
(set! completions-rect (second rects))
|
|
(set! question-rect (third rects))
|
|
(set! edit-rect (fourth rects)))
|
|
(if (and need-edit?
|
|
(or (not (eq? input last-input))
|
|
(not (eq? cursor last-cursor))))
|
|
(draw-edit dpy window gc options input cursor edit-rect)))
|
|
(set! last-input input)
|
|
(set! last-cursor cursor)
|
|
(set! last-completions completions)
|
|
|
|
(let ((e (receive event-channel)))
|
|
(cond
|
|
((expose-event? e)
|
|
(if completions
|
|
(draw-completions dpy window gc options completions
|
|
completions-rect))
|
|
(draw-question dpy window gc options question question-rect)
|
|
(if need-edit?
|
|
(draw-edit dpy window gc options input cursor edit-rect))
|
|
(loop input cursor completions))
|
|
|
|
((eq? (event-type key-press) (any-event-type e))
|
|
(let* ((keysym.str (lookup-string/keysym e))
|
|
(keysym (car keysym.str))
|
|
(str (cdr keysym.str)))
|
|
(cond
|
|
((equal? keysym xk-escape) #f)
|
|
((equal? keysym xk-return)
|
|
(or (matched-answer input)
|
|
(loop "" 0 #f)))
|
|
((not need-edit?)
|
|
(or (matched-answer str)
|
|
(loop "" 0 #f)))
|
|
((equal? keysym xk-left)
|
|
(loop input
|
|
(if (> cursor 0) (- cursor 1) cursor)
|
|
completions))
|
|
((equal? keysym xk-right)
|
|
(loop input
|
|
(if (< cursor (string-length input))
|
|
(+ cursor 1) cursor)
|
|
completions))
|
|
((equal? keysym xk-home)
|
|
(loop input 0 completions))
|
|
((equal? keysym xk-end)
|
|
(loop input (string-length input) completions))
|
|
((equal? keysym xk-delete)
|
|
(loop (if (< cursor (string-length input))
|
|
(string-append
|
|
(substring input 0 cursor)
|
|
(substring input (+ cursor 1)
|
|
(string-length input)))
|
|
input)
|
|
cursor completions))
|
|
((equal? keysym xk-backspace)
|
|
(if (> cursor 0)
|
|
(loop (string-append
|
|
(substring input 0 (- cursor 1))
|
|
(substring input cursor
|
|
(string-length input)))
|
|
(- cursor 1) completions)
|
|
(loop input cursor completions)))
|
|
((equal? keysym xk-tab)
|
|
;; tab-completion
|
|
(if complete
|
|
(let ((res (complete input cursor)))
|
|
(if (and (pair? res) (not (pair? (cdr res))))
|
|
(loop (car res) (cdr res) #f)
|
|
(loop input cursor res)))
|
|
(loop input cursor completions)))
|
|
;; TODO: up-down history
|
|
(else
|
|
(let ((new (string-append
|
|
(substring input 0 cursor)
|
|
str
|
|
(substring input cursor
|
|
(string-length input)))))
|
|
(loop new
|
|
(+ cursor (string-length str))
|
|
completions))))))
|
|
(else (loop input cursor completions)))))))
|
|
|
|
(define (calc-rects dpy parent question need-edit? completions? options)
|
|
(let* ((edit-font (get-option-value options 'edit-font))
|
|
(want-completions-width (if completions?
|
|
(strings-width edit-font completions?)
|
|
0))
|
|
(question-font (get-option-value options 'font))
|
|
(maximum-width 800) ;; or 2/3 of screen-width ??
|
|
(minimum-width 512) ;; or 1/3 of screen-widht ??
|
|
(want-question-width
|
|
(strings-width question-font
|
|
(split-multiline-text
|
|
question-font question
|
|
(if parent (window-width dpy parent)
|
|
maximum-width))))
|
|
(width (if parent
|
|
(window-width dpy parent)
|
|
(max minimum-width (min maximum-width
|
|
(max want-completions-width
|
|
want-question-width)))))
|
|
(border-width (get-option-value options 'border-width))
|
|
(completions-height (if completions?
|
|
(strings-height edit-font completions?)
|
|
0))
|
|
(question-width (- width (* 2 border-width)))
|
|
(completions-width question-width)
|
|
(question-height (strings-height question-font
|
|
(split-multiline-text
|
|
question-font question
|
|
question-width)))
|
|
(edit-height (if need-edit?
|
|
(+ 2 (font-struct:ascent edit-font)
|
|
(font-struct:descent edit-font))
|
|
0))
|
|
(edit-width question-width)
|
|
(spacing 2)
|
|
(height (+ (* 2 border-width) question-height completions-height
|
|
edit-height
|
|
(if need-edit? spacing 0)
|
|
(if completions? spacing 0)))
|
|
(root-window (default-root-window dpy))
|
|
(x (if parent 0
|
|
(quotient (- (window-width dpy root-window) width) 2)))
|
|
(y (if parent
|
|
(- (window-height dpy parent) height)
|
|
(quotient (- (window-height dpy root-window) height) 2))))
|
|
(let* ((window-rect (make-rectangle x y width height))
|
|
(completions-rect (make-rectangle border-width border-width
|
|
completions-width
|
|
completions-height))
|
|
(question-rect
|
|
(make-rectangle border-width
|
|
(if completions?
|
|
(+ spacing (rectangle:y completions-rect)
|
|
(rectangle:height completions-rect))
|
|
border-width)
|
|
question-width question-height))
|
|
(edit-rect
|
|
(make-rectangle border-width
|
|
(+ spacing (rectangle:y question-rect)
|
|
(rectangle:height question-rect))
|
|
edit-width edit-height)))
|
|
(list window-rect completions-rect question-rect edit-rect))))
|
|
|
|
(define (draw-background dpy window gc options floating?)
|
|
(let ((r (clip-rectangle dpy window)))
|
|
(set-gc-foreground! dpy gc (get-option-value options 'background-color))
|
|
(fill-rectangle* dpy window gc r)
|
|
(if floating?
|
|
(draw-shadow-rectangle dpy window gc r (white-pixel dpy)
|
|
(black-pixel dpy)))))
|
|
|
|
(define (draw-question dpy window gc options question r)
|
|
(let ((font-struct (get-option-value options 'font)))
|
|
(set-gc-font! dpy gc (font-struct:fid font-struct))
|
|
(set-gc-foreground! dpy gc (get-option-value options 'font-color))
|
|
(set-gc-background! dpy gc (get-option-value options 'background-color))
|
|
(draw-multiline-text dpy window gc font-struct question r)))
|
|
|
|
(define (draw-completions dpy window gc options strings r)
|
|
(let ((fs (get-option-value options 'edit-font)))
|
|
(set-gc-font! dpy gc (font-struct:fid fs)) ;; ??
|
|
(set-gc-foreground! dpy gc (get-option-value options 'font-color))
|
|
(set-gc-background! dpy gc (get-option-value options 'background-color))
|
|
(draw-text-lines dpy window gc fs strings r)))
|
|
|
|
(define (split-multiline-text fs text max-width)
|
|
(letrec ((split (lambda (x chars current lines)
|
|
(cond
|
|
((null? chars) (reverse (cons current lines)))
|
|
((eq? (car chars) #\newline) (split 0 (cdr chars)
|
|
"" (cons current lines)))
|
|
(else
|
|
(let* ((s (make-string 1 (car chars)))
|
|
(cw (char-struct:width (text-extents fs s))))
|
|
(if (<= (+ x cw) max-width)
|
|
(split (+ x cw) (cdr chars)
|
|
(string-append current s) lines)
|
|
(split cw (cdr chars)
|
|
s (cons current lines)))))))))
|
|
(split 0 (string->list text) "" '())))
|
|
|
|
(define (draw-multiline-text dpy window gc fs text r)
|
|
(draw-text-lines dpy window gc fs
|
|
(split-multiline-text fs text (rectangle:width r))
|
|
r))
|
|
|
|
(define (draw-text-lines dpy window gc fs lines r)
|
|
;; maybe clip drawing...
|
|
(let ((x (rectangle:x r))
|
|
(line-height (+ line-spacing (font-struct:ascent fs)
|
|
(font-struct:descent fs))))
|
|
(let loop ((y (rectangle:y r)) ;; what about max-height ??
|
|
(lines lines))
|
|
(if (not (null? lines))
|
|
(let ((line (car lines)))
|
|
(draw-image-string dpy window gc x (+ y (font-struct:ascent fs))
|
|
line)
|
|
(loop (+ y line-height) (cdr lines)))))))
|
|
|
|
(define (draw-edit dpy window gc options input cursor r)
|
|
(let* ((font-struct (get-option-value options 'edit-font))
|
|
(bg (get-option-value options 'edit-background-color))
|
|
(fg (get-option-value options 'edit-font-color))
|
|
(asc (font-struct:ascent font-struct)))
|
|
(set-gc-foreground! dpy gc bg)
|
|
(fill-rectangle* dpy window gc r)
|
|
(draw-shadow-rectangle dpy window gc r (black-pixel dpy)
|
|
(white-pixel dpy))
|
|
|
|
(set-gc-font! dpy gc (font-struct:fid font-struct))
|
|
(set-gc-foreground! dpy gc fg)
|
|
(set-gc-background! dpy gc bg)
|
|
(draw-image-string dpy window gc (+ (rectangle:x r) 1)
|
|
(+ (rectangle:y r) 1 asc) input)
|
|
;; cursor
|
|
(set-gc-function! dpy gc (gc-function xor))
|
|
(set-gc-foreground! dpy gc (white-pixel dpy))
|
|
(let* ((pre-cursor-width
|
|
(char-struct:width (text-extents font-struct
|
|
(substring input 0 cursor))))
|
|
(cursor-width (char-struct:width
|
|
(text-extents font-struct
|
|
(if (< cursor (string-length input))
|
|
(substring input cursor
|
|
(+ cursor 1))
|
|
" ")))))
|
|
(fill-rectangle dpy window gc
|
|
(+ (rectangle:x r) pre-cursor-width 1)
|
|
(+ (rectangle:y r) 1)
|
|
cursor-width
|
|
(+ 1 (font-struct:ascent font-struct)
|
|
(font-struct:descent font-struct)))
|
|
(set-gc-function! dpy gc (gc-function copy)))))
|
|
|
|
(define (strings-width fs strings)
|
|
(apply max
|
|
(map (lambda (s)
|
|
(char-struct:width (text-extents fs s)))
|
|
strings)))
|
|
|
|
(define (strings-height fs strings)
|
|
(let ((line-height (+ line-spacing (font-struct:ascent fs)
|
|
(font-struct:descent fs))))
|
|
(* line-height (length strings))))
|