Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
5b06e69a
Commit
5b06e69a
authored
Feb 16, 2012
by
Dave Cooper
Browse files
added x3d support for spheres and partial spheres
parent
4fd5f47b
Changes
4
Hide whitespace changes
Inline
Side-by-side
demos/wire-world/source/assembly.lisp
View file @
5b06e69a
...
...
@@ -9,7 +9,16 @@
:right
(
half
(
the-child
width
))
:front
(
half
(
the-child
height
))))
(
mudball
:type
'sphere
:display-controls
(
list
:color
:brown
)
:radius
3
:inner-radius
2.5
:end-horizontal-arc
pi
:start-vertical-arc
0
:end-vertical-arc
(
/
pi
4
)
:center
(
translate
(
the
center
)
:left
10
:rear
10
:up
(
the-child
radius
)))
(
ground
:type
'ground
:height
0
:length
50
:width
(
*
+phi+
50
))
...
...
@@ -25,14 +34,14 @@
:orientation
(
alignment
:rear
(
the
(
face-normal-vector
:top
)))
:length
3
:arc
(
*
3/2
pi
)
:radius-1
2
:radius-2
0.5
)
:radius-1
2
:radius-2
0.5
:inner-radius-1
1.8
:inner-radius-2
0.3
)
(
traffic-cone
:type
'traffic-cone
:center
(
translate
(
the
center
)
:left
5
:up
(
half
(
the-child
length
)))
:orientation
(
alignment
:rear
(
the
(
face-normal-vector
:top
)))
:length
1
:radius
0.5
:radius-1
0.5
;;:arc pi
)
...
...
@@ -55,11 +64,13 @@
:objects
((
roof
:type
'sphere
:display-controls
(
list
:color
:
yellow
)
:display-controls
(
list
:color
:
orange
)
:center
(
translate
(
the
center
)
:rear
(
half
(
the
length
)))
:pass-down
(
radius
))
:pass-down
(
radius
)
)
(
tower
:type
'cylinder
:display-controls
(
append
(
the
display-controls
)
(
list
:transparency
0.9
))
:pass-down
(
radius
length
))))
...
...
gdl/geom-base/wire/source/cylinder.lisp
View file @
5b06e69a
...
...
@@ -181,20 +181,51 @@ Partial cylinders and hollow cylinders are supported."
(
center-line
(
list
(
the
(
:end-arcs
0
)
:center
)
(
the
(
:end-arcs
1
)
:center
)))
(
top-points
(
the
(
end-arcs
1
)
(
equi-spaced-points
(
the
number-of-sections
))))
(
bottom-points
(
the
(
end-arcs
0
)
(
equi-spaced-points
(
the
number-of-sections
))))
(
polygons-for-ifs
(
unless
(
the
simple?
)
;;
;; FLAG -- For cones at least: fill in with more intermediate arcs, to get better aspect triangles.
;;
(
let
((
top-points
(
the
(
end-arcs
1
)
(
equi-spaced-points
(
the
number-of-sections
))
))
(
bottom-points
(
the
(
end-arcs
0
)
(
equi-spaced-points
(
the
number-of-sections
))
)))
(
let
((
top-points
(
the
top-points
))
(
bottom-points
(
the
bottom-points
)))
(
append
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
top-points
bottom-points
(
rest
top-points
)
(
rest
bottom-points
))
(
when
(
the
top-cap?
)
(
list
top-points
))
(
when
(
the
bottom-cap?
)
(
list
bottom-points
))
(
when
(
the
closed?
)
(
list
(
list
(
first
top-points
)
(
first
bottom-points
)
(
lastcar
bottom-points
)
(
lastcar
top-points
))))))))
(
when
(
and
(
the
top-cap?
)
(
not
(
or
(
the
hollow?
)
(
the
inner?
))))
(
list
top-points
))
(
when
(
and
(
the
bottom-cap?
)
(
not
(
or
(
the
hollow?
)
(
the
inner?
))))
(
list
bottom-points
))
(
when
(
and
(
the
closed?
)
(
not
(
or
(
the
hollow?
)
(
the
inner?
))))
(
list
(
list
(
first
top-points
)
(
first
bottom-points
)
(
lastcar
bottom-points
)
(
lastcar
top-points
))))
(
when
(
and
(
the
hollow?
)
(
not
(
the
inner?
)))
(
mapcar
#'
list
top-points
(
rest
top-points
)
(
rest
(
the
inner-cylinder
top-points
))
(
the
inner-cylinder
top-points
)))
(
when
(
and
(
the
hollow?
)
(
not
(
the
inner?
)))
(
mapcar
#'
list
bottom-points
(
rest
bottom-points
)
(
rest
(
the
inner-cylinder
bottom-points
))
(
the
inner-cylinder
bottom-points
)))
(
when
(
and
(
the
hollow?
)
(
not
(
the
inner?
)))
(
list
(
list
(
first
top-points
)
(
first
(
the
inner-cylinder
top-points
))
(
first
(
the
inner-cylinder
bottom-points
))
(
first
bottom-points
))
(
list
(
lastcar
top-points
)
(
lastcar
(
the
inner-cylinder
top-points
))
(
lastcar
(
the
inner-cylinder
bottom-points
))
(
lastcar
bottom-points
))))
(
when
(
the
hollow?
)
(
the
inner-cylinder
polygons-for-ifs
))))))
(
simple?
(
and
(
not
(
the
inner-radius
))
(
near-to?
(
the
arc
)
2pi
)))
...
...
gdl/geom-base/wire/source/sphere.lisp
View file @
5b06e69a
...
...
@@ -21,7 +21,7 @@
(
in-package
:geom-base
)
(
define-object
sphere
(
arcoid-mixin
base-object
)
(
define-object
sphere
(
ifs-output-mixin
arcoid-mixin
base-object
)
:documentation
(
:description
"The set of points equidistant from a given center point."
:examples
"<pre>
...
...
@@ -54,15 +54,15 @@
(
"Angle in radians. Starting vertical angle for a partial sphere. Default is -pi/2."
start-vertical-arc
(
-
pi/2
)
:defaulting
)
(
"Angle in radians. Ending horizontal angle for a partial sphere. Default is twice pi."
end-horizontal-arc
(
twice
pi
)
:defaulting
)
end-horizontal-arc
2
pi
:defaulting
)
(
"Angle in radians. Ending vertical angle for a partial sphere. Default is pi/2."
end-vertical-arc
pi/2
:defaulting
)
(
"Number. Radius of inner hollow for a hollow sphere. Default is NIL, for a non-hollow sphere."
inner-radius
nil
:defaulting
)
(
"Number. How many lines of latitude to show on the sphere in some renderings. Default value is 4."
number-of-horizontal-sections
4
)
number-of-horizontal-sections
8
)
(
"Number. How many lines of longitude to show on the sphere in some renderings. Default value is 4."
number-of-vertical-sections
4
)
number-of-vertical-sections
8
)
(
inner?
nil
))
:computed-slots
...
...
@@ -73,7 +73,7 @@
(
%renderer-info%
(
list
:vrml?
t
:view-default
:trimetric
))
(
%curves-to-draw%
(
parallel-and-meridian-curves
(
let*
((
center
(
the
:center
))
(
radius
(
the
:radius
))
(
face-ht
(
the
:%face-ht%
))
...
...
@@ -129,44 +129,93 @@
(
let
((
new-curves
(
arc-curves
face-ht
radius
center
start-vertical-arc
end-vertical-arc
)))
(
if
result
(
nconc
result
new-curves
)
(
setq
result
new-curves
))))))))
(
append
(
when
(
the
:inner-radius
)
(
the
:inner-sphere
:%curves-to-draw%
))
meridian-curves
parallel-curves
)))
(
list
:parallels
parallel-curves
:meridian-curves
meridian-curves
)))
(
%curves-to-draw%
(
append
(
when
(
the
:inner-radius
)
(
the
:inner-sphere
:%curves-to-draw%
))
(
getf
(
the
parallel-and-meridian-curves
)
:meridian-curves
)
(
getf
(
the
parallel-and-meridian-curves
)
:parallels
)))
(
horizontal-start-to-end-angle
(
-
(
the
:end-horizontal-arc
)(
the
:start-horizontal-arc
)))
(
vertical-start-to-end-angle
(
-
(
the
:end-vertical-arc
)
(
the
:start-vertical-arc
)))
(
parallel-angle
(
/
(
the
:vertical-start-to-end-angle
)
(
the
:number-of-vertical-sections
)))
(
radials-parallels-start
(
let
(
result
)
(
dolist
(
count
(
the
:parallels
:number-of-elements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:inner-radius
)
(
the
:inner-sphere
(
:parallels
count
)
:start
)
(
the
:center
))
(
the
(
:parallels
count
)
:start
))
result
))))
(
radials-parallels-end
(
let
(
result
)
(
dolist
(
count
(
the
:parallels
:number-of-elements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:inner-radius
)
(
the
:inner-sphere
(
:parallels
count
)
:end
)
(
the
:center
))
(
the
(
:parallels
count
)
:end
))
result
))))
(
radials-meridians-start
(
let
(
result
)
(
dolist
(
count
(
the
:meridians
:number-of-elements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:inner-radius
)
(
the
:inner-sphere
(
:meridians
count
)
:start
)
(
the
:center
))
(
the
(
:meridians
count
)
:start
))
result
))))
(
radials-meridians-end
(
let
(
result
)
(
dolist
(
count
(
the
:meridians
:number-of-elements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:inner-radius
)
(
the
:inner-sphere
(
:meridians
count
)
:end
)
(
the
:center
))
(
the
(
:meridians
count
)
:end
))
result
)))))
(
parallel-angle
(
/
(
the
vertical-start-to-end-angle
)
(
the
number-of-vertical-sections
)))
(
horizontal-increment-angle
(
/
(
the
horizontal-start-to-end-angle
)
(
the
number-of-horizontal-sections
)))
(
simple?
(
and
(
not
(
the
inner-radius
))
(
near-to?
(
the
start-horizontal-arc
)
0
)
(
near-to?
(
the
end-horizontal-arc
)
2pi
)
(
near-to?
(
the
start-vertical-arc
)
(
-
pi/2
))
(
near-to?
(
the
end-vertical-arc
)
pi/2
)))
(
polygon-points
(
let
((
right-vector
(
the
(
face-normal-vector
:right
)))
result
)
(
dotimes
(
m
(
1+
(
the
number-of-horizontal-sections
))
result
)
(
let*
((
tangent-vector
(
rotate-vector
right-vector
(
+
(
the
start-horizontal-arc
)
(
*
m
(
the
horizontal-increment-angle
)))
(
the
(
face-normal-vector
:top
))))
(
normal-vector
(
cross-vectors
tangent-vector
(
the
(
face-normal-vector
:top
))))
inner-result
)
(
dotimes
(
n
(
1+
(
the
number-of-vertical-sections
)))
(
let
((
ray
(
rotate-vector
tangent-vector
(
+
(
the
start-vertical-arc
)
(
*
n
(
the
parallel-angle
)))
normal-vector
)))
(
push
(
inter-line-sphere
(
the
center
)
ray
(
the
center
)
(
the
radius
)
ray
)
inner-result
)))
(
push
inner-result
result
)))))
(
polygons-for-ifs
(
unless
(
the
simple?
)
(
append
(
apply
#'
append
(
mapcar
#'
(
lambda
(
list1
list2
)
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
list1
(
rest
list1
)
list2
(
rest
list2
)))
(
the
polygon-points
)
(
rest
(
the
polygon-points
))))
(
when
(
and
(
the
inner-radius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
first
(
the
polygon-points
))
(
first
(
the
inner-sphere
polygon-points
))
(
rest
(
first
(
the
polygon-points
)))
(
rest
(
first
(
the
inner-sphere
polygon-points
)))))
(
when
(
and
(
the
inner-radius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
lastcar
(
the
polygon-points
))
(
lastcar
(
the
inner-sphere
polygon-points
))
(
rest
(
lastcar
(
the
polygon-points
)))
(
rest
(
lastcar
(
the
inner-sphere
polygon-points
)))))
(
when
(
and
(
the
inner-radius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
mapcar
#'
first
(
the
polygon-points
))
(
mapcar
#'
first
(
the
inner-sphere
polygon-points
))
(
rest
(
mapcar
#'
first
(
the
polygon-points
)))
(
rest
(
mapcar
#'
first
(
the
inner-sphere
polygon-points
)))))
(
when
(
and
(
the
inner-radius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
mapcar
#'
lastcar
(
the
polygon-points
))
(
mapcar
#'
lastcar
(
the
inner-sphere
polygon-points
))
(
rest
(
mapcar
#'
lastcar
(
the
polygon-points
)))
(
rest
(
mapcar
#'
lastcar
(
the
inner-sphere
polygon-points
)))))
(
when
(
the
inner-radius
)
(
the
inner-sphere
polygons-for-ifs
))))))
:hidden-objects
...
...
surf/lenses/source/x3d.lisp
View file @
5b06e69a
...
...
@@ -384,14 +384,16 @@
(
(
shape
()
(
cl-who:with-html-output
(
*stream*
nil
:indent
nil
)
(
:Shape
(
:Appearance
(
if
(
getf
(
the
display-controls
)
:pixel-texture
)
(
write-the
pixel-texture
)
(
write-the
material-properties
)))
(
:Sphere
:radius
(
the
radius
)))))
)
)
(
if
(
the
simple?
)
(
cl-who:with-html-output
(
*stream*
nil
:indent
nil
)
(
:Shape
(
:Appearance
(
if
(
getf
(
the
display-controls
)
:pixel-texture
)
(
write-the
pixel-texture
)
(
write-the
material-properties
)))
(
:Sphere
:radius
(
the
radius
))))
(
call-next-method
)))))
(
define-lens
(
x3d
cylinder
)()
:output-functions
...
...
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