From 4570e42eeb999646b7b22fd09a9a37c052f2a31f Mon Sep 17 00:00:00 2001 From: interp Date: Sat, 9 Nov 2002 18:26:26 +0000 Subject: [PATCH] bigger application --- .../web-server/root/surflets/spaceship.scm | 185 ++++++++++++++++++ 1 file changed, 185 insertions(+) create mode 100644 scheme/httpd/surflets/web-server/root/surflets/spaceship.scm diff --git a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm new file mode 100644 index 0000000..0506999 --- /dev/null +++ b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm @@ -0,0 +1,185 @@ +(define-structure servlet servlet-interface + (open scsh + scheme + servlets + let-opt + receiving) +(begin + +;;; Spaceship components +;;; Size (Class ...) +;;; Arms (Photontorpedos, Phaser) +;;; Shields +;;; Drive (Impuls, Warp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; DATA +(define classes + '("Constitution" "Excelsior" "Ambassador" "Galaxy")) + +(define drives + '("Impuls" "Warp")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Calculation + +(define (main req . update-text+class+armed?+shields?+drive) + (let-optionals update-text+class+armed?+shields?+drive + ((update-text #f) + (def-class #f) + (def-armed? #f) + (def-shields? #f) + (def-drive #f)) + (let* ((class-radios (make-radio-input-fields + (checked-radio classes def-class))) + (drive-radios (make-radio-input-fields + (checked-radio drives def-drive))) + (armed-checkbox (make-checkbox-input-field def-armed?)) + (shield-checkbox (make-checkbox-input-field def-shields?)) + (req (send-html/suspend + (lambda (new-url) + (generate-main-page new-url update-text + class-radios drive-radios + armed-checkbox shield-checkbox)))) + (bindings (get-bindings req)) + (class (input-field-value (car class-radios) bindings)) + (armed? (input-field-value armed-checkbox bindings)) + (shields? (input-field-value shield-checkbox bindings)) + (drive (input-field-value (car drive-radios) bindings))) + (cond + ((not class) + (main req "Please specifiy a class." class armed? shields? drive)) + ((not drive) + (main req "Please specifiy a drive." class armed? shields? drive)) + (else + (specify-components req #f class armed? shields? drive)))))) + +(define (specify-components req update-text class armed? shields? drive) + (receive (size med-beds) + (get-size req class) + (resulting-page + class + (and armed? (get-armed)) + (and shields? (get-shields)) + drive + size + med-beds))) + +(define (get-armed) 13) +(define (get-shields) 14) + +(define (resulting-page class armed shields drive size med-beds) + (send-html/finish + `(html ,(make-title) + (body + (h2 "Results") + (p "Your spaceship is of class " ,class + " containing " ,size " crew members, " + ,med-beds " treatment beds, " + ,(and armed (list armed " armed,")) + ,(and shields (list shields " shields")) + " and has a " ,drive " drive."))))) + + +(define (get-size req class . maybe-update-text) + ((lambda (a b) (< a b)) 0 #f) + + (let* ((update-text (:optional maybe-update-text #f)) + (size-input (make-number-input-field)) + (complain (lambda (class size) + (format #f "Spaceships of the ~a class can only have +up to ~a crew members. Please adjust the selected size or choose another +spaceship class" class size))) + (req (send-html/suspend + (lambda (new-url) + `(html + ,(make-title) + (body + (h2 "Step 2 -- Specify crew size") + (p "Please specify how many crew members your ship of class " ,class " +will have. The builder will add as many treatment beds and accomodations as necessary to +fullfill UFP Spaceship Crew's Rights Act 023/1000285.0/AB") + (p ,(and update-text `(font (@ (color "red")) ,update-text))) + (servlet-form ,new-url + GET + (table + (tr (td "My ship is for a crew of ") + (td ,size-input) + (td "people")) + (tr (td ,(make-submit-button)))))))))) + (bindings (get-bindings req)) + (size (input-field-value size-input bindings))) + (if (or (not size) + (<= size 0)) + (get-size req class "According to UFP Spaceship Crew Consistence Act +025/100030.2/BX there must be at least one person on each spaceship. Thus, please +specify a positive number.") + (cond + ((string=? class "Constitution") + (if (<= size 400) + (values size 14) + (get-size req class (complain class 400)))) + ((string=? class "Excelsior") + (if (<= size 570) + (values size 17) + (get-size req class (complain class 570)))) + ((string=? class "Ambassador") + (if (<= size 550) + (values size 16) + (get-size req class (complain class 550)))) + ((string=? class "Galaxy") + (if (<= size 760) + (values size 50) + (get-size req class (complain class 760)))) + (else + (get-size req class "Something is wrong. You cannot pass this point, sorry.") + ))))) +; (send-html/finish +; `(html (body "Done")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Page generating + +(define (make-title) + '(title "Spaceship Builder")) + +(define (generate-main-page new-url update-text + class-radios drive-radios + armed-checkbox shield-checkbox) + `(html + ,(make-title) + (body + (h1 "Welcome to the Spaceship Builder Web Site!") + (p "Here you can build your own space ship") + (h2 "Step 1 -- Selecting components") + ,(and update-text `(font (@ (color "red")) ,update-text)) + (servlet-form ,new-url + GET + (table + (tr (@ (valign "top")) + (td "My spaceship is of class") + (td (table ,@(table-radios class-radios classes)))) + (tr (td (table (tr (td ,armed-checkbox) (td "My spaceship is armed."))))) + (tr (td (table (tr (td ,shield-checkbox) (td "My spaceship has shields."))))) + (tr (@ (valign "top")) + (td "My spaceship's drive is ") + (td (table ,@(table-radios drive-radios drives)))) + (tr)) + ,(make-submit-button "Submit choices"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helping functions +(define (table-radios radios texts) + (map (lambda (radio text) + `(tr (td ,radio) (td ,text))) + radios texts)) + +(define (checked-radio list check-this) + (map (lambda (elem) + (if (equal? elem check-this) + (cons elem `(@ (checked))) + elem)) + list)) + + + ))