bigger application

scheme/httpd/surflets/web-server/root/surflets/spaceship.scm

@@ -0,0 +1,185 @@
+(define-structure servlet servlet-interface
+  (open scsh
+	scheme
+	servlets
+	let-opt
+	receiving)
+(begin
+
+;;; Spaceship components
+;;; Size (Class ...)
+;;; Arms (Photontorpedos, Phaser)
+;;; Shields
+;;; Drive (Impuls, Warp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DATA
+(define classes
+  '("Constitution" "Excelsior" "Ambassador" "Galaxy"))
+
+(define drives
+  '("Impuls" "Warp"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Calculation
+
+(define (main req . update-text+class+armed?+shields?+drive)
+  (let-optionals update-text+class+armed?+shields?+drive
+      ((update-text #f)
+       (def-class #f)
+       (def-armed? #f)
+       (def-shields? #f)
+       (def-drive #f))
+    (let* ((class-radios (make-radio-input-fields
+			  (checked-radio classes def-class)))
+	   (drive-radios (make-radio-input-fields
+			  (checked-radio drives def-drive)))
+	   (armed-checkbox (make-checkbox-input-field def-armed?))
+	   (shield-checkbox (make-checkbox-input-field def-shields?))
+	   (req (send-html/suspend
+		 (lambda (new-url)
+		   (generate-main-page new-url update-text
+				       class-radios drive-radios 
+				       armed-checkbox shield-checkbox))))
+	   (bindings (get-bindings req))
+	   (class (input-field-value (car class-radios) bindings))
+	   (armed? (input-field-value armed-checkbox bindings))
+	   (shields? (input-field-value shield-checkbox bindings))
+	   (drive (input-field-value (car drive-radios) bindings)))
+      (cond
+       ((not class)
+	(main req "Please specifiy a class." class armed? shields? drive))
+       ((not drive)
+	(main req "Please specifiy a drive." class armed? shields? drive))
+       (else
+	(specify-components req #f class armed? shields? drive))))))
+
+(define (specify-components req update-text class armed? shields? drive)
+  (receive (size med-beds)
+      (get-size req class)
+    (resulting-page
+     class
+     (and armed? (get-armed))
+     (and shields? (get-shields))
+     drive
+     size
+     med-beds)))
+
+(define (get-armed) 13)
+(define (get-shields) 14)
+
+(define (resulting-page 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 " ,drive " drive.")))))
+
+
+(define (get-size req class . maybe-update-text)
+    ((lambda (a b) (< a b))  0 #f)
+
+  (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))))))))))
+	 (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.")
+	(cond
+	 ((string=? class "Constitution")
+	  (if (<= size 400)
+	      (values size 14)
+	      (get-size req class (complain class 400))))
+	 ((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
+
+(define (make-title)
+  '(title "Spaceship Builder"))
+
+(define (generate-main-page new-url update-text
+			    class-radios drive-radios
+			    armed-checkbox shield-checkbox)
+  `(html 
+    ,(make-title)
+    (body
+     (h1 "Welcome to the Spaceship Builder Web Site!")
+     (p "Here you can build your own space ship")
+     (h2 "Step 1 -- Selecting components")
+     ,(and update-text `(font (@ (color "red")) ,update-text))
+     (servlet-form ,new-url
+       GET
+       (table
+	(tr (@ (valign "top"))
+	    (td "My spaceship is of class")
+	    (td (table ,@(table-radios class-radios classes))))
+	(tr (td (table (tr (td ,armed-checkbox) (td "My spaceship is armed.")))))
+	(tr (td (table (tr (td ,shield-checkbox) (td "My spaceship has shields.")))))
+	(tr (@ (valign "top"))
+	    (td "My spaceship's drive is ")
+	    (td (table ,@(table-radios drive-radios drives))))
+	(tr))
+       ,(make-submit-button "Submit choices")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helping functions
+(define (table-radios radios texts)
+  (map (lambda (radio text)
+	 `(tr (td ,radio) (td ,text)))
+       radios texts))
+
+(define (checked-radio list check-this)
+  (map (lambda (elem)
+	 (if (equal? elem check-this)
+	     (cons elem `(@ (checked)))
+	     elem))
+       list))
+
+
+  ))