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
Sidebyside
demos/wireworld/source/assembly.lisp
View file @
5b06e69a
...
...
@@ 9,7 +9,16 @@
:right
(
half
(
thechild
width
))
:front
(
half
(
thechild
height
))))
(
mudball
:type
'sphere
:displaycontrols
(
list
:color
:brown
)
:radius
3
:innerradius
2.5
:endhorizontalarc
pi
:startverticalarc
0
:endverticalarc
(
/
pi
4
)
:center
(
translate
(
the
center
)
:left
10
:rear
10
:up
(
thechild
radius
)))
(
ground
:type
'ground
:height
0
:length
50
:width
(
*
+phi+
50
))
...
...
@@ 25,14 +34,14 @@
:orientation
(
alignment
:rear
(
the
(
facenormalvector
:top
)))
:length
3
:arc
(
*
3/2
pi
)
:radius1
2
:radius2
0.5
)
:radius1
2
:radius2
0.5
:innerradius1
1.8
:innerradius2
0.3
)
(
trafficcone
:type
'trafficcone
:center
(
translate
(
the
center
)
:left
5
:up
(
half
(
thechild
length
)))
:orientation
(
alignment
:rear
(
the
(
facenormalvector
:top
)))
:length
1
:radius
0.5
:radius1
0.5
;;:arc pi
)
...
...
@@ 55,11 +64,13 @@
:objects
((
roof
:type
'sphere
:displaycontrols
(
list
:color
:
yellow
)
:displaycontrols
(
list
:color
:
orange
)
:center
(
translate
(
the
center
)
:rear
(
half
(
the
length
)))
:passdown
(
radius
))
:passdown
(
radius
)
)
(
tower
:type
'cylinder
:displaycontrols
(
append
(
the
displaycontrols
)
(
list
:transparency
0.9
))
:passdown
(
radius
length
))))
...
...
gdl/geombase/wire/source/cylinder.lisp
View file @
5b06e69a
...
...
@@ 181,20 +181,51 @@ Partial cylinders and hollow cylinders are supported."
(
centerline
(
list
(
the
(
:endarcs
0
)
:center
)
(
the
(
:endarcs
1
)
:center
)))
(
toppoints
(
the
(
endarcs
1
)
(
equispacedpoints
(
the
numberofsections
))))
(
bottompoints
(
the
(
endarcs
0
)
(
equispacedpoints
(
the
numberofsections
))))
(
polygonsforifs
(
unless
(
the
simple?
)
;;
;; FLAG  For cones at least: fill in with more intermediate arcs, to get better aspect triangles.
;;
(
let
((
toppoints
(
the
(
endarcs
1
)
(
equispacedpoints
(
the
numberofsections
))
))
(
bottompoints
(
the
(
endarcs
0
)
(
equispacedpoints
(
the
numberofsections
))
)))
(
let
((
toppoints
(
the
toppoints
))
(
bottompoints
(
the
bottompoints
)))
(
append
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
toppoints
bottompoints
(
rest
toppoints
)
(
rest
bottompoints
))
(
when
(
the
topcap?
)
(
list
toppoints
))
(
when
(
the
bottomcap?
)
(
list
bottompoints
))
(
when
(
the
closed?
)
(
list
(
list
(
first
toppoints
)
(
first
bottompoints
)
(
lastcar
bottompoints
)
(
lastcar
toppoints
))))))))
(
when
(
and
(
the
topcap?
)
(
not
(
or
(
the
hollow?
)
(
the
inner?
))))
(
list
toppoints
))
(
when
(
and
(
the
bottomcap?
)
(
not
(
or
(
the
hollow?
)
(
the
inner?
))))
(
list
bottompoints
))
(
when
(
and
(
the
closed?
)
(
not
(
or
(
the
hollow?
)
(
the
inner?
))))
(
list
(
list
(
first
toppoints
)
(
first
bottompoints
)
(
lastcar
bottompoints
)
(
lastcar
toppoints
))))
(
when
(
and
(
the
hollow?
)
(
not
(
the
inner?
)))
(
mapcar
#'
list
toppoints
(
rest
toppoints
)
(
rest
(
the
innercylinder
toppoints
))
(
the
innercylinder
toppoints
)))
(
when
(
and
(
the
hollow?
)
(
not
(
the
inner?
)))
(
mapcar
#'
list
bottompoints
(
rest
bottompoints
)
(
rest
(
the
innercylinder
bottompoints
))
(
the
innercylinder
bottompoints
)))
(
when
(
and
(
the
hollow?
)
(
not
(
the
inner?
)))
(
list
(
list
(
first
toppoints
)
(
first
(
the
innercylinder
toppoints
))
(
first
(
the
innercylinder
bottompoints
))
(
first
bottompoints
))
(
list
(
lastcar
toppoints
)
(
lastcar
(
the
innercylinder
toppoints
))
(
lastcar
(
the
innercylinder
bottompoints
))
(
lastcar
bottompoints
))))
(
when
(
the
hollow?
)
(
the
innercylinder
polygonsforifs
))))))
(
simple?
(
and
(
not
(
the
innerradius
))
(
nearto?
(
the
arc
)
2pi
)))
...
...
gdl/geombase/wire/source/sphere.lisp
View file @
5b06e69a
...
...
@@ 21,7 +21,7 @@
(
inpackage
:geombase
)
(
defineobject
sphere
(
arcoidmixin
baseobject
)
(
defineobject
sphere
(
ifsoutputmixin
arcoidmixin
baseobject
)
: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."
startverticalarc
(

pi/2
)
:defaulting
)
(
"Angle in radians. Ending horizontal angle for a partial sphere. Default is twice pi."
endhorizontalarc
(
twice
pi
)
:defaulting
)
endhorizontalarc
2
pi
:defaulting
)
(
"Angle in radians. Ending vertical angle for a partial sphere. Default is pi/2."
endverticalarc
pi/2
:defaulting
)
(
"Number. Radius of inner hollow for a hollow sphere. Default is NIL, for a nonhollow sphere."
innerradius
nil
:defaulting
)
(
"Number. How many lines of latitude to show on the sphere in some renderings. Default value is 4."
numberofhorizontalsections
4
)
numberofhorizontalsections
8
)
(
"Number. How many lines of longitude to show on the sphere in some renderings. Default value is 4."
numberofverticalsections
4
)
numberofverticalsections
8
)
(
inner?
nil
))
:computedslots
...
...
@@ 73,7 +73,7 @@
(
%rendererinfo%
(
list
:vrml?
t
:viewdefault
:trimetric
))
(
%curvestodraw%
(
parallelandmeridiancurves
(
let*
((
center
(
the
:center
))
(
radius
(
the
:radius
))
(
faceht
(
the
:%faceht%
))
...
...
@@ 129,44 +129,93 @@
(
let
((
newcurves
(
arccurves
faceht
radius
center
startverticalarc
endverticalarc
)))
(
if
result
(
nconc
result
newcurves
)
(
setq
result
newcurves
))))))))
(
append
(
when
(
the
:innerradius
)
(
the
:innersphere
:%curvestodraw%
))
meridiancurves
parallelcurves
)))
(
list
:parallels
parallelcurves
:meridiancurves
meridiancurves
)))
(
%curvestodraw%
(
append
(
when
(
the
:innerradius
)
(
the
:innersphere
:%curvestodraw%
))
(
getf
(
the
parallelandmeridiancurves
)
:meridiancurves
)
(
getf
(
the
parallelandmeridiancurves
)
:parallels
)))
(
horizontalstarttoendangle
(

(
the
:endhorizontalarc
)(
the
:starthorizontalarc
)))
(
verticalstarttoendangle
(

(
the
:endverticalarc
)
(
the
:startverticalarc
)))
(
parallelangle
(
/
(
the
:verticalstarttoendangle
)
(
the
:numberofverticalsections
)))
(
radialsparallelsstart
(
let
(
result
)
(
dolist
(
count
(
the
:parallels
:numberofelements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:innerradius
)
(
the
:innersphere
(
:parallels
count
)
:start
)
(
the
:center
))
(
the
(
:parallels
count
)
:start
))
result
))))
(
radialsparallelsend
(
let
(
result
)
(
dolist
(
count
(
the
:parallels
:numberofelements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:innerradius
)
(
the
:innersphere
(
:parallels
count
)
:end
)
(
the
:center
))
(
the
(
:parallels
count
)
:end
))
result
))))
(
radialsmeridiansstart
(
let
(
result
)
(
dolist
(
count
(
the
:meridians
:numberofelements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:innerradius
)
(
the
:innersphere
(
:meridians
count
)
:start
)
(
the
:center
))
(
the
(
:meridians
count
)
:start
))
result
))))
(
radialsmeridiansend
(
let
(
result
)
(
dolist
(
count
(
the
:meridians
:numberofelements
)
(
nreverse
result
))
(
push
(
list
(
if
(
the
:innerradius
)
(
the
:innersphere
(
:meridians
count
)
:end
)
(
the
:center
))
(
the
(
:meridians
count
)
:end
))
result
)))))
(
parallelangle
(
/
(
the
verticalstarttoendangle
)
(
the
numberofverticalsections
)))
(
horizontalincrementangle
(
/
(
the
horizontalstarttoendangle
)
(
the
numberofhorizontalsections
)))
(
simple?
(
and
(
not
(
the
innerradius
))
(
nearto?
(
the
starthorizontalarc
)
0
)
(
nearto?
(
the
endhorizontalarc
)
2pi
)
(
nearto?
(
the
startverticalarc
)
(

pi/2
))
(
nearto?
(
the
endverticalarc
)
pi/2
)))
(
polygonpoints
(
let
((
rightvector
(
the
(
facenormalvector
:right
)))
result
)
(
dotimes
(
m
(
1+
(
the
numberofhorizontalsections
))
result
)
(
let*
((
tangentvector
(
rotatevector
rightvector
(
+
(
the
starthorizontalarc
)
(
*
m
(
the
horizontalincrementangle
)))
(
the
(
facenormalvector
:top
))))
(
normalvector
(
crossvectors
tangentvector
(
the
(
facenormalvector
:top
))))
innerresult
)
(
dotimes
(
n
(
1+
(
the
numberofverticalsections
)))
(
let
((
ray
(
rotatevector
tangentvector
(
+
(
the
startverticalarc
)
(
*
n
(
the
parallelangle
)))
normalvector
)))
(
push
(
interlinesphere
(
the
center
)
ray
(
the
center
)
(
the
radius
)
ray
)
innerresult
)))
(
push
innerresult
result
)))))
(
polygonsforifs
(
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
polygonpoints
)
(
rest
(
the
polygonpoints
))))
(
when
(
and
(
the
innerradius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
first
(
the
polygonpoints
))
(
first
(
the
innersphere
polygonpoints
))
(
rest
(
first
(
the
polygonpoints
)))
(
rest
(
first
(
the
innersphere
polygonpoints
)))))
(
when
(
and
(
the
innerradius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
lastcar
(
the
polygonpoints
))
(
lastcar
(
the
innersphere
polygonpoints
))
(
rest
(
lastcar
(
the
polygonpoints
)))
(
rest
(
lastcar
(
the
innersphere
polygonpoints
)))))
(
when
(
and
(
the
innerradius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
mapcar
#'
first
(
the
polygonpoints
))
(
mapcar
#'
first
(
the
innersphere
polygonpoints
))
(
rest
(
mapcar
#'
first
(
the
polygonpoints
)))
(
rest
(
mapcar
#'
first
(
the
innersphere
polygonpoints
)))))
(
when
(
and
(
the
innerradius
)
(
not
(
the
inner?
)))
(
mapcar
#'
(
lambda
(
p1
p2
p3
p4
)
(
list
p1
p2
p4
p3
))
(
mapcar
#'
lastcar
(
the
polygonpoints
))
(
mapcar
#'
lastcar
(
the
innersphere
polygonpoints
))
(
rest
(
mapcar
#'
lastcar
(
the
polygonpoints
)))
(
rest
(
mapcar
#'
lastcar
(
the
innersphere
polygonpoints
)))))
(
when
(
the
innerradius
)
(
the
innersphere
polygonsforifs
))))))
:hiddenobjects
...
...
surf/lenses/source/x3d.lisp
View file @
5b06e69a
...
...
@@ 384,14 +384,16 @@
(
(
shape
()
(
clwho:withhtmloutput
(
*stream*
nil
:indent
nil
)
(
:Shape
(
:Appearance
(
if
(
getf
(
the
displaycontrols
)
:pixeltexture
)
(
writethe
pixeltexture
)
(
writethe
materialproperties
)))
(
:Sphere
:radius
(
the
radius
)))))
)
)
(
if
(
the
simple?
)
(
clwho:withhtmloutput
(
*stream*
nil
:indent
nil
)
(
:Shape
(
:Appearance
(
if
(
getf
(
the
displaycontrols
)
:pixeltexture
)
(
writethe
pixeltexture
)
(
writethe
materialproperties
)))
(
:Sphere
:radius
(
the
radius
))))
(
callnextmethod
)))))
(
definelens
(
x3d
cylinder
)()
:outputfunctions
...
...
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