gmrndcolor.tcl

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

proc gm_lookup_prop {brep_list facedim faceind lookupprop} {
    ## gmset val [gm_lookup_prop $brep_list $facedim $faceind $prop]
    ## Retrieves a value from a face given the property name.
    ## First argument is a brep in list from (output of gm_obj2list).
    ## Second and third argument specify the face.
    ## Fourth argument is property.
    ## Returns empty string if property not assigned.

    set lookuppropl [string tolower $lookupprop]
    set pvlist [lindex [lindex $brep_list [expr 5 + $facedim]] \
	    [expr 5 * $faceind + 1]]
    set pvlistlen [llength $pvlist]
    for {set j 0} {$j < $pvlistlen} {incr j 2} {
	set prop [lindex $pvlist $j]
	if {[string tolower $prop] == $lookuppropl} {
	    return [lindex $pvlist [expr $j + 1]]
	}
    }
    return ""
}



proc gmrndcolor {brep {dim_to_color ""}} {
    ## gmset a [gmrndcolor $b {$dim_to_color}]
    ##  This function assigns a random sequence of colors chosen from
    ##  a pallette of about 20  colors to brep b, and returns the colored brep as
    ## a.  Faces already colored are not recolored.  The second optional
    ## argument tells which dimension of faces should be colored.
    ## The default for the second argument is 1 less than the embedded dimension
    ##  of the brep, or its gdim, whichever is smaller.


    set brepl [gm_obj2list $brep]
    set gdim [lindex $brepl 1]
    set di [lindex $brepl 2]
    if {[string length $dim_to_color] == 0} {
	if {$gdim < [expr $di - 1]} {
	    set dim_to_color $gdim
	} else {
	    set dim_to_color [expr $di - 1]
	}
    }


    if {$dim_to_color > $gdim || $dim_to_color < 0} {
	error "Specified dimension out of range"
    }

    set colorlev [lindex $brepl [expr 5 + $dim_to_color]]
    set levsize [expr [llength $colorlev] / 5]
    set newcolorlev {}

    set base3(0) 1
    set base3(1) 0
    set base3(2) 0
    set newcolorlev {}
    for {set faceind 0} {$faceind < $levsize} {incr faceind} {
	set newpvlist [lindex $colorlev [expr 5 * $faceind + 1]]
	set prop [gm_lookup_prop $brepl $dim_to_color $faceind color]
	if {$prop == ""} {
	    set colorval [list ([expr 0.5*$base3(0)] \
		    [expr 0.5*$base3(1)] \
		    [expr 0.5*$base3(2)] 1)]
	    lappend newpvlist color $colorval
	    set pos 0
	    while {$pos < 3} {
		incr base3($pos)
		if {$base3($pos) == 3} {
		    set base3($pos) 0
		    incr pos
		} else {
		   break
		}
	    }
	}
	lappend newcolorlev [lindex $colorlev [expr 5 * $faceind]] \
		$newpvlist \
		[lindex $colorlev [expr 5 * $faceind + 2]] \
		[lindex $colorlev [expr 5 * $faceind + 3]] \
		[lindex $colorlev [expr 5 * $faceind + 4]]
    }
    set newbrep [list [lindex $brepl 0] $gdim $di \
	    [lindex $brepl 3] [lindex $brepl 4]]
    for {set fdim 0} {$fdim <= $gdim} {incr fdim} {
	if {$fdim == $dim_to_color} {
	    lappend newbrep $newcolorlev
	} else {
	    lappend newbrep [lindex $brepl [expr 5 + $fdim]]
	}
    }
    return [gm_list2obj $newbrep]
}

proc gmshowcolor {brep {dim_to_color ""}} {
    ## gmshowcolor $obj {$dim} makes a plot of the colors of
    ## the faces of the object.  This is useful for setting
    ## up boundary conditions.   dim is the dimension of faces
    ## whose colors show, default for dim is the embedded
    ## dimension of the brep - 1 or its intrinsic dim, whichever
    ## is smaller.
    set brepl [gm_obj2list $brep]
    set gdim [lindex $brepl 1]
    set di [lindex $brepl 2]
    if {[string length $dim_to_color] == 0} {
	if {$gdim < [expr $di - 1]} {
	    set dim_to_color $gdim
	} else {
	    set dim_to_color [expr $di - 1]
	}
    }

    if {$dim_to_color > $gdim || $dim_to_color < 0} {
	error "Specified dimension out of range"
    }
    set levsize [expr [llength [lindex $brepl [expr 5 + $dim_to_color]]] / 5]

    # Find the first free index.

    set index 1
    set found 0
    set cmds [info commands]
    while {$found == 0} {
	set toplevname "gmshowcolor-$index"
	if {[lsearch $cmds .$toplevname] < 0} {
	    set found 1
	} else {
	    incr index
	}
    }
    set handle $index
    toplevel .$toplevname
    frame .$toplevname.frame
    pack .$toplevname.frame
    set coheight 0.7
    set canv .$toplevname.v
    canvas $canv -background khaki4 \
	    -width 8c \
	    -height [expr $coheight* $levsize]c
    pack $canv -in .$toplevname.frame

    set fcount 0
    global gmviz_default_color
    for {set faceind 0} {$faceind < $levsize} {incr faceind} {
	set facename [lindex [lindex $brepl [expr 5+$dim_to_color]] \
		[expr 5*$faceind]]
	set this_color [gm_lookup_prop $brepl $dim_to_color $faceind color]
	if {[llength $this_color] > 0} {
	    set this_color1 $this_color
	    set this_color_name $this_color
	} else {
	    set this_color_name default
	    if {[llength $gmviz_default_color] == 4} {
		set this_color1 "($gmviz_default_color)"
	    } else {
		set this_color1 \
			[concat {(} \
			[gmviz_process_rgb $gmviz_default_color] \
			{)}]
	    }
	}
	set this_color1 [string trim $this_color1]
	if {![string match (*) $this_color1]} {
	    error "Colorspec not enclosed in parentheses"
	}
	set this_color1 [string range $this_color1 1 \
		[expr [string length $this_color1] - 2]]
	if {[llength $this_color1] != 4} {
	    error "Colorspec '$this_color1' does not have four entries"
	}
	if {[lindex $this_color1 3] == 0} {
	    continue
	}

	set hexcolor1 [format "#%2x%2x%2x" \
		[expr int([lindex $this_color1 0] * 255.0)] \
		[expr int([lindex $this_color1 1] * 255.0)] \
		[expr int([lindex $this_color1 2] * 255.0)]]
	regsub -all " " $hexcolor1 0 hexcolor2
	set fcount1 [expr $fcount+0.9]
	set pos [expr $fcount*$coheight]
	set pos1 [expr $fcount1*$coheight]
	$canv create polygon 0 ${pos}c \
		0 ${pos1}c \
		3c ${pos1}c \
		3c ${pos}c \
		-fill $hexcolor2
	set fcounth [expr $fcount+0.5]
	set posh [expr $fcounth * $coheight]
	if {[string length $facename] > 25} {
	    set facename [string range $facename 0 24]
	}
	$canv create text 3.1c ${posh}c \
		-text "$dim_to_color:$faceind $facename" -anchor sw
	$canv create text 6.1c ${posh}c -text $this_color_name \
		-anchor sw
	incr fcount
    }
    global gm_default_button_color
    button .$toplevname.dismiss \
	    -text "Dismiss" \
	    -command [list destroy .$toplevname] \
	    -background $gm_default_button_color
    pack .$toplevname.dismiss -in .$toplevname.frame -side top -anchor ne
}


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