gmmake_torus.tcl

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

proc gmmake_torus {inner_rad outer_rad subdiv} {    
    # gmmake_torus $innerrad $outerrad $numsubdiv
    # Make a quadratic bezier approximation to a torus.
    # The first argument is the inner radius, the second is
    # the outer radius, and the third is the number of
    # bezier subdivisions.

    if {$outer_rad <= $inner_rad || $inner_rad <= 0} {
	error "Outer radius must exceed inner radius and both must be positive"
    }
    if {$subdiv < 3} {
	error "Number of bezier subdivisions must be at least 3"
    }


    global PI
    set control_points { }
    set tan1 [expr tan($PI / $subdiv)]
    set mult [expr sqrt(1.0 + $tan1 * $tan1)]
    set control_points {}
    set rad1 [expr 0.5 * ($inner_rad + $outer_rad)]
    set rad2 [expr 0.5 * ($outer_rad - $inner_rad)]
    for {set j 0} {$j < 2 * $subdiv} {incr j} {
	set cos1 [expr cos($j * $PI / $subdiv)]
	set sin1 [expr sin($j * $PI / $subdiv)]
	for {set k 0} {$k < 2 * $subdiv} {incr k} {
	    set cos2 [expr $rad2 * cos($k * $PI / $subdiv)]
	    set sin2 [expr $rad2 * sin($k * $PI / $subdiv)]
	    set x 0
	    if {$j % 2 == 0 && $k % 2 == 0} {
		set y [expr $rad1 + $cos2]
		set z $sin2
	    } elseif {$j % 2 == 0 && $k % 2 == 1} {
		set y [expr $rad1 + $mult * $cos2]
		set z [expr $mult * $sin2]
	    } elseif {$j % 2 == 1 && $k % 2 == 0} {
		set y [expr ($rad1 + $cos2) * $mult]
		set z $sin2
	    } else { #  if $j % 2 == 1 && $k % 2 == 1
		set y [expr $rad1 * $mult + $cos2 * $mult * $mult]
		set z [expr $mult * $sin2]
	    }
	    lappend control_points [expr $cos1 * $x + $sin1 * $y]
	    lappend control_points [expr -$sin1 * $x + $cos1 * $y]
	    lappend control_points $z
	}
    }

    set patches {}
    for {set j 0} {$j < $subdiv} {incr j} {
	set j1 [expr ($j + 1) % $subdiv]
	for {set k 0} {$k < $subdiv} {incr k} {
	    set k1 [expr ($k + 1) % $subdiv]
	    lappend patches [list bezier_quad 2 2 \
		    [expr $j * $subdiv * 4 + $k * 2] \
		    [expr (2 * $j + 1) * $subdiv * 2 + $k * 2] \
		    [expr $j1 * $subdiv * 4 + $k * 2] \
		    [expr $j * $subdiv * 4 + $k * 2 + 1] \
		    [expr (2 * $j + 1) * $subdiv * 2 + $k * 2 + 1] \
		    [expr $j1 * $subdiv * 4 + $k * 2 + 1] \
		    [expr $j * $subdiv * 4 + $k1 * 2] \
		    [expr (2 * $j + 1) * $subdiv * 2 + $k1 * 2] \
		    [expr $j1 * $subdiv * 4 + $k1 * 2]]
	}
    }
    set obj [list brep_v2.0 3 3 {} $control_points {} {} \
	    [list torus_surf {} {} {} $patches] \
	    {torus {} {torus_surf} {} {}}]
    return [gm_list2obj $obj]
}
		

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