scheme shell
about
download
support
resources
docu
links
 
scsh.net

User Inquiry

YES-OR-NO? on steroids.

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


UserInquiry - raw wiki source | code snippets archive