sunet/web-server/root/surflets/calculate.scm

(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"))
    ))