;; -*- mode: common-lisp; package: user; readtable: xml -*-
(in-package :user)
(eval-when (compile eval)
(setq *readtable* (named-readtable :xml)))
(eval-when (compile load eval)
(require :aserve))
(defvar *ray-trace-base-url* nil)
(defun prefix-url (url)
(if *ray-trace-base-url*
(concatenate 'string *ray-trace-base-url* url)
url))
;; A several control entries for any object will have a name of the form "id-prop" where
;; id the decimal representation os a unique cardinal number identifier, and prop is the
;; name of the attribute. Thus, sphere id 3 will have these attribute names:
;; 3-x 3-y 3-z 3-s 3-r 3-g 3-b
;; The meanings of these attribute names should be obvious, except for Red and radiuS.
;; This code breaks a single attribute alist into an alist of separate alists for each
;; object, keyed on the cardinal number id.
(defun restructure-form-alist (alist)
(loop with lists = nil
for (control-name . value) in alist
as (matchp nil id-string attribute-name) =
(multiple-value-list (match-regexp "^\\([0-9]+\\)-\\(.*\\)$" control-name))
when matchp
do (let* ((id (parse-carefully id-string))
(entry (or (assoc id lists)
(car (push (list id) lists))))
(attribute (intern attribute-name
(load-time-value (find-package :keyword)))))
(push (cons attribute value) (cdr entry)))
finally (return (sort lists #'< :key #'car))))
(defun alistify-objects (objects &key excludes)
(loop for (id . alist) in objects
nconc (loop for (key . val) in alist
unless (member key excludes :test #'eq)
collect (cons (format nil "~a-~a" id key) val))))
;; This uses the lisp reader to parse a string. It returns nil on any error or if there
;; is any extra non-whitespace in the string.
(defun parse-carefully (string)
(let* ((*read-eval* nil)
(s (string-trim '(#\space #\newline #\return #\tab #\linefeed) string))
(len (length s)))
(ignore-errors
(multiple-value-bind (val end) (read-from-string s)
(and (= end len)
val)))))
(defparameter *smiley*
'(("res" . "2")
("1-enabled" . "1-enabled") ("1-x" . "0") ("1-y" . "0")
("1-z" . "1300") ("1-s" . "300") ("1-r" . "255") ("1-g" . "230")
("1-b" . "230") ("2-enabled" . "2-enabled") ("2-x" . "-100")
("2-y" . "50") ("2-z" . "1000") ("2-s" . "50") ("2-r" . "255")
("2-g" . "255") ("2-b" . "255") ("3-enabled" . "3-enabled")
("3-x" . "-70") ("3-y" . "50") ("3-z" . "1000") ("3-s" . "50")
("3-r" . "255") ("3-g" . "255") ("3-b" . "255")
("4-enabled" . "4-enabled") ("4-x" . "100") ("4-y" . "50")
("4-z" . "1000") ("4-s" . "50") ("4-r" . "255") ("4-g" . "255")
("4-b" . "255") ("5-enabled" . "5-enabled") ("5-x" . "70")
("5-y" . "50") ("5-z" . "1000") ("5-s" . "50") ("5-r" . "255")
("5-g" . "255") ("5-b" . "255") ("6-enabled" . "6-enabled")
("6-x" . "-85") ("6-y" . "50") ("6-z" . "960") ("6-s" . "30")
("6-r" . "100") ("6-g" . "100") ("6-b" . "255")
("7-enabled" . "7-enabled") ("7-x" . "85") ("7-y" . "50")
("7-z" . "960") ("7-s" . "30") ("7-r" . "100") ("7-g" . "100")
("7-b" . "255") ("8-enabled" . "8-enabled") ("8-x" . "0")
("8-y" . "-30") ("8-z" . "950") ("8-s" . "40") ("8-r" . "255")
("8-g" . "230") ("8-b" . "130") ("9-enabled" . "9-enabled")
("9-x" . "-250") ("9-y" . "10") ("9-z" . "1300") ("9-s" . "100")
("9-r" . "255") ("9-g" . "200") ("9-b" . "190")
("10-enabled" . "10-enabled") ("10-x" . "250") ("10-y" . "10")
("10-z" . "1300") ("10-s" . "100") ("10-r" . "255") ("10-g" . "200")
("10-b" . "190") ("11-enabled" . "11-enabled") ("11-x" . "0")
("11-y" . "-120") ("11-z" . "940") ("11-s" . "45") ("11-r" . "240")
("11-g" . "40") ("11-b" . "50") ("12-enabled" . "12-enabled")
("12-x" . "0") ("12-y" . "-120") ("12-z" . "933") ("12-s" . "40")
("12-r" . "40") ("12-g" . "20") ("12-b" . "20")
("13-enabled" . "13-enabled") ("13-x" . "0") ("13-y" . "230")
("13-z" . "1130") ("13-s" . "50") ("13-r" . "100") ("13-g" . "50")
("13-b" . "50") ("14-enabled" . "14-enabled") ("14-x" . "-40")
("14-y" . "220") ("14-z" . "1130") ("14-s" . "50") ("14-r" . "100")
("14-g" . "50") ("14-b" . "50") ("15-enabled" . "15-enabled")
("15-x" . "40") ("15-y" . "220") ("15-z" . "1130") ("15-s" . "50")
("15-r" . "100") ("15-g" . "50") ("15-b" . "50") ("16-x" . "0")
("16-y" . "0") ("16-z" . "1000") ("16-s" . "100") ("16-r" . "255")
("16-g" . "255") ("16-b" . "255") ("17-x" . "0") ("17-y" . "0")
("17-z" . "1000") ("17-s" . "100") ("17-r" . "255") ("17-g" . "255")
("17-b" . "255") ("18-x" . "0") ("18-y" . "0") ("18-z" . "1000")
("18-s" . "100") ("18-r" . "255") ("18-g" . "255") ("18-b" . "255")
("19-x" . "0") ("19-y" . "0") ("19-z" . "1000") ("19-s" . "100")
("19-r" . "255") ("19-g" . "255") ("19-b" . "255") ("20-x" . "0")
("20-y" . "0") ("20-z" . "1000") ("20-s" . "100") ("20-r" . "255")
("20-g" . "255") ("20-b" . "255"))
)
(defparameter *h2o*
'(("res" . "2")
("1-enabled" . "1-enabled") ("1-b" . "60") ("1-g" . "255") ("1-r" . "200")
("1-s" . "100") ("1-z" . "1000") ("1-y" . "0") ("1-x" . "0")
("2-enabled" . "2-enabled") ("2-b" . "255") ("2-g" . "200") ("2-r" . "255")
("2-s" . "60") ("2-z" . "960") ("2-y" . "65") ("2-x" . "55")
("3-enabled" . "3-enabled") ("3-b" . "255") ("3-g" . "200") ("3-r" . "255")
("3-s" . "60") ("3-z" . "1020") ("3-y" . "-70") ("3-x" . "40"))
)
;; This generates the html for the ray-trace control form.
(defun sphere-control-form (stream spheres query-alist)
(net.xml.generator:with-xml-generation (stream)
(let ((invalid-data nil)) ; True if any invalid data detected.
!hr
;; This is the html form with which the user enters and edits objects and attributes.
!((form @action "spheres.html#scroll" @method "post")
!(table
!(tr
!(td
;; This table lays out the objects (spheres) one per row with the each attribute's
;; text input in a separate column.
(flet ((sphere (new-id alist enabled)
;; This function emits one <td>:
;; name is the keyword name of the parameter
;; default is the default value if the parameter is not found on the alist,
;; used to initialized non-enabled rows at the end of the table.
;; size is the width of the form text input area.
;; type is a common lisp type used to check legal values. CL read is used
;; to obtain the value, and typep used to check it. Any error causes the
;; value to be flagged in red, and prevents image generation.
;; String fields are converted to numbers using parse-carefully, which is
;; presumably safe. It might be sufficient to use read-from-string
;; instead, provided the rest of the input field check to be whitespace
;; -- bad syntax should be detected. But if the Lisp reader is used,
;; be sure to bind *read-eval* nil around the call or else there will
;; be a gigantic security hole in the web server.
(flet ((field (name default &key (size 6) type)
(let ((value (or (cdr (assoc name alist))
default)))
!((td (unless (ignore-errors
(let ((val (parse-carefully value)))
(or (null type)
(typep val type))))
(setf invalid-data t)
@bgcolor "red"))
!((input @name (format nil "~a-~a" new-id name)
@type "text" @size size
@value value))))))
!(tr
!((td @align "right") @new-id)
(let ((name (format nil "~a-enabled" new-id)))
;; The keyword in the above line allows the code to work in
;; both case-sensitive and case-insensitive Lisp images.
!((td @align "center")
!((input @type "checkbox" @name name @value name
(when enabled @checked "checked")))))
(field :|x| "0" :type '(real -10000 10000))
(field :|y| "0" :type '(real -10000 10000))
(field :|z| "1000" :type '(real 0 20000))
(field :|s| "100" :type '(real 0 10000))
(field :|r| "255" :size 3 :type '(mod 256))
(field :|g| "255" :size 3 :type '(mod 256))
(field :|b| "255" :size 3 :type '(mod 256))
)))
(buttons ()
!((table @cellspacing "10")
!(tr !(td !((input @type "submit" @name "bmp" @value "Render BMP Image")))
#+(and unix (not dlc))
!(td !((input @type "submit" @name "gif" @value "Render GIF Image")))
!(td "|")
!(td !((input @type "submit" @name "update" @value "Update")))
!(td !((input @type "reset" @value "Reset")))
!(td !((input @type "submit" @name "clear" @value "Clear")))
!(td "|")
!(td !((input @type "submit" @name "h2o" @value "Preload H2O")))
!(td !((input @type "submit" @name "smiley" @value "Preload Smiley")))))))
(buttons)
!((table @cellpadding "2" @cellspacing "0" @border "0")
;; First the column headings.
!(tr !(th "Id") !(th "Enable")
!(th "X") !(th "Y") !(th "Z") !(th "Radius")
!(th "R") !(th "G") !(th "B"))
;; Finally, add 5 extra (to a maximum of 20) non-enabled rows so
;; the user can add new objects.
(let* ((new-id 0)
(max (loop for (id . alist) in spheres
do (sphere (incf new-id) alist t)
maximizing id)))
(loop repeat 5 while (< new-id 20)
for id from (1+ max)
do (sphere (incf new-id) nil nil))))
(buttons)))))
;; This is a fragment target so when the imaghe is displayed, it won't be scrolled
;; off the bottom of the browser window, misleading users into thinking nothing
;; happened.
!((a @name "scroll"))
!hr
;; This is the radio-button control for magnification (here called resolution).
(let ((res (or (parse-carefully (cdr (assoc "res" query-alist :test #'equal)))
1)))
!(table
!(tr
!(td "Image Size: ")
!(td !((table @cellspacing "10")
!(tr (loop for i from 1 to 10 do !(th @(* 100 i))))
!(tr (loop for i from 1 to 10
do !(td !((input @type "radio" @name "res" @value i
#+dlc
(when (> i 2)
@disabled "disabled")
(when (eql i res)
@checked "checked"))))))
#+dlc
!(tr
!((td @colspan "10" @align "right")
!(i "Download and run the code locally to use higher image sizes.")))))))))
(not invalid-data))))
;; This hides the botched API of net.aserve:with-http-body.
(defmacro with-http-response-body ((stream-var req ent &rest rest) &body body)
`(net.aserve:with-http-body (,req ,ent ,@rest)
(let ((,stream-var net.html.generator:*html-stream*))
,@body)))
(defun spheres-publisher (req ent)
(net.aserve:with-http-response (req ent)
(with-http-response-body (stm req ent)
(let* ((*print-level* nil)
;; Turn off pretty printing for speed when not developing.
;;(*print-pretty* nil)
;;(*print-right-margin* 79)
(query-alist (net.aserve:request-query req))
(data (delete-if (lambda (x) (not (cdr (assoc :|enabled| (cdr x)))))
(restructure-form-alist
(cond ((assoc "smiley" query-alist :test #'equal)
*smiley*)
((assoc "h2o" query-alist :test #'equal)
*h2o*)
((assoc "clear" query-alist :test #'equal)
nil)
(t query-alist))))))
(net.xml.generator:with-xml-generation (stm)
!(html
!(head !(title "Ray Trace Control")
;; The following is to allow CSS stylesheet control of color, etc.
!((meta @http-equiv "Content-Style-Type" @content "text/css")))
!(body
!(h1 "Ray Trace Control Panel")
!(p "Go to the "
!((a @href "index.html") "introduction and instructions page")
".")
!(p "Go to the "
!((a @href "description.html") "ray tracing description page")
".")
(let* ((ok-p (sphere-control-form stm data query-alist)))
(if ok-p
(let* ((res (or (cdr (assoc "res" query-alist :test #'equal)) "1"))
(dim (or (ignore-errors (* 100 (read-from-string res)))
100))
(urlencoding
(net.aserve:query-to-form-urlencoded
(cons (cons "res" res)
(alistify-objects data :excludes '(:|enabled|))))))
(cond
((assoc "gif" query-alist :test #'equal)
!((table @frame "null" @cellspacing 20)
!(caption "Rendered GIF Image")
!(tr
!((td @valign "bottom")
!((img
@alt "Wait for image to be rendered"
;; These attributes encourage browsers to display an empty
;; box outline while the image is being computed by the
;; server.
@width dim @height dim @border 3
@src (prefix-url (format nil "/image.gif?~a"
urlencoding))))))))
((assoc "bmp" query-alist :test #'equal)
!((table @frame "null" @cellspacing 20)
!(caption "Rendered BMP Image")
!(tr
!((td @valign "bottom")
!((img
@alt "Wait for image to be rendered"
@width dim @height dim @border 3
@src (prefix-url (format nil "/image.bmp?~a"
urlencoding)))))))))
!hr)
!((p @style "color: red")
"Please correct the illegal values outlined in red."))))))))))
(defun raytrace-publisher-gif (req ent)
(raytrace-publisher-1 req ent :gif))
(defun raytrace-publisher-bmp (req ent)
(raytrace-publisher-1 req ent :bmp))
(defun raytrace-publisher-1 (req ent gif-or-bmp)
(net.aserve:with-http-response (req ent :timeout #.(* 60 10))
(with-http-response-body (stm req ent)
(let* ((query-alist (net.aserve:request-query req))
(data (restructure-form-alist query-alist))
(*world* nil)) ; Bind separately on each process!
(loop for (nil . alist) in data
do (flet ((val (prop)
(parse-carefully (cdr (assoc prop alist :test #'eq)))))
;; Since all Z values are negative, we flip the Z axis here for purposes
;; of the user interface. The ray tracing engine preserves the
;; more-usual geometric convention of negative Z going into the page.
(defsphere (val :|x|) (val :|y|) (- (val :|z|)) (val :|s|)
(make-rgbi (val :|r|) (val :|g|) (val :|b|)))))
(ray-trace *world*
:res (max 1
(min 10
(or (ignore-errors
(parse-carefully (cdr (assoc "res" query-alist :test #'equal))))
1)))
gif-or-bmp stm)))))
;; This function starts the server and publishes the urls it serves. Since many systems
;; restrict low-numbered ports to privileged users, and because the standard http port 80
;; might already be used by a server on the local host, we listen on a high-numbered port
;; by default. Multiple servers on a single host will need to choose different ports.
;; The url for connecting will be something like
;; "http://localhost:8097/".
(defun start-server (&optional (port 8097))
(let ((server (net.aserve:start :port port)))
;; By default we publish all the files without any directory pathname component so the
;; files can also be browsed in place by any browser without starting the HTTP server.
;; This is necessary because these files contain instructions how build and start the server!
(net.aserve:publish-file :path (prefix-url "/") :file "./index.html")
(net.aserve:publish-file :path (prefix-url "/index.html") :file "./index.html")
(net.aserve:publish-file :path (prefix-url "/description.html") :file "./description.html")
(publish-computed-entities :server server)
(loop for name in '("defsys"
"color" "dib" "ppm" "raytrace"
"xml-generator" "webpage")
do (net.aserve:publish-file :path (prefix-url (format nil "/~a.lisp" name))
:file (format nil "./~a.lisp" name)
:content-type "text/plain"))))
;; This hook is used by the dynamic learning center to publish the ray
;; tracer as part of the dlc web site.
(defun publish-computed-entities (&key server host)
(net.aserve:publish :server server
:host host
:path (prefix-url "/spheres.html")
:function 'spheres-publisher)
(net.aserve:publish :server server
:host host
:path (prefix-url "/image.gif")
:function 'raytrace-publisher-gif
:content-type "image/gif")
(net.aserve:publish :server server
:host host
:path (prefix-url "/image.bmp")
:function 'raytrace-publisher-bmp
:content-type "image/bmp"))