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
}
}if 0 {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 everythingI 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. GreeneCategory 3D Graphics