gmtransf.tcl

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

proc gmtranslate args {
    ## gmset a [gmtranslate $t1 $t2 ...] 
    ## constructs a translation operator.  The
    ##  dimension is inferred from the number of arguments.

    set n [llength $args]
    set transform {}
    for {set i 0} {$i < $n} {incr i} {
	set row {}
	for {set j 0} {$j < $n} {incr j} {
	    if {$i == $j} {
		lappend row 1
	    } else {
		lappend row 0
	    }
	}
	lappend row [expr -[lindex $args $i]]
	lappend transform $row
    }
    return $transform
}


proc gmdilate args {
    ## gmset a [gmdilate $t1 $t2 ...] 
    ## constructs a dilation operator.  The
    ##  dimension is inferred from the number of arguments.

    set n [llength $args]
    set transform {}
    for {set i 0} {$i < $n} {incr i} {
	set row {}
	for {set j 0} {$j < $n} {incr j} {
	    if {$i == $j} {
		lappend row [lindex $args $i]
	    } else {
		lappend row 0
	    }
	}
	lappend row 0
	lappend transform $row
    }
    return $transform
}


proc gmrotate {angle {di 2} {coor1 0} {coor2 1}} {
    ## gmset a [gmrotate $angle $d $coor1 $coor2] constructs a d-dimensional
    ##  transformation matrix that rotates everything by 'angle' radians
    ## counterclockwise in the coor1-coor2 plane (Givens rotation).
    ## gmset a [gmrotate $angle] alone creates a 2D rotation matrix.
    if {$coor1 < 0 || $coor1 >= $di || $coor2 < 0 \
	    || $coor2 >= $di} {
	error "Coordinate arguments out of range";
    }
    if {$coor1 == $coor2} {
	error "Coordinate arguments must differ";
    }
    set transform {}
    for {set i 0} {$i < $di} {incr i} {
	set row {}
	for {set j 0} {$j < $di} {incr j} {
	    if {$i == $coor1 && $j == $coor1} {
		lappend row [expr cos($angle)]
	    } elseif {$i == $coor1 && $j == $coor2} {
		lappend row [expr -sin($angle)]
	    } elseif {$i == $coor2 && $j == $coor1} {
		lappend row [expr sin($angle)]
	    } elseif {$i == $coor2 && $j == $coor2} {
		lappend row [expr cos($angle)]
	    } elseif {$i == $j} {
		lappend row 1
	    } else {
		lappend row 0
	    }
	}
	lappend row 0
	lappend transform $row
    }
    return $transform
}


proc gmcompose {transf1 transf2} {
    ## gmset c [gmcompose $a $b]
    ## This function composes two affine transformations, and returns
    ## the composition.  Thus,
    ##     gmset result [gmapply $mat1 [gmapply $mat2 $obj]]
    ## should be equivalent to
    ##   gmset result [gmapply [gmcompose $mat1 $mat2] $obj]
    ## but the latter is more efficient.
    set m1 [llength $transf1]
    set m2 [llength $transf2]
    set n1 [llength [lindex $transf1 0]]
    set n2 [llength [lindex $transf2 0]]
    if {[expr $n1 -1] != $m2} {
	error "The two transforms have incompatible sizes"
    }

    set prod {}
    for {set i 0} {$i < $m1} {incr i} {
	set row {}
	for {set j 0} {$j < $n2} {incr j} {
	    if {$j == $n2 - 1} {
		set t [lindex [lindex $transf1 $i] $m2]
	    } else {
		set t 0.0
	    }
	    for {set k 0} {$k < $m2} {incr k} {
		set t [expr $t + \
			[lindex [lindex $transf1 $i] $k] * \
			[lindex [lindex $transf2 $k] $j]]
	    }
	    lappend row $t
	}
	lappend prod $row
    }
    return $prod
}

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