introduce data structure for spaceship class' boundary data

This commit is contained in:
interp 2002-11-15 12:52:58 +00:00
parent a0e331636c
commit 393ea38bb8
1 changed files with 44 additions and 30 deletions

View File

@ -4,7 +4,9 @@
servlets servlets
let-opt let-opt
receiving receiving
(subset srfi-13 (string-downcase))) define-record-types
(subset srfi-13 (string-downcase))
(subset srfi-1 (find)))
(begin (begin
;;; Spaceship components ;;; Spaceship components
@ -15,8 +17,25 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATA ;; DATA
(define classes (define-record-type ship-data :ship-data
'("Constitution" "Excelsior" "Ambassador" "Galaxy")) (make-ship-data class max-crew med-sections)
ship-data?
(class ship-data-class)
(max-crew ship-data-max-crew)
(med-sections ship-data-med-sections))
(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))))
(define classes (map ship-data-class ships))
(define drives (define drives
'("Impuls" "Warp")) '("Impuls" "Warp"))
@ -60,14 +79,21 @@
(get-size req class) (get-size req class)
(resulting-page (resulting-page
class class
(and armed? (get-armed)) (and armed? (get-armed req class))
(and shields? (get-shields)) (and shields? (get-shields req class))
drive drive
size size
med-beds))) med-beds)))
(define (get-armed) 13) (define (get-armed req class . maybe-update-text)
(define (get-shields) 14) (let-optionals maybe-update-text
((update-text #f))
"nothing-done-yet"))
(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 (resulting-page class armed shields drive size med-beds)
(send-html/finish (send-html/finish
@ -77,7 +103,7 @@
(p "Your spaceship is of class " ,class (p "Your spaceship is of class " ,class
" containing " ,size " crew members, " " containing " ,size " crew members, "
,med-beds " treatment beds, " ,med-beds " treatment beds, "
,(and armed (list armed " armed,")) ,(and armed (list armed " armed, "))
,(and shields (list shields " shields")) ,(and shields (list shields " shields"))
" and has a " ,(string-downcase drive) " drive."))))) " and has a " ,(string-downcase drive) " drive.")))))
@ -113,28 +139,11 @@ fullfill UFP Spaceship Crew's Rights Act 023/1000285.0/AB")
(get-size req class "According to UFP Spaceship Crew Consistence Act (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 025/100030.2/BX there must be at least one person on each spaceship. Thus, please
specify a positive number.") specify a positive number.")
(cond (let* ((ship (ship-ref class))
((string=? class "Constitution") (max-size (ship-data-max-crew ship) ))
(if (<= size 400) (if (<= size max-size)
(values size 14) (values size (ship-data-med-sections ship))
(get-size req class (complain class 400)))) (get-size req class (complain class max-size)))))))
((string=? class "Excelsior")
(if (<= size 570)
(values size 17)
(get-size req class (complain class 570))))
((string=? class "Ambassador")
(if (<= size 550)
(values size 16)
(get-size req class (complain class 550))))
((string=? class "Galaxy")
(if (<= size 760)
(values size 50)
(get-size req class (complain class 760))))
(else
(get-size req class "Something is wrong. You cannot pass this point, sorry.")
)))))
; (send-html/finish
; `(html (body "Done"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Page generating ;; Page generating
@ -181,4 +190,9 @@ specify a positive number.")
elem)) elem))
list)) list))
(define (ship-ref name)
(find (lambda (ship) (string=? (ship-data-class ship) name))
ships))
)) ))