Update! | SetSelf
The classic GDL wireframe bus -- steer it, stretch it, and watch the design rules respond.
Live KBE checks evaluated against the current parameters.
Clear distance between seats: 8.78 in (minimum 7 in)
Distance from front of one seat to back of the seat fore of it.
Body front overhang exceeds chassis overhang by 10.0 in (target 15.0 in)
Computed by subtracting the front overhang of the chassis from the front overhang of the body.
Right-wheel turn angle for a given left-wheel angle: the actual linkage geometry vs. the Ackermann ideal. Steer with the Turn Angle parameter and watch the front knuckles in the 3D view.
| Left (deg) | Actual Right (deg) | Ideal Right (deg) |
|---|---|---|
| 5 | 4.83 | 4.74 |
| 10 | 9.43 | 9.40 |
| 15 | 13.76 | 13.87 |
| 20 | 17.82 | 18.18 |
| 25 | 21.60 | 22.36 |
| 30 | 25.09 | 26.43 |
| 35 | 28.25 | 30.42 |
The complete Gendl source for this demo, reconstituted live from the in-memory object definitions serving this page.
Want to change it? Open this source in a live Emacs and rebuild your own copy of the page.
Hack this demo →(define-object assembly (node-mixin)
:input-slots
((strings-for-display "School Bus")
(length 0)
(width 0)
(display-controls (list :vrml-navigation-info
(list "speed" 5)
:vrml-viewpoints
(list (list "position"
(translate
(the center)
:up
500
:right
(half (the wheelbase)))))))
(show-display-list? t)
(use-local-box? nil)
(use-standard-saved-slots? t)
(wheelbase 300 :settable)
(track 96 :settable)
(height 80 :settable)
(turn-angle 0 :settable)
(number-of-rows 10 :settable)
(minimum-inter-seat-clearance 7 :settable))
:objects
((body-frame-overhang :type 'body-frame-overhang-rule
:chassis-front-overhang (the chassis front-overhang)
:body-front-overhang (the body front-overhang))
(chassis :type 'chassis
:pass-down (wheelbase track turn-angle)
:datum (the center)
:height 20)
(body :type 'body
:pass-down (:wheelbase :track)
:frame-width (the chassis frame-width)
:firewall-base (translate (the center)
:up
(half (the chassis frame-height))
:right
(- (the-child cab-width)
(the-child body-frame-overhang result))))
(interior :type 'interior
:firewall-base (the body :firewall-base)
:width (- (the body width) (the body cab-width))
:length (the body length)
:height (the body height)
:number-of-rows (the number-of-rows)
:minimum-inter-seat-clearance (the minimum-inter-seat-clearance)))
:hidden-objects
((axis-x :type 'box :length 1 :width 100 :height 1)
(axis-y :type 'box :length 100 :width 1 :height 1)
(axis-z :type 'box :length 1 :width 1 :height 100))
:trickle-down-slots
(show-display-list?))(define-object chassis (application-mixin)
:input-slots
(wheelbase
track
datum
height
(turn-angle 0 :settable)
(front-overhang 25 :settable)
(rear-overhang 72 :settable)
(frame-rail-height 6 :settable)
(frame-rail-thickness 2.5 :settable)
(turn-type :left :settable)
(toe-in-angle 0.5 :settable)
(camber-angle 1.0 :settable)
(caster-angle -1.0 :settable)
(kingpin-inclination-angle 7 :settable)
(tie-rod-arm-length :medium :settable)
(tie-rod-arm-setting :medium :settable))
:computed-slots
((respondent self)
(ui-display-list-objects (remove-if #'(lambda
(item)
(typep item 'base-rule-object))
(the :children)))
(frame-width (the :frame :width))
(frame-height (the :frame :height))
(left-rotation (- (ecase (the :turn-type)
(:left (the :turn-angle))
(:right
(if (the :left-hit-point)
(angle-between-vectors-d
(the (:knuckles-straight 0) :tie-rod-arm-vector)
(subtract-vectors
(the :left-hit-point)
(the (:knuckles-straight 0)
:tie-rod-arm-axis-point))
(the (:knuckles-straight 0) :top-vector)
t)
0)))
(the :toe-in-angle)))
(right-rotation (+ (ecase (the :turn-type)
(:right (the :turn-angle))
(:left
(if (the :right-hit-point)
(angle-between-vectors-d
(the (:knuckles-straight 1) :tie-rod-arm-vector)
(subtract-vectors
(the :right-hit-point)
(the (:knuckles-straight 1)
:tie-rod-arm-axis-point))
(the (:knuckles-straight 1) :top-vector)
t)
0)))
(the :toe-in-angle)))
(tie-rod-length (3d-distance (the (:knuckles-straight 0) :tie-rod-arm-end)
(the (:knuckles-straight 1) :tie-rod-arm-end)))
(left-hit-point (let ((circle
(the (:knuckles-straight 0) :tie-rod-arm-circle))
(sphere (the (:knuckles 1) :tie-rod-sphere)))
(inter-circle-sphere
(getf circle :center)
(getf circle :radius)
(getf circle :axis-vector)
(getf sphere :center)
(getf sphere :radius)
nil)))
(right-hit-point (let ((circle
(the (:knuckles-straight 1) :tie-rod-arm-circle))
(sphere (the (:knuckles 0) :tie-rod-sphere)))
(inter-circle-sphere
(getf circle :center)
(getf circle :radius)
(getf circle :axis-vector)
(getf sphere :center)
(getf sphere :radius)
t)))
(ideal-right-rotation (let ((rear-axle-intersect
(inter-line-plane
(the (axles 1) center)
(the (face-normal-vector :rear))
(the (knuckles 0) center)
(the (knuckles 0)
(face-normal-vector :right)))))
(angle-between-vectors-d
(the (face-normal-vector :rear))
(subtract-vectors
(the (knuckles 1) center)
rear-axle-intersect))))
(ackermann-data (let ((samples (list-elements (the steering-samples))))
(list :left
(cons 0
(mapcar #'(lambda
(sample)
(the-object sample turn-angle))
samples))
:right
(cons 0
(mapcar #'(lambda
(sample)
(the-object sample right-rotation))
samples))
:ideal-right
(cons 0
(mapcar #'(lambda
(sample)
(the-object
sample
ideal-right-rotation))
samples))))))
:objects
((tie-rod :type 'c-cylinder
:radius 1.5
:start (the (:knuckles 0) :tie-rod-arm-end)
:end (the (:knuckles 1) :tie-rod-arm-end))
(frame :type 'frame
:width (+ (the :wheelbase) (the :front-overhang) (the :rear-overhang))
:length (* 4/9 (the :track))
:height (the :frame-rail-height)
:thickness (the :frame-rail-thickness)
:center (translate (the :datum) :right (half (the-child :width))))
(rule-ackermann :type 'rule-ackermann
:ackermann-data (list :left
(getf (the ackermann-data) :left)
:right
(getf (the ackermann-data) :right))
:ackermann-data-ideal (list
:left
(getf (the ackermann-data) :left)
:right
(getf
(the ackermann-data)
:ideal-right)))
(knuckles :type 'knuckle
:pseudo-inputs (front-vector left-vector top-vector
transformation-matrix)
:sequence (:size 2)
:side (ecase (the-child :index) (0 :left) (1 :right))
:top-vector (getf (the (:axles 0) :kingpin-vectors)
(the-child :side))
:front-vector (cross-vectors
(the-child :top-vector)
(the (:face-normal-vector (the-child :side))))
:left-vector (cross-vectors
(the-child :top-vector)
(ecase (the-child :side)
(:left
(reverse-vector (the-child :front-vector)))
(:right (the-child :front-vector))))
:pass-down (:tie-rod-length :tie-rod-arm-length
:tie-rod-arm-setting)
:spindle-downward-pitch (+ (the :kingpin-inclination-angle)
(the :camber-angle))
:center (the (:axles 0) (:kingpins (the-child :index)) :center)
:transformation-matrix (alignment :top
(the-child :top-vector)
:front
(rotate-vector-d
(the-child :front-vector)
(ecase
(the-child :side)
(:left (the :left-rotation))
(:right
(the :right-rotation)))
(the-child :top-vector))
:left
(rotate-vector-d
(the-child :left-vector)
(ecase
(the-child :side)
(:left (the :left-rotation))
(:right
(the :right-rotation)))
(the-child :top-vector)))
:orientation (the-child :transformation-matrix))
(axles :type (:sequence '(axle rear-axle))
:sequence (:size 2)
:center (translate (the :datum)
:down
(+ (half (the :frame :height))
(half (the-child :height)))
:right
(ecase (the-child :index)
(0 (the :front-overhang))
(1 (+ (the :front-overhang) (the :wheelbase)))))
:transformation-matrix (alignment :left
(rotate-vector-d
(the (:face-normal-vector :left))
(the :caster-angle)
(the
(:face-normal-vector :front))))
:orientation (the-child :transformation-matrix)
:height 10
:length (- (the :track)
(ecase (the-child :index)
(0 (twice (the (:wheels-front 0) :length)))
(1 (twice (the (:wheels-rear 0) :length)))))
:pass-down (:kingpin-inclination-angle)
:width 10
:display-controls (list :color :black :line-thickness 2))
(wheels-front :type 'wheel
:sequence (:size 2)
:pseudo-inputs (transformation-matrix)
:center (the (:knuckles (the-child :index)) :spindle-center)
:transformation-matrix (alignment
:front
(the
(:knuckles (the-child :index))
:spindle-vector))
:orientation (the-child :transformation-matrix)
:length 9
:radius 19
:inner-radius 7
:display-controls (list :color
"#333333"
:shininess
0.6
:specular-color
"#999999"))
(wheels-rear :type 'wheel
:sequence (:size 2)
:center (translate (getf (the (:axles 1) :wheel-centers)
(ecase
(the-child :index)
(0 :left)
(1 :right)))
(ecase (the-child :index)
(0 :front)
(1 :rear))
(half (the-child :length)))
:pseudo-inputs (transformation-matrix)
:transformation-matrix (alignment
:front
(the
(:face-normal-vector
(ecase
(the-child :index)
(0 :front)
(1 :rear)))))
:orientation (the-child :transformation-matrix)
:display-controls (list :color
"#333333"
:shininess
0.6
:specular-color
"#999999")
:length 15
:radius 19
:inner-radius 7))
:hidden-objects
((steering-samples :type 'chassis
:sequence (:size 35)
:turn-angle (1+ (the-child index))
:turn-type :left
:toe-in-angle 0
:pass-down (wheelbase track datum height front-overhang
rear-overhang frame-rail-height
frame-rail-thickness camber-angle caster-angle
kingpin-inclination-angle tie-rod-arm-length
tie-rod-arm-setting))
(knuckles-straight :type 'knuckle
:sequence (:size 2)
:center (the (:axles 0)
(:kingpins (the-child :index))
:center)
:side (ecase (the-child :index) (0 :left) (1 :right))
:top-vector (getf (the (:axles 0) :kingpin-vectors)
(the-child :side))
:front-vector (cross-vectors
(the-child :top-vector)
(the (:face-normal-vector
(the-child :side))))
:left-vector (cross-vectors
(the-child :top-vector)
(ecase (the-child :side)
(:left
(reverse-vector
(the-child :front-vector)))
(:right (the-child :front-vector))))
:spindle-downward-pitch (+
(the :kingpin-inclination-angle)
(the :camber-angle))
:pass-down (:tie-rod-arm-length :tie-rod-arm-setting)
:pseudo-inputs (front-vector left-vector top-vector
transformation-matrix)
:transformation-matrix (alignment
:top
(the-child :top-vector)
:front
(rotate-vector-d
(the-child :front-vector)
(the :toe-in-angle)
(ecase
(the-child :side)
(:left
(reverse-vector
(the-child :top-vector)))
(:right
(the-child :top-vector))))
:left
(rotate-vector-d
(the-child :left-vector)
(the :toe-in-angle)
(ecase
(the-child :side)
(:left
(reverse-vector
(the-child :top-vector)))
(:right
(the-child :top-vector)))))
:orientation (the-child :transformation-matrix))))(define-object rule-ackermann (gwl-rule-object)
:input-slots
(ackermann-data-ideal
ackermann-data)
:computed-slots
((rule-title "Ackermann")
(rule-description "Each right turn angle plotted against the corresponding
left turn angle should follow a certain relationship to aid in vehicle handling
and avoid tire scrub. In the diagram below, the red curve indicates actual Left
wheel turn-angles plotted against the corresonding Right wheel turn angle,
and the green curve indicates the Ideal according to Ackermann's rule.")
(violated? nil))
:hidden-objects
((graph :type 'graph
:x-values (list (getf (the ackermann-data-ideal) :left)
(getf (the ackermann-data) :left))
:y-values (list (getf (the ackermann-data-ideal) :right)
(getf (the :ackermann-data) :right))
:colors (list :green :red))
(view-object :type 'web-drawing
:object-roots (list (the :graph))
:page-width 500
:page-length 500)))(define-object interior (application-mixin)
:input-slots
(firewall-base
length
width
height
(number-of-rows 10 :settable)
(minimum-inter-seat-clearance 7 :settable))
:computed-slots
((ui-display-list-objects (list (the :sections)))
(use-local-box? nil)
(reclined-angle 20 :settable)
(max-reclined-angle 30 :settable))
:objects
((sections :type 'seating-section
:body-reference-points (list :left
(translate
(the :firewall-base)
:front
(half (the :length))
:right
(the :width))
:right
(translate
(the :firewall-base)
:rear
(half (the :length))
:right
(the :width)))
:usable-cabin-width (the :width)
:pass-down (number-of-rows reclined-angle max-reclined-angle
minimum-inter-seat-clearance))))(define-object seating-section (base-object)
:input-slots
(fare-class
usable-cabin-width
body-reference-points
max-reclined-angle
number-of-rows
minimum-inter-seat-clearance
(use-local-box? nil))
:objects
((inter-seat-spacing-computation :type 'inter-seat-spacing
:length 0
:width 0
:height 0
:pass-down (:max-reclined-angle
:usable-cabin-width
:number-of-rows))
(inter-seat-clearance-check :type 'inter-seat-clearance-check
:inter-seat-spacing (the
inter-seat-spacing-computation
result)
:clearance-extent-typical (the
inter-seat-spacing-computation
clearance-extent-typical)
:length 0
:width 0
:height 0
:value (the minimum-inter-seat-clearance))
(sides :type 'seating-side
:fare-class (the fare-class)
:sequence (:size 2)
:side (ecase (the-child index) (0 :left) (1 :right))
:display-controls (list :color :green)
:body-reference-point (getf (the body-reference-points)
(the-child side))
:pass-down (:number-of-rows :reclined-angle)
:inter-seat-spacing (the inter-seat-spacing-computation result)
:x-max-typical (the inter-seat-spacing-computation x-max-typical)
:x-vector (the (face-normal-vector :right)))))(define-object inter-seat-clearance-check (gwl-rule-object)
:input-slots
(inter-seat-spacing
clearance-extent-typical
value)
:computed-slots
((rule-title "Legroom")
(rule-description "Distance from front of one seat to back of the seat fore of it.")
(rule-result (number-format (the result) 2))
(violated? (< (the result) (the value)))
(result (- (the inter-seat-spacing) (the clearance-extent-typical)))))(define-object bus-ui (demos-common:demo-ui-mixin session-control-mixin
base-html-page)
:documentation
(:description "Interactive school-bus demo page: the classic GDL bus
example hosted in the 2026 demo framework. Steering follows the
Ackermann rule and the interior layout is governed by live design
checks -- both surfaced on the page."
:author "Genworks International")
:input-slots
((title "School Bus Demo")
(demo-slug "bus")
(objects (list (the model)))
(view-projection-key :bus-view)
(view-projection-vector (unitize-vector (make-vector 1 0.7 0.8)))
(wheelbase 300 :settable)
(track 96 :settable)
(bus-height 80 :settable)
(turn-angle 0 :settable)
(number-of-rows 10 :settable)
(minimum-legroom 7 :settable))
:computed-slots
((source-pane-objects '(assembly chassis rule-ackermann interior
seating-section inter-seat-clearance-check bus-ui
demos-common:demo-ui-mixin))
(body (with-lhtml-string
nil
(:div :class "max-w-5xl mx-auto p-8"
(str
(the (page-intro "School Bus"
"The classic GDL wireframe bus -- steer it, stretch it, and watch the design rules respond.")))
(str
(the (card :title "Parameters" :content
(with-lhtml-string
nil
(:div :class "p-6" (str (the control-form)))))))
(str
(the (card :title "3D View" :content
(with-lhtml-string
nil
(:div :class "p-6 relative" :style "height: 600px;"
(str (the viewport-area div)))))))
(str (the design-rules-section div))
(str
(the (card :title "Source Code" :subtitle
"The complete Gendl source for this demo, reconstituted live from the in-memory object definitions serving this page."
:content (the source-code-panes)))))))
(design-rules-card (the (card :title "Design Rules" :subtitle
"Live KBE checks evaluated against the current parameters."
:content
(with-lhtml-string
nil
(:div :class
"px-6 py-4 grid grid-cols-1 md:grid-cols-2 gap-6"
(str (the legroom-panel))
(str (the overhang-panel)))
(:div :class "px-6 pb-6"
(str (the ackermann-panel)))))))
(legroom-panel (let ((check
(the model
interior
sections
inter-seat-clearance-check)))
(with-lhtml-string
nil
(:div :class "rounded-md border border-gray-200 p-4"
(:div :class "flex items-center justify-between mb-2"
(:h4 :class "text-sm font-semibold text-gray-900"
"Legroom")
(str
(if (the-object check violated?)
(with-lhtml-string
nil
(:span :class
"inline-flex items-center rounded-full bg-red-100 px-2 py-1 text-xs font-semibold text-red-800"
"VIOLATED"))
(with-lhtml-string
nil
(:span :class
"inline-flex items-center rounded-full bg-green-100 px-2 py-1 text-xs font-semibold text-green-800"
"PASS")))))
(:p :class "text-sm text-gray-700 tabular-nums"
(fmt
"Clear distance between seats: ~a in (minimum ~a in)"
(the-object check rule-result)
(the-object check value)))
(:p :class "text-xs text-gray-500 mt-1"
(str (the-object check rule-description)))))))
(overhang-panel (let ((rule (the model body-frame-overhang)))
(with-lhtml-string
nil
(:div :class "rounded-md border border-gray-200 p-4"
(:div :class "flex items-center justify-between mb-2"
(:h4 :class "text-sm font-semibold text-gray-900"
"Body / Frame Overhang")
(:span :class
"inline-flex items-center rounded-full bg-gray-100 px-2 py-1 text-xs font-semibold text-gray-700"
"COMPUTED"))
(:p :class "text-sm text-gray-700 tabular-nums"
(fmt
"Body front overhang exceeds chassis overhang by ~,1f in (target ~,1f in)"
(the-object rule result)
(the-object rule target-value)))
(:p :class "text-xs text-gray-500 mt-1"
(str (the-object rule rule-result-help)))))))
(ackermann-panel (let* ((data (the model chassis ackermann-data))
(lefts (getf data :left))
(rights (getf data :right))
(ideals (getf data :ideal-right)))
(with-lhtml-string
nil
(:div :class "rounded-md border border-gray-200 p-4"
(:h4 :class "text-sm font-semibold text-gray-900 mb-2"
"Ackermann Steering")
(:p :class "text-xs text-gray-500 mb-3"
"Right-wheel turn angle for a given left-wheel angle: the actual linkage geometry vs. the Ackermann ideal. Steer with the Turn Angle parameter and watch the front knuckles in the 3D view.")
(:div :class "overflow-x-auto"
(:table :class
"min-w-full table-fixed divide-y divide-gray-200"
(:thead :class "bg-gray-50"
(:tr
(:th :class
"px-4 py-2 text-right text-xs font-medium text-gray-500 uppercase tracking-wider"
"Left (deg)")
(:th :class
"px-4 py-2 text-right text-xs font-medium text-gray-500 uppercase tracking-wider"
"Actual Right (deg)")
(:th :class
"px-4 py-2 text-right text-xs font-medium text-gray-500 uppercase tracking-wider"
"Ideal Right (deg)")))
(:tbody :class "divide-y divide-gray-100"
(dolist (left (list 5 10 15 20 25 30 35))
(let ((pos (position left lefts)))
(when pos
(htm
(:tr :class "hover:bg-gray-50"
(:td :class
"px-4 py-2 text-sm text-right tabular-nums text-gray-900"
(fmt "~d" left))
(:td :class
"px-4 py-2 text-sm text-right tabular-nums text-gray-700"
(fmt "~,2f" (nth pos rights)))
(:td :class
"px-4 py-2 text-sm text-right tabular-nums text-gray-700"
(fmt "~,2f" (nth pos ideals)))))))))))))))
(control-form (with-form-string
(:class "grid grid-cols-2 md:grid-cols-4 gap-6")
(str
(the (param-field "Wheelbase (in)"
(the wheelbase-control))))
(str (the (param-field "Track (in)" (the track-control))))
(str
(the (param-field "Body Height (in)"
(the height-control))))
(str
(the (param-field "Turn Angle (deg)"
(the turn-angle-control))))
(str (the (param-field "Seat Rows" (the rows-control))))
(str
(the (param-field "Min Legroom (in)"
(the legroom-control)))))))
:objects
((wheelbase-control :type 'number-form-control
:default (the wheelbase)
:ajax-submit-on-change? t
:domain :number
:min 220
:max 380
:step 10)
(track-control :type 'number-form-control
:default (the track)
:ajax-submit-on-change? t
:domain :number
:min 80
:max 110
:step 2)
(height-control :type 'number-form-control
:default (the bus-height)
:ajax-submit-on-change? t
:domain :number
:min 60
:max 100
:step 4)
(turn-angle-control :type 'number-form-control
:default (the turn-angle)
:ajax-submit-on-change? t
:domain :number
:min -35
:max 35
:step 5)
(rows-control :type 'number-form-control
:default (the number-of-rows)
:ajax-submit-on-change? t
:domain :number
:min 4
:max 14
:step 1)
(legroom-control :type 'number-form-control
:default (the minimum-legroom)
:ajax-submit-on-change? t
:domain :number
:min 4
:max 14
:step 1)
(model :type 'assembly
:wheelbase (the wheelbase-control value)
:track (the track-control value)
:height (the height-control value)
:turn-angle (the turn-angle-control value)
:number-of-rows (the rows-control value)
:minimum-inter-seat-clearance (the legroom-control value))
(design-rules-section :type 'base-html-div
:inner-html (the design-rules-card))))(define-object demo-ui-mixin nil
:documentation
(:description "Chrome shared by every public demo page: Tailwind
stylesheet hookup, card and parameter-field helpers, source-code panes
reconstituted live from the in-memory definitions, and a standard
viewport driven by the demo's objects list -- one viewport-html-div
whose renderer follows graphics-format: shaded (x3dom), wireframe
(svg) or hidden-line (svg through base-view's hidden-line remover),
switched by the toggle the pane wears -- and whose projection is the
demo's own angle or one of Gendl's standard views, chosen from the
View menu beside it."
:author "Genworks International")
:input-slots
(("List of define-object symbols shown in the Source Code card."
source-pane-objects nil)
("List of supporting defun symbols shown after the object panes."
source-pane-functions nil)
("String or nil. The demo's slug under /demo/ (e.g. \"staircase\"),
which names it to the holodeck; nil renders no Hack-this-demo link."
demo-slug nil)
(view-projection-key :demo-view)
(view-projection-vector (unitize-vector (make-vector 1 -1 0.5)))
("Keyword, :x3dom, :svg or :hidden-line. The viewport's format when the
page opens: shaded (x3dom), wireframe (svg), or hidden-line (svg with the
hidden edges removed). The toggle on the pane switches it."
graphics-format-default :x3dom))
:computed-slots
((use-svgpanzoom? t)
(use-x3dom? t)
(view-key (the view-control value))
(view-vector (if (eql (the view-key) (the view-projection-key))
(the view-projection-vector)
(getf *standard-views* (the view-key))))
(viewport-toolbar-html (with-lhtml-string
nil
(:div :class
"absolute left-1 top-1 z-10 flex items-center rounded bg-white/80 px-2 py-0.5 text-xs shadow backdrop-blur select-none"
(:span :class "text-gray-600" "View")
(str (the view-control form-control)))
(:div :class
"absolute right-1 top-1 z-10 flex overflow-hidden rounded bg-white/80 text-xs shadow backdrop-blur select-none"
(dolist (choice
'((:x3dom "Shaded")
(:svg "Wireframe")
(:hidden-line "Hidden line")))
(let ((active?
(eql (first choice)
(the graphics-format))))
(htm
(:span :class
(if active?
"px-2 py-0.5 bg-indigo-600 text-white"
"px-2 py-0.5 cursor-pointer text-gray-600 hover:text-indigo-700")
:title
(if active?
"The current graphics format"
"Switch the graphics format")
:onclick
(unless active?
(the (gdl-ajax-call
:function-key
:set-graphics-format!
:arguments
(list (first choice)))))
(str (second choice)))))))))
(additional-header-content (string-append
(with-lhtml-string
nil
(:script
(str (the viewport-renderers-js-baseline))))
(call-next-method)
(with-lhtml-string
nil
(:link :href
(format nil
"~a/demo/css/demos-style.css"
*url-prefix*)
:rel "stylesheet" :type "text/css")
(:script (str (the busy-overlay-js))))))
(busy-overlay-js "
(function () {
var count = 0, overlay = null, nonQuiet = false;
function ensureOverlay () {
if (overlay) return overlay;
overlay = document.createElement('div');
overlay.id = 'demo-busy-overlay';
overlay.setAttribute('style',
'position:fixed;inset:0;z-index:9999;display:none;' +
'background:rgba(249,250,251,0.55);backdrop-filter:blur(1px);' +
'transition:opacity 100ms;opacity:0;');
var pill = document.createElement('div');
pill.setAttribute('style',
'position:absolute;top:1.25rem;left:50%;transform:translateX(-50%);' +
'background:#4f46e5;color:#fff;padding:0.4rem 1rem;' +
'border-radius:9999px;font:500 0.875rem system-ui,sans-serif;' +
'box-shadow:0 2px 8px rgba(0,0,0,0.25);');
pill.textContent = 'Rebuilding\\u2026';
overlay.appendChild(pill);
document.body.appendChild(overlay);
return overlay;
}
function show () {
var el = ensureOverlay();
if (document.activeElement && document.activeElement.blur)
document.activeElement.blur();
el.style.display = 'block';
requestAnimationFrame(function () { el.style.opacity = '1'; });
}
function hide () {
if (overlay) { overlay.style.opacity = '0'; overlay.style.display = 'none'; }
}
var origOpen = XMLHttpRequest.prototype.open;
XMLHttpRequest.prototype.open = function (method, url) {
this._gdlAjax = typeof url === 'string' && url.indexOf('/gdlAjax') === 0;
return origOpen.apply(this, arguments);
};
var origSend = XMLHttpRequest.prototype.send;
XMLHttpRequest.prototype.send = function () {
if (this._gdlAjax) {
count++;
if (nonQuiet) { show(); nonQuiet = false; }
this.addEventListener('loadend', function () {
count--;
if (count <= 0) { count = 0; hide(); }
});
}
return origSend.apply(this, arguments);
};
window.addEventListener('DOMContentLoaded', function () {
var orig = window.gdlAjax;
if (!orig) return;
window.gdlAjax = function (evt, params, asynch, quiet) {
if (!quiet) nonQuiet = true;
return orig.apply(this, arguments);
};
});
})();
")
(source-code-panes (apply #'string-append
(the (hack-banner))
(append (mapcar #'(lambda
(sym)
(the (object-source-pane sym)))
(the source-pane-objects))
(mapcar #'(lambda
(sym)
(the (defun-source-pane sym)))
(the source-pane-functions)))))
(graphics-format (the graphics-format-default) :settable))
:objects
((view-control :type 'menu-form-control
:default (the view-projection-key)
:size 1
:ajax-submit-on-change? t
:class "cursor-pointer text-xs text-gray-700"
:style "background:transparent;border:0;padding:0 0 0 0.25rem"
:choice-plist (list (the view-projection-key)
"Default"
:trimetric
"Trimetric"
:front
"Front"
:rear
"Rear"
:left
"Left"
:right
"Right"
:top
"Top"
:bottom
"Bottom"))
(viewport-area :type 'viewport-html-div
:image-format (if (eql (the graphics-format) :hidden-line)
:svg
(the graphics-format))
:hidden-lines (if (eql (the graphics-format) :hidden-line)
:remove
:draw)
:header-html (the viewport-toolbar-html)
:projection-key (the view-key)
:projection-vector (the view-vector)
:display-list-object-roots (the objects)))
:functions
((set-graphics-format! (format) (the (set-slot! :graphics-format format)))
(page-intro
(heading blurb)
(with-lhtml-string
nil
(:div :class "mb-4 flex items-center justify-between"
(:a :href "/demos/index.html" :class
"text-sm font-medium text-indigo-600 hover:text-indigo-500"
"← All demos")
(when *developing?*
(htm
(:div :class
"text-xs text-gray-500 [&_a]:text-indigo-600 [&_a]:font-medium [&_p]:m-0"
(str (the development-links))))))
(:div :class "text-center mb-8"
(:h1 :class "text-4xl font-bold text-gray-900 mb-2" (str heading))
(:p :class "text-lg text-gray-600" (str blurb)))))
(card
(&key title subtitle content)
(with-lhtml-string
nil
(:div :class "bg-white rounded-lg shadow-lg overflow-hidden mb-8"
(:div :class "px-6 py-4 bg-gray-50 border-b border-gray-200"
(:h3 :class "text-lg font-medium text-gray-900" (str title))
(when subtitle
(htm (:p :class "text-sm text-gray-600" (str subtitle)))))
(str content))))
(param-field
(label control)
(with-lhtml-string
nil
(:div :class "space-y-2"
(:label :class "block text-sm font-medium text-gray-700" :for
(the-object control id) (str label))
(:div :class
"param-field block w-full rounded-md border border-gray-300 bg-white px-3 py-2 shadow-sm"
(str (the-object control form-control))))))
(hack-banner
nil
(if (and *hack-base* (the demo-slug))
(with-lhtml-string
nil
(:div :class
"px-6 py-3 bg-indigo-50 border-b border-indigo-100 flex items-center justify-between gap-4"
(:p :class "text-sm text-indigo-900"
"Want to change it? Open this source in a live Emacs and rebuild your own copy of the page.")
(:a :href (format nil "~a/?arg=~a" *hack-base* (the demo-slug))
:target "_blank" :rel "noopener" :class
"shrink-0 inline-flex items-center rounded-md bg-indigo-600 px-3 py-1.5 text-sm font-semibold text-white shadow-sm hover:bg-indigo-700"
"Hack this demo →")))
""))
(object-source-pane
(sym)
(with-lhtml-string
nil
(:details :class "border-b border-gray-100"
(:summary :class
"px-6 py-3 cursor-pointer select-none font-mono text-sm font-medium text-indigo-700 hover:bg-gray-50"
(fmt "(define-object ~a ...)" (the (pane-label sym))))
(:div :class "src-pane"
(wmd (format nil "```lisp~%~a```" (definition-source-string sym)))))))
(defun-source-pane
(sym)
(let ((source (function-source-string sym)))
(if source
(with-lhtml-string
nil
(:details :class "border-b border-gray-100"
(:summary :class
"px-6 py-3 cursor-pointer select-none font-mono text-sm font-medium text-indigo-700 hover:bg-gray-50"
(fmt "(defun ~a ...)" (the (pane-label sym))))
(:div :class "src-pane"
(wmd (format nil "```lisp~%~a```" source)))))
"")))
(pane-label
(sym)
(string-downcase
(if (eq (symbol-package sym) (symbol-package (the type)))
(symbol-name sym)
(format nil
"~a:~a"
(package-name (symbol-package sym))
(symbol-name sym)))))))