gmcavity.tcl

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

proc gmcavity {brep1o brep2o} {
    # gmset newbrep [gmcavity $brep1 $brep2]
    # This routine creates a new brep formed by making brep2
    # a cavity in brep1.  The routine  glues the two breps together
    # and renumbers everything.  It does not check that the gluing
    # is sensible -- in particular, it does not verify that 
    # brep2 actually is enclosed by brep1.

    global gm_brep_type_code
    set brep1 [gm_obj2list $brep1o]
    set brep2 [gm_obj2list $brep2o]
    if {[lindex $brep1 0] != $gm_brep_type_code ||  \
	    [lindex $brep2 0] != $gm_brep_type_code} {
	error "Both arguments to gm_cavity must be breps"
    }

    set di [lindex $brep1 2]
    if {[lindex $brep2 2] != $di} {
	error "Error: breps have different embedded dimensions"
    }

    if {[lindex $brep1 1] != $di} {
	error "Error: brep1 is not full dimensional"
    }

    if {[llength [lindex $brep1 [expr 5+$di]]] != 5} {
	error "Error: brep1 has more than one top-level face"
    }

    set allfacenames {}
    for {set fdim 0} {$fdim <= $di} {incr fdim} {
	set thislev [lindex $brep1 [expr $fdim + 5]]
	for {set j 0} {$j < [llength $thislev]} {incr j 5} {
	    lappend allfacenames [string tolower [lindex $thislev $j]]
	}
    }

    for {set co 1} {1} {incr co} {
	if {[string first _cav$co $allfacenames] < 0} {
	    break
	}
    }
    set appendstr _cav$co


    set gdim2 [lindex $brep2 1]
    set newbdry {}
    set newib {}
    set brep2_toplev [lindex $brep2 [expr 5+$gdim2]]
    set numtoplevface [expr [llength $brep2_toplev] / 5]
    if {$gdim2 < $di - 1} {
	for {set j 0} {$j < $numtoplevface} {incr j} {
	    set facename [lindex $brep2_toplev [expr $j*5]]$appendstr
	    lappend newib $facename
	}
    } elseif {$gdim2 == $di - 1} {
	for {set j 0} {$j < $numtoplevface} {incr j} {
	    set facename [lindex $brep2_toplev [expr $j*5]]$appendstr
	    lappend newbdry $facename
	    lappend newbdry $facename
	}
    } elseif {$gdim2 == $di} {
	for {set j 0} {$j < $numtoplevface} {incr j} {
	    set chlist [lindex $brep2_toplev [expr $j*5+2]]
	    foreach facename $chlist {
		lappend newbdry ${facename}${appendstr}
	    }
	}
    }
	    

    set brep1_numcp [expr [llength [lindex $brep1 4]] / $di]
    set new_cplist [concat [lindex $brep1 4] [lindex $brep2 4]]

    set newbrep [list $gm_brep_type_code $di $di {} $new_cplist]
    set new_iblist1 {}
    set new_iblist2 {}
    for {set fdim 0} {$fdim <= $di} {incr fdim} {
	if {$fdim == $di} {
	    set old_lev [lindex $brep1 [expr $fdim + 5]]
	    set this_lev [list [lindex $old_lev 0] \
		    [lindex $old_lev 1] \
		    [concat [lindex $old_lev 2] $newbdry] \
		    [concat [lindex $old_lev 3] $newib] \
		    {} ]
	} else {
	    set this_lev [lindex $brep1 [expr $fdim + 5]]
	    if {$fdim <= $gdim2} {
		set brep2_lev [lindex $brep2 [expr $fdim + 5]]
		set levsize [expr [llength $brep2_lev] / 5]
		for {set j 0} {$j < $levsize} {incr j} {
		    lappend this_lev [lindex $brep2_lev [expr $j*5]]$appendstr
		    lappend this_lev [lindex $brep2_lev [expr $j*5+1]]
		    set chlist [lindex $brep2_lev [expr $j*5+2]]
		    set newchlist {}
		    foreach item $chlist {
			lappend newchlist ${item}$appendstr
		    }
		    lappend this_lev $newchlist
		    set iblist [lindex $brep2_lev [expr $j*5+3]]
		    set newiblist {}
		    foreach item $iblist {
			lappend newiblist ${item}$appendstr
		    }
		    lappend this_lev $newiblist
		    set patchlist [lindex $brep2_lev [expr $j*5+4]]
		    set newpatchlist {}
		    foreach patch $patchlist {
			set patchtype [lindex $patch 0]
			if {[string tolower $patchtype] == "vertex"} {
			    set firstcp 1
			} elseif {[string tolower $patchtype] == "bezier_curve"} {
			    set firstcp 2
			} elseif {[string tolower $patchtype] == "bezier_triangle"} {
			    set firstcp 2
			} elseif {[string tolower $patchtype] == "bezier_quad"} {
			    set firstcp 3
			} else {
			    error "Unknown patch type $patchtype"
			}
			set newpatch {}
			for {set k 0} {$k < $firstcp} {incr k} {
			    lappend newpatch [lindex $patch $k]
			}
			for {set k $firstcp} {$k < [llength $patch]} {incr k} {
			    lappend newpatch [expr [lindex $patch $k] + $brep1_numcp]
			}
			lappend newpatchlist $newpatch
		    }
		    lappend this_lev $newpatchlist
		}
	    }
	}
	lappend newbrep $this_lev
    }
    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
# ------------------------------------------------------------------