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.]
This commit is contained in:
interp 2002-11-17 14:38:38 +00:00
parent 9816e1c1ed
commit 4c3bde22fa
1 changed files with 247 additions and 114 deletions

View File

@ -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)))))
))