### Posted to tcl by kbk at Thu Dec 16 02:26:28 GMT 2010view raw

1. package require Tcl 8.5
2.
3. # Use math functions and operators as commands (Lisp-like).
4. namespace path {tcl::mathfunc tcl::mathop}
5.
7. proc add3 {A B C} {
8. lassign \$A Ax Ay Az
9. lassign \$B Bx By Bz
10. lassign \$C Cx Cy Cz
11. list [+ \$Ax \$Bx \$Cx] [+ \$Ay \$By \$Cy] [+ \$Az \$Bz \$Cz]
12. }
13.
14. # Multiply a point by a constant.
15. proc mulC {m A} {
16. lassign \$A x y z
17. list [* \$m \$x] [* \$m \$y] [* \$m \$z]
18. }
19.
20. # Take the centroid of a set of points.
21. # Note that each of the arguments is a *list* of coordinate triples
22. # This makes things easier later.
23. proc centroid args {
24. set x [set y [set z 0.0]]
25. foreach plist \$args {
26. incr n [llength \$plist]
27. foreach p \$plist {
28. lassign \$p px py pz
29. set x [+ \$x \$px]
30. set y [+ \$y \$py]
31. set z [+ \$z \$pz]
32. }
33. }
34. set n [double \$n]
35. list [/ \$x \$n] [/ \$y \$n] [/ \$z \$n]
36. }
37.
38. # Select from the list the value from each of the indices in the *lists*
39. # in the trailing arguments.
40. proc selectFrom {list args} {
41. foreach is \$args {foreach i \$is {lappend r [lindex \$list \$i]}}
42. return \$r
43. }
44.
45. # Rotate a list.
46. proc lrot {list {n 1}} {
47. set n [% \$n [llength \$list]]
48. list {*}[lrange \$list \$n end] {*}[lrange \$list 0 [incr n -1]]
49. }
50.
51. # Generate an edge by putting the smaller coordinate index first.
52. proc edge {a b} {
53. list [min \$a \$b] [max \$a \$b]
54. }
55.
56. # Perform one step of Catmull-Clark subdivision of a surface.
57. proc CatmullClark {points faces} {
58. # Generate the new face-points and list of edges, plus some lookup tables.
59. set edges {}
60. foreach f \$faces {
61. set ps [selectFrom \$points \$f]
62. set fp [centroid \$ps]
63. lappend facepoints \$fp
64. foreach p \$ps {
65. lappend fp4p(\$p) \$fp
66. }
67. foreach p1 \$f p2 [lrot \$f] {
68. set e [edge \$p1 \$p2]
69. if {\$e ni \$edges} {
70. lappend edges \$e
71. }
72. lappend fp4e(\$e) \$fp
73. }
74. }
75.
76. # Generate the new edge-points and mid-points of edges, and a few more
77. # lookup tables.
78. set i [+ [llength \$points] [llength \$faces]]
79. foreach e \$edges {
80. set ep [selectFrom \$points \$e]
81. set mid [centroid \$ep]
82. if {[llength \$fp4e(\$e)] > 1} {
83. lappend edgepoints [centroid \$ep \$fp4e(\$e)]
84. } else {
85. lappend edgepoints \$mid
86. }
87. set en4e(\$e) \$i
88. foreach p \$ep {
89. lappend ep4p(\$p) \$mid
90. }
91. incr i
92. }
93.
94. # Generate the new vertex points with our lookup tables.
95. foreach p \$points {
96. set n [llength \$fp4p(\$p)]
97. if {\$n == [llength \$ep4p(\$p)]} {
98. lappend newPoints [add3 [mulC [/ [- \$n 3.0] \$n] \$p] \
99. [mulC [/ 1.0 \$n] [centroid \$fp4p(\$p)]] \
100. [mulC [/ 2.0 \$n] [centroid \$ep4p(\$p)]]]
101. } else {
102. lappend newPoints [centroid [list \$p] \$ep4p(\$p)]
103. }
104. }
105.
106. # Now compute the new set of quadrilateral faces.
107. set i [llength \$points]
108. foreach f \$faces {
109. foreach a \$f b [lrot \$f] c [lrot \$f -1] {
110. lappend newFaces [list \
111. \$a \$en4e([edge \$a \$b]) \$i \$en4e([edge \$c \$a])]
112. }
113. incr i
114. }
115.
116. list [concat \$newPoints \$facepoints \$edgepoints] \$newFaces
117. }
118.
119. package require Tk
120.
121. # A simple-minded ordering function for faces
122. proc orderf {points face1 face2} {
123. set d1 [set d2 0.0]
124. foreach p [selectFrom \$points \$face1] {
125. lassign \$p x y z
126. set d1 [expr {\$d1 + sqrt(\$x*\$x + \$y*\$y + \$z*\$z)}]
127. }
128. foreach p [selectFrom \$points \$face2] {
129. lassign \$p x y z
130. set d2 [expr {\$d2 + sqrt(\$x*\$x + \$y*\$y + \$z*\$z)}]
131. }
132. expr {\$d1<\$d2 ? -1 : \$d1>\$d2 ? 1 : 0}
133. }
134.
135. # Plots a net defined in points-and-faces fashion
136. proc visualizeNet {w points faces args} {
137. foreach face [lsort -command [list orderf \$points] \$faces] {
138. set c {}
139. set polyCoords [selectFrom \$points \$face]
140. set sum {[list 0. 0. 0.]}
141. set centroid [centroid \$polyCoords]
142. foreach coord \$polyCoords {
143. lassign \$coord x y z
144. lappend c \
145. [expr {200. + 190. * (0.867 * \$x - 0.9396 * \$y)}] \
146. [expr {200 + 190. * (0.5 * \$x + 0.3402 * \$y - \$z)}]
147. }
148. lassign \$centroid x y z
149. set depth [expr {int(255*sqrt(\$x*\$x + \$y*\$y + \$z*\$z) / sqrt(3.))}]
150. set grey [format #%02x%02x%02x \$depth \$depth \$depth]
151. \$w create polygon \$c -fill \$grey {*}\$args
152. }
153. }
154. # Make a display surface
155. pack [canvas .c -width 400 -height 400 -background #7f7f7f]
156.
157. # Points to define the unit cube
158. set points {
159. {0.0 0.0 0.0}
160. {1.0 0.0 0.0}
161. {1.0 1.0 0.0}
162. {0.0 1.0 0.0}
163. {0.0 0.0 1.0}
164. {1.0 0.0 1.0}
165. {1.0 1.0 1.0}
166. {0.0 1.0 1.0}
167. }
168. foreach pt \$points {
169. lassign \$pt x y z
170. lappend points [list [expr {0.25 + 0.5*\$x}] [expr {0.25 + 0.5*\$y}] \$z]
171. }
172.
173. # Try removing {1 2 6 5} to demonstrate holes.
174. set faces {
175. {0 8 9 1}
176. {1 9 10 2}
177. {2 10 11 3}
178. {3 11 8 0}
179. {0 1 5 4}
180. {1 2 6 5}
181. {2 3 7 6}
182. {3 0 4 7}
183. {4 5 13 12}
184. {5 6 14 13}
185. {6 7 15 14}
186. {7 4 12 15}
187. {8 9 13 12}
188. {9 10 14 13}
189. {10 11 15 14}
190. {11 8 12 15}
191. }
192.
193. # Show the initial layout
194. visualizeNet .c \$points \$faces -outline white -fill {}
195.
196. # Apply the Catmull-Clark algorithm to generate a new surface
197. lassign [CatmullClark \$points \$faces] points2 faces2
198.
199. ## Uncomment the next line to get the second level of subdivision
200. lassign [CatmullClark \$points2 \$faces2] points2 faces2
201. lassign [CatmullClark \$points2 \$faces2] points2 faces2
202.
203. # Visualize the new surface
204. visualizeNet .c \$points2 \$faces2 -outline #0000cc