+ let arms be specified

+ add extra order page
+ add data about spaceship classes
This commit is contained in:
interp 2002-11-15 15:49:02 +00:00
parent 393ea38bb8
commit 9816e1c1ed
1 changed files with 247 additions and 51 deletions

View File

@ -5,8 +5,8 @@
let-opt
receiving
define-record-types
(subset srfi-13 (string-downcase))
(subset srfi-1 (find)))
(subset srfi-13 (string-downcase string-join))
(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)
(list-ref data 1)
(list-ref data 2)))
;; class-name max-crew med-sections
'(("Constitution" 400 14)
("Excelsior" 570 14)
("Ambassador" 550 15)
("Galaxy" 760 17))))
(apply make-ship-data data))
;; class-name max-crew med-sections max-shuttles
;; (possible) arm-types
;; max-arms (TW) max-shields (TJ)
;; extras
;; build-time (months)
'(("Constitution" 400 14 10
(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)
(let-optionals maybe-update-text
((update-text #f))
"nothing-done-yet"))
(define (get-armed req class . maybe-update-text+weapons+energy)
(let-optionals maybe-update-text+weapons+energy
((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)))
(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)
(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.")))))
(generate-finish-page (calculate-build-time class armed shields drive size))))
(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
,(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")
(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))))))))))
(generate-size-page new-url update-text
class size-input))))
(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
025/100030.2/BX there must be at least one person on each spaceship. Thus, please
specify a positive number.")
(get-size req class positive-size)
(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)))))))
))