user-input-output.scm 3.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101
  1. (define-module (user-input-output)
  2. #:use-module (ice-9 textual-ports)
  3. #:use-module (ice-9 optargs)
  4. #:use-module (srfi srfi-1)
  5. #:export (read-line
  6. write-string
  7. remove-whitespace-chars
  8. ask-user
  9. ask-user-for-character
  10. ask-user-for-number
  11. ask-user-for-integer-number
  12. ask-user-for-yes-no-decision))
  13. ;; Using the recommended Textual I/O described in:
  14. ;; https://www.gnu.org/software/guile/manual/html_node/Textual-I_002fO.html#Textual-I_002fO
  15. (define (read-line)
  16. (get-line (current-input-port)))
  17. (define (write-string string)
  18. (define port (current-output-port))
  19. (put-string port string))
  20. (define (remove-whitespace-chars string)
  21. (string-delete (lambda (char)
  22. (memq char '(#\newline #\tab #\return #\space)))
  23. string))
  24. (define* (ask-user question pred
  25. #:key
  26. (input-cleanup-proc remove-whitespace-chars)
  27. (possible-answers #f)
  28. (q-a-separator ": ")
  29. (invalid-input-message "Invalid input.\n"))
  30. (define (write-question question possible-answers q-a-separator)
  31. (write-string question)
  32. (if possible-answers
  33. (write-string (string-append " " "(" (string-join possible-answers "/") ")"))
  34. (write-string ""))
  35. (write-string q-a-separator))
  36. (write-question question possible-answers q-a-separator)
  37. (let* ([input (read-line)]
  38. [cleaned-input (input-cleanup-proc input)])
  39. (cond [(pred cleaned-input)
  40. (cond [possible-answers
  41. (cond [(member cleaned-input possible-answers) cleaned-input]
  42. [else
  43. (write-string invalid-input-message)
  44. (ask-user question
  45. pred
  46. #:input-cleanup-proc input-cleanup-proc
  47. #:possible-answers possible-answers
  48. #:q-a-separator q-a-separator
  49. #:invalid-input-message invalid-input-message)])]
  50. [else cleaned-input])]
  51. [else (write-string invalid-input-message)
  52. (ask-user question
  53. pred
  54. #:input-cleanup-proc input-cleanup-proc
  55. #:possible-answers possible-answers
  56. #:q-a-separator q-a-separator
  57. #:invalid-input-message invalid-input-message)])))
  58. (define* (ask-user-for-character question char-pred
  59. #:key
  60. (invalid-input-message "Invalid input. Enter a character.\n"))
  61. (ask-user question
  62. (λ (input)
  63. (and (= (string-length input) 1)
  64. (char-pred (car (string->list input)))))
  65. #:invalid-input-message invalid-input-message))
  66. (define (ask-user-for-number question number-pred)
  67. (string->number
  68. (ask-user question
  69. (lambda (input)
  70. (and (string->number input)
  71. (number-pred (string->number input)))))))
  72. (define (ask-user-for-integer-number question number-pred)
  73. (ask-user-for-number question (λ (num) (and (number-pred num)
  74. (integer? num)))))
  75. (define (ask-user-for-yes-no-decision question positive-answers negative-answers)
  76. (let ([user-input
  77. (ask-user question
  78. (λ (input)
  79. (member input (lset-union string=? positive-answers negative-answers)))
  80. #:possible-answers (reverse (lset-union string=?
  81. positive-answers
  82. negative-answers)))])
  83. (member user-input positive-answers)))