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.  
  6. # Add 3 points.
  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