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
parent
9816e1c1ed
commit
4c3bde22fa
|
|
@ -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
|
||||
(receive (weapons energy shield)
|
||||
(get-armed+shields req class armed? shields?)
|
||||
(order-page req
|
||||
class
|
||||
(and armed? (get-armed req class))
|
||||
(and shields? (get-shields req class))
|
||||
weapons energy
|
||||
shield
|
||||
drive
|
||||
size
|
||||
med-beds)))
|
||||
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)
|
||||
(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 (if def-energy
|
||||
(ship-data-arm-types (ship-ref class)))))
|
||||
(energy-input (and armed?
|
||||
(if def-energy
|
||||
(make-number-input-field def-energy)
|
||||
(make-number-input-field)))
|
||||
(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)
|
||||
(weapons (and armed?
|
||||
(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))))))))
|
||||
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."))))
|
||||
(filter-map (lambda (checkbox+text)
|
||||
(and (input-field-value (car checkbox+text) bindings)
|
||||
(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
|
||||
(+ (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
|
||||
,(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."))))
|
||||
(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)))
|
||||
(li ,(if weapons
|
||||
(format #f "Armed with ~a, powered with ~a TW"
|
||||
(text-enumerate weapons) energy))
|
||||
(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)))))
|
||||
|
||||
))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue