Add several features like

+ extras page
+ shield energy
+ construction time calculation
+ hostname resolving
+ comments
+ some others I cannot remember

[Sorry for the bundled commit, my ISP went down again.]

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")
+  '((double-casing . "Double Casing")
-    (tractor . "tractor ray")
+    (tractor . "Tractor Ray")
-    (shuttle-ramp . "shuttle ramp")
+    (shuttle-ramp . "Shuttle Ramp")
-    (transwarp . "trans warp drive (experimental)")
+    (transwarp . "Trans Warp Drive (experimental)")
-    (discus . "detachable discus section")
+    (discus . "Detachable Discus Section")
-    (wide-angle-firing . "300° fire angle")
+    (wide-angle-firing . "300° Fire Angle")
-    (transporter . "extra transporters (+35)")
+    (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
+    (receive (weapons energy shield)
-     class
+	(get-armed+shields req class armed? shields?)
-     (and armed? (get-armed req class))
+      (order-page req
-     (and shields? (get-shields req class))
+		  class
-     drive
+		  weapons energy
-     size
+		  shield
-     med-beds)))
+		  drive
+		  size
+		  med-beds
+		  (get-extras req class)))))
 
-(define (get-armed req class . maybe-update-text+weapons+energy)
+;;; Ask the customer about details for the arming and the shield of
-  (let-optionals maybe-update-text+weapons+energy
+;;; 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))
+       (def-energy #f)
-    (format #t "1~a, ~a, ~a~%" update-text def-weapons def-energy)
+       (def-shield #f))
-    (let* ((checkboxes+text 
+    (let* ((checkboxes+text
-	    (map (lambda (type)
+	    (and armed?
-		   (let ((text (cdr (assoc type arm-types))))
+		 (map (lambda (type)
-		     (cons (make-checkbox-input-field
+			(let ((text (cdr (assoc type arm-types))))
-			    (and def-weapons (member? text def-weapons))
+			  (cons (make-checkbox-input-field
-			    text)
+				 (and def-weapons (member? text def-weapons))
-			   text)))
+				 text)
-		 (ship-data-arm-types (ship-ref class))))
+				text)))
-	   (energy-input (if def-energy 
+		      (ship-data-arm-types (ship-ref class)))))
-			     (make-number-input-field def-energy)
+	   (energy-input (and armed?
-			     (make-number-input-field)))
+			      (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
+		   (generate-armed+shield-page new-url update-text
-					checkboxes+text energy-input))))
+					       checkboxes+text energy-input
+					       shield-input))))
 	   (bindings (get-bindings req))
-	   (weapons (filter-map (lambda (checkbox+text)
+	   (weapons (and armed?
-				  (input-field-value (car checkbox+text) bindings))
+			 (filter-map (lambda (checkbox+text)
-				checkboxes+text))
+				       (input-field-value (car checkbox+text) bindings))
-	   (energy (input-field-value energy-input bindings)))
+				     checkboxes+text)))
-      (cond
+	   (energy (and armed?
-       ((null? weapons)
+			(input-field-value energy-input bindings)))
-	(confirm-no-weapons req class))
+	   (shield (and shields?
-       ((or (not energy)
+			(input-field-value shield-input bindings)))
-	    (<= energy 0))
+	   (complains 
-	(get-armed req class positive-energy weapons energy))
+	    (remove not
-       (else
+		    (list
-	(let ((max-energy (ship-data-max-arms (ship-ref class))))
+		     (and armed?
-	  (if (<= energy max-energy)
+			  (null? weapons)
-	      (cons weapons energy)
+			  need-weapons)
-	      (get-armed req class (energy-boundary class max-energy)
+		     (and armed?
-			 weapons energy))))))))
+			  (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)
+;;; Ask the customer about extras he want for his ship. The selectable
-  (let* ((submit-yes (make-submit-button "Yes, I am."))
+;;; items are taken from the ship data list.
-	 (submit-no (make-submit-button "No, let me reconsider."))
+(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 
+		 (generate-extras-page new-url class checkboxes+text))))
-					      submit-yes submit-no))))
 	 (bindings (get-bindings req)))
-    (if (input-field-binding submit-yes bindings)
+    (filter-map (lambda (checkbox+text)
-	#f
+		  (and (input-field-value (car checkbox+text) bindings)
-	(get-armed req class "Select at least one weapon."))))
+		       (cdr checkbox+text)))
-    
+		checkboxes+text)))
-(define (get-shields req class . maybe-update-text)
-  (let-optionals maybe-update-text
-      ((update-text #f))
-    "nothing-done-yet"))
 
-(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 
+     (if weapons
-	 (+ (length (car armed))
+	 (+ (length weapons)
-	    (if (> (cdr armed) 40000) 2 1))
+	    (if (> arms-energy 40000) 2 1))
 	 0)
-     (if shields
+     (if shield-energy
-	 1
+	 (if (> shield-energy 2200000)
+	     3
+	     2)
 	 0)
-     4					;; for impulse drive
+     4					; for impulse drive
-     (if (string=? drive "Warp") 2 0)	;; extra for warp drive
+     (if (string=? drive "Warp") 2 0)	; extra for warp drive
-     (if (> size 300) 3 2)		;; This includes the med-beds.
+     (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 
+;;; HTML page generator for Step 3 and 4: Arming and shields.
-			     checkboxes+text energy-input)
+;;; Shows the possible arming for selection and asks about the amount
-  (format #t "2~%")
+;;; 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
+       ,(if (and checkboxes+text energy-input)
-	(table ,@(map (lambda (checkbox+text)
+	    `((h2 "Step 3 -- Specify arming")
-			`(tr (td ,(car checkbox+text))
+	      (p "Please select one or more arm types for your ship and amount of energy you want to spent for it or them, respectively.")
-			     (td ,(cdr checkbox+text))))
+	      ,(print-update update-text)
-		      checkboxes+text)))
+	      (p
-       (p
+	       (table ,@(map (lambda (checkbox+text)
-	(table (tr (td "Use") (td ,energy-input) (td "TW for weapons."))))
+			       `(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)
+;;; Text displayed, if arms' energy is not positive.
-  `(html
+(define positive-energy 
-    ,(make-title)
+  "Please specify a positive number for the amount of arms energy.")
-    (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)))))))
 
-(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)
+;;; Text displayed if no weapons are selected, though the customer
-  (format #f "Spaceships of class ~a cannot spent more than ~a TW for their arming."
+;;; 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 
+	   (li ,(if weapons
-		    (let ((weapons (car armed))
+		    (format #f "Armed with ~a, powered with ~a TW"
-			  (energy (cdr armed)))
+			    (text-enumerate weapons) arms-energy)
-		      (format #f "Armed with ~a, powered with ~a TW"
-			      (text-enumerate weapons) energy))
 		    "No arms"))
-	   (li ,(if shields 
+	   (li ,(if shield-energy 
-		    (list shields " shields")
+		    (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. 
+	       (p "Your order has been registered. "
-We will contact you as soon as the ship is built.")
+		  "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)))))
+
   ))