orion-wm/src/prompt.scm

;; 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))))