diff --git a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm index 8aa9de7..1af5c05 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm @@ -6,7 +6,9 @@ receiving define-record-types (subset srfi-13 (string-downcase string-join)) - (subset srfi-1 (find filter-map split-at))) + (subset srfi-1 (find filter-map split-at remove)) + sunet-utilities + httpd-request) (begin ;;; Spaceship components @@ -14,6 +16,7 @@ ;;; Arms (Photontorpedos, Phaser) ;;; Shields ;;; Drive (Impuls, Warp) +;;; Extras (Double Casing, Trans Warp Drive, etc.) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DATA @@ -31,6 +34,9 @@ (extras ship-data-extras) (build-time ship-data-build-time)) +;;; This are the orderable ships with their data. The following +;;; procedures will refer to this list to get the data for a ship +;;; class. (define ships (map (lambda (data) (apply make-ship-data data)) @@ -63,11 +69,14 @@ 10)) )) +;;; All orderable classes extracted from ship data list. (define classes (map ship-data-class ships)) +;;; All orderable drives. (define drives '("Impuls" "Warp")) +;;; All orderable arm types. (define arm-types '((7 . "Phaser Type VII") (8 . "Phaser Type VIII") (9 . "Phaser Type IX") (10 . "Phaser Type X") @@ -75,21 +84,25 @@ (torpedo2 . "Photon-Torpedo-System Class 2") (torpedo-M/AM . "Photonen-Torpedo-System M/AM"))) +;;; All orderable extras. The ship data contains a list of extras a +;;; ship class may have. (define extras - '((double-casing . "double casing") - (tractor . "tractor ray") - (shuttle-ramp . "shuttle ramp") - (transwarp . "trans warp drive (experimental)") - (discus . "detachable discus section") - (wide-angle-firing . "300° fire angle") - (transporter . "extra transporters (+35)") + '((double-casing . "Double Casing") + (tractor . "Tractor Ray") + (shuttle-ramp . "Shuttle Ramp") + (transwarp . "Trans Warp Drive (experimental)") + (discus . "Detachable Discus Section") + (wide-angle-firing . "300° Fire Angle") + (transporter . "Extra Transporters (+35)") (captains-yacht . "Captain's Yacht") - (life-maintenance . "extended life maintenance system") + (life-maintenance . "Extended Life Maintenance System (ELMS)") )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Calculation +;;; Main entry point. Shows a welcome message, and invites to order a +;;; spaceship. (define (main req . update-text+class+armed?+shields?+drive) (let-optionals update-text+class+armed?+shields?+drive ((update-text #f) @@ -121,94 +134,140 @@ (else (specify-components req #f class armed? shields? drive)))))) +;;; Step 2ff: Let the customer specify the crew size, the arming, the +;;; shields and the extras, showing a result page at the end. (define (specify-components req update-text class armed? shields? drive) (receive (size med-beds) (get-size req class) - (order-page - class - (and armed? (get-armed req class)) - (and shields? (get-shields req class)) - drive - size - med-beds))) + (receive (weapons energy shield) + (get-armed+shields req class armed? shields?) + (order-page req + class + weapons energy + shield + drive + size + med-beds + (get-extras req class))))) -(define (get-armed req class . maybe-update-text+weapons+energy) - (let-optionals maybe-update-text+weapons+energy +;;; Ask the customer about details for the arming and the shield of +;;; his spaceship. The selectable components are taken from the ship +;;; data list. +(define (get-armed+shields req class armed? shields? . + maybe-update-text+weapons+energy+shield) + (let-optionals maybe-update-text+weapons+energy+shield ((update-text #f) (def-weapons #f) - (def-energy #f)) - (format #t "1~a, ~a, ~a~%" update-text def-weapons def-energy) - (let* ((checkboxes+text - (map (lambda (type) - (let ((text (cdr (assoc type arm-types)))) - (cons (make-checkbox-input-field - (and def-weapons (member? text def-weapons)) - text) - text))) - (ship-data-arm-types (ship-ref class)))) - (energy-input (if def-energy - (make-number-input-field def-energy) - (make-number-input-field))) + (def-energy #f) + (def-shield #f)) + (let* ((checkboxes+text + (and armed? + (map (lambda (type) + (let ((text (cdr (assoc type arm-types)))) + (cons (make-checkbox-input-field + (and def-weapons (member? text def-weapons)) + text) + text))) + (ship-data-arm-types (ship-ref class))))) + (energy-input (and armed? + (if def-energy + (make-number-input-field def-energy) + (make-number-input-field)))) + (shield-input (and shields? + (if def-shield + (make-number-input-field def-shield) + (make-number-input-field)))) (req (send-html/suspend (lambda (new-url) - (generate-armed-page new-url update-text - checkboxes+text energy-input)))) + (generate-armed+shield-page new-url update-text + checkboxes+text energy-input + shield-input)))) (bindings (get-bindings req)) - (weapons (filter-map (lambda (checkbox+text) - (input-field-value (car checkbox+text) bindings)) - checkboxes+text)) - (energy (input-field-value energy-input bindings))) - (cond - ((null? weapons) - (confirm-no-weapons req class)) - ((or (not energy) - (<= energy 0)) - (get-armed req class positive-energy weapons energy)) - (else - (let ((max-energy (ship-data-max-arms (ship-ref class)))) - (if (<= energy max-energy) - (cons weapons energy) - (get-armed req class (energy-boundary class max-energy) - weapons energy)))))))) + (weapons (and armed? + (filter-map (lambda (checkbox+text) + (input-field-value (car checkbox+text) bindings)) + checkboxes+text))) + (energy (and armed? + (input-field-value energy-input bindings))) + (shield (and shields? + (input-field-value shield-input bindings))) + (complains + (remove not + (list + (and armed? + (null? weapons) + need-weapons) + (and armed? + (check-bounded-number-field class energy positive-energy + ship-data-max-arms + arms-boundary)) + (and shields? + (check-bounded-number-field class shield positive-shield + ship-data-max-shield + shield-boundary)))))) + (if (null? complains) + (values weapons energy shield) + (get-armed+shields req class armed? shields? + `(p ,@(map (lambda (complain) `(,complain (br))) + complains)) + weapons energy shield))))) -(define (confirm-no-weapons req class) - (let* ((submit-yes (make-submit-button "Yes, I am.")) - (submit-no (make-submit-button "No, let me reconsider.")) +;;; Ask the customer about extras he want for his ship. The selectable +;;; items are taken from the ship data list. +(define (get-extras req class) + (let* ((checkboxes+text (map (lambda (extra) + (cons (make-checkbox-input-field extra) + (cdr (assoc extra extras)))) + (ship-data-extras (ship-ref class)))) (req (send-html/suspend (lambda (new-url) - (generate-confirm-no-weapons new-url class - submit-yes submit-no)))) + (generate-extras-page new-url class checkboxes+text)))) (bindings (get-bindings req))) - (if (input-field-binding submit-yes bindings) - #f - (get-armed req class "Select at least one weapon.")))) - -(define (get-shields req class . maybe-update-text) - (let-optionals maybe-update-text - ((update-text #f)) - "nothing-done-yet")) + (filter-map (lambda (checkbox+text) + (and (input-field-value (car checkbox+text) bindings) + (cdr checkbox+text))) + checkboxes+text))) -(define (order-page class armed shields drive size med-beds) +;;; Show the selected components of the customers ship and ask him for +;;; ordering the whole thing (without telling him, how long this will +;;; take, of course ;-) ) +(define (order-page req class weapons arms-energy shield-energy drive + size med-beds extras) (send-html/suspend (lambda (new-url) - (generate-order-page new-url class armed shields drive size med-beds))) + (generate-order-page new-url class weapons arms-energy + shield-energy drive size med-beds + extras))) (send-html/finish - (generate-finish-page (calculate-build-time class armed shields drive size)))) + (generate-finish-page (calculate-build-time class weapons arms-energy + shield-energy drive size + extras) + req))) -(define (calculate-build-time class armed shields drive size) +;;; This returns the number of months that are probably necessary to +;;; build the ship. The data are taken from experience of the last +;;; five years :-) +(define (calculate-build-time class weapons arms-energy shield-energy + drive size extras) (+ (ship-data-build-time (ship-ref class)) - (if armed - (+ (length (car armed)) - (if (> (cdr armed) 40000) 2 1)) + (if weapons + (+ (length weapons) + (if (> arms-energy 40000) 2 1)) 0) - (if shields - 1 + (if shield-energy + (if (> shield-energy 2200000) + 3 + 2) 0) - 4 ;; for impulse drive - (if (string=? drive "Warp") 2 0) ;; extra for warp drive - (if (> size 300) 3 2) ;; This includes the med-beds. + 4 ; for impulse drive + (if (string=? drive "Warp") 2 0) ; extra for warp drive + (if (> size 300) 3 2) ; This includes the med-beds. + (length extras) )) +;;; This asks the customer to specify how many crew members his ship +;;; will have. We only check that there is at least one crew member +;;; and the maximum crew member for a class is not exceeded. (define (get-size req class . maybe-update-text) (let* ((update-text (:optional maybe-update-text #f)) (size-input (make-number-input-field)) @@ -230,9 +289,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Page and text generating +;;; Title of each HTML page. (define (make-title) '(title "Spaceship Builder")) +;;; The following procedure do the actual HTML composing for the +;;; different steps. Nothing exciting here. + +;;; Main page HTML. (define (generate-main-page new-url update-text class-radios drive-radios armed-checkbox shield-checkbox) @@ -241,7 +305,6 @@ (body (h1 "Welcome to the Spaceship Builder Web Site!") (p "Here you can build your own space ship.") - (p "Please note that this site is currently under construction. You cannot specify much details.") (h2 "Step 1 -- Selecting components") ,(and update-text `(font (@ (color "red")) ,update-text)) (servlet-form ,new-url @@ -258,6 +321,7 @@ (tr)) ,(make-submit-button "Submit choices"))))) +;;; Size page HTML. (define (generate-size-page new-url update-text class size-input) `(html ,(make-title) @@ -275,54 +339,75 @@ fullfill UFP Spaceship Crew's Rights Act 023/1000285.0/AB") (td "people")) (tr (td ,(make-submit-button)))))))) +;;; Text displayed if crew size is too big for the spaceship's class. (define (complain-size 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)) +;;; Text displayed if size is not positive. (define positive-size "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.") -(define (generate-armed-page new-url update-text - checkboxes+text energy-input) - (format #t "2~%") +;;; HTML page generator for Step 3 and 4: Arming and shields. +;;; Shows the possible arming for selection and asks about the amount +;;; of energy for arming and shields. +(define (generate-armed+shield-page new-url update-text + checkboxes+text energy-input + shield-input) `(html ,(make-title) (body - (h2 "Step 3 -- Specify arming") - (p "Please select one or more arm types for your ship and amount of energy you want to spent for it or them, respectively.") - ,(print-update update-text) (servlet-form ,new-url GET - (p - (table ,@(map (lambda (checkbox+text) - `(tr (td ,(car checkbox+text)) - (td ,(cdr checkbox+text)))) - checkboxes+text))) - (p - (table (tr (td "Use") (td ,energy-input) (td "TW for weapons.")))) + ,(if (and checkboxes+text energy-input) + `((h2 "Step 3 -- Specify arming") + (p "Please select one or more arm types for your ship and amount of energy you want to spent for it or them, respectively.") + ,(print-update update-text) + (p + (table ,@(map (lambda (checkbox+text) + `(tr (td ,(car checkbox+text)) + (td ,(cdr checkbox+text)))) + checkboxes+text))) + (p + (table (tr (td "Use") (td ,energy-input) (td "TW for weapons."))))) + '(h2 "Step 3 -- Done: No Arming")) + ,(if shield-input + `((h2 "Step 4 -- Specify shields") + (p "Please specify the amount of energy you want to spent for your shields:") + (table (tr (td ,shield-input) (td "TJ")))) + '(h2 "Step 4 -- Done: No shields")) ,(make-submit-button "OK"))))) -(define (generate-confirm-no-weapons new-url class submit-yes submit-no) - `(html - ,(make-title) - (body - (h2 "Confirm Step 3 -- Specify arming") - (p "Are you sure that you don't want any weapons for you ship of class " - ,class "?") - (servlet-form ,new-url - GET - (table (tr (td ,submit-yes) (td ,submit-no))))))) +;;; Text displayed, if arms' energy is not positive. +(define positive-energy + "Please specify a positive number for the amount of arms energy.") -(define positive-energy "Please specify a positive number for the amount of energy") +;;; Text displayed if shield's energy is not positive. +(define positive-shield + "Please specify a positive number for the amount of shield energy.") -(define (energy-boundary class max-energy) - (format #f "Spaceships of class ~a cannot spent more than ~a TW for their arming." +;;; Text displayed if no weapons are selected, though the customer +;;; wished to have an armed spaceship. +(define need-weapons + "Please specify at least one weapon or turn back to main selection page and deselect arming.") + +;;; Text displayed if arms' energy is too high for the spaceship class. +(define (arms-boundary class max-energy) + (format #f "Spaceships of class ~a cannot spend more than ~a TW for their arming." class max-energy)) -(define (generate-order-page new-url class armed shields drive size med-beds) +;;; Text displayed if shield's energy is too high for the spaceship class. +(define (shield-boundary class max-shield) + (format #f "Spaceships of class ~a cannot spend more than ~a TJ for their shields." + class max-shield)) + +;;; HTML page generator for the summary (order) page. +;;; Shows alle the details chosen for construction. +(define (generate-order-page new-url class weapons arms-energy + shield-energy drive size med-beds extras) `(html ,(make-title) (body (h2 "Ordering") @@ -331,35 +416,64 @@ specify a positive number.") (li "Class \"" ,class "\"") (li ,size " crew members") (li ,med-beds " treatment beds") - (li ,(if armed - (let ((weapons (car armed)) - (energy (cdr armed))) - (format #f "Armed with ~a, powered with ~a TW" - (text-enumerate weapons) energy)) + (li ,(if weapons + (format #f "Armed with ~a, powered with ~a TW" + (text-enumerate weapons) arms-energy) "No arms")) - (li ,(if shields - (list shields " shields") + (li ,(if shield-energy + (format #f "~a TJ of shield energy" shield-energy) "No shields")) - (li ,drive " drive")) + (li ,drive " drive") + ,@(map (lambda (extra-text) + `(li ,extra-text)) + extras)) (servlet-form ,new-url - GET + POST ,(make-submit-button "Order now"))))) -(define (generate-finish-page months) +;;; HTML page generator for the extras page. +;;; Shows a list of possible extras of this spaceship class for selection. +(define (generate-extras-page new-url class checkboxes+text) + `(html + ,(make-title) + (body + (h2 "Step 5 -- Extras") + (p "Select one or more extras that are available for +spaceships of class " ,class) + (servlet-form ,new-url + GET + (table ,@(map (lambda (checkbox+text) + `(tr (td ,(car checkbox+text)) + (td ,(cdr checkbox+text)))) + checkboxes+text)) + ,(make-submit-button "OK"))))) + +;;; HTML page generator. +;;; Shows the final page with a "Thank you" and an estimate for the +;;; construction time. Furthermore, it shows the customers host-name +;;; or its IP-adress. +(define (generate-finish-page months req) `(html ,(make-title) (body (h2 "Ordered") (p "Thank you for your ordering.") - (p "Your order has been registered. -We will contact you as soon as the ship is built.") + (p "Your order has been registered. " + "We will contact you (" + ,(host-name-or-ip (socket-remote-address (request:socket req))) + ") as soon as the ship is built.") (p "This will take about " ,months " months.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Helping functions + +;;; Creates HTML-table rows, putting a radio in front of a text. (define (table-radios radios texts) (map (lambda (radio text) `(tr (td ,radio) (td ,text))) radios texts)) +;;; Adds the 'checked attribute to a radio button, if its value +;;; (stored in LIST) equals to CHECK-THIS. With this, the selected +;;; value of a radio list can be restored if the page is redisplayed. (define (checked-radio list check-this) (map (lambda (elem) (if (equal? elem check-this) @@ -367,16 +481,24 @@ We will contact you as soon as the ship is built.") elem)) list)) +;;; Returns the ship-data structure for the class of name NAME. (define (ship-ref name) (find (lambda (ship) (string=? (ship-data-class ship) name)) ships)) +;;; "Prints" UPDATE-TEXT in red color, i.e. in an HTML paragraph +;;; block. (define (print-update update-text) `(p ,(and update-text `(font (@ (color "red")) ,update-text)))) +;;; Same as R5RS member, except that it returns either #t or #f. (define (member? thing list) (if (member thing list) #t #f)) +;;; Makes an enumeration of the strings in TEXT-LIST: +;;; (text-enumerate '("John", "Bill", "Juliet") +;;; => "John, Bill and Juliet" +;;; with reasonable results if the list's length is smaller than 2. (define (text-enumerate text-list) (let ((len (length text-list))) (case len @@ -390,5 +512,16 @@ We will contact you as soon as the ship is built.") " and " (car last))))))) +;;; Does a check on the value of a number-input-field. Abstraction +;;; over two cases occured above. Best explained by the use above. +(define (check-bounded-number-field class input positiv selector boundary) + (if (or (not input) + (<= input 0)) + positiv + (let ((max (selector (ship-ref class)))) + (if (<= input max) + #f + (boundary class max))))) + ))