1# File : begin 2if { [array get Draw_Groups "TOPOLOGY Check commands"] == "" } { 3 pload TOPTEST 4 pload VISUALIZATION 5} 6pload XDE 7pload QAcommands 8 9if { [info exists imagedir] == 0 } { 10 set imagedir . 11} 12if { [info exists test_image] == 0 } { 13 set test_image photo 14} 15 16set scriptdir [file dirname [info script]] 17 18set mistake 0 19 20#################### procedure GetDigit returns digit (cut) from string #################### 21proc GetDigit {s} { 22 set res "" 23 for {set a 0} {$a < [string length $s]} {incr a} { 24 if {[string index $s $a]>="0" && [string index $s $a]<="9"} { 25 set res [set res][string index $s $a] 26 } else { 27 if {[string index $s $a]=="e" || [string index $s $a]=="-"} { 28 set res [set res][string index $s $a] 29 } else {return $res} 30 } else {return $res} 31 } 32 return $res 33} 34 35#################### procedure ShapeCenter returns (three coords string) center of given shape 36proc ShapeCenter {s} { 37puts $s 38 global $s 39 return [CenterOfShape $s] 40# set ss [explode $s V] 41# if {[llength $ss] == 0} {set ss $s} 42# set x 0 43# set y 0 44# set z 0 45# for {set a 0} {[lindex $ss $a] != ""} {incr a} { 46# set dmp [dump [lindex $ss $a]] 47# set fromindex [lsearch $dmp Elementary] 48# if {$fromindex != -1} { 49# set x [expr $x+[GetDigit [lindex $dmp [expr $fromindex+6]]]] 50# set y [expr $y+[GetDigit [lindex $dmp [expr $fromindex+12]]]] 51# set z [expr $z+[GetDigit [lindex $dmp [expr $fromindex+18]]]] 52# } 53# set fromindex [lsearch $dmp "3D"] 54# set x [expr $x+[GetDigit [lindex $dmp [expr $fromindex+2]]]] 55# set y [expr $y+[GetDigit [lindex $dmp [expr $fromindex+3]]]] 56# set z [expr $z+[GetDigit [lindex $dmp [expr $fromindex+4]]]] 57# } 58# set x [expr $x/[llength $ss]] 59# set y [expr $y/[llength $ss]] 60# set z [expr $z/[llength $ss]] 61# return "$x $y $z" 62} 63 64#################### procedure IsSame returns true, if given shapes has same TShapes #################### 65proc IsSame {s1 s2} { 66 global $s1 $s2 67puts "$s1 $s2" 68 if {[IsSameShapes $s1 $s2] == 1} {return 1} 69 return 0 70# 71# set d1 [dump $s1] 72# set d2 [dump $s1] 73# if {[llength $d1]<10 || [llength $d2]<10} { 74# return 0 75# } 76# 77# if {[lindex [dump $s1] 28] == [lindex [dump $s2] 28]} { 78# if {[lindex [dump $s1] 29] == [lindex [dump $s2] 29]} {return 1} 79# } 80# return 0 81} 82 83#################### procedure NextLabel set lab as next label of lab at this level #################### 84proc NextLabel {lab} { 85 upvar 1 $lab l 86 set i [string last ":" "[set l]"] 87 if {$i == -1} {set l [expr [set l]+1]} else { 88 set l [string range [set l] 0 $i][expr 1+[string range [set l] [expr $i+1] [string length [set l]]]] 89 } 90} 91 92#################### checking the naming at myLab label ( tests at myNameLab label ) #################### 93#################### show errors, increments working labels #################### 94proc Checking {Name} { 95 global D IsDone TestError 96 upvar 1 myLab l1 myNameLab l2 97 98 set bad "" 99 if {[catch {set bad [CheckNaming D $l2 1 Label $l1 1 1 1]}]} { 100 set IsDone 0 101 set TestError "$TestError # $Name naming failed at label $l2 with exception" 102 } else { 103 if {[llength $bad] > 0} { 104 set IsDone 0 105 set TestError "$TestError # $Name naming failed at label $l2 sublabels $bad" 106 } 107 } 108 NextLabel l1 109 NextLabel l2 110} 111