Update! | SetSelf
Personal pods on a rail run like a utility line past homes, carried between neighbourhoods on twin track cables. One bogie serves both, the towers are sized by the sag, and the model checks that a pod passes every support.
A sketch of the method, not a design: the rope's weight and strength are rules of thumb, and wind is not considered.
| The line | 420 m of cable: 2 main spans of 150 m, approach spans of 60 m | |
| The cable | 32 mm, 5.7 kg/m, breaking force 998 kN, held at 200 kN | |
| Sag at mid-span | 2.26 m: 0.79 m the cable's own, 1.47 m under 2 pods | |
| Saddle height | 9.8 m: 5.0 m clearance, 2.5 m of pod, 2.3 m of sag | |
| Tension | safety factor 4.97 against 3.15 asked | ok |
| Gradient | steepest cable 10.3 % against 15.0 % allowed; the shortest approach span within it is 32 m | ok |
| Clearance | least under a pod on the main spans as drawn, 5.74 m | ok |
| Approach spans | dip 0.00 m below the rail they leave | ok |
| Passage | a bogie at every pole, tower and anchor, and the pods as drawn: 0 clashes | ok |
| Tensioner travel | 0.30 m over 60 K | |
| Longest lowering | 7.3 m, from a saddle to the ground |
The complete Gendl source for this demo: object definitions reconstituted live from the in-memory definitions serving this page, the passage check's functions via the Lisp's own source records.
Want to change it? Open this source in a live Emacs and rebuild your own copy of the page.
Hack this demo →(define-object pod-line (track-mixin base-object)
:documentation
(:description "A neighbourhood on rail, then the same pods crossing
open country on twin track cables to the next neighbourhood's rail.
The tower height is not an input: it follows from the span, the
tension, the pods allowed on a span and the clearance asked for."
:author "Genworks International")
:input-slots
(("Main cable span between towers, mm" span-length 150000)
("Number of main spans" span-count 2)
("Approach span between a rail end and the first tower, mm"
approach-length 60000)
("Horizontal tension in each of the two cables, kN" cable-tension-kn 200)
("Cable diameter, mm; the rail's running heads match it" cable-diameter 32)
("Between the two cables, and the rail's two running heads, mm" gauge 500)
("Mass of a loaded pod with its bogie, kg" pod-mass-kg 800)
("Pods let onto one span at a time" pods-per-span 2)
("Clearance kept under a pod, mm" clearance 5000)
("Pods on the cables: 0 to 1 is the approach span, 1 to 2 the first main span"
cable-pod-positions (list 0.5 1.5 2.0 2.35))
("0 = docked under the bogie, 1 = lowered to the ground"
cable-pod-drops (list 0 0 0 1.0))
(cable-pod-colors (list :steel-blue :green-sea :steel-blue :orange-mandarin))
("Length of neighbourhood main rail" line-length 40000)
("Height of track axis above ground" beam-center-z 6500)
("Rail shown at the far neighbourhood, mm" far-rail-length 20000)
("Coldest night to hottest day, K" temperature-range 60)
("Least breaking force over greatest tension" required-safety-factor 3.15)
("Steepest cable the drive is to climb, rise over run" gradient-limit 0.15))
:computed-slots
((input-controls (list :span-length
(list :min 100000 :max 600000 :step 10000)
:span-count
(list :kind :integer :min 1 :max 6)
:approach-length
(list :min 40000 :max 200000 :step 5000)
:cable-tension-kn
(list :min 80 :max 400 :step 10)
:cable-diameter
(list :min 24 :max 60 :step 2)
:gauge
(list :min 400 :max 800 :step 50)
:pod-mass-kg
(list :min 400 :max 1500 :step 50)
:pods-per-span
(list :kind :integer :min 1 :max 6)
:clearance
(list :min 3000 :max 8000 :step 250)))
(head-radius (half (the cable-diameter)))
(gravity 9.81)
(cable-mass-per-m (* 0.0056 (expt (the cable-diameter) 2)))
(unit-weight (/ (* (the cable-mass-per-m) (the gravity)) 1000.0))
(breaking-force (* 975.0 (expt (the cable-diameter) 2)))
(tension (* 1000.0 (the cable-tension-kn)))
(pod-load (* 0.5 (the pod-mass-kg) (the gravity)))
(hang-depth (- (the reference-pod nominal-bottom)))
(self-sag (/ (* (the unit-weight) (expt (the span-length) 2))
(* 8 (the tension))))
(pod-sag (/ (* (the pods-per-span) (the pod-load) (the span-length))
(* 4 (the tension))))
(design-sag (+ (the self-sag) (the pod-sag)))
(support-z (+ (the clearance) (the hang-depth) (the design-sag)))
(design-gradient (let ((pods
(/ (* (the pods-per-span) (the pod-load))
(the tension))))
(max (+ (/ (* (the unit-weight) (the span-length))
(* 2 (the tension)))
pods)
(+ (/ (- (the support-z) (the beam-center-z))
(the approach-length))
(/ (* (the unit-weight) (the approach-length))
(* 2 (the tension)))
pods))))
(least-approach (let* ((a (/ (the unit-weight) (* 2 (the tension))))
(b
(- (the gradient-limit)
(/ (* (the pods-per-span) (the pod-load))
(the tension))))
(c (- (the support-z) (the beam-center-z)))
(root (- (expt b 2) (* 4 a c))))
(when (and (plusp b) (not (minusp root)))
(/ (- b (sqrt root)) (* 2 a)))))
(design-tension (* (the tension) (sqrt (1+ (expt (the design-gradient) 2)))))
(safety-factor (/ (the breaking-force) (the design-tension)))
(start-x (half (the line-length)))
(cable-run (+ (twice (the approach-length))
(* (the span-count) (the span-length))))
(end-x (+ (the start-x) (the cable-run)))
(supports (append (list (make-point (the start-x) 0 (the beam-center-z)))
(loop for i from 0 to (the span-count)
collect (make-point (+
(the start-x)
(the approach-length)
(* i (the span-length)))
0
(the support-z)))
(list (make-point (the end-x)
0
(the beam-center-z)))))
(spans (1- (length (the supports))))
(span-runs (append (list (the approach-length))
(make-list (the span-count)
:initial-element
(the span-length))
(list (the approach-length))))
(span-starts (loop for run in (the span-runs)
for start = 0 then (+ start previous)
for previous = run
collect start))
(wheelbase (the reference-pod wheelbase))
(pod-seats (mapcar #'(lambda (position)
(the (seat-at (the (station-of position)))))
(the cable-pod-positions)))
(passage-seats (loop for support in
(append (the span-starts) (list (the cable-run)))
append (loop for offset in '(-400 0 400)
collect (the
(seat-at (+ support offset))))))
(least-clearance (- (loop for index from 1 to (the span-count)
minimize (the (span index) lowest-z))
(the hang-depth)))
(approach-dip (- (the beam-center-z)
(min (the (span 0) lowest-z)
(the (span (1- (the spans))) lowest-z))))
(tensioner-travel (* 1.2E-5 (the cable-run) (the temperature-range)))
(longest-lowering (- (the support-z) (the hang-depth)))
(clashes (find-clashes (append (list-elements (the cable-pod))
(list-elements (the passage-pod))
(the neighbourhood pods))
(append (list-elements (the tower))
(list (the near-anchor)
(the far-anchor)
(the far-rail))
(list-elements (the far-pole))
(the neighbourhood structures))))
(checks (list :tension
(>= (the safety-factor) (the required-safety-factor))
:gradient
(<= (the design-gradient) (the gradient-limit))
:clearance
(>= (the least-clearance) (- (the clearance) 1))
:approach
(<= (the approach-dip) 1)
:passage
(null (the clashes))))
(findings (flet ((verdict (key) (if (getf (the checks) key) :ok :fails)))
(list (list "The line"
(format nil
"~d m of cable: ~d main span~:p of ~d m, approach spans of ~d m"
(round (the cable-run) 1000)
(the span-count)
(round (the span-length) 1000)
(round (the approach-length) 1000))
nil)
(list "The cable"
(format nil
"~d mm, ~,1f kg/m, breaking force ~d kN, held at ~d kN"
(the cable-diameter)
(the cable-mass-per-m)
(round (the breaking-force) 1000)
(round (the cable-tension-kn)))
nil)
(list "Sag at mid-span"
(format nil
"~,2f m: ~,2f m the cable's own, ~,2f m under ~d pod~:p"
(/ (the design-sag) 1000)
(/ (the self-sag) 1000)
(/ (the pod-sag) 1000)
(the pods-per-span))
nil)
(list "Saddle height"
(format nil
"~,1f m: ~,1f m clearance, ~,1f m of pod, ~,1f m of sag"
(/ (the support-z) 1000)
(/ (the clearance) 1000)
(/ (the hang-depth) 1000)
(/ (the design-sag) 1000))
nil)
(list "Tension"
(format nil
"safety factor ~,2f against ~,2f asked"
(the safety-factor)
(the required-safety-factor))
(verdict :tension))
(list "Gradient"
(format nil
"steepest cable ~,1f % against ~,1f % allowed; ~a"
(* 100 (the design-gradient))
(* 100 (the gradient-limit))
(if (the least-approach)
(format
nil
"the shortest approach span within it is ~d m"
(ceiling (the least-approach) 1000))
"no approach span climbs to these saddles within it"))
(verdict :gradient))
(list "Clearance"
(format nil
"least under a pod on the main spans as drawn, ~,2f m"
(/ (the least-clearance) 1000))
(verdict :clearance))
(list "Approach spans"
(format nil
"dip ~,2f m below the rail they leave"
(/ (max 0 (the approach-dip)) 1000))
(verdict :approach))
(list "Passage"
(format nil
"a bogie at every pole, tower and anchor, and the pods as drawn: ~d clash~:*~[es~;~:;es~]"
(length (the clashes)))
(verdict :passage))
(list "Tensioner travel"
(format nil
"~,2f m over ~d K"
(/ (the tensioner-travel) 1000)
(the temperature-range))
nil)
(list "Longest lowering"
(format nil
"~,1f m, from a saddle to the ground"
(/ (the longest-lowering) 1000))
nil)))))
:objects
((neighbourhood :type 'neighbourhood
:line-length (the line-length)
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit)
:beam-center-z (the beam-center-z))
(near-anchor :type 'anchor-station
:cable-point (first (the supports))
:gauge (the gauge)
:head-radius (the head-radius)
:outward 1)
(far-anchor :type 'anchor-station
:cable-point (lastcar (the supports))
:gauge (the gauge)
:head-radius (the head-radius)
:outward -1
:tensioner? t)
(far-rail :type 'rail-segment
:start (make-point (the end-x) 0 (the beam-center-z))
:end (make-point (+ (the end-x) (the far-rail-length))
0
(the beam-center-z))
:gauge (the gauge)
:head-radius (the head-radius))
(ground :type 'box
:width (+ (the cable-run) (the far-rail-length))
:length 9000
:height 50
:center (make-point (+ (the start-x)
(half (+
(the cable-run)
(the far-rail-length))))
0
-25)
:display-controls (list :color :dark-olive-green))
(tower :type 'span-tower
:sequence (:size (1+ (the span-count)))
:cable-point (nth (1+ (the-child index)) (the supports))
:slope-in (the (span (the-child index)) (slope-at 1))
:slope-out (the (span (1+ (the-child index))) (slope-at 0))
:gauge (the gauge)
:head-radius (the head-radius))
(span :type 'cable-span
:sequence (:size (the spans))
:start (nth (the-child index) (the supports))
:end (nth (1+ (the-child index)) (the supports))
:tension (the tension)
:unit-weight (the unit-weight)
:pod-load (the pod-load)
:pod-fractions (let ((index (the-child index)))
(loop for position in (the cable-pod-positions)
when (= (min (floor position) (1- (the spans)))
index)
collect (- position index)))
:gauge (the gauge))
(cable-pod :type 'pod-unit
:sequence (:size (length (the cable-pod-positions)))
:center (first (nth (the-child index) (the pod-seats)))
:slope (second (nth (the-child index) (the pod-seats)))
:orientation (alignment :right
(make-vector 1 0 0)
:top
(make-vector 0 0 1))
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit)
:drop-fraction (or (nth (the-child index) (the cable-pod-drops))
0)
:pod-color (or (nth (the-child index) (the cable-pod-colors))
:steel-blue))
(far-pole :type 'utility-pole
:sequence (:size 2)
:base-x (+ (the end-x) 4000 (* (the-child index) 12000))
:base-y -1200
:beam-point (make-point (+ (the end-x)
4000
(* (the-child index) 12000))
0
(the beam-center-z))
:gauge (the gauge)
:head-radius (the head-radius)))
:hidden-objects
((reference-pod :type 'pod-unit
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit))
(passage-pod :type 'pod-unit
:sequence (:size (length (the passage-seats)))
:center (first (nth (the-child index) (the passage-seats)))
:slope (second (nth (the-child index) (the passage-seats)))
:orientation (alignment :right
(make-vector 1 0 0)
:top
(make-vector 0 0 1))
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit)))
:functions
(("Distance along the ground from the near rail end to POSITION, which
counts in spans."
station-of
(position)
(let ((index (max 0 (min (floor position) (1- (the spans))))))
(+ (nth index (the span-starts))
(* (- position index) (nth index (the span-runs))))))
("The point of the track axis at STATION: on the cables, or on the rail
at either end of them."
axis-point-at
(station)
(if (< 0 station (the cable-run))
(let ((index
(position-if #'(lambda (start) (<= start station))
(the span-starts)
:from-end
t)))
(the (span index)
(point-at
(/ (- station (nth index (the span-starts)))
(nth index (the span-runs))))))
(make-point (+ (the start-x) station) 0 (the beam-center-z))))
("Centre and slope of a bogie at STATION, each axle standing on the track."
seat-at
(station)
(let ((rear (the (axis-point-at (- station (half (the wheelbase))))))
(front (the (axis-point-at (+ station (half (the wheelbase)))))))
(list (midpoint rear front)
(/ (- (get-z front) (get-z rear)) (the wheelbase)))))))(define-object track-mixin nil
:documentation
(:description "The running geometry that rail, cable and bogie share.
The track axis runs midway between the two running heads at the height
of their centres, and every height here is measured from it.")
:input-slots
((gauge 500)
(head-radius 16)
(wheel-radius 120)
(wheel-width 80)
("Steepest track the bogie is to meet, rise over run" gradient-limit 0.15)
("How far along the track the plumb parts under the pivot reach"
plumb-reach 500))
:computed-slots
((plate 12)
(slot-half (- (half (the gauge)) (the head-radius) 25))
(inner-half (+ (half (the gauge)) (half (the wheel-width)) 40))
(outer-half (+ (the inner-half) (the plate)))
(flange-top (- (the head-radius)))
(girder-bottom (- (the flange-top) 30))
(inside-top (+ (the head-radius) (twice (the wheel-radius)) 50))
(girder-top (+ (the inside-top) (the plate)))
(under-track (+ (the head-radius)
110
(* (the plumb-reach) (the gradient-limit))))))(define-object rail-segment (track-mixin base-object)
:documentation
(:description "Straight slotted box girder from START to END, both
on the track axis. The bogie runs inside on two round running heads and
the pod's hanger comes down through the slot, so the girder can be held
from above or from either side anywhere along its length.")
:input-slots
(start
end
(color :slate-gray))
:computed-slots
((direction (unitize-vector (subtract-vectors (the end) (the start))))
(across (unitize-vector (cross-vectors (make-vector 0 0 1) (the direction))))
(upward (cross-vectors (the direction) (the across)))
(run (3d-distance (the start) (the end)))
(middle (midpoint (the start) (the end)))
(attitude (alignment :right (the direction) :rear (the across))))
:objects
((top-plate :type 'box
:width (the run)
:length (twice (the outer-half))
:height (the plate)
:center (translate-along-vector
(the middle)
(the upward)
(+ (the inside-top) (half (the plate))))
:orientation (the attitude)
:display-controls (list :color (the color)))
(web :type 'box
:sequence (:size 2)
:width (the run)
:length (the plate)
:height (- (the inside-top) (the girder-bottom))
:center (translate-along-vector
(translate-along-vector
(the middle)
(the upward)
(half (+ (the inside-top) (the girder-bottom))))
(the across)
(* (if (zerop (the-child index)) -1 1)
(+ (the inner-half) (half (the plate)))))
:orientation (the attitude)
:display-controls (list :color (the color)))
(flange :type 'box
:sequence (:size 2)
:width (the run)
:length (- (the inner-half) (the slot-half))
:height (- (the flange-top) (the girder-bottom))
:center (translate-along-vector
(translate-along-vector
(the middle)
(the upward)
(half (+ (the flange-top) (the girder-bottom))))
(the across)
(* (if (zerop (the-child index)) -1 1)
(half (+ (the inner-half) (the slot-half)))))
:orientation (the attitude)
:display-controls (list :color (the color)))
(head :type 'cylinder
:sequence (:size 2)
:radius (the head-radius)
:length (the run)
:center (translate-along-vector
(the middle)
(the across)
(* (if (zerop (the-child index)) -1 1) (half (the gauge))))
:orientation (alignment :rear (the direction))
:display-controls (list :color :silver))))(define-object utility-pole (track-mixin base-object)
:documentation
(:description "Slender pole with an arm out over the girder, which
hangs from it. BEAM-POINT is on the track axis.")
:input-slots
(base-x
base-y
beam-point
(pole-radius 130)
(arm-height 220))
:computed-slots
((arm-z (+ (get-z (the beam-point)) (the girder-top) (half (the arm-height))))
(top-z (+ (the arm-z) (half (the arm-height)) 100))
(arm-start (make-point (the base-x) (the base-y) (the arm-z)))
(over-track (make-point (get-x (the beam-point))
(get-y (the beam-point))
(the arm-z)))
(reach (unitize-vector (subtract-vectors (the over-track) (the arm-start)))))
:objects
((pole :type 'cylinder
:radius (the pole-radius)
:length (the top-z)
:center (make-point (the base-x) (the base-y) (half (the top-z)))
:orientation (alignment :rear (make-vector 0 0 1))
:display-controls (list :color :wood-dark))
(collar :type 'box
:width 500
:length 500
:height 200
:center (make-point (the base-x) (the base-y) 100)
:display-controls (list :color :dim-gray))
(arm :type 'box-beam
:start (the arm-start)
:end (translate-along-vector
(the over-track)
(the reach)
(the outer-half))
:section-width 150
:section-height (the arm-height)
:color :dim-gray)))(define-object pod-unit (track-mixin base-object)
:documentation
(:description "Bogie, winch drum, tethers and pod cabin. CENTER is
on the track axis; orientation points :right along the line. Four
wheels run on the two running heads or cables; a narrow spine comes
down between them to a pivot, below which winch and pod hang plumb
whatever the SLOPE of the track.")
:input-slots
(("Rise over run of the track under the bogie" slope 0)
(drop-fraction 0)
(ground-z 0)
(pod-body-length 1400)
(pod-radius 750)
(pod-height 1700)
(pod-color :steel-blue)
(drum-radius 110)
(hang-gap 200)
(skid-height 100)
(wheelbase 600)
(spine-width 200)
(frame-height 120))
:computed-slots
((pitch (atan (the slope)))
(along (the (face-normal-vector :right)))
(across (the (face-normal-vector :rear)))
(plumb (the (face-normal-vector :top)))
(tangent (add-vectors (scalar*vector (cos (the pitch)) (the along))
(scalar*vector (sin (the pitch)) (the plumb))))
(normal (cross-vectors (the tangent) (the across)))
(truck-attitude (alignment :right (the tangent) :rear (the across)))
(axle-height (+ (the head-radius) (the wheel-radius)))
(spine-top (+ (the axle-height) 40))
(spine-bottom (- (+ (the under-track) (half (the frame-height)))))
(frame-top (- (the under-track)))
(frame-bottom (- (the frame-top) (the frame-height)))
(drum-z (- (the frame-bottom) (the drum-radius)))
(nominal-pod-top (- (the drum-z) (the drum-radius) (the hang-gap)))
(nominal-bottom (- (the nominal-pod-top) (the pod-height) (the skid-height)))
(max-drop (- (+ (get-z (the center)) (the nominal-bottom)) (the ground-z)))
(drop (* (the drop-fraction) (the max-drop)))
(pod-top (- (the nominal-pod-top) (the drop)))
(pod-mid (- (the pod-top) (half (the pod-height))))
(vertical (alignment :rear
(the (face-normal-vector :top))
:right
(the (face-normal-vector :right)))))
:objects
((spine :type 'box
:width 900
:length (the spine-width)
:height (- (the spine-top) (the spine-bottom))
:center (translate-along-vector
(the center)
(the normal)
(half (+ (the spine-top) (the spine-bottom))))
:orientation (the truck-attitude)
:display-controls (list :color :grey-slate-dark))
(pivot :type 'cylinder
:radius 45
:length (+ (the spine-width) 120)
:center (translate (the center)
:up
(half (+ (the frame-top) (the frame-bottom))))
:display-controls (list :color :goldenrod))
(winch-frame :type 'box
:width (twice (the plumb-reach))
:length 500
:height (the frame-height)
:center (translate (the center)
:up
(half (+
(the frame-top)
(the frame-bottom))))
:display-controls (list :color :grey-slate-dark))
(winch-drum :type 'cylinder
:radius (the drum-radius)
:length 360
:center (translate (the center) :up (the drum-z))
:display-controls (list :color :goldenrod))
(dock-plate :type 'box
:width 600
:length 600
:height 60
:center (translate (the center) :up (+ (the pod-top) 30))
:display-controls (list :color :dim-gray))
(pod-body :type 'box
:width (the pod-body-length)
:length (twice (the pod-radius))
:height (the pod-height)
:center (translate (the center) :up (the pod-mid))
:display-controls (list :color (the pod-color)))
(door :type 'box
:width 800
:length 30
:height (* 0.85 (the pod-height))
:center (translate (the center)
:front
(+ (the pod-radius) 25)
:up
(- (the pod-mid) (* 0.05 (the pod-height))))
:display-controls (list :color :teal))
(skid :type 'box
:width (+ (the pod-body-length) (the pod-radius))
:length (* 1.4 (the pod-radius))
:height (the skid-height)
:center (translate (the center)
:up
(- (the pod-top)
(the pod-height)
(half (the skid-height))))
:display-controls (list :color :dim-gray))
(wheel :type 'cylinder
:sequence (:size 4)
:radius (the wheel-radius)
:length (the wheel-width)
:center (translate-along-vector
(translate-along-vector
(translate-along-vector
(the center)
(the tangent)
(* (if (< (the-child index) 2) -1 1)
(half (the wheelbase))))
(the normal)
(the axle-height))
(the across)
(* (if (evenp (the-child index)) -1 1) (half (the gauge))))
:display-controls (list :color :black))
(axle :type 'cylinder
:sequence (:size 2)
:radius 30
:length (+ (the gauge) (the wheel-width))
:center (translate-along-vector
(translate-along-vector
(the center)
(the tangent)
(* (if (zerop (the-child index)) -1 1)
(half (the wheelbase))))
(the normal)
(the axle-height))
:display-controls (list :color :dim-gray))
(tether :type 'cylinder
:sequence (:size 4)
:radius 15
:length (- (the drum-z) (the pod-top))
:center (translate (the center)
:right
(* (if (< (the-child index) 2) -1 1)
0.3
(the pod-body-length))
:rear
(* (if (evenp (the-child index)) -1 1)
0.35
(the pod-radius))
:up
(half (+ (the drum-z) (the pod-top))))
:orientation (the vertical)
:display-controls (list :color :black))
(pod-end :type 'cylinder
:sequence (:size 2)
:radius (the pod-radius)
:length (the pod-height)
:center (translate (the center)
:right
(* (- (the-child index) 0.5)
(the pod-body-length))
:up
(the pod-mid))
:orientation (the vertical)
:display-controls (list :color (the pod-color)))
(side-window :type 'box
:sequence (:size 2)
:width (* 0.9 (the pod-body-length))
:length 20
:height (* 0.35 (the pod-height))
:center (translate (the center)
:rear
(* (if (zerop (the-child index)) -1 1)
(+ (the pod-radius) 10))
:up
(+ (the pod-mid) (* 0.15 (the pod-height))))
:display-controls (list :color :dark-slate-blue))))(define-object home-lot (track-mixin base-object)
:documentation
(:description "A house with its own spur off the main line,
two yard poles, a switch, a landing pad and the owner's pod.")
:input-slots
(junction-x
beam-center-z
(bend 4500)
(setback 13000)
(park-back 1800)
(pole-offset 1200)
(house-width 7000)
(house-length 8000)
(house-height 3200)
(roof-rise 2000)
(pad-thickness 150)
(pod-color :firebrick)
(drop-fraction 1.0))
:computed-slots
((bz (the beam-center-z))
(p0 (make-point (the junction-x) 0 (the bz)))
(p1 (make-point (+ (the junction-x) (the bend)) (the bend) (the bz)))
(p2 (make-point (+ (the junction-x) (the bend)) (the setback) (the bz)))
(pad-x (+ (the junction-x) (the bend)))
(pad-y (- (the setback) (the park-back)))
(house-right (- (the pad-x) 2200))
(house-left (- (the house-right) (the house-width)))
(house-front (- (the pad-y) (half (the house-length)))))
:objects
((spur-a :type 'rail-segment
:start (the p0)
:end (the p1)
:gauge (the gauge)
:head-radius (the head-radius))
(spur-b :type 'rail-segment
:start (the p1)
:end (the p2)
:gauge (the gauge)
:head-radius (the head-radius))
(switch :type 'box
:width 1200
:length (+ (twice (the outer-half)) 200)
:height (+ (- (the girder-top) (the girder-bottom)) 100)
:center (translate-along-vector
(the p0)
(make-vector 0 0 1)
(half (+ (the girder-top) (the girder-bottom))))
:display-controls (list :color :goldenrod))
(pad :type 'box
:width 3600
:length 4000
:height (the pad-thickness)
:center (make-point (the pad-x) (the pad-y) (half (the pad-thickness)))
:display-controls (list :color :gray))
(house :type 'box
:width (the house-width)
:length (the house-length)
:height (the house-height)
:center (make-point (half (+ (the house-left) (the house-right)))
(the pad-y)
(half (the house-height)))
:display-controls (list :color :feldspar))
(roof :type 'global-polygon-projection
:vertex-list (list (make-point (- (the house-left) 300)
(the house-front)
(the house-height))
(make-point (+ (the house-right) 300)
(the house-front)
(the house-height))
(make-point (half
(+
(the house-left)
(the house-right)))
(the house-front)
(+ (the house-height) (the roof-rise)))
(make-point (- (the house-left) 300)
(the house-front)
(the house-height)))
:projection-vector (make-vector 0 1 0)
:projection-depth (the house-length)
:display-controls (list :color :sienna))
(front-door :type 'box
:width 40
:length 1000
:height 2100
:center (make-point (+ (the house-right) 20) (the pad-y) 1050)
:display-controls (list :color :green-hunter))
(walk :type 'box
:width 2200
:length 1200
:height 60
:center (make-point (- (the pad-x) 2900) (the pad-y) 30)
:display-controls (list :color :grey-light))
(pod :type 'pod-unit
:center (make-point (the pad-x) (the pad-y) (the bz))
:orientation (alignment :right
(make-vector 0 1 0)
:top
(make-vector 0 0 1))
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit)
:ground-z (the pad-thickness)
:drop-fraction (the drop-fraction)
:pod-color (the pod-color))
(yard-pole :type 'utility-pole
:sequence (:size 2)
:base-x (+ (the pad-x) (the pole-offset))
:base-y (if (zerop (the-child index)) (the bend) (the setback))
:beam-point (if (zerop (the-child index)) (the p1) (the p2))
:gauge (the gauge)
:head-radius (the head-radius)))
:hidden-objects
((passage-pod :type 'pod-unit
:center (the p2)
:orientation (alignment :right
(make-vector 0 1 0)
:top
(make-vector 0 0 1))
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit))))(define-object neighbourhood (track-mixin base-object)
:documentation
(:description "A main rail on utility poles run past homes, each
with its spur, a lane under the line and one pod under way.")
:input-slots
(("Length of main line shown" line-length 40000)
("Main-line pole spacing, like utility poles" pole-spacing 12000)
("Height of track axis above ground" beam-center-z 6500)
("Pole distance from track axis" pole-offset 1200)
("Main-line x where each home spur branches"
home-junctions (list -13000 3000))
("Colour of each owner's pod"
home-pod-colors (list :firebrick :orange-mandarin))
("0 = pod up at travel height, 1 = on its ground pad"
home-drop-fractions (list 1.0 0.5))
("Position of a pod travelling on the main line" travel-pod-x 14000)
("Width of the lane under the line" road-width 3500))
:computed-slots
((pole-count (1+ (floor (- (the line-length) 4000) (the pole-spacing))))
(pods (append (list (the travelling-pod))
(list-elements (the passage-pod))
(loop for home in (list-elements (the home))
collect (the-object home pod)
collect (the-object home passage-pod))))
(structures (append (list (the main-rail))
(list-elements (the main-pole))
(loop for home in (list-elements (the home))
append (list (the-object home spur-a)
(the-object home spur-b))
append (list-elements
(the-object home yard-pole))))))
:objects
((main-rail :type 'rail-segment
:start (make-point (- (half (the line-length)))
0
(the beam-center-z))
:end (make-point (half (the line-length)) 0 (the beam-center-z))
:gauge (the gauge)
:head-radius (the head-radius))
(road :type 'box
:width (the line-length)
:length (the road-width)
:height 50
:center (make-point 0 (+ 500 (half (the road-width))) -25)
:display-controls (list :color :grey-slate-dark))
(travelling-pod :type 'pod-unit
:center (make-point (the travel-pod-x) 0 (the beam-center-z))
:orientation (alignment :right
(make-vector 1 0 0)
:top
(make-vector 0 0 1))
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit)
:pod-color :steel-blue)
(main-pole :type 'utility-pole
:sequence (:size (the pole-count))
:base-x (+ (- (half (the line-length)))
2000
(* (the-child index) (the pole-spacing)))
:base-y (- (the pole-offset))
:beam-point (make-point (+ (- (half (the line-length)))
2000
(*
(the-child index)
(the pole-spacing)))
0
(the beam-center-z))
:gauge (the gauge)
:head-radius (the head-radius))
(home :type 'home-lot
:sequence (:size (length (the home-junctions)))
:junction-x (nth (the-child index) (the home-junctions))
:pod-color (nth (the-child index) (the home-pod-colors))
:drop-fraction (nth (the-child index) (the home-drop-fractions))
:beam-center-z (the beam-center-z)
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit)))
:hidden-objects
((passage-pod :type 'pod-unit
:sequence (:size (the pole-count))
:center (the (main-pole (the-child index)) beam-point)
:orientation (alignment :right
(make-vector 1 0 0)
:top
(make-vector 0 0 1))
:gauge (the gauge)
:head-radius (the head-radius)
:gradient-limit (the gradient-limit))))(define-object cable-span (base-object)
:documentation
(:description "Twin track cables hung between two supports, which
may stand at different heights. The shape follows the general cable
theorem: the sag below the chord is the bending moment of the simply
supported beam carrying the same loads, divided by the horizontal
tension. Tension, weight and pod load are those of ONE cable.")
:input-slots
(start
end
("Horizontal tension in one cable, N" tension nil)
("Weight of one cable per length, N/mm" unit-weight nil)
("Where pods stand, as fractions of the span" pod-fractions nil)
("One pod's weight on one cable, N" pod-load 0)
(gauge 500)
(segments 24))
:computed-slots
((run (sqrt (+ (expt (- (get-x (the end)) (get-x (the start))) 2)
(expt (- (get-y (the end)) (get-y (the start))) 2))))
(rise (- (get-z (the end)) (get-z (the start))))
(heading (unitize-vector
(make-vector (- (get-x (the end)) (get-x (the start)))
(- (get-y (the end)) (get-y (the start)))
0)))
(lateral (cross-vectors (make-vector 0 0 1) (the heading)))
(stations (sort (remove-duplicates
(append (loop for i from 0 to (the segments)
collect (/ i (float (the segments))))
(the pod-fractions))
:test
#'(lambda (a b) (< (abs (- a b)) 1.0E-6)))
#'<))
(axis-points (mapcar #'(lambda (s) (the (point-at s))) (the stations)))
(lowest-z (apply #'min (mapcar #'get-z (the axis-points))))
(max-sag (apply #'max
(mapcar #'(lambda (s) (the (sag-at s))) (the stations))))
(max-slope (max (abs (the (slope-at 0))) (abs (the (slope-at 1)))))
(max-tension (* (the tension) (sqrt (1+ (expt (the max-slope) 2))))))
:objects
((cable :type 'global-polyline
:sequence (:size 2)
:vertex-list (let ((shift (* (- (the-child index) 0.5) (the gauge))))
(mapcar #'(lambda (point)
(translate-along-vector
point
(the lateral)
shift))
(the axis-points)))
:display-controls (list :color :black :line-thickness 2)))
:functions
((moment-at
(s)
(let ((x (* s (the run))) (l (the run)))
(+ (* 0.5 (the unit-weight) x (- l x))
(loop for f in (the pod-fractions)
for a = (* f l)
sum (* (the pod-load)
(if (<= x a) (/ (* x (- l a)) l) (/ (* a (- l x)) l)))))))
(shear-at
(s)
(let ((x (* s (the run))) (l (the run)))
(+ (* (the unit-weight) (- (half l) x))
(loop for f in (the pod-fractions)
for a = (* f l)
sum (* (the pod-load) (if (< x a) (/ (- l a) l) (- (/ a l))))))))
(sag-at (s) (/ (the (moment-at s)) (the tension)))
(slope-at
(s)
(- (/ (the rise) (the run)) (/ (the (shear-at s)) (the tension))))
(point-at
(s)
(let ((on-chord
(translate-along-vector (the start) (the heading) (* s (the run)))))
(make-point (get-x on-chord)
(get-y on-chord)
(- (+ (get-z (the start)) (* s (the rise)))
(the (sag-at s))))))))(define-object saddle-pair (track-mixin base-object)
:documentation
(:description "Two saddles hung from a beam above the track. Each
cable lies in a shoe held from its OUTER side, beyond the wheels, which
leaves the top of the cable to the wheels and the gap between the cables
to the bogie's spine. A shoe is two halves, one along the cable as it
arrives and one along it as it leaves. The line runs along +X.")
:input-slots
(cable-point
(beam-rise 900)
(saddle-length 1600)
("Rise over run of the cable arriving" slope-in 0)
("Rise over run of the cable leaving" slope-out 0))
:computed-slots
((px (get-x (the cable-point)))
(py (get-y (the cable-point)))
(pz (get-z (the cable-point)))
(hanger-offset (+ (half (the gauge)) (half (the wheel-width)) 70))
(shoe-inner (- (half (the gauge)) (the head-radius) 10))
(shoe-outer (+ (the hanger-offset) 20)))
:objects
((hanger :type 'box
:sequence (:size 2)
:width 120
:length 40
:height (+ (the beam-rise) (the head-radius) 50)
:center (make-point (the px)
(+ (the py)
(* (if (zerop (the-child index)) -1 1)
(the hanger-offset)))
(- (+ (the pz) (the beam-rise))
(half (+
(the beam-rise)
(the head-radius)
50))))
:display-controls (list :color :dim-gray))
(shoe :type 'box
:sequence (:size 4)
:width (half (the saddle-length))
:length (- (the shoe-outer) (the shoe-inner))
:height 50
:center (let* ((leaving? (oddp (the-child index)))
(slope (if leaving? (the slope-out) (the slope-in)))
(tangent (unitize-vector (make-vector 1 0 slope)))
(normal (cross-vectors tangent (make-vector 0 1 0))))
(translate-along-vector
(translate-along-vector
(translate-along-vector
(the cable-point)
tangent
(* (if leaving? 1 -1) (/ (the saddle-length) 4)))
normal
(- (+ (the head-radius) 25)))
(make-vector 0 1 0)
(* (if (< (the-child index) 2) -1 1)
(half (+ (the shoe-outer) (the shoe-inner))))))
:orientation (alignment :right
(unitize-vector
(make-vector 1
0
(if
(oddp (the-child index))
(the slope-out)
(the slope-in))))
:rear
(make-vector 0 1 0))
:display-controls (list :color :goldenrod))))(define-object span-tower (track-mixin base-object)
:documentation
(:description "Tapered mast beside the line with an arm out over
the cables, which rest in a pair of saddles hung from the arm.")
:input-slots
(cable-point
(slope-in 0)
(slope-out 0)
(mast-offset 2400)
(arm-rise 900)
(base-radius 260)
(top-radius 150))
:computed-slots
((px (get-x (the cable-point)))
(py (get-y (the cable-point)))
(mast-y (- (the py) (the mast-offset)))
(arm-z (+ (get-z (the cable-point)) (the arm-rise)))
(top-z (+ (the arm-z) 300))
(arm-length (+ (the mast-offset) (the saddles hanger-offset) 200)))
:objects
((mast :type 'cone
:radius (the base-radius)
:radius-1 (the base-radius)
:radius-2 (the top-radius)
:length (the top-z)
:center (make-point (the px) (the mast-y) (half (the top-z)))
:orientation (alignment :rear (make-vector 0 0 1))
:display-controls (list :color :wood-dark))
(footing :type 'box
:width 900
:length 900
:height 300
:center (make-point (the px) (the mast-y) 150)
:display-controls (list :color :dim-gray))
(arm :type 'box
:width 220
:length (the arm-length)
:height 260
:center (make-point (the px)
(+ (the mast-y) (half (the arm-length)))
(the arm-z))
:display-controls (list :color :dim-gray))
(saddles :type 'saddle-pair
:cable-point (the cable-point)
:gauge (the gauge)
:head-radius (the head-radius)
:slope-in (the slope-in)
:slope-out (the slope-out)
:beam-rise (the arm-rise))))(define-object anchor-station (track-mixin base-object)
:documentation
(:description "Where the rail ends and the cables begin. The cables
run on from the girder's running heads and are made fast in its end,
which hangs from a portal over the track; the portal is guyed back to
two ground anchors against the cables' pull. OUTWARD is 1 when the
cables leave toward +X, -1 toward -X. With TENSIONER? the station
carries the counterweights that keep the tension through the seasons.")
:input-slots
(cable-point
(outward 1)
(tensioner? nil)
(leg-offset 1700)
(beam-rise 900)
(backstay-run 7000)
(backstay-spread 1200))
:computed-slots
((px (get-x (the cable-point)))
(py (get-y (the cable-point)))
(top-z (+ (get-z (the cable-point)) (the beam-rise)))
(hanger-height (- (the beam-rise) 130 (the girder-top))))
:objects
((crossbeam :type 'box
:width 260
:length (+ (twice (the leg-offset)) 400)
:height 260
:center (make-point (the px) (the py) (the top-z))
:display-controls (list :color :dim-gray))
(leg :type 'cylinder
:sequence (:size 2)
:radius 160
:length (the top-z)
:center (make-point (the px)
(+ (the py)
(* (if (zerop (the-child index)) -1 1)
(the leg-offset)))
(half (the top-z)))
:orientation (alignment :rear (make-vector 0 0 1))
:display-controls (list :color :wood-dark))
(girder-hanger :type 'box
:sequence (:size 2)
:width 120
:length 40
:height (the hanger-height)
:center (make-point (- (the px) (* (the outward) 60))
(+ (the py)
(*
(if (zerop (the-child index)) -1 1)
(- (the outer-half) 60)))
(+ (get-z (the cable-point))
(the girder-top)
(half (the hanger-height))))
:display-controls (list :color :dim-gray))
(anchor-block :type 'box
:sequence (:size 2)
:width 1600
:length 1600
:height 600
:center (make-point (- (the px)
(* (the outward) (the backstay-run)))
(+ (the py)
(*
(if (zerop (the-child index)) -1 1)
(+
(the leg-offset)
(the backstay-spread))))
300)
:display-controls (list :color :gray))
(backstay :type 'strut
:sequence (:size 2)
:start (make-point (the px)
(+ (the py)
(* (if (zerop (the-child index)) -1 1)
(the leg-offset)))
(the top-z))
:end (translate-along-vector
(the (anchor-block (the-child index)) center)
(make-vector 0 0 1)
300)
:radius 25
:color :black)
(counterweight :type 'box
:sequence (:size (if (the tensioner?) 2 0))
:width 700
:length 500
:height 2200
:center (make-point (the px)
(+ (the py)
(*
(if (zerop (the-child index)) -1 1)
(+ (the leg-offset) 500)))
(* 0.45 (the top-z)))
:display-controls (list :color :goldenrod))))(define-object strut (base-object)
:documentation
(:description "Round member from START to END.")
:input-slots
(start
end
(radius 40)
(color :dim-gray))
:objects
((rod :type 'cylinder
:radius (the radius)
:length (3d-distance (the start) (the end))
:center (midpoint (the start) (the end))
:orientation (alignment :rear
(unitize-vector
(subtract-vectors (the end) (the start))))
:display-controls (list :color (the color)))))(define-object box-beam (base-object)
:documentation
(:description "Straight horizontal beam from START to END.")
:input-slots
(start
end
(section-width 250)
(section-height 350)
(color :slate-gray))
:computed-slots
((direction (unitize-vector (subtract-vectors (the end) (the start)))))
:objects
((beam :type 'box
:width (3d-distance (the start) (the end))
:length (the section-width)
:height (the section-height)
:center (midpoint (the start) (the end))
:orientation (alignment :right
(the direction)
:top
(make-vector 0 0 1))
:display-controls (list :color (the color)))))(define-object pod-line-ui (demos-common:demo-ui-mixin session-control-mixin
base-html-page)
:documentation
(:description "Interactive pod line demo page: parameter form, live
viewport on the whole line or a part of it, and the design checks the
model makes of itself."
:author "Genworks International")
:input-slots
((title "Suspended Pod Line Demo")
(demo-slug "pod-line")
(view-projection-key :pod-line-view)
(view-projection-vector (unitize-vector (make-vector 0.6 -1 0.35)))
(span-length 150 :settable)
(span-count 2 :settable)
(approach-length 60 :settable)
(cable-tension 200 :settable)
(cable-diameter 32 :settable)
(gauge 500 :settable)
(pod-mass 800 :settable)
(pods-per-span 2 :settable)
(clearance 5 :settable))
:computed-slots
((source-pane-objects '(pod-line track-mixin rail-segment utility-pole
pod-unit home-lot neighbourhood cable-span
saddle-pair span-tower anchor-station strut box-beam
pod-line-ui demos-common:demo-ui-mixin))
(source-pane-functions '(find-clashes oriented-boxes-clash?
oriented-box
boxes-clash?
leaf-name))
(objects (let ((model (the model)))
(ecase (the focus-control value)
(:transition
(append (list (the-object model neighbourhood)
(the-object model near-anchor)
(the-object model (span 0))
(the-object model (tower 0)))
(loop for pod in
(list-elements (the-object model cable-pod))
for position in
(the-object model cable-pod-positions)
when (< position 1) collect pod)))
(:line (list model))
(:tower
(list (the-object model (tower 0))
(the-object model (passage-pod 4))))
(:rail
(list (the-object model neighbourhood main-rail)
(the-object model neighbourhood (main-pole 1))
(the-object model
neighbourhood
(passage-pod 1)))))))
(body (with-lhtml-string
nil
(:div :class "max-w-5xl mx-auto p-8"
(str
(the (page-intro "Suspended Pod Line"
"Personal pods on a rail run like a utility line past homes, carried between neighbourhoods on twin track cables. One bogie serves both, the towers are sized by the sag, and the model checks that a pod passes every support.")))
(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 checks-section div))
(str
(the (card :title "Source Code" :subtitle
"The complete Gendl source for this demo: object definitions reconstituted live from the in-memory definitions serving this page, the passage check's functions via the Lisp's own source records."
:content (the source-code-panes)))))))
(checks-card (the (card :title "Design Checks" :subtitle
"A sketch of the method, not a design: the rope's weight and strength are rules of thumb, and wind is not considered."
:content
(with-lhtml-string
nil
(:div :class "overflow-x-auto"
(str (the findings-table)))))))
(findings-table (with-lhtml-string
nil
(:table :class
"min-w-full table-fixed divide-y divide-gray-200"
(:tbody :class "divide-y divide-gray-100"
(dolist (finding (the model findings))
(destructuring-bind
(topic text verdict)
finding
(htm
(:tr :class "hover:bg-gray-50"
(:td :class
"px-6 py-3 w-40 text-sm font-medium text-gray-900"
(str topic))
(:td :class "px-6 py-3 text-sm text-gray-700"
(str text))
(:td :class "px-6 py-3 w-24 text-right"
(when verdict
(htm
(:span :class
(if (eql verdict :ok)
"inline-flex rounded-full px-2 py-0.5 text-xs font-semibold bg-green-100 text-green-800"
"inline-flex rounded-full px-2 py-0.5 text-xs font-semibold bg-red-100 text-red-800")
(str
(if (eql verdict :ok)
"ok"
"fails"))))))))))))))
(control-form (with-form-string
(:class "grid grid-cols-2 md:grid-cols-4 gap-6")
(str
(the (param-field "Span (m)" (the span-length-control))))
(str
(the (param-field "Main Spans" (the span-count-control))))
(str
(the (param-field "Approach Span (m)"
(the approach-length-control))))
(str
(the (param-field "Clearance (m)"
(the clearance-control))))
(str
(the (param-field "Cable Tension (kN)"
(the cable-tension-control))))
(str
(the (param-field "Cable Diameter (mm)"
(the cable-diameter-control))))
(str (the (param-field "Gauge (mm)" (the gauge-control))))
(str (the (param-field "Show" (the focus-control))))
(str
(the (param-field "Pod Mass (kg)" (the pod-mass-control))))
(str
(the (param-field "Pods per Span"
(the pods-per-span-control)))))))
:objects
((span-length-control :type 'number-form-control
:default (the span-length)
:ajax-submit-on-change? t
:domain :number
:min 100
:max 600
:step 10)
(span-count-control :type 'number-form-control
:default (the span-count)
:ajax-submit-on-change? t
:domain :number
:min 1
:max 6
:step 1)
(approach-length-control :type 'number-form-control
:default (the approach-length)
:ajax-submit-on-change? t
:domain :number
:min 40
:max 200
:step 5)
(clearance-control :type 'number-form-control
:default (the clearance)
:ajax-submit-on-change? t
:domain :number
:min 3
:max 8
:step 0.25)
(cable-tension-control :type 'number-form-control
:default (the cable-tension)
:ajax-submit-on-change? t
:domain :number
:min 80
:max 400
:step 10)
(cable-diameter-control :type 'number-form-control
:default (the cable-diameter)
:ajax-submit-on-change? t
:domain :number
:min 24
:max 60
:step 2)
(gauge-control :type 'number-form-control
:default (the gauge)
:ajax-submit-on-change? t
:domain :number
:min 400
:max 800
:step 50)
(pod-mass-control :type 'number-form-control
:default (the pod-mass)
:ajax-submit-on-change? t
:domain :number
:min 400
:max 1500
:step 50)
(pods-per-span-control :type 'number-form-control
:default (the pods-per-span)
:ajax-submit-on-change? t
:domain :number
:min 1
:max 6
:step 1)
(focus-control :type 'menu-form-control
:default :transition
:size 1
:ajax-submit-on-change? t
:choice-plist '(:transition "Rail to cable" :line
"The whole line" :tower "A pod at a tower"
:rail "A pod at a pole"))
(model :type 'pod-line
:span-length (* 1000 (the span-length-control value))
:span-count (the span-count-control value)
:approach-length (* 1000 (the approach-length-control value))
:clearance (* 1000 (the clearance-control value))
:cable-tension-kn (the cable-tension-control value)
:cable-diameter (the cable-diameter-control value)
:gauge (the gauge-control value)
:pod-mass-kg (the pod-mass-control value)
:pods-per-span (the pods-per-span-control value))
(checks-section :type 'base-html-div :inner-html (the checks-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)))))))lisp
(defun find-clashes (pods structures)
"The pairs of leaves, one of a pod in PODS and one under STRUCTURES, whose
oriented boxes overlap; each leaf is named by its path from the root.
A wheel is not held against what it runs on: the running heads, and the
shoes on which the cables lie."
(let ((structure-leaves (loop for object in structures
append (the-object object leaves))))
(loop for pod in pods
for reach = (the-object pod bounding-box)
for fixed = (loop for leaf in structure-leaves
when (boxes-clash? reach (the-object leaf bounding-box) 0)
collect (cons leaf (oriented-box leaf)))
append (loop for leaf in (the-object pod leaves)
for box = (oriented-box leaf)
append (loop for (other . other-box) in fixed
when (and (oriented-boxes-clash? box other-box)
(not (and (eql (leaf-name leaf) :wheel)
(member (leaf-name other)
'(:head :shoe)))))
collect (list (the-object leaf root-path)
(the-object other root-path)))))))
lisp
(defun oriented-boxes-clash? (box-1 box-2 &optional (tolerance 1))
"True when two oriented boxes overlap by more than TOLERANCE, which is when
no axis separates them: none of either box, and none square to an edge
of each."
(destructuring-bind (centre-1 axes-1 halves-1) box-1
(destructuring-bind (centre-2 axes-2 halves-2) box-2
(let ((between (subtract-vectors centre-2 centre-1)))
(flet ((separates? (axis)
(flet ((reach (axes halves)
(loop for own in axes
for half in halves
sum (* half (abs (dot-vectors own axis))))))
(>= (abs (dot-vectors between axis))
(- (+ (reach axes-1 halves-1) (reach axes-2 halves-2))
tolerance)))))
(not (or (some #'separates? axes-1)
(some #'separates? axes-2)
(loop for edge-1 in axes-1
thereis (loop for edge-2 in axes-2
for square = (cross-vectors edge-1 edge-2)
thereis (and (> (length-vector square) 1.0e-6)
(separates?
(unitize-vector square))))))))))))
lisp
(defun oriented-box (leaf)
"Centre, three axes and three half-sizes of the box that bounds LEAF along
its own axes: a box itself, a cylinder or cone squared off, anything
else by its bounding box along the global axes."
(flet ((own-axes ()
(mapcar #'(lambda (face) (the-object leaf (face-normal-vector face)))
'(:right :rear :top))))
(case (the-object leaf type)
(box (list (the-object leaf center) (own-axes)
(list (half (the-object leaf width))
(half (the-object leaf length))
(half (the-object leaf height)))))
((cylinder cone)
(let ((radius (if (eql (the-object leaf type) 'cone)
(max (the-object leaf radius-1) (the-object leaf radius-2))
(the-object leaf radius))))
(list (the-object leaf center) (own-axes)
(list radius (half (the-object leaf length)) radius))))
(otherwise
(destructuring-bind (low high) (the-object leaf bounding-box)
(list (midpoint low high)
(list (make-vector 1 0 0) (make-vector 0 1 0) (make-vector 0 0 1))
(list (half (- (get-x high) (get-x low)))
(half (- (get-y high) (get-y low)))
(half (- (get-z high) (get-z low))))))))))
lisp
(defun boxes-clash? (box-1 box-2 &optional (tolerance 1))
"True when two bounding boxes overlap by more than TOLERANCE along every axis."
(loop for axis from 0 to 2
always (> (- (min (aref (second box-1) axis) (aref (second box-2) axis))
(max (aref (first box-1) axis) (aref (first box-2) axis)))
tolerance)))
lisp
(defun leaf-name (leaf)
(let ((name (first (the-object leaf root-path))))
(if (consp name) (first name) name)))