diff --git a/patches/1590/p003.lisp b/patches/1590/p003.lisp new file mode 100644 index 0000000000000000000000000000000000000000..59ad54dbe5e13be46d1d0274bc57531880caa304 --- /dev/null +++ b/patches/1590/p003.lisp @@ -0,0 +1,110 @@ +;; +;; Copyright 2016 Genworks International +;; +;; This source file is part of the General-purpose Declarative +;; Language project (GDL). +;; +;; 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 +;; . +;; + +(in-package :surf) + +(define-object normally-projected-curve (curve) + + :input-slots (from-surface + curve to-surface + (number-of-points 200)) + + + :computed-slots ((sample-points (the curve uv-curve (equi-spaced-points (the number-of-points)))) + + (normals (mapcar #'(lambda(point) (the from-surface (normal (get-u point) (get-v point)))) (the sample-points))) + + (projected-points (mapcar #'(lambda(point normal) + (the to-surface (projected-point (the from-surface (point (get-u point) (get-v point))) normal))) + (the sample-points) (the normals))) + + (projected-points-3d (mapcar #'get-3d-point-of (the projected-points))) + + + (projected-points-uv (mapcar #'get-uv-point-of (the projected-points))) + + (built-from (the fitted-3d))) + + + + :hidden-objects ((fitted :type 'fitted-curve + :points (the projected-points-3d)) + + (fitted-uv :type 'fitted-curve + :points (mapcar #'(lambda(point) (make-point (get-x point) (get-y point) 0)) (the projected-points-uv))) + + (approximated :type 'approximated-curve + :curve-in (the fitted-uv) + :tolerance 0.00001) + + (fitted-3d :type 'b-spline-curve + :knot-vector (the approximated knot-vector) + :degree (the approximated degree) + :weights (the approximated weights) + :control-points (mapcar #'(lambda(point) + (the to-surface (point (get-u point) (get-v point)))) + (the approximated control-points))))) + + +(define-object-amendment curve () + :computed-slots + ((%curves-to-draw% + (unless (or *curve-tessellation?* + (near-to? (the total-length) 0)) + (if (typep self 'arc-curve) + (call-next-method) + (if (or (the %decomposed?%) (= (the %decomposed% curves number-of-elements) 1)) + (unless (and (= (the degree) 1) (not (the rational?))) + (when (list-elements (the beziers)) + (let (result) + (dolist (bezier + (if t ;;*chain-beziers-for-display?* + (chain-nurbs-curves (list-elements (the beziers))) + (list-elements (the beziers))) + result) + (if (null result) + (setq result (the-object bezier %curves-to-draw%)) + (nconc result (the-object bezier %curves-to-draw%))))))) + (append-elements (the %decomposed% curves) + (the-element %curves-to-draw%)))))))) + +#+nil +(define-object normally-projected-curve-test (normally-projected-curve) + + :computed-slots ((from-surface (the test-fitted-surface)) + (curve (the projected)) + (to-surface (the offset-surface))) + + + :objects ((test-fitted-surface :type 'test-fitted-surface + :grid-height 1) + + (offset-surface :type 'rectangular-surface + :length 5 :width 5 :center (make-point 2 2 1.5)) + + (projected :type 'projected-curve + :curve-in (the segment) + :surface (the test-fitted-surface) + :projection-vector (the (face-normal-vector :bottom))) + + (segment :type 'linear-curve + :start (make-point 1 1 3) + :end (make-point 3 3 3))))