Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
gendl
gendl
Commits
90f0231e
Commit
90f0231e
authored
Jun 02, 2016
by
Dave Cooper
Browse files
added p003
parent
3d19b326
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
110 additions
and
0 deletions
+110
-0
patches/1590/p003.lisp
patches/1590/p003.lisp
+110
-0
No files found.
patches/1590/p003.lisp
0 → 100644
View file @
90f0231e
;;
;; 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
;; <http://www.gnu.org/licenses/>.
;;
(
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
))))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment