Commit 53225681 authored by Dave Cooper's avatar Dave Cooper
Browse files

Moved some demos and prerelease code into there.

parent 5fa0ca1d
# tutorials
Code for the upcoming Gendl tutorial videos.
\ No newline at end of file
Code for the upcoming Gendl tutorial videos.
Also contains pre-release of geysr development browser IDE.
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(asdf:defsystem #:bench :description
"The Gendl® bench Subsystem" :author "Genworks International"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20190920" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode ()
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:gdl "source/lumber") (:gdl "source/package")
(:gdl "source/patches") (:gdl "source/product")
(:gdl "source/planked-back") (:gdl "source/planked-base")
(:gdl "source/planking") (:gdl "source/back-frame")
(:gdl "source/base-frame") (:gdl "source/leg-assy")
(:gdl "source/node") (:gdl "source/process")
(:gdl "source/processes")))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :bench)
(define-object back-frame (base-object)
:input-slots
(width length height display-controls crossmember-spread recline-angle-degrees)
:objects
(
(ends :type 'angle-cut-2x4 ;;flag replace with polygon-projections for cut
:front-angle-degrees (the recline-angle-degrees)
:rear-angle-degrees 0
:sequence (:size 2)
:side (ecase (the-child index) (0 :left) (1 :right))
:pseudo-inputs (side)
:center (ecase (the-child side)
(:left (translate (the (face-center :left))
:right (half (the-child height))))
(:right (translate (the (face-center :right))
:left (half (the-child height)))))
:orientation (alignment :top (the (face-normal-vector :left))
:rear (the (face-normal-vector :rear))))
(crossmembers :type 'angle-cut-2x4
:sequence (:size 3)
:side (ecase (the-child index) (0 :datum) (1 :left) (2 :right))
:hidden? (case (the-child side) ((:left :right) nil) (:datum t))
:datum (the (crossmembers 0))
:pseudo-inputs (datum side)
:length (3d-distance (the (rails 3) (edge-center :left :top))
(the (rails 4) (edge-center :left :bottom)))
:pseudo-inputs (side)
:front-angle-degrees (the recline-angle-degrees)
:rear-angle-degrees 0
:sequence (:size 2)
:orientation (the (ends 0) orientation)
:center (ecase (the-child side)
(:datum (the center))
((:left :right)
(translate (the center)
(the-child side)
(half (the crossmember-spread))
:rear
(distance-to-plane (the-child datum (face-center :rear))
(the (rails 4) (face-center :bottom))
(the (rails 4) (face-normal-vector :bottom)))))))
(rails :type '2x4
:sequence (:size 5)
:side (ecase (the-child index) (0 :datum) (1 :datum*) (2 :datum**) (3 :front) (4 :rear))
:datum (the (rails 0))
:datum* (the (rails 1))
:datum** (the (rails 2))
:front (the (rails 3))
:pseudo-inputs (side datum datum* datum** front)
:hidden? (case (the-child side)
((:front :rear) nil)
(otherwise t))
:center (ecase (the-child side)
(:rear (translate (the (face-center :rear))
:front (half (the-child height))))
(:datum (translate (the (face-center :front))
:rear (half (the-child height))))
(:datum* (flush-center (the-child datum center)
(least #'get-y (the-child datum bounding-box))
(the (face-center :front))
(the (face-normal-vector :rear))))
(:datum** (flush-center (the-child datum* center)
(the-child datum* (closest-vertex (the (:vertex :top :left :front))))
(the (face-center :top))(the (face-normal-vector :top))))
(:front (flush-center (the-child datum** center)
(the-child datum** (edge-center :left :top))
(the (face-center :top))
(the (face-normal-vector :top))
(the-child datum** (face-normal-vector :right)))))
:length (- (the width) (the (ends 0) height) (the (ends 1) height))
:orientation (alignment :top (rotate-vector-d (the (face-normal-vector :rear))
(ecase (the-child side)
(:datum (the recline-angle-degrees))
(:datum* (the recline-angle-degrees))
(:datum** (the recline-angle-degrees))
(:front (the recline-angle-degrees))
(:rear 0))
(the (face-normal-vector :right)))
:rear (the (face-normal-vector :left))))))
(define-object test-back-frame (back-frame)
:computed-slots
((width (+ 3 56))
(length 19)
(height (+ 1/2 3))
(display-controls (list :color :orange))
(crossmember-spread 15)
(recline-angle-degrees 15)))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :bench)
(define-object base-frame (base-object)
:input-slots
(armrest-overhang)
:computed-slots (;;(display-controls (list :color :brown))
(legs-width (sum-elements (the leg-assys) (the-element length)))
(front-rail-datum (the (rails 0) (face-center :bottom))))
:objects
((rails :type '2x4
:sequence (:size 2)
:side (ecase (the-child index) (0 :front) (1 :rear))
:pseudo-inputs (side)
:length (- (the width)
(sum-elements (the leg-assys) (the-element length)))
:orientation (alignment :rear (the (face-normal-vector :right))
:right (the (face-normal-vector :top)))
:center (translate (the (edge-center :front :bottom))
:up (+ 1/2 13 (half (the-child width)))
:rear (ecase (the-child side)
(:front (+ (the armrest-overhang)
(half (the-child height))))
(:rear (- (the length)
(half (the-child height)))))))
(crossmembers :type '2x4
:sequence (:size 3)
:length (- (3d-distance (the (rails 0) center)
(the (rails 1) center))
(half (+ (the (rails 0) height)
(the (rails 1) height))))
:orientation (alignment :top (the (face-normal-vector :right))
:right (the (face-normal-vector :top)))
:center (translate (midpoint (the (rails 0) center) (the (rails 1) center))
:left
(ecase (the-child index)
(0 (- (/ (the width) 4)))
(1 0)
(2 (/ (the width) 4)))))
(leg-assys :type 'leg-assy
:sequence (:size 2)
:side (ecase (the-child index) (0 :left) (1 :right))
:pseudo-inputs (side)
:orientation (alignment :top (the (face-normal-vector :top))
:rear (the (face-normal-vector (the-child side)))
:left (the (face-normal-vector :front)))
:center
(let ((start-center (the (face-center (the-child side)))))
(translate-along-vector start-center
(subtract-vectors (the center) start-center)
(half (the-child length))))
:pass-down (armrest-overhang)
:width (the length)
:length (+ 1/2 3)
:height (the height))))
(define-object test-base-frame (base-frame)
:computed-slots
((width (+ 59 7)) (length (+ 27 1/2)) (height 25)
(armrest-overhang 3/2)))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
("lumber" "package" "patches" "product" "planked-back" "planked-base" "planking")
\ No newline at end of file
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :bench)
(define-object leg-assy (box)
:input-slots
((length (+ 1/2 3))
(width (+ 27 1/2))
(height 25)
(armrest-overhang 3/2)
(display-controls (list :color :tan) :defaulting)
)
:objects
(;;(bbox :type 'box)
(armrest :type '2x4
:length (the width)
:orientation (alignment :top (the (face-normal-vector :top))
:right (the (face-normal-vector :rear)))
:center (translate (the (face-center :top))
:down (half (the-child height))))
(cross-member :type '2x4
:length (3d-distance (the (legs 0) (face-center :right))
(the (legs 1) (face-center :left)))
:center (translate (the (edge-center :bottom :rear))
:up (+ 1/2 13 (half (the-child width)))
:front (half (the-child height))
:right (half (the armrest-overhang)))
:orientation (alignment :top (the (face-normal-vector :rear))
:rear (the (face-normal-vector :left))))
(legs :type '4x4
:sequence (:size 2)
:side (ecase (the-child index) (0 :left) (1 :right))
:pseudo-inputs (side)
:length (- (the height) (the armrest height))
:orientation (alignment :rear (the (face-normal-vector :top))
:right (the (face-normal-vector :right)))
:center
(let ((start-center (the (face-center (the-child side)))))
(translate start-center
:down (half (- (the height) (the-child length)))
(ecase (the-child side)
(:left :right) (:right :left))
(ecase (the-child side)
(:right (half (the-child height)))
(:left (+ (the armrest-overhang)
(half (the-child height))))))))))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(gwl:define-package :lumber (:export #:angle-cut-2x4 #:1x4 #:2x4 #:4x4
#:2x4-8ft))
(in-package :lumber)
(define-object 4x4 (box)
:computed-slots
((width (+ 1/2 3))
(height (+ 1/2 3))))
(define-object 2x4 (box)
:computed-slots
((cut? t)
(width (+ 1/2 3))
(height (+ 1/2 1))))
(define-object 2x4-8ft (2x4)
:computed-slots ((cut? nil)
(length (* 8 12))))
(define-object 1x4 (box)
:computed-slots
((width (+ 1/2 3))
(height 1/2)))
;;
;; FLAG move to tests area.
;;
(define-object test-angle-cut-2x4 (angle-cut-2x4)
:computed-slots
((display-controls (list :color :green))
(offset :down)
(length 19)
(front-angle-degrees 15)))
(define-object angle-cut-2x4 (global-polygon-projection 2x4)
:objects ((original :type 'box :hidden? t))
:input-slots ((front-angle-degrees 0) (rear-angle-degrees 0))
:computed-slots
((offset :down)
(projection-depth (the height))
(vertex-list (list (the (vertex :bottom :front :right))
(let ((p-line (the (vertex :bottom :front :right)))
(u-line (rotate-vector-d (the (face-normal-vector :left))
(the front-angle-degrees)
(the (face-normal-vector :bottom))))
(p-plane (the (vertex :bottom :front :left)))
(u-plane (the (face-normal-vector :left))))
(let ((intersect (inter-line-plane p-line u-line p-plane u-plane)))
(translate-along-vector p-line (subtract-vectors intersect p-line)
(3d-distance intersect p-line))))
(the (vertex :bottom :rear :left)) (the (vertex :bottom :rear :right))))))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :bench)
(define-object node (base-object)
:input-slots ((model-parameters *model-A*) (painted? t :defaulting))
:trickle-down-slots (painted?)
:objects
((product :type 'product
:parameters (the model-parameters))
(process :type 'process-object
:after (the product))
))
(defparameter *model-A*
(list :width 66 :length (+ 27 1/2) :height 25 :armrest-overhang 3/2
:back-height 19 :back-crossmember-spread 15
:recline-angle-degrees 15 :base-plank-type '2x4 :back-plank-type '2x4 :back-offset 0))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(gwl:define-package :bench (:export #:assembly #:node) (:use :lumber))
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
;;
;; Below can be cleared with 1596
;;
(#+allegro
excl:without-package-locks
#-allegro progn
(in-package :geom-base)
(defun flush-center (ref-center datum p-plane u-plane &optional (u-datum u-plane))
(translate-along-vector ref-center u-datum
(distance-to-plane datum p-plane u-plane u-datum)))
(defun distance-to-plane (datum p-plane u-plane &optional (u-datum u-plane))
(3d-distance datum (inter-line-plane datum u-datum p-plane u-plane)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(flush-center distance-to-plane) :geom-base)))
;;
;; All below can be cleared as of 1596
;;
(#+allegro
excl:without-package-locks
#-allegro progn
(in-package :gdl)
(defun %unbind-dependent-slots% (object slot &key updating?)
(let ((current (gethash (list object slot) *unbound-slots*)))
(unless current
(setf (gethash (list object slot) *unbound-slots*) t)
(if (slot-exists-p object slot)
(let ((slot-value (slot-value object slot)))
(when (not (eq (first (ensure-list slot-value)) 'gdl-rule:%unbound%))
(when (and *eager-setting-enabled?* (null (second slot-value)))
(push (list object slot) *leaf-resets*))
(let ((list-or-hash (second slot-value)))
(if (listp list-or-hash)
(mapc #'(lambda(notify-cons)
(destructuring-bind (node . messages) notify-cons
(mapc #'(lambda(message)
(%unbind-dependent-slots% node message
:updating? updating?))
messages))) list-or-hash)
(maphash #'(lambda(node messages)
(mapc #'(lambda(message)
(%unbind-dependent-slots% node message
:updating? updating?))
messages)) list-or-hash)))
(if (third slot-value)
(setf (second (slot-value object slot)) nil)
(setf (slot-value object slot)
(if (or updating? (not (the-object object remember-children?))
(not *remember-previous-slot-values?*))
'gdl-rule::%unbound%
(list 'gdl-rule::%unbound% nil nil (first (slot-value object slot))))))))
(when (and (find-class 'gdl-remote nil) (typep object 'gdl-remote))
(the-object object (unbind-remote-slot slot))))))))
(#+allegro
excl:without-package-locks
#-allegro progn
(in-package :gwl)
(define-object-amendment base-ajax-graphics-sheet ()
:input-slots
((viewport-js-text ""))))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; This source file contains 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.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;