+ let arms be specified

+ add extra order page
+ add data about spaceship classes

scheme/httpd/surflets/web-server/root/surflets/spaceship.scm

@@ -5,8 +5,8 @@
 	let-opt
 	receiving
 	define-record-types
-	(subset srfi-13 (string-downcase))
+	(subset srfi-13 (string-downcase string-join))
-	(subset srfi-1 (find)))
+	(subset srfi-1 (find filter-map split-at)))
 (begin
 
 ;;; Spaceship components
@@ -18,28 +18,75 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; DATA
 (define-record-type ship-data :ship-data
-  (make-ship-data class max-crew med-sections)
+  (make-ship-data class max-crew med-sections max-shuttles arm-types 
+		  max-arms max-shield extras build-time)
   ship-data?
   (class ship-data-class)
   (max-crew ship-data-max-crew)
-  (med-sections ship-data-med-sections))
+  (med-sections ship-data-med-sections)
+  (max-shuttles ship-data-max-shuttles)
+  (arm-types ship-data-arm-types)
+  (max-arms ship-data-max-arms)
+  (max-shield ship-data-max-shield)
+  (extras ship-data-extras)
+  (build-time ship-data-build-time))
 
 (define ships
   (map (lambda (data)
-	 (make-ship-data (list-ref data 0)
+	 (apply make-ship-data data))
-			 (list-ref data 1)
+       ;; class-name	max-crew med-sections	max-shuttles
-			 (list-ref data 2)))
+       ;;               (possible) arm-types 
-       ;; class-name		max-crew med-sections
+       ;;		max-arms (TW)   max-shields (TJ)
-       '(("Constitution"	400	14) 
+       ;;		extras
-	 ("Excelsior"		570	14) 
+       ;;		build-time (months)
-	 ("Ambassador"		550	15) 
+       '(("Constitution" 400	14		10
-	 ("Galaxy"		760	17))))
+			(7 torpedo2)	
+			17000	729000
+			(double-casing tractor shuttle-ramp)
+			6)
+	 ("Excelsior"	 570	14		#f
+			(8 7 torpedo2)	
+			41000	2106000
+			(double-casing tractor transwarp)
+			7)
+	 ("Ambassador"	550	15		#f
+			(9 8 7 torpedo1)	
+			62500	4298000
+			(double-casing tractor)
+			8)
+	 ("Galaxy"	 760	17		25
+			(10 9 8 torpedo2 torpedo-M/AM)
+			61200	5400000
+			(double-casing tractor discus wide-angle-firing
+					transporter captains-yacht
+					life-maintenance) 
+			10))
+       ))
 
 (define classes (map ship-data-class ships))
 
 (define drives
   '("Impuls" "Warp"))
 
+(define arm-types
+  '((7 . "Phaser Type VII")  (8 . "Phaser Type VIII")
+    (9 . "Phaser Type IX") (10 .  "Phaser Type X")
+    (torpedo1 . "Class 1 Torpedo")
+    (torpedo2 . "Photon-Torpedo-System Class 2")
+    (torpedo-M/AM . "Photonen-Torpedo-System M/AM")))
+
+(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)")
+    (captains-yacht . "Captain's Yacht")
+    (life-maintenance . "extended life maintenance system")
+    ))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Calculation
 
@@ -77,7 +124,7 @@
 (define (specify-components req update-text class armed? shields? drive)
   (receive (size med-beds)
       (get-size req class)
-    (resulting-page
+    (order-page
      class
      (and armed? (get-armed req class))
      (and shields? (get-shields req class))
@@ -85,68 +132,103 @@
      size
      med-beds)))
 
-(define (get-armed req class . maybe-update-text)
+(define (get-armed req class . maybe-update-text+weapons+energy)
-  (let-optionals maybe-update-text
+  (let-optionals maybe-update-text+weapons+energy
-      ((update-text #f))
+      ((update-text #f)
-    "nothing-done-yet"))
+       (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)))
+	   (req (send-html/suspend
+		 (lambda (new-url)
+		   (generate-armed-page new-url update-text
+					checkboxes+text energy-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))))))))
+
+(define (confirm-no-weapons req class)
+  (let* ((submit-yes (make-submit-button "Yes, I am."))
+	 (submit-no (make-submit-button "No, let me reconsider."))
+	 (req (send-html/suspend
+	       (lambda (new-url)
+		 (generate-confirm-no-weapons new-url class 
+					      submit-yes submit-no))))
+	 (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"))
 
-(define (resulting-page class armed shields drive size med-beds)
+(define (order-page class armed shields drive size med-beds)
+  (send-html/suspend
+   (lambda (new-url)
+     (generate-order-page new-url class armed shields drive size med-beds)))
   (send-html/finish
-   `(html ,(make-title)
+   (generate-finish-page (calculate-build-time class armed shields drive size))))
-	  (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 " ,(string-downcase drive) " drive.")))))
 
+(define (calculate-build-time class armed shields drive size)
+  (+ (ship-data-build-time (ship-ref class))
+     (if armed 
+	 (+ (length (car armed))
+	    (if (> (cdr armed) 40000) 2 1))
+	 0)
+     (if shields
+	 1
+	 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.
+     ))
 
 (define (get-size req class . maybe-update-text)
   (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 
+		 (generate-size-page new-url update-text
-		   ,(make-title)
+				     class size-input))))
-		   (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 
+	(get-size req class positive-size)
-025/100030.2/BX there must be at least one person on each spaceship. Thus, please 
-specify a positive number.")
 	(let* ((ship (ship-ref class))
 	       (max-size (ship-data-max-crew ship) ))
 	  (if (<= size max-size)
 	      (values size (ship-data-med-sections ship))
-	      (get-size req class (complain class max-size)))))))
+	      (get-size req class (complain-size class max-size)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Page generating
+;; Page and text generating
 
 (define (make-title)
   '(title "Spaceship Builder"))
@@ -176,6 +258,101 @@ specify a positive number.")
 	(tr))
        ,(make-submit-button "Submit choices")))))
 
+(define (generate-size-page new-url update-text class size-input)
+  `(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")
+     ,(print-update 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))))))))
+
+(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))
+
+(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 
+    ,(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."))))
+       ,(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)))))))
+
+(define positive-energy "Please specify a positive number for the amount of energy")
+
+(define (energy-boundary class max-energy)
+  (format #f "Spaceships of class ~a cannot spent more than ~a TW for their arming."
+	  class max-energy))
+
+(define (generate-order-page new-url class armed shields drive size med-beds)
+  `(html ,(make-title)
+	 (body 
+	  (h2 "Ordering")
+	  (p "This are the data of your spaceship:")
+	  (ul
+	   (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))
+		    "No arms"))
+	   (li ,(if shields 
+		    (list shields " shields")
+		    "No shields"))
+	   (li ,drive " drive"))
+	  (servlet-form ,new-url
+	    GET
+	    ,(make-submit-button "Order now")))))
+
+(define (generate-finish-page months)
+  `(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 "This will take about " ,months " months."))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Helping functions
 (define (table-radios radios texts)
@@ -194,5 +371,24 @@ specify a positive number.")
   (find (lambda (ship) (string=? (ship-data-class ship) name))
 	ships))
 
+(define (print-update update-text)
+  `(p ,(and update-text `(font (@ (color "red")) ,update-text))))
+
+(define (member? thing list)
+  (if (member thing list) #t #f))
+
+(define (text-enumerate text-list)
+  (let ((len (length text-list)))
+    (case len
+      ((0) "")
+      ((1) (car text-list))
+      ((2) (string-append (car text-list) " and " (cadr text-list)))
+      (else
+       (receive (head last)
+	   (split-at text-list (- len 1))
+	 (string-append (string-join head ", ")
+			" and "
+			(car last)))))))
+
   ))