;; Copyright © 2026 Genworks International ;; ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU Affero General Public License as ;; published by the Free Software Foundation, either version 3 of the ;; License, or (at your option) any later version. Distributed WITHOUT ;; ANY WARRANTY; see . (in-package :gdl-user) (defun building-bom (&key (nominal-height 3000) (nominal-width 3000) (nominal-length 3000) (roof-angle 30) (output-filename nil)) (let ((obj (make-object 'building :nominal-height nominal-height :nominal-width nominal-width :nominal-length nominal-length :truss-angle roof-angle :output-filename output-filename))) (if output-filename (theo obj write-bom-file!) (theo obj bom-formatted)))) (define-object building (box) :input-slots ((nominal-height 3000) (nominal-width 3000) (nominal-length 4000) (brick-height 45) (brick-length 180) (brick-width 90) (mortar-joint-width 10) (truss-angle 30) (beam-width 40) (beam-height 50) (wall-thickness 3) (material-density 7800) (roof-overhang 50) (cladding-thickness 10) (max-beam-spacing 1500) (output-filename nil)) :computed-slots ((length (the left-wall length)) (width (the rear-wall length)) (height (+ (the left-wall height) (the (roof-truss 0) height))) (number-of-roof-trusses (let ((trusses (ceiling (the left-wall length) 1500))) (max trusses 2))) (truss-spacing (div (- (the left-wall length) (the beam-width)) (- (the number-of-roof-trusses) 1))) (truss-offsets (let ((res nil)) (dotimes (n (the number-of-roof-trusses) (nreverse res)) (push (+ (half (the beam-width)) (* n (the truss-spacing))) res)))) (roof-length (+ (the left-wall length) (twice (the roof-overhang)))) (roof-width (the cladding-thickness)) (roof-height (let ((apex (the (roof-truss 0) apex-point)) (gutter (the (roof-truss 0) front-gutter-point))) (+ (3d-distance apex gutter) (the roof-overhang)))) ;; building properties (walls (remove nil (mapcar #'(lambda(a) (when (typep a 'wall) a)) (the children)))) (full-bricks (apply '+ (mapsend (the walls) :full-bricks))) (half-bricks (apply '+ (mapsend (the walls) :half-bricks))) (mortar-volume (apply '+ (mapsend (the walls) :mortar-volume))) (cladding-dimensions (list :length (the roof-length) :width (the roof-height))) (beam-properties (the (roof-truss 0) beam-properties)) (beam-qty-by-size (let ((res nil)) (dolist (plis (the beam-properties) ) (let* ((trusses (the number-of-roof-trusses)) (l (getf plis :length-mm)) (p (position l res :key #'(lambda(a) (getf a :length-mm)))) (qty (when p (getf (nth p res) :qty)))) (if p (setf (getf (nth p res) :qty) (+ qty trusses)) (setq res (append (list (list :length-mm l :qty trusses)) res))))) (safe-sort res '< :key #'(lambda(a) (getf a :length-mm))))) (roof-truss-mass (* (apply '+ (mapcar #'(lambda(a) (getf a :mass-kg)) (the beam-properties))) (the number-of-roof-trusses))) (building-materials (list :full-bricks (the full-bricks) :half-bricks (the half-bricks) :mortar-volume-m3 (div (the mortar-volume) 1000000000) :beams (the beam-qty-by-size) :roof-cladding (append (the cladding-dimensions) (list :qty 2)))) (bom-formatted (let* ((bom (the building-materials)) (cladding (getf bom :roof-cladding)) (bricks (format nil "Bricks~%======~% Full Bricks ~a~% Half Bricks ~a~%" (getf bom :full-bricks) (getf bom :half-bricks))) (mortar (format nil "Mortar~%======~% Volume ~,3f m^3~%" (getf bom :mortar-volume-m3))) (l (round-to-nearest (getf cladding :length) 1)) (w (round-to-nearest (getf cladding :width) 1)) (roof (format nil "Roof Cladding~%======~% Qty ~a~% Dimensions (L x W x T) ~d x ~d x ~d~%" (getf cladding :qty) l w (the cladding-thickness))) (beams (getf (the building-materials) :beams)) (beams-list (flatten (mapcar #'(lambda(a) (list (getf a :qty) (round-to-nearest (getf a :length-mm) 1))) beams))) (beams-header (format nil "Beams~%=====~% Section (H x W x T) ~a x ~a x ~a~%" (the beam-height) (the beam-width) (the wall-thickness))) (beam-lengths (format nil "~{ Qty ~a Length ~a~%~}" beams-list))) (format nil "~@{~a~}" bricks mortar roof beams-header beam-lengths))) ) :functions ((write-bom-file! () (with-open-file (s (the output-filename) :direction :output :if-exists :supersede :if-does-not-exist :create) (format t "Exporting the BOM to ~a~%" (the output-filename)) (format s "~a" (the bom-formatted)) (format t "Exporting complete~%"))) (get-roof-mid-point! (first-gutter last-gutter last-index) (let*((mid-gutter (midpoint first-gutter last-gutter)) (first-apex (the (roof-truss 0) apex-point)) (last-apex (the (roof-truss last-index) apex-point)) (mid-apex (midpoint first-apex last-apex)) (vec (subtract-vectors mid-gutter mid-apex)) (mid-edge (translate-along-vector mid-gutter vec (the roof-overhang)))) (midpoint mid-apex mid-edge))) ) :objects ((left-wall :type 'wall :pass-down (brick-height brick-length brick-width mortar-joint-width) :center (translate-along-vector (translate-along-vector (the (edge-center :bottom :left)) (the (face-normal-vector :right)) (half (the-child width))) (the (face-normal-vector :top)) (half (the-child height))) :wall-length (the nominal-length) :wall-height (the nominal-height)) (right-wall :type 'wall :pass-down (brick-height brick-length brick-width mortar-joint-width) :center (translate-along-vector (translate-along-vector (the (edge-center :bottom :right)) (the (face-normal-vector :left)) (half (the-child width))) (the (face-normal-vector :top)) (half (the-child height))) :wall-length (the nominal-length) :wall-height (the nominal-height)) (rear-wall :type 'wall :pass-down (brick-height brick-length brick-width mortar-joint-width) :center (translate-along-vector (translate-along-vector (the (edge-center :bottom :rear)) (the (face-normal-vector :front)) (half (the-child width))) (the (face-normal-vector :top)) (half (the-child height))) :orientation (alignment :rear (the (face-normal-vector :right))) :wall-length (the nominal-width) :wall-height (the nominal-height)) (roof-truss :type 'truss :sequence (:size (the number-of-roof-trusses)) :truss-length (the rear-wall length) :center (translate-along-vector (translate-along-vector (the (edge-center :front :top)) (the (face-normal-vector :bottom)) (half (the-child height))) (the (face-normal-vector :rear)) (nth (the-child index) (the truss-offsets))) :orientation (alignment :rear (the (face-normal-vector :right)) ) :pass-down (truss-angle beam-width beam-height wall-thickness material-density)) (roof-cladding-left :type 'box :length (the roof-length) :height (the roof-height) :width (the cladding-thickness) :orientation (alignment :left (the (roof-truss 0) front-slope-normal)) :center (let* ((last-index (- (the number-of-roof-trusses) 1)) (first-gutter (the (roof-truss 0) front-gutter-point)) (last-gutter (the (roof-truss last-index) front-gutter-point)) (mid-ctr (the (get-roof-mid-point! first-gutter last-gutter last-index)))) (translate-along-vector mid-ctr (the (roof-truss 0) front-slope-normal) (half (the cladding-thickness))))) (roof-cladding-right :type 'box :length (the roof-length) :height (the roof-height) :width (the cladding-thickness) :orientation (alignment :left (the (roof-truss 0) rear-slope-normal)) :center (let* ((last-index (- (the number-of-roof-trusses) 1)) (first-gutter (the (roof-truss 0) rear-gutter-point)) (last-gutter (the (roof-truss last-index) rear-gutter-point)) (mid-ctr (the (get-roof-mid-point! first-gutter last-gutter last-index)))) (translate-along-vector mid-ctr (the (roof-truss 0) rear-slope-normal) (half (the cladding-thickness))))) ) ) (define-object wall(box) :input-slots ((brick-height 45) (brick-length 180) (brick-width 90) (mortar-joint-width 10) (wall-length 3700) (wall-height 900) (first-row :start-full) (front-edge :full) (rear-edge :full)) :computed-slots ((row-height (+ (the brick-height) (the mortar-joint-width))) (number-of-rows (round-to-nearest (div (the wall-height) (the row-height)) 1)) (actual-wall-height (* (the row-height) (the number-of-rows))) ;; for the wall-length we need the number of full bricks ;; if there are n full bricks then there will be (n-1) mortar joints ;; so n*brick-length + n-1*mortar-joint-width = overall-length ;; or n(brick-length + mortar-join-width) - mortar-joint-width = overall-length ;; or n = (overall-length - mortar-joint-width)/(brick-length + mortar-joint-width) (number-of-bricks (round-to-nearest (div (- (the wall-length) (the mortar-joint-width)) (+ (the brick-length) (the mortar-joint-width))) 1)) (actual-wall-length (+ (* (the number-of-bricks) (the brick-length)) (* (- (the number-of-bricks) 1) (the mortar-joint-width)))) ;; box inputs - gives the wall bounding box (height (the actual-wall-height)) (width (the brick-width)) (length (the actual-wall-length)) (full-bricks (apply '+ (list-elements (the row) (the-element full-bricks)))) (half-bricks (apply '+ (list-elements (the row) (the-element half-bricks)))) (mortar-volume (apply '+ (list-elements (the row) (the-element mortar-volume)))) (mortar-density 2162) (mortar-mass (* (the mortar-density) (div (the mortar-volume) 1000000000))) ) :objects ((row :type 'row :sequence (:size (the number-of-rows)) :center (translate-along-vector (the (face-center :bottom)) (the (face-normal-vector :top)) (+ (half (the-child height)) (* (the-child index) (the-child height)))) :height (+ (the brick-height) (the mortar-joint-width)) :full-bricks-per-row (the number-of-bricks) :pass-down (brick-height brick-length brick-width mortar-joint-width length width first-row front-edge rear-edge)))) (define-object row (box) :input-slots (full-bricks-per-row brick-height brick-length brick-width mortar-joint-width first-row front-edge rear-edge ) :computed-slots ((full-brick-row? (cond ((eq (the first-row) :start-full) (or (zerop (the index)) (evenp (the index)))) ((eq (the first-row) :start-half) (not (or (zerop (the index)) (evenp (the index))))))) (full-bricks (the bricks-and-mortar full-bricks)) (half-bricks (the bricks-and-mortar half-bricks)) (mortar-volume (+ (the bricks-and-mortar mortar-joint-volume) (the mortar-bed volume)))) :objects ((bricks-and-mortar :type 'bricks-and-mortar :height (the brick-height) :center (translate-along-vector (the mortar-bed (face-center :top)) (the mortar-bed (face-normal-vector :top)) (half (the-child height))) :pass-down (width length full-brick-row? brick-height brick-length brick-width mortar-joint-width full-bricks-per-row front-edge rear-edge)) (mortar-bed :type 'box :height (the mortar-joint-width) :center (translate-along-vector (the (face-center :bottom)) (the (face-normal-vector :top)) (half (the-child height))) :pass-down (width length)))) (define-object bricks-and-mortar (box) :input-slots (full-brick-row? full-bricks-per-row brick-height brick-length brick-width mortar-joint-width front-edge rear-edge) :computed-slots ((first-full-brick-start-point (if (the full-brick-row?) (the (face-center :front)) (the (mortar-joint 0) (face-center :rear)))) (first-mortar-joint-start-point (cond ((the full-brick-row?) (the (full-brick 0) (face-center :rear))) ((eq (the front-edge) :full) (the (half-brick 0) (face-center :rear))) ((eq (the front-edge) :keyed) (translate-along-vector (the (face-center :front)) (the (face-normal-vector :rear)) (half (the brick-length)))))) (number-of-full-bricks (if (the full-brick-row?) (the full-bricks-per-row) (- (the full-bricks-per-row) 1))) (number-of-half-bricks (cond ((the full-brick-row?) 0) ((and (eq (the front-edge) :full)(eq (the rear-edge) :full)) 2) ((and (eq (the front-edge) :keyed) (eq (the rear-edge) :full)) 1) ((and (eq (the front-edge) :full) (eq (the rear-edge) :keyed)) 1) ((and (eq (the front-edge) :keyed) (eq (the rear-edge) :keyed)) 0))) ;; whether or not the ends are :full or :keyed, the number of mortar joints remains the same since the mortar joint ;; when it is :keyed is used to connect to the full brick of the other wall (number-of-mortar-joints (if (the full-brick-row?) (- (the number-of-full-bricks) 1) (+ (the number-of-full-bricks) 1))) ;; if it isn't a full brick row then there will be an extra joint because one ;; full brick is replaced with 2 half bricks so without correcting the ;; mortar-joint-width the ends of a full brick row and one starting and ;; finishing with half bricks won't align. So we need to correct ;; the mortar-joint-width (corrected-joint-width (if (the full-brick-row?) (the mortar-joint-width) (let ((total-gap (* (- (the number-of-mortar-joints) 1) (the mortar-joint-width)))) (div total-gap (the number-of-mortar-joints))))) ;; collating the output. We could do this analytically, but for this example we'll use the geometry (full-bricks (length (list-elements (the full-brick)))) (half-bricks (length (list-elements (the half-brick)))) (mortar-joint-volume (apply '+ (list-elements (the mortar-joint) (the-element volume)))) ) :functions ((first-full-brick-center! () (translate-along-vector (the first-full-brick-start-point) (the (face-normal-vector :rear)) (half (the brick-length)))) (other-full-brick-center! (index) ;; if its a full brick row, (full-brick 1) is positioned relative to (joint 0) ;; if its a half brick row, (full-brick 1) is positioned relative to (joint 1) (let ((ind (if (the full-brick-row?) (- index 1) index))) (translate-along-vector (the (mortar-joint ind) (face-center :rear)) (the (face-normal-vector :rear)) (half (the brick-length))))) (first-joint-center! () (translate-along-vector (the first-mortar-joint-start-point) (the (face-normal-vector :rear)) (half (the corrected-joint-width)))) (other-joint-center! (index) ;; if its a full brick row, (joint 1) is positioned relative to (full-brick 1) ;; if its a half brick row, (joint 1) is positioned relative to (full-brick 0) (let ((ind (if (the full-brick-row?) index (- index 1)))) (translate-along-vector (the (full-brick ind) (face-center :rear)) (the (face-normal-vector :rear)) (half (the corrected-joint-width))))) (first-half-brick-center! () (translate-along-vector (the (face-center :front)) (the (face-normal-vector :rear)) (half (half (the brick-length))))) (last-half-brick-center! () (translate-along-vector (theo (the mortar-joint last) (face-center :rear)) (the (face-normal-vector :rear)) (half (half (the brick-length)))))) :objects ((full-brick :type 'box :sequence (:size (the number-of-full-bricks)) :center (if (= (the-child index) 0) (the first-full-brick-center!) (the (other-full-brick-center! (the-child index)))) :length (the brick-length) :height (the brick-height) :width (the brick-width)) (half-brick :type 'box :sequence (:size (the number-of-half-bricks)) :center (cond ((and (= (the-child index) 0) (eq (the front-edge) :full)) (the first-half-brick-center!)) ((and (= (the-child index) 0) (eq (the front-edge) :keyed) (eq (the rear-edge) :full)) (the last-half-brick-center!)) ((eq (the rear-edge) :full) (the last-half-brick-center!))) :length (half (the brick-length)) :height (the brick-height) :width (the brick-width)) (mortar-joint :type 'box :sequence (:size (the number-of-mortar-joints)) :center (if (= (the-child index) 0) (the first-joint-center!) (the (other-joint-center! (the-child index)))) :height (the brick-height) :width (the brick-width) :length (the corrected-joint-width)))) (defun degrees-to-radians (degrees) (div (* degrees pi) 180)) (define-object truss (box) :input-slots ((truss-length 2000) (truss-height nil) (truss-angle 30) (beam-width 30) (beam-height 50) (wall-thickness 3) (material-density 7800) (tonne-rate 450)) :computed-slots ((length (the truss-length)) (height (cond ((the truss-height)(the truss-height)) ((the truss-angle) (+ (* (half (the truss-length)) (tan (degrees-to-radians (the truss-angle)))) (the beam-height))))) (width (the beam-width)) (truss-front-slope-vector (the (get-slope-vector! :front))) (truss-rear-slope-vector (the (get-slope-vector! :rear))) (front-slope-length (the (get-slope-length! :front))) (rear-slope-length (the (get-slope-length! :rear))) (front-slope-center (the (get-slope-center! :front))) (rear-slope-center (the (get-slope-center! :rear))) (beam-properties (mapsend (the children) :beam-properties)) (total-mass (round-to-nearest (apply '+ (mapcar #'(lambda(a) (getf a :mass-kg)) (the beam-properties))) 0.001)) (total-cost (round-to-nearest (apply '+ (mapcar #'(lambda(a) (getf a :cost-gbp)) (the beam-properties))) 0.01)) ;; messages to support roof cladding sizing and positioning (apex-point (inter-line-plane (the rear-slope-construction-line end) (the truss-rear-slope-vector) (the lower-beam center) (the (face-normal-vector :rear)))) (front-gutter-point (the front-slope-construction-line start)) (rear-gutter-point (the rear-slope-construction-line start)) (front-slope-normal (the front-slope-beam (face-normal-vector :top))) (rear-slope-normal (the rear-slope-beam (face-normal-vector :top))) ) :functions ((get-slope-vector! (beam-side) (let ((v-key (the (get-v-key! beam-side))) (l-key (the (get-l-key! beam-side)))) (subtract-vectors (the vertical-beam (edge-center :rear v-key)) (the lower-beam (edge-center l-key :top))))) (get-slope-length! (beam-side) (let ((v-key (the (get-v-key! beam-side))) (l-key (the (get-l-key! beam-side)))) (3d-distance (the vertical-beam (edge-center :rear v-key)) (the lower-beam (edge-center l-key :top))))) (get-slope-center! (beam-side) (let ((pt (case beam-side (:front (the front-slope-construction-line center)) (:rear (the rear-slope-construction-line center)))) (norm-vector (case beam-side (:front (the front-slope-beam (face-normal-vector :bottom))) (:rear (the rear-slope-beam (face-normal-vector :bottom)))))) (translate-along-vector pt norm-vector (half (the beam-height))))) (get-v-key! (beam-side) (case beam-side (:front :top) (:rear :bottom))) (get-l-key! (beam-side) (case beam-side (:front :front) (:rear :rear))) ) :objects ((lower-beam :type 'beam :pass-down (:beam-height :beam-width :wall-thickness :material-density :tonne-rate) :beam-length (the truss-length) :center (translate-along-vector (the (face-center :bottom)) (the (face-normal-vector :top)) (half (the beam-height)))) (vertical-beam :type 'beam :pass-down (:beam-height :beam-width :wall-thickness :material-density :tonne-rate) :beam-length (- (the height) (the beam-height)) :orientation (alignment :rear (the (face-normal-vector :top)) :right (the (face-normal-vector :right))) :center (translate-along-vector (the lower-beam (face-center :top)) (the lower-beam (face-normal-vector :top)) (half (the-child beam-length)))) (front-slope-beam :type 'beam :pass-down (:beam-height :beam-width :wall-thickness :material-density :tonne-rate) :beam-length (the front-slope-length) :center (the front-slope-center) :orientation (alignment :rear (the truss-front-slope-vector) :right (the (face-normal-vector :right)))) (rear-slope-beam :type 'beam :pass-down (:beam-height :beam-width :wall-thickness :material-density :tonne-rate) :beam-length (the rear-slope-length) :center (the rear-slope-center) :orientation (alignment :rear (the truss-rear-slope-vector) :left (the (face-normal-vector :right)))) ) :hidden-objects ((apex-pt :type 'sphere :radius 5 :display-controls (list :color :green) :center (the apex-point)) (front-slope-construction-line :type 'line :start (the lower-beam (edge-center :front :top)) :end (the vertical-beam (edge-center :rear :top))) (rear-slope-construction-line :type 'line :start (the lower-beam (edge-center :rear :top)) :end (the vertical-beam (edge-center :rear :bottom))) (front-mid-pt :type 'sphere :display-controls (list :color :blue) :radius 5 :center (the front-slope-construction-line center)) (rear-mid-pt :type 'sphere :display-controls (list :color :blue) :center (the rear-slope-construction-line center) :radius 5) (pt-1 :type 'sphere :radius 5 :display-controls (list :color :green) :center (the lower-beam (edge-center :rear :top))) (pt-2 :type 'sphere :radius 5 :display-controls (list :color :red) :center (the vertical-beam (edge-center :rear :bottom)) ) (vector-line :type 'vector-line :start-point (the rear-slope-construction-line center) :vector (the rear-slope-beam (face-normal-vector :bottom)) :length 150) )) (define-object vector-line (box) :input-slots ((start-point (make-point 0 0 0)) (vector (make-vector 1 0 1)) (length 50) (width 1)) :computed-slots ((height (div (the length) 5))) :objects ((v-line :type 'line :start (the start-point) :display-controls (list :color :red) :end (translate-along-vector (the start-point) (the vector) (the length))) (arrow :type 'cone :radius-1 0 :radius-2 (div (the length) 50) :length (div (the length) 5) :display-controls (list :color :red) :center (translate-along-vector (the v-line end) (the vector) (half (the-child length))) :orientation (alignment :front (the vector))))) (define-object beam (box) :input-slots ((beam-length 1000) (beam-width 40) (beam-height 50) (wall-thickness 2) (material-density 7800) (tonne-rate 500)) :computed-slots ((length (the beam-length)) (width (the beam-width)) (height (the beam-height)) (beam-volume (- (the outer volume) (the inner volume))) (beam-mass (* (div (the beam-volume) 1000000000) (the material-density))) (beam-cost (* (the tonne-rate) (div (the beam-mass) 1000))) (beam-properties (list :volume-mm3 (the beam-volume) :mass-kg (round-to-nearest (the beam-mass) 0.01) :cost-gbp (round-to-nearest (the beam-cost) 0.01) :length-mm (the beam-length) :width-mm (the beam-width) :height-mm (the beam-height) :thickness-mm (the wall-thickness)))) :objects ((outer :type 'box :length (the beam-length) :width (the beam-width) :height (the beam-height)) (inner :type 'box :length (the beam-length) :width (- (the beam-width) (twice (the wall-thickness))) :height (- (the beam-height) (twice (the wall-thickness))))) )