Adjusting testing cases

[occt.git] / tests / bugs / begin

# File : begin
if { [array get Draw_Groups "TOPOLOGY Check commands"] == "" } {
    pload TOPTEST
    pload VISUALIZATION
#    set env(CSF_DrawPluginQADefaults) $env(CASROOT)/src/DrawResources/.
#    pload QAcommands
#    pload -DrawPluginQA QAcommands
}

# to prevent loops limit to 16 minutes
cpulimit 1000

#set script_dir [file dirname [info script]]/script
# if { [info exist WorkDirectory] == 0 } {
#    set WorkDirectory "/tmp"
#    if { [array get env TEMP] != "" } {
#	set WorkDirectory "$env(TEMP)"
#	}
#    }

if { [info exists imagedir] == 0 } {
   set imagedir .
}
if { [info exists test_image] == 0 } {
   set test_image photo
}

# Procedure to check equality of two reals with tolerance (relative and absolute)
proc checkreal {name value expected tol_abs tol_rel} {
    if { abs ($value - $expected) > $tol_abs + $tol_rel * abs ($expected) } {
        puts "Error: $name = $value is not equal to expected $expected"
    } else {
        puts "Check of $name OK: value = $value, expected = $expected"
    }
    return
}



# Procedure to check color in the point near default coordinate

proc checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
    set x_start [expr ${coord_x} - 2]
    set y_start [expr ${coord_y} - 2]
    set mistake 0
    set i 0
    while { $mistake != 1 && $i <= 5 } {
	set j 0
	while { $mistake != 1 && $j <= 5 } {
	    set position_x [expr ${x_start} + $j]
	    set position_y [expr ${y_start} + $i]
	    puts $position_x
	    puts $position_y
	    global color2d
	    if { [info exists color2d] } {
		set color [ QAAISGetPixelColor2d ${position_x} ${position_y} ]
	    } else {
		set color [ QAGetPixelColor ${position_x} ${position_y} ]
	    }
	    regexp {RED +: +([-0-9.+eE]+)} $color full rd
	    regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
	    regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
	    set rd_int [expr int($rd * 1.e+05)]
	    set gr_int [expr int($gr * 1.e+05)]
	    set bl_int [expr int($bl * 1.e+05)]
	    
	    if { $rd_ch != 0 } {
		set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
	    } else {
		set tol_rd $rd_int
	    }
	    if { $gr_ch != 0 } {
		set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
	    } else {
		set tol_gr $gr_int
	    }
	    if { $bl_ch != 0 } {
		set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
	    } else {
		set tol_bl $bl_int
	    }

	    if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
		puts "Warning : Point with true color was not found near default coordinates"
		set mistake 0
	    } else {
		set mistake 1
	    }
	    incr j
	}
	incr i
    }
    return $mistake
}

# Procedure to check color using command QAgetPixelColor with tolerance
proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
    puts "Coordinate x = $coord_x"
    puts "Coordinate y = $coord_y"
    puts "RED color of RGB is $rd_get"
    puts "GREEN color of RGB is $gr_get"
    puts "BLUE color of RGB is $bl_get"
    
    if { $coord_x <= 1 || $coord_y <= 1 } {
	puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
	return -1
    }
    global color2d
	if { [info exists color2d] } {
	    set color [ QAAISGetPixelColor2d ${coord_x} ${coord_y} ]
	} else {
	    set color [ QAGetPixelColor ${coord_x} ${coord_y} ]
	}

    regexp {RED +: +([-0-9.+eE]+)} $color full rd
    regexp {GREEN +: +([-0-9.+eE]+)} $color full gr
    regexp {BLUE +: +([-0-9.+eE]+)} $color full bl
    set rd_int [expr int($rd * 1.e+05)]
    set gr_int [expr int($gr * 1.e+05)]
    set bl_int [expr int($bl * 1.e+05)]
    set rd_ch [expr int($rd_get * 1.e+05)]
    set gr_ch [expr int($gr_get * 1.e+05)]
    set bl_ch [expr int($bl_get * 1.e+05)]
    
    if { $rd_ch != 0 } {
	set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
    } else {
	set tol_rd $rd_int
    }
    if { $gr_ch != 0 } {
	set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
    } else {
	set tol_gr $gr_int
    }
    if { $bl_ch != 0 } {
	set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
    } else {
	set tol_bl $bl_int
    }
    set status 0
    if { $tol_rd > 0.2 } {
	puts "Warning : RED light of additive color model RGB is invalid"
	set status 1
    }
    if { $tol_gr > 0.2 } {
	puts "Warning : GREEN light of additive color model RGB is invalid"
	set status 1
    }
    if { $tol_bl > 0.2 } {
	puts "Warning : BLUE light of additive color model RGB is invalid"
	set status 1
    }

    if { $status != 0 } {
	puts "Warning : Colors of default coordinate are not equal"
    }

    global stat
    if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
	set info [checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
	set stat [lindex $info end]
	if { ${stat} != 1 } {
	    puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
	    return $stat
	} else {
	    puts "Point with valid color was found"
	    return $stat
	}
    } else {
	set stat 1
    }
}


# Procedure to check if sequence of values in listval follows linear trend
# adding the same delta on each step.
#
# The function does statistical estimation of the mean variation of the
# values of the sequence, and dispersion, and returns true only if both 
# dispersion and deviation of the mean from expected delta are within 
# specified tolerance.
#
# If mean variation differs from expected delta on more than two dispersions,
# the check fails and procedure raises error with specified message.
#
# Otherwise the procedure returns false meaning that more iterations are needed.
# Note that false is returned in any case if length of listval is less than 3.
#
# See example of use to check memory leaks in bugs/caf/bug23489
#
proc checktrend {listval delta tolerance message} {
    set nbval [llength $listval]
    if { $nbval < 3} {
        return 0
    }

    # calculate mean value
    set mean 0.
    set prev [lindex $listval 0]
    foreach val [lrange $listval 1 end] {
        set mean [expr $mean + ($val - $prev)]
        set prev $val
    }
    set mean [expr $mean / $nbval]

    # calculate dispersion
    set sigma 0.
    set prev [lindex $listval 0]
    foreach val [lrange $listval 1 end] {
        set d [expr ($val - $prev) - $mean]
        set sigma [expr $sigma + $d * $d]
        set prev $val
    }
    set sigma [expr sqrt ($sigma / ($nbval - 1))]

    puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"

    # check if deviation is definitely too big
    if { abs ($mean - $delta) > 2. * $sigma } {
        puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
        error $message
    }

    # check if deviation is clearly within a range
    return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
}