+ let arms be specified
+ add extra order page + add data about spaceship classes
This commit is contained in:
interp
parent
393ea38bb8
commit
9816e1c1ed
|
|
@ -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)))))))
|
||||
|
||||
))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue