Updated 2012-09-21 12:44:52 by RLE

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 \

                        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