; ,open fluids srfi-23 formats receiving
; (define with-fluid let-fluid)
;; (INQUIRE-USER <question> <answer-alist> [<default-answer> ;procedure
;; [<eof-thunk>]])
;; Each element of ANSWER-ALIST, a proper list, should be a pair with
;; the form
;; (<answer-specification> <continuation>)
;; Ask QUESTION and dispatch the user's answer by searching for a key
;; in ANSWER-ALIST. No further description is given -- see below --.
;;
;; ANSWER-SPECIFICATIONS have the following meanings:
;;
;; - a procedure of one argument
;; -- apply this predicate to the line of user input to test if
;; it should match.
;; - a string
;; -- compare the string, case-insensitively, to the user input
;; - the symbol YES
;; -- as if the specification were a list of certain predefined
;; affirmative answers
;; - the symbol NO
;; -- as if the specification were a list of certain predefined
;; negative answers
;; - a proper list of answer specifications
;; -- test to see if any of the elements match
;; - #T
;; -- automatically matches
;;
;; The exact action that INQUIRE-USER performs to ask a question of the
;; user depends on two fluid variables. These are fluids in order that
;; a programmer may replace them if the user is not interacting through
;; a console (e.g., for a GUI program), or the programmer may desire to
;; use a different format for the question, or something.
;;
;; ($USER-INQUIRER <inquirer-procedure>) ;fluid variable
;; INQUIRER-PROCEDURE must match the signature of INQUIRE-USER. This
;; procedure will be called by INQUIRE-USER.
;;
;; The top-level value of $USER-INQUIRER can be described as, using the
;; same signature as INQUIRE-USER:
;;
;; Ask QUESTION and dispatch the user's answer by searching for a key
;; in ANSWER-ALIST. Should the user's answer be an EOF, keep trying,
;; but stop after a certain number of retries. In the case where the
;; user should input an answer with no matching answer specification,
;; the question is reiterated.
;;
;; A blank line indicates DEFAULT-ANSWER.
;;
;; ($MAX-USER-INQUIRIES <maximum>) ;fluid variable
;; MAXIMUM specifies the number of iterations of inquiry that will be
;; executed before giving up. The top-level value in this is 10.
;;
;; $MAX-USER-INQUIRIES isn't actually necessarily used. It is merely a
;; hint to the current inquirer procedure.
;;
;; The procedures WITH-USER-INQUIRER & WITH-MAX-USER-INQUIRIES create a
;; layer of abstraction over the two fluids.
;;
;; There is one utility for inquirers other than the default one:
;;
;; (USER-ANSWER-MATCHES? <user-answer> <answer-spec>) ;procedure
;; Does USER-ANSWER match ANSWER-SPEC as described above?
;;
;; A variant of Y-OR-N-P is trivially defined at the bottom:
;;
;; (YES-OR-NO? <question> <default> [<eof-thunk>]) ;procedure
;; Ask QUESTION. Return #T to indicate positive input from the user,
;; or #F to indicate negative input.
;;;; Implementation
(define (user-answer-matches? answer answer-spec)
(cond ((eq? answer-spec #t)
#t)
((procedure? answer-spec)
(answer-spec answer))
((string? answer-spec)
(string-ci=? answer answer-spec))
((eq? answer-spec 'yes)
(user-answer-matches? answer user-inquiry:*yes*))
((eq? answer-spec 'no)
(user-answer-matches? answer user-inquiry:*no*))
((proper-list? answer-spec)
(any (lambda (answer-spec*)
(user-answer-matches? answer answer-spec*))
answer-spec))
(else
(error "Bad user answer spec"
answer-spec))))
(define user-inquiry:default-inquirer
(lambda (question answer-alist . opt-args)
(define max-count (fluid $max-user-inquiries))
(receive (default eof-thunk)
(cond ((null? opt-args)
(values #f
(lambda ()
(error "EOF after maximum yes/no retries"
max-count))))
((null? (cdr opt-args))
(values (and (car opt-args)
;; Cheap hack to figure out what the system
;; prefers to format arbitrary objects.
(format #f "~A" (car opt-args)))
(lambda ()
(error "EOF after maximum yes/no retries"
max-count))))
((null? (cddr opt-args))
(values (car opt-args) (cadr opt-args)))
(else
(apply error "Too many arguments"
user-inquiry:default-inquirer
question answer-alist
opt-args)))
(define read-line/default
(if default
(lambda ()
(let ((l (read-line)))
(cond ((eof-object? l)
l)
((zero? (string-length l))
default)
(else
l))))
read-line))
(define (maybe-retry count)
(newline)
(cond ((zero? count)
(eof-thunk))
(else
(display "I shall ask only another ")
(write count)
(display (if (= count 1) " time." " times."))
(newline)
(loop (- count 1)))))
(define (loop count)
(display question)
(cond (default
(display " [")
(display default)
(display "]")))
(display " ")
(let ((line (read-line/default)))
(cond ((eof-object? line)
(maybe-retry count))
((assoc* line answer-alist user-answer-matches?)
=> (lambda (probe) ((cadr probe) line)))
(else
(display
" Please answer the question that was asked.")
(newline)
(loop count)))))
(loop max-count))))
(define user-inquiry:default-max 10)
(define $user-inquirer (make-fluid user-inquiry:default-inquirer))
(define $max-user-inquiries (make-fluid user-inquiry:default-max))
(define (with-user-inquirer user-inquirer thunk)
(with-fluid $user-inquirer user-inquirer thunk))
(define (with-max-user-inquiries max thunk)
(with-fluid $max-user-inquiries max thunk))
(define user-inquiry:*yes*
'("y" "yes" "yeah" "yeh" "yah" "aye" "ayup" "yup" "indeed" "affirmed"
"affirmative" "positive" "sure" "ok" "okay"))
(define user-inquiry:*no*
'("n" "no" "nah" "na" "naw" "nope" "no way" "negative" "not affirmed"
"not affirmative" "nyet!" "nay"))
(define (inquire-user question answer-alist . opt-args)
(apply (fluid $user-inquirer)
question
answer-alist
opt-args))
;; YES-OR-NO? is trivially defined in terms of INQUIRE-USER.
(define (yes-or-no? question . opt-args)
(apply inquire-user question
`((yes ,(lambda (line) #t))
(no ,(lambda (line) #f)))
opt-args))
