gmq11read.tcl

来自「算断裂的」· TCL 代码 · 共 256 行

proc gm_q11read_checkbracket {str numitem} {
   # puts $str
    if {[llength $str] != [expr $numitem + 2] || \
	    [lindex $str 0] != "<" || \
	    [lindex $str [expr $numitem + 1]] != ">"} {
	puts "length = [llength $str]"
	foreach item $str {
	    puts "item = $item"
	}
	error "Wrong number of items in bracket string (file format error)"
    }
}

proc gm_q11read_checkparen {str} {
    set l [llength $str]
    if {[lindex $str 0] != "(" || \
	    [lindex $str [expr $l - 1]] != ")"} {
	puts "first = [lindex $str 0]"
	puts "last = [lindex  $str [expr $l - 1]]"
	error "Parenthesized list missing parens (file format error)"
    }
    return [expr $l - 2]
}

proc gmq11read {filename} {
    #  gmset brep [gmq11read $filename]
    # This routine reads a brep from a file in QMG 1.1 Ascii format.
    
    global gm_brep_type_code
    set fi [open $filename r]
    set sbrep [read $fi]
    close $fi
    set sbrep "\n$sbrep"
    while 1 {
	set p [string first "\n#" $sbrep]
	if {$p < 0} {
	    break
	}
	set p1 [string first "\n" [string range $sbrep [expr $p + 1] end]]
	if {$p1 < 0} {
	    set p1 [string length [string range $sbrep [expr $p + 1] end]]
	}
	set sbrep "[string range $sbrep 0 $p][string \
		range $sbrep [expr $p + $p1 + 1] end]"
    }
    # puts $sbrep
    regsub -all < $sbrep " \{< " sbrep
    regsub -all > $sbrep " >\} " sbrep
    regsub -all \\( $sbrep " \{( " sbrep
    regsub -all \\) $sbrep " )\} " sbrep
    set sbrep [lindex $sbrep 0]
    gm_q11read_checkbracket $sbrep 2
    if {[lindex $sbrep 1] != "brep"} {
	error "Keyword 'brep' missing from file header"
    }
    set sbrep [lindex $sbrep 2]
    gm_q11read_checkbracket $sbrep 3
    set gdim [lindex $sbrep 1]
    set di [lindex $sbrep 2]
    if {$gdim < 0 || $gdim > $di || $di < 2 || $di > 3} {
	error "intrinsic or embedded dimension out of range"
    }
    set sbrep [lindex $sbrep 3]
    set newbrep [list $gm_brep_type_code $gdim $di {}]
    set cplist {}
    set cptable {}
    set segtable {}
    for {set dim 0} {$dim <= $gdim} {incr dim} {
	set newlevlist {}
	gm_q11read_checkbracket $sbrep 2
	set thislev [lindex $sbrep 1]
	set numface [gm_q11read_checkparen $thislev]
	for {set faceind 0} {$faceind < $numface} {incr faceind} {
	    set thisface [lindex $thislev [expr $faceind + 1]]
	    gm_q11read_checkbracket $thisface 4
	    set facename [lindex $thisface 1]
	    set facemap($facename) $faceind
	    set facedimmap($facename) $dim
	    set pvlist [lindex $thisface 2]
	    set numpv [gm_q11read_checkparen $pvlist]
	    set pvlist [lrange $pvlist 1 $numpv]
	    set chlist [lindex $thisface 3]
	    set numchild [gm_q11read_checkparen $chlist]
	    set chlist [lrange $chlist 1 $numchild]
	    set iblist [lindex $thisface 4]
	    set numib [gm_q11read_checkparen $iblist]
	    set iblist [lrange $iblist 1 $numib]
	    set pointfound 0
	    set newpv {}
	    foreach thispv $pvlist {
		gm_q11read_checkbracket $thispv 2
		set prop [string tolower [lindex $thispv 1]]
		set val [lindex $thispv 2]
		if {$prop == "point"} {
		    if {$dim == 0} {
			if {$pointfound} {
			    error "Point property occurs twice in vertex"
			}
			set pointfound 1
			set d1 [gm_q11read_checkparen $val]
			if {$d1 != $di} {
			    error "Number of coordinate entries does not match embedded dim"
			}
			set thiscoord [lrange $val 1 $di]
			lappend cptable $thiscoord
			foreach item $thiscoord {
			    lappend cplist $item
			}
		    }
		} elseif {$prop == "affine_coef"} {
		} elseif {$prop == "affine_rhs"} {
		} elseif {$prop == "color"} {
		    gm_q11read_checkbracket $val 4
		    set val1 "([lindex $val 1] [lindex $val 2] \
			    [lindex $val 3] [lindex $val 4])"
		    lappend newpv color $val1
		} else {
		    lappend newpv $prop $val
		}
	    }
	    if {$dim == 0 && !$pointfound} {
		error "No point property for vertex"
	    }
	    lappend newlevlist $facename $newpv $chlist $iblist
	    if {$dim == 0} {
		set bezlist [list [list vertex $faceind]]
	    } elseif {$dim == 1} {
		if {[llength $chlist] == 0 || \
			[llength $chlist] % 2 != 0} {
		    error "Edge must have an even number of boundaries"
		}
		set maxdelta -1.0
		set bestd -1
		for {set dim1 0} {$dim1 < $di} {incr dim1} {
		    set ub -1e307
		    set lb 1e307
		    foreach child $chlist {
			set subfaceind $facemap($child)
			set coord [lindex $cptable $subfaceind]
			set thiscoord [lindex $coord $dim1]
			if {$thiscoord < $lb} {
			    set lb $thiscoord
			}
			if {$thiscoord > $ub} {
			    set ub $thiscoord
			}
			set delta [expr $ub - $lb]
			if {$delta > $maxdelta} {
			    set maxdelta $delta
			    set bestd $dim1
			}
		    }
		}
		set chlist1 [concat $chlist $iblist $iblist]
		set sortlist {}
		foreach child $chlist1 {
		    set subfaceind $facemap($child)
		    lappend sortlist [list $subfaceind \
			    [lindex [lindex $cptable $subfaceind] $bestd]]
		}
		set sortlist [lsort -real -index 1 $sortlist]
		set bezlist {}
		set seglist {}
		for {set i 0} {$i < [llength $sortlist]} {incr i 2} {
		    set sp [lindex [lindex $sortlist $i] 0]
		    set ep [lindex [lindex $sortlist [expr $i+1]] 0]
		    lappend seglist [list $sp $ep]
		    lappend bezlist [list bezier_curve 1 $sp $ep]
		}
		lappend segtable $seglist
	    } elseif {$dim == 2 && $di == 3} {
		set newiblist {}
		if {[llength $chlist] < 3} {
		    error "Must have at least 3 children for 2-dim face"
		}
		foreach ib $iblist {
		    if {$facedimmap($ib) == 1} {
			lappend chlist $ib
			lappend chlist $ib
		    } else {
			lappend newiblist $ib
		    }
		}
		set smallcoordlist {}
		set smallseglist {}
		foreach child $chlist {
		    set subfaceind $facemap($child)
		    foreach seg [lindex $segtable $subfaceind] {
			set smallseg {}
			for {set k 0} {$k < 2} {incr k} {
			    set ep [lindex $seg $k]
			    if {[catch {set smallnum $big2small($ep)}]} {
				set big2small($ep) [llength $smallcoordlist]
				set smallnum $big2small($ep)
				lappend smallcoordlist \
					[lindex $cptable $ep]
				set small2big($smallnum) $ep
			    }
			    lappend smallseg $smallnum
			}
			lappend smallseglist $smallseg
		    }
		}
		foreach ib $newiblist {
		    set subfaceind $facemap($ib)
		    if {[catch {set smallnum $big2small($subfaceind)}]} {
			set big2small($subfaceind) [llength $smallcoordlist]
			set smallnum $big2small($subfaceind)
			lappend smallcoordlist \
				[lindex $cptable $sufaceind]
			set small2big($smallnum) $subfaceind
		    }
		}

		set triangles [gm_polytri $smallcoordlist $smallseglist]
		set bezlist {}
		foreach tri $triangles {
		    set thisbez {bezier_triangle 1}
		    for {set k 0} {$k < 3} {incr k} {
			lappend thisbez $small2big([lindex $tri $k])
		    }
		    lappend bezlist $thisbez
		}
		unset small2big
		unset big2small
	    } else {
		set bezlist {}
	    }
	    lappend newlevlist $bezlist
	}
	if {$dim == 0} {
	    lappend newbrep $cplist
	}
	lappend newbrep $newlevlist
	set sbrep [lindex $sbrep 2]
    }
    if {$sbrep != "nil"} {
	error "Brep does not terminate with nil"
    }
    return [gm_list2obj $newbrep]
}

# ------------------------------------------------------------------
# Copyright (c) 1999 by Cornell University.  All rights reserved
# See the accompanying file 'Copyright' for authorship information,
# the terms of the license governing this software, and disclaimers
# concerning this software.
# ------------------------------------------------------------------
# This file is part of the QMG software.  
# Version 2.0 of QMG, release date September 3, 1999
# ------------------------------------------------------------------