116 lines
3.5 KiB
Scheme
116 lines
3.5 KiB
Scheme
(define-structure surflet surflet-interface
|
|
(open surflets
|
|
surflets/my-input-fields
|
|
surflet-requests
|
|
handle-fatal-error
|
|
let-opt
|
|
scheme-with-scsh)
|
|
(begin
|
|
|
|
;; This doesn't use c-a-l-l-b-a-c-k-s anymore.
|
|
|
|
(define *operator-alist*
|
|
`(("+" . ,+)
|
|
("-" . ,-)
|
|
("*" . ,*)
|
|
("/" . ,/)))
|
|
|
|
(define operator-symbol car)
|
|
(define operator-operator cdr)
|
|
|
|
(define operator-input-field
|
|
(let ((name (generate-input-field-name "operator")))
|
|
(make-input-field
|
|
name "operator"
|
|
(lambda (input-field operator-string)
|
|
(let ((operator (assoc operator-string *operator-alist*)))
|
|
(if operator
|
|
operator
|
|
(error "no such operator" operator-string))))
|
|
'()
|
|
(lambda (input-field)
|
|
`(select (@ (name ,name))
|
|
,@(map (lambda (operator)
|
|
`(option ,(operator-symbol operator)))
|
|
*operator-alist*))))))
|
|
|
|
|
|
(define (make-number-field/default default)
|
|
(if default
|
|
(make-number-field default)
|
|
(make-number-field)))
|
|
|
|
(define (show-page operator-pair number1 number2 . maybe-update-text)
|
|
(let* ((update-text (:optional maybe-update-text ""))
|
|
(number-field1 (make-number-field/default number1))
|
|
(number-field2 (make-number-field/default number2))
|
|
(calculate-button (make-submit-button "Calculate"))
|
|
(change-button (make-submit-button "Change operator"))
|
|
(req
|
|
(send-html/suspend
|
|
(lambda (new-url)
|
|
`(html
|
|
(title "Simple calculator")
|
|
(body (h1 "Simple calculator")
|
|
(font (@ (color "red")) ,update-text)
|
|
(surflet-form
|
|
,new-url
|
|
(table
|
|
(tr (td "Do calculation:"))
|
|
(tr (td ,number-field1)
|
|
(td ,(operator-symbol operator-pair))
|
|
(td ,number-field2)
|
|
(td " = ")
|
|
(td ,calculate-button)))
|
|
(hr)
|
|
(p "You may choose another operator:")
|
|
(table
|
|
(tr (td ,operator-input-field)
|
|
(td ,change-button)))
|
|
(hr)
|
|
(p (url "/" "Return to main menu."))))))))
|
|
(bindings (get-bindings req)))
|
|
(let ((number1 (input-field-value number-field1 bindings))
|
|
(number2 (input-field-value number-field2 bindings)))
|
|
(cond
|
|
((returned-via? calculate-button bindings)
|
|
(if number1
|
|
(if number2
|
|
(calculate operator-pair number1 number2)
|
|
(show-page operator-pair number1 number2
|
|
"Please enter a valid second number."))
|
|
(show-page operator-pair number1 number2
|
|
"Please enter a valid first number.")))
|
|
((returned-via? change-button bindings)
|
|
(with-fatal-error-handler
|
|
(lambda (c d)
|
|
;; This should never happen.
|
|
(show-page operator-pair #f #f
|
|
"Internal error. Please retry or report."))
|
|
(show-page (input-field-value operator-input-field
|
|
bindings)
|
|
number1 number2)))
|
|
(else
|
|
;; This should never happen.
|
|
(show-page operator-pair #f #f
|
|
"Internal error. Please retry or report."))))))
|
|
|
|
(define (calculate operator-pair number1 number2)
|
|
(let ((operator (operator-operator operator-pair)))
|
|
(show-result number1 (operator-symbol operator-pair) number2
|
|
(operator number1 number2))))
|
|
|
|
(define (show-result number1 operator-symbol number2 result)
|
|
(send-html
|
|
`(html (title "Calculation Result")
|
|
(body (h1 "Result")
|
|
(p ,number1 " " ,operator-symbol " " ,number2
|
|
" = " ,result)
|
|
(hr)
|
|
(p (url "calculate.scm" "Make new calculation") (br)
|
|
(url "/" "Return to main menu."))))))
|
|
|
|
(define (main req)
|
|
(show-page (car *operator-alist*) #f #f)
|
|
(error "This does not return"))
|
|
)) |