gm_addpropval.tcl

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

proc gm_addpropval {brep facenamelist proplist vallist} {
    #   gmset newbrep [gm_addpropval $brep $faces $prop $val]
    # This function adds new property-value pairs to faces of a
    # brep, and returns the so-modified brep.  Argument faces is a list
    # of names of faces (strings) to modify.  Arguments prop and val are both 
    # lists of strings.  To delete a property-value pair from a face, set the
    # val to the empty string.  If an entry in faces is the empty string, this
    # corresponds to adding the face to the brep's global property-value list.

    set brepl [gm_obj2list $brep]
    global gm_brep_type_code
    if {[lindex $brepl 0] != $gm_brep_type_code} {
	error "First argument to gm_addpropval must be a brep"
    }
    if {[llength $facenamelist] != [llength $proplist] || \
	    [llength $facenamelist] != [llength $vallist]} {
	error "Number of faces in list must equal number of props and number of values"
    }
    for {set j 0} {$j < [llength $facenamelist]} {incr j} {
	set thisface [string tolower [lindex $facenamelist $j]]
	set thispropp [lindex $proplist $j]
	set thisprop [string tolower $thispropp]
	set thisval [lindex $vallist $j]
	if {![info exists newpropvalx($thisface,$thisprop)]} {
	    set newpropvalx($thisface,$thisprop) 1
	    lappend newprop($thisface) $thispropp $thisval
	}
	set thisfacefound($thisface) 0
    }

    set gdim [lindex $brepl 1]
    set newbrepl [list $gm_brep_type_code $gdim [lindex $brepl 2]]
    set pvlist [lindex $brep 3]
    set newpvlist {}
    set numpv [expr [llength $pvlist] / 2]
    for {set j 0} {$j < $numpv} {incr j} {
	set thispropp [lindex $pvlist [expr $j * 2]]
	set thisprop [string tolower $thispropp]
	set thisval [lindex $pvlist [expr $j * 2 + 1]]
	if {![info exists newpropvalx(,$thisprop)]} {
	    lappend newpvlist $thispropp $thisval
	}
    }
    if {[info exists newprop()]} {
	set numpv [expr [llength $newprop()] / 2]
	for {set j 0} {$j < $numpv} {incr j} {
	    set prop [lindex $newprop() [expr 2 * $j]]
	    set val [lindex $newprop() [expr 2 * $j + 1]]
	    if {[string length $val] > 0} {
		lappend newpvlist $prop $val
	    }
	}
    }
    set thisfacefound() 1

    lappend newbrepl $newpvlist [lindex $brepl 4]
    for {set fdim 0} {$fdim <= $gdim} {incr fdim} {
	set oldfaces [lindex $brepl [expr $fdim + 5]]
	set newfaces {}
	set numface [expr [llength $oldfaces] / 5]
	for {set faceind 0} {$faceind < $numface} {incr faceind} {
	    set facename [lindex $oldfaces [expr 5 * $faceind]]
	    set facenamel [string tolower $facename]
	    set oldpvlist [lindex $oldfaces [expr 5 * $faceind + 1]]
	    set numpv [expr [llength $oldpvlist] / 2]
	    set newpvlist {}
	    for {set j 0} {$j < $numpv} {incr j} {
		set thispropp [lindex $oldpvlist [expr $j * 2]]
		set thisprop [string tolower $thispropp]
		set thisval [lindex $oldpvlist [expr $j * 2 + 1]]
		if {![info exists newpropvalx($facenamel,$thisprop)]} {
		    lappend newpvlist $thispropp $thisval
		}
	    }

	    if {[info exists newprop($facenamel)]} {
		set numpv [expr [llength $newprop($facenamel)] / 2]
		for {set j 0} {$j < $numpv} {incr j} {
		    set prop [lindex $newprop($facenamel) [expr 2 * $j]]
		    set val [lindex $newprop($facenamel) [expr 2 * $j + 1]]
		    if {[string length $val] > 0} {
			lappend newpvlist $prop $val
		    }
		}
	    }

	    lappend newfaces $facename $newpvlist \
		    [lindex $oldfaces [expr 5 * $faceind + 2]] \
		    [lindex $oldfaces [expr 5 * $faceind + 3]] \
		    [lindex $oldfaces [expr 5 * $faceind + 4]]
	    set thisfacefound($facename) 1
	}
	lappend newbrepl $newfaces
    }

    set an [array names thisfacefound]
    foreach subscr $an {
	if {!$thisfacefound($subscr)} {
	    disp "Warning: face name '$subscr' given in input does not exist in brep"
	}
    }
    return [gm_list2obj $newbrepl]
}

# ------------------------------------------------------------------
# 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
# ------------------------------------------------------------------