test7.tcl

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

# QMG test 7 - a circle with two elliptic holes and a crack.
# Make an approximation to a circle using 6 Bezier cubic arcs.

set numseg 6
global PI
global interactive

gmset {verts codes} [gm_circ_approx 0 [expr 2*$PI] $numseg]
gmset verts [lrange $verts 0 [expr 3*$numseg-1]]
set codes {}
for {set j 0} {$j < $numseg} {incr j} {
    if {$j == 0} {
	lappend codes 0
    } else {
	lappend codes 2
    } 
    lappend codes 3 3
}

set c0 [gm_cpoly $verts $codes]

## Make two elliptic holes.

set hole1 [gmapply {{.2 0 0} {0 .1 -.5}} $c0]
set c [gmcavity $c0 $hole1]
set hole2 [gmapply {{.2 0 0} {0 .1 .5}} $c0]
set c [gmcavity $c $hole2]

## Make a slit by modifying the brep directly.

## Insert two new control points at (-.6,-.1) and (.6,.1).

set c_l [gm_obj2list $c]
set newcp [lindex $c_l 4]
set numcp [expr [llength $newcp] / 2]
lappend newcp -.6 -.1 .6 .1

## Insert two new vertices at these points.

set newvtx [lindex $c_l 5]
lappend newvtx newv1 {} {} {} [list [list vertex $numcp]]
lappend newvtx newv2 {} {} {} [list [list vertex [expr $numcp+1]]]

set newedge [lindex $c_l 6]
lappend newedge newe1 {} {newv1 newv2} {} \
	[list [list bezier_curve 1 $numcp [expr $numcp+1]]]

set toplev [lindex $c_l 7]
set newrbdry [lindex $toplev 2]
lappend newrbdry newe1 newe1

set c [gm_list2obj [list [lindex $c_l 0] [lindex $c_l 1] \
	[lindex $c_l 2] [lindex $c_l 3] \
	$newcp $newvtx $newedge \
	[list [lindex $toplev 0] [lindex $toplev 1] $newrbdry \
	[lindex $toplev 3] [lindex $toplev 4]]]]

set c [gmrndcolor $c]

if {[llength [info globals interactive]]} {
    global gmviz_beziersub
    set tmp $gmviz_beziersub
    if {$tmp < 15} {
	set gmviz_beziersub 15
    }
    gmviz $c
    set gmviz_beziesub $tmp
    gmshowcolor $c
}


## generate a mesh.  Elements of size about .2.


gmset show 0
if {[llength [info globals interactive]]} {
  gmset show 1
}

gmset m [gmmeshgen $c size "(const .2)" show $show]

if {[llength [info globals interactive]]} {
    ## Display the mesh
    gmviz $m
    update
}

gmset {c2 m2} [gmdouble $c * $m]


## Check the mesh.


set asp [gmchecktri $c2 $m2]

if {[llength [info globals aspprod]]} {
    global aspprod
    set aspprod [expr $aspprod * $asp]
    global meshsizesum
    gmset {numvtx numelt} [gmmeshsize $m2]
    set meshsizesum [expr $meshsizesum + $numvtx]
}


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