I recently had a need to generate triangle strips for [OpenGL] triangle meshes and found
Pierre Terdiman's nice C++ code at http://www.codercorner.com/Strips.htm. I was
in the middle of converting it to plain C when it occurred to me that this would
be a nice little project to implement in Tcl, not only to validate my specfic conversion,
but also to share with the community.

The basic idea is to turn a list of triangles (triples of vertex indices) into a list of
tristrips (arbitrary length lists of vertex indices) while preserving the orientation of
the original input triangles.

Here's some Tcl to do this :

 package provide tristrip

 namespace eval tristrip {

 # public
        variable oneside 1 ;# generate one-sided triangle strips
	variable cnctall 0 ;# connect all strips
	variable SGIalgo 0 ;# use SGI algorithm for trilist traversal
	variable oppoext 1 ;# do opposite direction strip extension

	#Generate Triangle Strips from Triangle List
	#
	proc genTriStrips {trilst {one 1s} {cnc noconnect} {sgi nosgi}} {
		variable edgmap; catch { array unset edgmap }
		variable usegbl; catch { array unset usegbl }

		# set options (this needs reworking (suggestions welcome)...)
		#
		variable oneside; variable cnctall; variable SGIalgo
		if {[string equal $one "1s"]} {
			set oneside 1 } else { set oneside 0 }
		if {[string equal $cnc "connect"]} {
			set cnctall 1 } else { set cnctall 0 }
		if {[string equal $sgi "sgi"]} {
			set SGIalgo 1 } else { set SGIalgo 0; }

		# create edge -> triangles mapping
		#
		newEdgMap $trilst ;

		# unimplemented (exercise for the reader :)
		#
		variable SGIalgo
		if {$SGIalgo} {
			# sort trilst ascending based on the number of neighbors
			# per tri. i.e., visit most-isolated tris first.
		}

		# create strips
		#
		set stripLst [list]
		foreach tri $trilst {
			# starting from unused triangles ...
			if {![info exists usegbl($tri)]} {
				# generate a strip, save it, mark its tri's used
				foreach {s u} [genBestStrip $tri] { break }
				lappend stripLst $s
				foreach t $u { set usegbl($t) 1 }
			}
		}

		catch { array unset edgmap; array unset usegbl }

		if {$cnctall} {
			set stripLst [list [connectAllStrips $stripLst]]
		}

		return $stripLst
	}

 # private
	variable edgmap    ;# triangles sharing an edge
	variable usegbl    ;# triangles in use globally

	proc genBestStrip {tri0} {
		# best strip so far for input tri
		set bestVtxLst {}; set bestTriLst {}

		# generate strips in all three directions
		#
		foreach \
			fwdDir {{old mid dum} {mid dum old} {dum old mid}} \
			bakDir {{mid old dum} {old dum mid} {dum mid old}} \
		{
			# initialize for this strip
			catch {array unset uselcl};
			foreach $fwdDir [set tri $tri0] { break }
			set vLst [list $old $mid]; set tLst [list]

			# extend strip
			foreach {vLst tLst} \
				[extendStrip $vLst $tLst $tri $old $mid uselcl] { break }

			# if opposite-direction strip extension is configured
			variable oppoext
			if {$oppoext} {
				# look backwards from original tri
				foreach $bakDir [set tri $tri0] { break }

				# for an adjacent unused tri
				set tri [unusedTri [otherTri $tri0 $old $mid] uselcl]
				if {$tri != ""} {
					# found one so reverse strip
					reverseLst vLst; reverseLst tLst

					# extend again
					foreach {vLst tLst} \
						[extendStrip $vLst $tLst $tri $old $mid uselcl] \
							{ break }

					# for one-sided strips,
					# reverse strip and check/correct original windings
					#
					variable oneside
					if {$oneside} {
						reverseLst vLst; reverseLst tLst;
						set idxtri0 0;
						foreach t $tLst {
							if {$t == $tri0} { break };
							incr idxtri0
						}
						if {[expr {$idxtri0%2}] == 1} {
							set vLst [linsert $vLst 0 [lindex $vLst 0]]
						}
					} 
				}
			}

			# save strip if longer than current best strip
			#
			set tLen [llength $tLst]
			set bLen [llength $bestTriLst]
			if {$tLen > $bLen} {
				set bestVtxLst $vLst; set bestTriLst $tLst
			}
		}

		return [list $bestVtxLst $bestTriLst]
	}

	# extend input strip (and it's trilst) in the old/mid direction
	proc extendStrip {vLst tLst tri old mid uselclnam} {
		upvar 1 $uselclnam uselcl

		while {$tri != ""} {
			lappend vLst [set new [otherVtx $tri $old $mid]]
			lappend tLst $tri; set uselcl($tri) 1
			set tri [unusedTri [otherTri $tri $mid $new] uselcl]
			set old $mid; set mid $new
		}

		return [list $vLst $tLst]
	}

	# flatten all strip lists to one strip if configured
	proc connectAllStrips {stripLst} {
		variable oneside

		set vLst [list]; set vLen 0
		foreach s $stripLst {
			if {$vLst != ""} {
				set vEnd [lindex $vLst end]
				set sBeg [lindex $s 0]

				lappend vLst $vEnd $sBeg; incr vLen 2

				# check/correct for one sided strip winding flip
				if {$oneside && [expr {$vLen%2}] == 1} {
					foreach {v1 v2 rest} $s { break }
					if {$v1 != $v2} {
						lappend vLst $v1; incr vLen
					}
				}
			}

			# append the existing strip
			foreach v $s { lappend vLst $v; incr vLen }
		}

		return $vLst
	}

	# Create an edge-to-triangles map.  Keys are ordered pairs of
	# vertex indices and values are a list of triangles sharing the edge
	#
	proc newEdgMap {trilst} {
		variable edgmap; array unset edgmap
		foreach tri $trilst { foreach {v1 v2 v3} $tri { break }
			addEdgTri $v1 $v2 $tri
			addEdgTri $v2 $v3 $tri
			addEdgTri $v3 $v1 $tri
		}
		# can't handle non-manifold meshes
		foreach edg [array names edgmap] {
			if {[llength $edgmap($edg)] > 2} {
				return -code error \
					"Non-manifold input : edge $edg $edgmap($edg)"
			}
		}
	}

	# add a triangle to the list of triangles sharing edge ab
	proc addEdgTri {a b tri} {
		variable edgmap;
		if {$a < $b} { set lo $a; set hi $b
		} else       { set lo $b; set hi $a }
		lappend edgmap($lo,$hi) $tri
	}

	# get the list of triangles sharing edge ab
	proc getEdgTriLst {a b} {
		variable edgmap
		if {$a < $b} { set lo $a; set hi $b 
		} else       { set lo $b; set hi $a }
		return $edgmap($lo,$hi)
	}

	# reverse list variable in the caller's scope
	proc reverseLst {lstvarnam} {
		upvar 1 $lstvarnam lst
		set revlst [list]; set n [llength $lst] 
		while {[incr n -1] >= 0} { lappend revlst [lindex $lst $n] }
		set lst $revlst
	}

	# find the other vertex of a triangle when given two
	proc otherVtx {tri a b} {
		foreach {v1 v2 v3} $tri { break }
		if {$v1 == $a && $v2 == $b || $v1 == $b && $v2 == $a} { return $v3 }
		if {$v2 == $a && $v3 == $b || $v2 == $b && $v3 == $a} { return $v1 }
		if {$v3 == $a && $v1 == $b || $v3 == $b && $v1 == $a} { return $v2 }
	}

	# find the other triangle sharing the edge ab
	proc otherTri {tri a b} {
		variable edgmap
		foreach {t1 t2} [getEdgTriLst $a $b] { break }
		if {$tri == $t1} { set oth $t2 } else { set oth $t1 }
		return $oth
	}

	# return input triangle if unused both globally and in the given map
	proc unusedTri {tri lclusenam} {
		variable usegbl; upvar 1 $lclusenam uselcl
		set unused $tri
		if {[info exists usegbl($tri)]} { set unused "" } ;# in use globally
		if {[info exists uselcl($tri)]} { set unused "" } ;# in use locally
		return $unused
	}
 }

I suppose we need some code to test this too. Yes, this is probably more complex
than needed (feel free to add the simple test cases) but I needed to check performance
numbers on large regular closed meshes.


 proc genShape {typ} {
	set vclst [list]

	if {[string equal $typ "o"]} {
		# octahedron vertices on unit sphere
		set p [expr {double(1)}];
		set m [expr {double(-1)}];
		set z [expr {double(0)}];
		set xp [list $p $z $z] ; set xm [list $m $z $z]
		set yp [list $z $p $z] ; set ym [list $z $m $z]
		set zp [list $z $z $p] ; set zm [list $z $z $m]
		# octohedron (all tris ccw)
		lappend vclst \
			[list $xp $yp $zp] [list $xp $zm $yp] [list $xp $zp $ym] \
			[list $xp $ym $zm] [list $xm $yp $zm] [list $xm $zm $ym] \
			[list $xm $zp $yp] [list $xm $ym $zp]

	} elseif {[string equal $typ "d"]} {
		# triangular dipyramid (a convex deltahedron)
		# vertices on unit sphere
		set Pi    [expr {3.14159265358979323846}]
		set cos60 [expr {cos($Pi*30/180.0)}]
		set sin60 [expr {sin($Pi*30/180.0)}]
		set p     [expr {double(1)}]
		set m     [expr {double(-1)}]
		set z     [expr {double(0)}]
		set top [list $z $p $z]; set bot [list $z $m $z]
		set bak [list $z $z $m]
		set lft [list -$cos60 $z $sin60]; set rit [list $cos60 $z $sin60]
		# triangular dipyramid
		lappend vclst \
			[list $rit $top $lft] [list $lft $bot $rit] \
			[list $rit $bot $bak] [list $bak $top $rit] \
			[list $top $bak $lft] [list $lft $bot $bak]

	} elseif {[string equal $typ "t"]} {
		# tetrahedron vertices on unit sphere
		set sqrt3p [expr {0.5773502692}]
		set sqrt3m [expr {-0.5773502692}]
		set PPP [list $sqrt3p $sqrt3p $sqrt3p] ;# +X, +Y, +Z
		set MMP [list $sqrt3m $sqrt3m $sqrt3p] ;# -X, -Y, +Z
		set MPM [list $sqrt3m $sqrt3p $sqrt3m] ;# -X, +Y, -Z
		set PMM [list $sqrt3p $sqrt3m $sqrt3m] ;# +X, -Y, -Z
		# tetrahedron (all tris ccw)
		lappend vclst \
			[list $PPP $MPM $MMP] [list $PPP $MMP $PMM] \
			[list $MPM $PMM $MMP] [list $MPM $PPP $PMM]

	} else {
		return -code error "unknown shape type $typ"
	}

	return $vclst
 }

 # repeatedly subdivide a list of triangles to the given depth
 # normalizes all generated vertices to lie on the unit sphere
 # returns new list of triangle vertices
 #
 proc sphdivtrilst {tclst {depth 3}} {
    proc K {a b} {set a}; # local K combiner

	if {$depth < 0}         { set depth 0
	} elseif {$depth > 5}   { set depth 5 }

	set curlst $tclst
	set nxtlst [list]

	while {[incr depth -1] >= 0} {
		foreach t [K $curlst [set curlst [list]]] {
			# get triangle vertex coordiates
			foreach {v1 v2 v3} $t break
			foreach {x1 y1 z1} $v1 {x2 y2 z2} $v2 {x3 y3 z3} $v3 \
				break

			set x [expr {($x1+$x2)}]
			set y [expr {($y1+$y2)}]
			set z [expr {($z1+$z2)}]
			set l [expr {sqrt($x*$x + $y*$y + $z*$z)}]
			set v12 [list [expr {$x/$l}] [expr {$y/$l}] [expr {$z/$l}]]

			set x [expr {($x2+$x3)}]
			set y [expr {($y2+$y3)}]
			set z [expr {($z2+$z3)}]
			set l [expr {sqrt($x*$x + $y*$y + $z*$z)}]
			set v23 [list [expr {$x/$l}] [expr {$y/$l}] [expr {$z/$l}]]

			set x [expr {($x3+$x1)}]
			set y [expr {($y3+$y1)}]
			set z [expr {($z3+$z1)}]
			set l [expr {sqrt($x*$x + $y*$y + $z*$z)}]
			set v31 [list [expr {$x/$l}] [expr {$y/$l}] [expr {$z/$l}]]

			lappend nxtlst \
				[list $v1 $v12 $v31] \
				[list $v2 $v23 $v12] \
				[list $v3 $v31 $v23] \
				[list $v12 $v23 $v31] \
		}

		set curlst $nxtlst
		set nxtlst [list]
	}

	return $curlst
 }

 proc genSphere {ndv {typ o} {regen 0}} {

	if {!$regen} {
		global sphereCache; if {[info exists sphereCache($typ,$ndv)]} {
			return $sphereCache($typ,$ndv)
		} else {
			array unset sphereCache ;# only cache 1 typ,ndv pair
		}
	}

	set trilst [sphdivtrilst [genShape $typ] $ndv]

	# create vertex list from sphere's triangles
	set unqvtxlst {}
	foreach t $trilst {
		foreach {v1 v2 v3} $t { lappend unqvtxlst $v1 $v2 $v3 } }
	set unqvtxlst [lsort -unique $unqvtxlst]

	# create unique vertex map
	set idx 0
	foreach v $unqvtxlst {
		if {![info exists vtxidxmap($v)]} {
			set vtxidxmap($v) $idx
			incr idx
		}
	}

	# create triangle list using vertex indices
	set i 0
	set trivtxidxlst {}
	foreach t $trilst {
		foreach {v1 v2 v3} $t {
			lappend trivtxidxlst \
				[list $vtxidxmap($v1) $vtxidxmap($v2) $vtxidxmap($v3)]
		}
	}
	#puts "[llength $trivtxidxlst] tris [llength $unqvtxlst] unqvtx"

	return [set sphereCache($typ,$ndv) [list $unqvtxlst $trivtxidxlst]]
 }

 proc statStripList {vL tL sL} {
	set vLen [llength $vL]
	set tLen [llength $tL]
	set sLen [llength $sL]
	puts "\t$tLen input triangles $vLen vertices $sLen strips"
	set vr 0; set lL [list]
	foreach s $sL { incr vr [set l [llength $s]]; lappend lL $l }
	puts -nonewline "\ttotal vtx refs : $vr : #/strip :"
	foreach l $lL { puts -nonewline " $l" }; puts ""
	puts "\ttri/tristrip vtx ref ratio : [expr {$tLen*3.0/$vr}]"
	puts "\t#tristrip refs/~#min refs ratio : [expr {$vr/2.0/$vLen}]"
 }

 proc runtstTriStrip {n {typ o} {onesid 1s} {cnc connect}} {
	set et0 [time {
		foreach {vL tL} [genSphere $n $typ 1] { break }
	}]
	set et1 [time {
		set sL [tristrip::genTriStrips $tL $onesid $cnc]
	}]
	puts "genTriStrips \$tl $onesid $cnc : $et1" 
	puts "\tgenSphere $n $typ 1: $et0" 
	statStripList $vL $tL $sL
 }

 proc tstTriStrip {{nlst {0 1}} {tlst {t d}} {slst {2s}} {clst {connect}}} {
	foreach n $nlst {
	foreach t $tlst {
	foreach s $slst {
	foreach c $clst {
		puts "runtstTriStrip $n $t $s $c"
		runtstTriStrip $n $t $s $c
		puts ""
	} } } }
 }

 #tstTriStrip {0 1 2 3 4 5} {t d o} {2s 1s} {connect !connect} ;# test everything

I don't currently have a way to easily visualize this directly since I haven't
yet found a Tcl/Tk OpenGL widget (I must admit I haven't looked thoroughly) that 
handles indirect vertex references and tristrips at the scripting level.

[Mark K. Greene]
----
[Category 3D Graphics]