I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

# Catmull–Clark subdivision surface/Tcl Test Code

This is the test code for the Tcl solution of the Catmull-Clark problem.

Library: Tk

## Utility Functions

`package require Tk # A simple-minded ordering function for facesproc orderf {points face1 face2} {    set d1 [set d2 0.0]    foreach p [selectFrom \$points \$face1] {	lassign \$p x y z	set d1 [expr {\$d1 + sqrt(\$x*\$x + \$y*\$y + \$z*\$z)}]    }    foreach p [selectFrom \$points \$face2] {	lassign \$p x y z	set d2 [expr {\$d2 + sqrt(\$x*\$x + \$y*\$y + \$z*\$z)}]    }    expr {\$d1<\$d2 ? -1 : \$d1>\$d2 ? 1 : 0}} # Plots a net defined in points-and-faces fashionproc visualizeNet {w points faces args} {    foreach face [lsort -command [list orderf \$points] \$faces] {	set c {}	set polyCoords [selectFrom \$points \$face]	set sum {[list 0. 0. 0.]}	set centroid [centroid \$polyCoords]	foreach coord \$polyCoords {	    lassign \$coord x y z	    lappend c \		[expr {200. + 190. * (0.867 * \$x - 0.9396 * \$y)}] \		[expr {200 + 190. * (0.5 * \$x + 0.3402 * \$y - \$z)}]	}	lassign \$centroid x y z	set depth [expr {int(255*sqrt(\$x*\$x + \$y*\$y + \$z*\$z) / sqrt(3.))}]	set grey [format #%02x%02x%02x \$depth \$depth \$depth]	\$w create polygon \$c -fill \$grey {*}\$args    }}`

## Demonstration

(Using the utility functions from above, plus the code from the main solution page.)

`# Make a display surfacepack [canvas .c -width 400 -height 400 -background #7f7f7f] # Points to define the unit cubeset points {    {0.0 0.0 0.0}    {1.0 0.0 0.0}    {1.0 1.0 0.0}    {0.0 1.0 0.0}    {0.0 0.0 1.0}    {1.0 0.0 1.0}    {1.0 1.0 1.0}    {0.0 1.0 1.0}}foreach pt \$points {    lassign \$pt x y z    lappend points [list [expr {0.25 + 0.5*\$x}] [expr {0.25 + 0.5*\$y}] \$z]} # Try removing {1 2 6 5} to demonstrate holes.set faces {    {0 8 9 1}    {1 9 10 2}    {2 10 11 3}    {3 11 8 0}    {0 1 5 4}    {1 2 6 5}    {2 3 7 6}    {3 0 4 7}    {4 5 13 12}    {5 6 14 13}    {6 7 15 14}    {7 4 12 15}    {8 9 13 12}    {9 10 14 13}    {10 11 15 14}    {11 8 12 15}} # Show the initial layoutvisualizeNet .c \$points \$faces -outline white -fill {} # Apply the Catmull-Clark algorithm to generate a new surfacelassign [CatmullClark \$points \$faces] points2 faces2 ## Uncomment the next line to get the second level of subdivisionlassign [CatmullClark \$points2 \$faces2] points2 faces2lassign [CatmullClark \$points2 \$faces2] points2 faces2 # Visualize the new surfacevisualizeNet .c \$points2 \$faces2 -outline #0000cc`

## Program Output

This figure shows the result of running the code on this page.