diff --git a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm index b013b80..8aa9de7 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm +++ b/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-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))))))) + ))