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. (Orientation is used in OpenGL to determine which of the
two sides of a triangle will be drawn). For example:

 % set trilst [list {0 1 2} {1 2 3} {2 3 4}]
 % tristrip::genTriStrips $trilst 2s
 % {0 1 2 3 4}

Note the orientation of the odd triangles is preserved and the even ones have their original orientation
reversed (this is what OpenGL expects).

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]