Update testing system for compatibly test case with master during prepare delivery

src/DrawResources/CheckCommands.tcl

@@ -170,15 +170,23 @@ proc _check_arg {check_name check_result {get_value 0}} {
   upvar narg narg
   upvar args args
   if { $arg == ${check_name} } {
-    if {${get_value}} {
+    if { ${get_value} == "?" } {
+      set next_arg_index [expr $narg + 1]
+      if { $next_arg_index < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $next_arg_index]] } {
+        set ${check_result} "[lindex $args $next_arg_index]"
+        set narg ${next_arg_index}
+      } else {
+        set ${check_result} "true"
+      }
+    } elseif {${get_value}} {
       incr narg
-      if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
+      if { $narg < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $narg]] } {
         set ${check_result} "[lindex $args $narg]"
       } else {
         error "Option ${check_result} requires argument"
       }
     } else {
-      set ${check_result} 1
+      set ${check_result} "true"
     }
     return 1
   }
@@ -351,26 +359,36 @@ proc checkfreebounds {shape ref_value args} {
 }
 
 help checkmaxtol {
-  Compare max tolerance of shape with ref_value.
+  Returns max tolerance of the shape and prints error message if specified
-  Argument "source_shapes" is a list of used for sewing shapes.
+  criteria are not satisfied.
-  It can be empty to skip comparison of tolerance with source shapes.
 
-  Use: checkmaxtol shape ref_value [source_shapes={}] [options...]
+  Use: checkmaxtol shape [options...]
-  Allowed options are:
+
-    -min_tol: minimum tolerance for comparison
+  Options specify criteria for checking the maximal tolerance value:
-    -multi_tol: tolerance multiplier
+    -ref <value>: check it to be equal to reference value.
+    -min_tol <value>: check it to be not greater than specified value.
+    -source <list of shapes>: check it to be not greater than 
+            maximal tolerance of specified shape(s)
+    -multi_tol <value>: additional multiplier for value specified by -min_tol 
+               or -shapes options.
 }
-proc checkmaxtol {shape ref_value {source_shapes {}} args} {
+
-  puts "checkmaxtol ${shape} ${ref_value} ${source_shapes} ${args}"
+proc checkmaxtol {shape args} {
+  puts "checkmaxtol ${shape} ${args}"
   upvar ${shape} ${shape}
 
+  set ref_value ""
+  set source_shapes {}
   set min_tol 0
   set tol_multiplier 0
 
+  # check arguments
   for {set narg 0} {$narg < [llength $args]} {incr narg} {
     set arg [lindex $args $narg]
     if {[_check_arg "-min_tol" min_tol 1] ||
-        [_check_arg "-multi_tol" tol_multiplier 1]
+        [_check_arg "-multi_tol" tol_multiplier 1] ||
+        [_check_arg "-source" source_shapes 1] ||
+        [_check_arg "-ref" ref_value 1]
        } {
       continue
     }
@@ -382,26 +400,33 @@ proc checkmaxtol {shape ref_value {source_shapes {}} args} {
   }
 
   # get max tol of shape
-  regexp {max tol = ([-0-9.+eE]+)} [tolmax ${shape}] full max_tol
+  set max_tol 0
+  if {[regexp "Tolerance MAX=(\[-0-9.+eE\]+)" [tolerance ${shape}] full maxtol_temp]} {
+    set max_tol ${maxtol_temp}
+  } else {
+    error "Error: cannot get tolerances of shape \"${shape}\""
+  }
 
-  checkreal "Max tolerance" $max_tol $ref_value 0.0001 0.01
+  # find max tol of source shapes
-  if {[llength $source_shapes]} {
+  foreach source_shape ${source_shapes} {
-    # find max tol of source shapes
+    upvar ${source_shape} ${source_shape}
-    foreach source_shape $source_shapes {
+    set _src_max_tol [checkmaxtol ${source_shape}]
-      upvar ${source_shape} ${source_shape}
+    if { [expr ${_src_max_tol} > ${min_tol} ] } {
-      regexp {max tol = ([-0-9.+eE]+)} [tolmax $source_shape] full _src_max_tol
+      set min_tol ${_src_max_tol}
-      if { ${_src_max_tol} > ${min_tol} } {
-        set min_tol ${_src_max_tol}
-      }
-    }
-    if {${tol_multiplier}} {
-      set min_tol [expr ${tol_multiplier} * ${_src_max_tol}]
-    }
-    # compare max tol of source shapes with max tol of sewing_result
-    if { ${max_tol} > ${min_tol} } {
-      puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than max tolerance of source shapes (${min_tol})"
     }
   }
+  # apply -multi_tol option
+  if {${tol_multiplier}} {
+    set min_tol [expr ${tol_multiplier} * ${_src_max_tol}]
+  }
+  # compare max tol of source shapes with checking tolerance
+  if { ${min_tol} && [expr ${max_tol} > ${min_tol}] } {
+    puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than checking tolerance (${min_tol})"
+  }
+  if { ${ref_value} != "" } {
+    checkreal "Max tolerance" ${max_tol} ${ref_value} 0.0001 0.01
+  }
+  return ${max_tol}
 }
 
 help checkfaults {
@@ -435,3 +460,632 @@ proc checkfaults {shape source_shape {ref_value 0}} {
     puts "Error : Number of faults is $nb_r"
   }
 }
+
+# auxiliary: check all arguments
+proc _check_args { args {options {}} {command_name ""}} {
+  # check arguments
+  for {set narg 0} {${narg} < [llength ${args}]} {incr narg} {
+    set arg [lindex ${args} ${narg}]
+    set toContinue 0
+    foreach option ${options} {
+      set option_name            [lindex ${option} 0]
+      set variable_to_save_value [lindex ${option} 1]
+      set get_value              [lindex ${option} 2]
+      set local_value ""
+      if { [_check_arg ${option_name} local_value ${get_value}] } {
+        upvar 1 ${variable_to_save_value} ${variable_to_save_value}
+        set ${variable_to_save_value} ${local_value}
+        set toContinue 1
+      }
+    }
+    if {${toContinue}} { continue }
+    # unsupported option
+    if { [regexp {^-} ${arg}] } {
+      error "Error: unsupported option \"${arg}\""
+    }
+    error "Error: cannot interpret argument ${narg} (${arg})"
+  }
+  foreach option ${options} {
+    set option_name            [lindex ${option} 0]
+    set variable_to_save_value [lindex ${option} 1]
+    set should_exist           [lindex ${option} 3]
+    if {![info exists ${variable_to_save_value}] && ${should_exist} == 1} {
+      error "Error: wrong using of command '${command_name}', '${option_name}' option is required"
+    }
+  }
+}
+
+help checkprops {
+  Procedure includes commands to compute length, area and volume of input shape.
+
+  Use: checkprops shapename [options...]
+  Allowed options are:
+    -l LENGTH: command lprops, computes the mass properties of all edges in the shape with a linear density of 1
+    -s AREA: command sprops, computes the mass properties of all faces with a surface density of 1 
+    -v VOLUME: command vprops, computes the mass properties of all solids with a density of 1
+    -eps EPSILON: the epsilon defines relative precision of computation
+    -deps DEPSILON: the epsilon defines relative precision to compare corresponding values
+    -equal SHAPE: compare area\volume\length of input shapes. Puts error if its are not equal
+    -notequal SHAPE: compare area\volume\length of input shapes. Puts error if its are equal
+    -skip: count shared shapes only once, skipping repeatitions
+  Options -l, -s and -v are independent and can be used in any order. Tolerance epsilon is the same for all options.
+}
+
+proc checkprops {shape args} {
+    puts "checkprops ${shape} ${args}"
+    upvar ${shape} ${shape}
+
+    if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
+        puts "Error: The command cannot be built"
+        return
+    }
+
+    set length -1
+    set area -1
+    set volume -1
+    set epsilon 1.0e-4
+    set compared_equal_shape -1
+    set compared_notequal_shape -1
+    set equal_check 0
+    set skip 0
+    set depsilon 1e-2
+
+    set options {{"-eps" epsilon 1}
+                 {"-equal" compared_equal_shape 1}
+                 {"-notequal" compared_notequal_shape 1}
+                 {"-skip" skip 0}
+                 {"-deps" depsilon 1}}
+
+    if { [regexp {\-[not]*equal} $args] } {
+        lappend options {"-s" area 0}
+        lappend options {"-l" length 0}
+        lappend options {"-v" volume 0}
+        set equal_check 1
+    } else {
+        lappend options {"-s" area 1}
+        lappend options {"-l" length 1}
+        lappend options {"-v" volume 1}
+    }
+    _check_args ${args} ${options} "checkprops"
+
+    if { ${length} != -1 || ${equal_check} == 1 } {
+        lappend CommandNames {lprops}
+        set equal_check 0
+    }
+    if { ${area} != -1 || ${equal_check} == 1 } {
+        lappend CommandNames {sprops}
+        set equal_check 0
+    }
+    if { ${volume} != -1 || ${equal_check} == 1 } {
+        lappend CommandNames {vprops}
+        set equal_check 0
+    }
+
+    set skip_option ""
+    if { $skip } {
+        set skip_option "-skip"
+    }
+    
+    foreach CommandName ${CommandNames} {
+        switch $CommandName {
+            "lprops"    { set mass ${length}; set prop "length" }
+            "sprops"    { set mass ${area}; set prop "area" }
+            "vprops"    { set mass ${volume}; set prop "volume" }
+        }
+        regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${shape} ${epsilon} $skip_option] full m
+
+        if { ${compared_equal_shape} != -1 } {
+            upvar ${compared_equal_shape} ${compared_equal_shape}
+            regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_equal_shape} ${epsilon} $skip_option] full compared_m
+            if { $compared_m != $m } {
+                puts "Error: Shape ${compared_equal_shape} is not equal to shape ${shape}"
+            }
+        }
+
+        if { ${compared_notequal_shape} != -1 } {
+            upvar ${compared_notequal_shape} ${compared_notequal_shape}
+            regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_notequal_shape} ${epsilon} $skip_option] full compared_m
+            if { $compared_m == $m } {
+                puts "Error: Shape ${compared_notequal_shape} is equal shape to ${shape}"
+            }
+        }
+
+        if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
+            if { [string compare "$mass" "empty"] != 0 } {
+                if { $m == 0 } {
+                    puts "Error : The command is not valid. The $prop is 0."
+                }
+                if { $mass > 0 } {
+                    puts "The expected $prop is $mass"
+                }
+                #check of change of area is < 1%
+                if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > $depsilon) || ($mass == 0 && $m != 0) } {
+                    puts "Error : The $prop of result shape is $m"
+                }
+            } else {
+                if { $m != 0 } {
+                    puts "Error : The command is not valid. The $prop is $m"
+                }
+            }
+        }
+    }
+}
+
+help checkdump {
+  Procedure includes command to parse output dump and compare it with reference values.
+
+  Use: checkdump shapename [options...]
+  Allowed options are:
+    -name NAME: list of parsing parameters (e.g. Center, Axis, etc)
+    -ref VALUE: list of reference values for each parameter in NAME 
+    -eps EPSILON: the epsilon defines relative precision of computation
+}
+
+proc checkdump {shape args} {
+    puts "checkdump ${shape} ${args}"
+    upvar ${shape} ${shape}
+
+    set ddump -1
+    set epsilon -1
+    set options {{"-name" params 1}
+                 {"-ref" ref 1}
+                 {"-eps" epsilon 1}
+                 {"-dump" ddump 1}}
+
+    if { ${ddump} == -1 } {
+        set ddump [dump ${shape}]
+    }
+    _check_args ${args} ${options} "checkdump"
+
+    set index 0
+    foreach param ${params} {
+        set pattern "${param}\\s*:\\s*" 
+        set number_pattern "(\[-0-9.+eE\]+)\\s*" 
+        set ref_values ""
+        set local_ref ${ref}
+        if { [llength ${params}] > 1 } {
+            set local_ref [lindex ${ref} ${index}]
+        }
+        foreach item ${local_ref} {
+            if { ![regexp "$pattern$number_pattern" $ddump full res] } {
+                puts "Error: cheked parameter ${param} is not listed in dump"
+                break
+            }
+            lappend ref_values $res 
+            set pattern "${pattern}${res},\\s*" 
+            ## without precision
+            if { ${epsilon} == -1 } {
+                if { ${item} != ${res} } {
+                    puts "Error: parameter ${param} - current value (${res}) is not equal to reference value (${item})"
+                } else {
+                    puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
+                }
+            ## with precision
+            } else {
+                set precision 0.0000001
+                if { ( abs($res) > $precision ) || ( abs($item) > $precision ) } {
+                    if { ($item != 0 && [expr 1.*abs($item - $res)/$item] > $epsilon) || ($item == 0 && $res != 0) } {
+                        puts "Error: The $param of the resulting shape is $res and the expected $param is $item"
+                    } else {
+                        puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})"
+                    }
+                }
+            }
+        }
+        incr index
+    }
+}
+
+help checklength {
+  Procedure includes commands to compute length of input curve.
+
+  Use: checklength curvename [options...]
+  Allowed options are:
+    -l LENGTH: command length, computes the length of input curve with precision of computation
+    -eps EPSILON: the epsilon defines relative precision of computation
+    -equal CURVE: compare length of input curves. Puts error if its are not equal
+    -notequal CURVE: compare length of input curves. Puts error if its are equal
+}
+
+proc checklength {shape args} {
+    puts "checklength ${shape} ${args}"
+    upvar ${shape} ${shape}
+
+    if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
+        puts "Error: The command cannot be built"
+        return
+    }
+
+    set length -1
+    set epsilon 1.0e-4
+    set compared_equal_shape -1
+    set compared_notequal_shape -1
+    set equal_check 0
+
+    set options {{"-eps" epsilon 1}
+                 {"-equal" compared_equal_shape 1}
+                 {"-notequal" compared_notequal_shape 1}}
+
+    if { [regexp {\-[not]*equal} $args] } {
+        lappend options {"-l" length 0}
+        set equal_check 1
+    } else {
+        lappend options {"-l" length 1}
+    }
+    _check_args ${args} ${options} "checkprops"
+
+    if { ${length} != -1 || ${equal_check} == 1 } {
+        set CommandName length
+        set mass $length
+        set prop "length"
+        set equal_check 0
+    }
+
+    regexp "The +length+ ${shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${shape} ${epsilon}] full m
+
+    if { ${compared_equal_shape} != -1 } {
+        upvar ${compared_equal_shape} ${compared_equal_shape}
+        regexp "The +length+ ${compared_equal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m
+        if { $compared_m != $m } {
+            puts "Error: length of shape ${compared_equal_shape} is not equal to shape ${shape}"
+        }
+    }
+
+    if { ${compared_notequal_shape} != -1 } {
+        upvar ${compared_notequal_shape} ${compared_notequal_shape}
+        regexp "The +length+ ${compared_notequal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m
+        if { $compared_m == $m } {
+            puts "Error: length of shape ${compared_notequal_shape} is equal shape to ${shape}"
+        }
+    }
+
+    if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } {
+        if { [string compare "$mass" "empty"] != 0 } {
+            if { $m == 0 } {
+                puts "Error : The command is not valid. The $prop is 0."
+            }
+            if { $mass > 0 } {
+                puts "The expected $prop is $mass"
+            }
+            #check of change of area is < 1%
+            if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } {
+                puts "Error : The $prop of result shape is $m"
+            }
+        } else {
+            if { $m != 0 } {
+                puts "Error : The command is not valid. The $prop is $m"
+            }
+        }
+    }
+}
+
+help checkview {
+  Display shape in selected viewer.
+
+  Use: checkview [options...]
+  Allowed options are:
+    -display shapename: display shape with name 'shapename'
+    -3d: display shape in 3d viewer
+    -2d [ v2d / smallview ]: display shape in 2d viewer (default viewer is a 'smallview')
+    -vdispmode N: it is possible to set vdispmode for 3d viewer (default value is 1)
+    -screenshot: procedure will try to make screenshot of already created viewer
+    -path <path>: location of saved screenshot of viewer
+
+    Procedure can check some property of shape (length, area or volume) and compare it with some value N:
+      -l [N]
+      -s [N]
+      -v [N]
+    If current property is equal to value N, shape is marked as valid in procedure.
+    If value N is not given procedure will mark shape as valid if current property is non-zero.
+    -with {a b c}: display shapes 'a' 'b' 'c' together with 'shape' (if shape is valid)
+    -otherwise {d e f}: display shapes 'd' 'e' 'f' instead of 'shape' (if shape is NOT valid)
+    Note that one of two options -2d/-3d is required.
+}
+
+proc checkview {args} {
+  puts "checkview ${args}"
+
+  set 3dviewer 0
+  set 2dviewer false
+  set shape ""
+  set PathToSave ""
+  set dispmode 1
+  set isScreenshot 0
+  set check_length false
+  set check_area false
+  set check_volume false
+  set otherwise {}
+  set with {}
+
+  set options {{"-3d" 3dviewer 0}
+               {"-2d" 2dviewer ?}
+               {"-display" shape 1}
+               {"-path" PathToSave 1}
+               {"-vdispmode" dispmode 1}
+               {"-screenshot" isScreenshot 0}
+               {"-otherwise" otherwise 1}
+               {"-with" with 1}
+               {"-l" check_length ?}
+               {"-s" check_area ?}
+               {"-v" check_volume ?}}
+
+  # check arguments
+  _check_args ${args} ${options} "checkview"
+
+  if { ${PathToSave} == "" } {
+    set PathToSave "./photo.png"
+  }
+
+  if { ${3dviewer} == 0 && ${2dviewer} == false } {
+    error "Error: wrong using of command 'checkview', please use -2d or -3d option"
+  }
+
+  if { ${isScreenshot} } {
+    if { ${3dviewer} } {
+      vdump ${PathToSave}
+    } else {
+      xwd ${PathToSave}
+    }
+    return
+  }
+
+  set mass 0
+  set isBAD 0
+  upvar ${shape} ${shape}
+  if {[isdraw ${shape}]} {
+    # check area
+    if { [string is boolean ${check_area}] } {
+      if { ${check_area} } {
+        regexp {Mass +: +([-0-9.+eE]+)} [sprops ${shape}] full mass
+      }
+    } else {
+      set mass ${check_area}
+    }
+    # check length
+    if { [string is boolean ${check_length}] } {
+      if { ${check_length} } {
+        regexp {Mass +: +([-0-9.+eE]+)} [lprops ${shape}] full mass
+      }
+    } else {
+      set mass ${check_length}
+    }
+    # check volume
+    if { [string is boolean ${check_volume}] } {
+      if { ${check_volume} } {
+        regexp {Mass +: +([-0-9.+eE]+)} [vprops ${shape}] full mass
+      }
+    } else {
+      set mass ${check_volume}
+    }
+  } else {
+    set isBAD 1
+  }
+  if { ${3dviewer} } {
+    vinit
+    vclear
+  } elseif { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
+    smallview
+    clear
+  } elseif { ${2dviewer} == "v2d"} {
+    v2d
+    2dclear
+  }
+  if {[isdraw ${shape}]} {
+    if { ( ${check_area} == false && ${check_length} == false && ${check_volume} == false ) || ( ${mass} != 0 ) } {
+      foreach s ${with} {
+        upvar ${s} ${s}
+      }
+      lappend with ${shape}
+      if { ${3dviewer} } {
+        vdisplay {*}${with}
+      } else {
+        donly {*}${with}
+      }
+    } else {
+      set isBAD 1
+    }
+  } else {
+    set isBAD 1
+  }
+
+  if { ${isBAD} && [llength ${otherwise}] } {
+    foreach s ${otherwise} {
+      upvar ${s} ${s}
+    }
+    if { ${3dviewer} } {
+      vdisplay {*}${otherwise}
+    } else {
+      donly {*}${otherwise}
+    }
+  }
+
+  if { ${3dviewer} } {
+    vsetdispmode ${dispmode}
+    vfit
+    vdump ${PathToSave}
+  } else {
+    if { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} {
+      fit
+    } elseif { ${2dviewer} == "v2d"} {
+      2dfit
+    }
+    xwd ${PathToSave}
+  }
+
+}
+
+help checktrinfo {
+  Compare maximum deflection, number of nodes and triangles in "shape" mesh with given reference data
+
+  Use: checktrinfo shapename [options...]
+  Allowed options are:
+    -tri [N]:  compare current number of triangles in "shapename" mesh with given reference data.
+               If reference value N is not given and current number of triangles is equal to 0
+               procedure checktrinfo will print an error.
+    -nod [N]:  compare current number of nodes in "shapename" mesh with given reference data.
+               If reference value N is not givenand current number of nodes is equal to 0
+               procedure checktrinfo will print an error.
+    -defl [N]: compare current value of maximum deflection in "shapename" mesh with given reference data
+               If reference value N is not given and current maximum deflection is equal to 0
+               procedure checktrinfo will print an error.
+    -max_defl N:     compare current value of maximum deflection in "shapename" mesh with max possible value
+    -tol_abs_tri N:  absolute tolerance for comparison of number of triangles (default value 0)
+    -tol_rel_tri N:  relative tolerance for comparison of number of triangles (default value 0)
+    -tol_abs_nod N:  absolute tolerance for comparison of number of nodes (default value 0)
+    -tol_rel_nod N:  relative tolerance for comparison of number of nodes (default value 0)
+    -tol_abs_defl N: absolute tolerance for deflection comparison (default value 0)
+    -tol_rel_defl N: relative tolerance for deflection comparison (default value 0)
+    -ref [trinfo a]: compare deflection, number of triangles and nodes in "shapename" and in "a"
+}
+proc checktrinfo {shape args} {
+    puts "checktrinfo ${shape} ${args}"
+    upvar ${shape} ${shape}
+
+    if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} {
+        puts "Error: The command cannot be built"
+        return
+    }
+
+    set ref_nb_triangles false
+    set ref_nb_nodes false
+    set ref_deflection false
+    set tol_abs_defl 0
+    set tol_rel_defl 0
+    set tol_abs_tri 0
+    set tol_rel_tri 0
+    set tol_abs_nod 0
+    set tol_rel_nod 0
+    set max_defl -1
+    set ref_info ""
+
+    set options {{"-tri" ref_nb_triangles ?}
+                 {"-nod" ref_nb_nodes ?}
+                 {"-defl" ref_deflection ?}
+                 {"-tol_abs_defl" tol_abs_defl 1}
+                 {"-tol_rel_defl" tol_rel_defl 1}
+                 {"-tol_abs_tri" tol_abs_tri 1}
+                 {"-tol_rel_tri" tol_rel_tri 1}
+                 {"-tol_abs_nod" tol_abs_nod 1}
+                 {"-tol_rel_nod" tol_rel_nod 1}
+                 {"-max_defl" max_defl 1}
+                 {"-ref" ref_info 1}}
+
+    _check_args ${args} ${options} "checktrinfo"
+
+    # get current number of triangles and nodes, value of max deflection
+    set tri_info [trinfo ${shape}]
+    set triinfo_pattern "(\[0-9\]+) +triangles.*\[^0-9]\(\[0-9\]+) +nodes.*deflection +(\[-0-9.+eE\]+)"
+    if {![regexp "${triinfo_pattern}" ${tri_info} dump cur_nb_triangles cur_nb_nodes cur_deflection]} {
+        puts "Error: command trinfo prints empty info"
+    }
+
+    # get reference values from -ref option
+    if { "${ref_info}" != ""} {
+        if {![regexp "${triinfo_pattern}" ${ref_info} dump ref_nb_triangles ref_nb_nodes ref_deflection]} {
+            puts "Error: reference information gived by -ref option is wrong"
+        }
+    }
+
+    # check number of triangles
+    if { [string is boolean ${ref_nb_triangles}] } {
+        if { ${cur_nb_triangles} <= 0 && ${ref_nb_triangles} } {
+            puts "Error: Number of triangles is equal to 0"
+        }
+    } else {
+        if {[regexp {!([-0-9.+eE]+)} $ref_nb_triangles full ref_nb_triangles_value]} {
+            if  {${ref_nb_triangles_value} == ${cur_nb_triangles} } {
+                puts "Error: Number of triangles is equal to ${ref_nb_triangles_value} but it should not"
+            }
+        } else {
+            checkreal "Number of triangles" ${cur_nb_triangles} ${ref_nb_triangles} ${tol_abs_tri} ${tol_rel_tri}
+        }
+    }
+
+    # check number of nodes
+    if { [string is boolean ${ref_nb_nodes}] } {
+        if { ${cur_nb_nodes} <= 0 && ${ref_nb_nodes} } {
+            puts "Error: Number of nodes is equal to 0"
+        }
+    } else {
+        if {[regexp {!([-0-9.+eE]+)} $ref_nb_nodes full ref_nb_nodes_value]} {
+            if  {${ref_nb_nodes_value} == ${cur_nb_nodes} } {
+                puts "Error: Number of nodes is equal to ${ref_nb_nodes_value} but it should not"
+            }
+        } else {
+            checkreal "Number of nodes" ${cur_nb_nodes} ${ref_nb_nodes} ${tol_abs_nod} ${tol_rel_nod}
+        }
+    }
+
+    # check deflection
+    if { [string is boolean ${ref_deflection}] } {
+        if { ${cur_deflection} <= 0 && ${ref_deflection} } {
+            puts "Error: Maximal deflection is equal to 0"
+        }
+    } else {
+        checkreal "Maximal deflection" ${cur_deflection} ${ref_deflection} ${tol_abs_defl} ${tol_rel_defl}
+    }
+
+    if { ${max_defl} != -1 && ${cur_deflection} > ${max_defl} } {
+        puts "Error: Maximal deflection is too big"
+    }
+}
+
+help checkplatform {
+  Return name of current platform if no options are given.
+
+  Use: checkplatform [options...]
+  Allowed options are:
+    -windows : return 1 if current platform is 'Windows', overwise return 0
+    -linux   : return 1 if current platform is 'Linux', overwise return 0
+    -osx     : return 1 if current platform is 'MacOS X', overwise return 0
+
+  Only one option can be used at once.
+  If no option is given, procedure will return the name of current platform.
+}
+proc checkplatform {args} {
+    set check_for_windows false
+    set check_for_linux false
+    set check_for_macosx false
+
+    set options {{"-windows" check_for_windows 0}
+                 {"-linux" check_for_linux 0}
+                 {"-osx" check_for_macosx 0}}
+
+    _check_args ${args} ${options} "checkplatform"
+
+    if { [regexp "indows" $::tcl_platform(os)] } {
+        set current_platform Windows
+    } elseif { $::tcl_platform(os) == "Linux" } {
+        set current_platform Linux
+    } elseif { $::tcl_platform(os) == "Darwin" } {
+        set current_platform MacOS
+    }
+
+    # no args are given
+    if { !${check_for_windows} && !${check_for_linux} && !${check_for_macosx}} {
+        return ${current_platform}
+    }
+
+    # check usage of proc checkplatform
+    if { [expr [string is true ${check_for_windows}] + [string is true ${check_for_linux}] + [string is true ${check_for_macosx}] ] > 1} {
+        error "Error: wrong usage of command checkplatform, only single option can be used at once"
+    }
+
+    # checking for Windows platform
+    if { ${check_for_windows} && ${current_platform} == "Windows" } {
+        return 1
+    }
+
+    # checking for Mac OS X platforms
+    if { ${check_for_linux} && ${current_platform} == "Linux" } {
+        return 1
+    }
+
+    # checking for Mac OS X platforms
+    if { ${check_for_macosx} && ${current_platform} == "MacOS" } {
+        return 1
+    }
+
+    # current platform is not equal to given as argument platform, return false
+    return 0
+}

src/DrawResources/StandardCommands.tcl

@@ -95,6 +95,7 @@ help help {help pattern, or help command string group, to set help} {DRAW Genera
 # the getsourcefile command in TCL
 #################################################
 
+help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Commands}
 
 proc getsourcefile {{command ""}} {
 
@@ -136,8 +137,6 @@ proc getsourcefile {{command ""}} {
     return [join $out "\n"]
 }
 
-help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Commands}
-
 #################################################
 # whatis
 #################################################
@@ -147,6 +146,8 @@ help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Comm
 #    puts -nonewline $aVarName; puts -nonewline " is a "; puts [dtyp ${aVarName}]
 #}
 
+help whatis "whatis object1 object2 ..." 
+
 proc whatis args {
     set __out_string ""
     foreach i $args {
@@ -159,8 +160,6 @@ proc whatis args {
     return ${__out_string}
 }
 
-help whatis "whatis object1 object2 ..." 
-
 #################################################
 # library, lsource
 #################################################
@@ -195,6 +194,8 @@ proc isgdraw {var} {
     return [isdraw $var]
 }
 
+help directory {directory [pattern], list draw variables} {DRAW Variables management}
+
 proc directory {{joker *}} {
     set res ""
     foreach var [info globals $joker] { 
@@ -203,8 +204,6 @@ proc directory {{joker *}} {
     return $res
 }
 
-help directory {directory [pattern], list draw variables} {DRAW Variables management}
-
 proc lsd {} { exec ls [datadir] }
 
 proc dall {} {
@@ -259,6 +258,8 @@ proc do {var start end args} {
 
 set Draw_DataDir "."
 
+help datadir {datadir [directory]} "DRAW Variables management"
+
 proc datadir {{dir ""}} {
     global Draw_DataDir
     if {$dir != ""} {
@@ -271,7 +272,7 @@ proc datadir {{dir ""}} {
     return $Draw_DataDir
 }
 
-help datadir {datadir [directory]} "DRAW Variables management"
+help save {save variable [filename]} "DRAW Variables management"
 
 proc save {name {file ""}} {
     if {$file == ""} {set file $name}
@@ -282,7 +283,7 @@ proc save {name {file ""}} {
     return [file join $Draw_DataDir $file]
 }
 
-help save {save variable [filename]} "DRAW Variables management"
+help restore {restore filename [variablename]} "DRAW Variables management"
 
 proc restore {file {name ""}} {
     if {$name == ""} {
@@ -295,8 +296,6 @@ proc restore {file {name ""}} {
     return $name
 }
 
-help restore {restore filename [variablename]} "DRAW Variables management"
-
 #################################################
 # misc...
 #################################################
@@ -311,6 +310,7 @@ proc ppcurve {a} {
 # display and donly with jokers
 #################################################
 
+help disp {display variables matched by glob pattern} "DRAW Variables management"
 
 proc disp { args } {
     set res ""
@@ -331,25 +331,7 @@ proc disp { args } {
     return $res
 }
 
-
+help don {display only variables matched by glob pattern} "DRAW Variables management"
-proc donl { args } {
-    set res ""
-    foreach joker $args {
-	if { $joker == "." } {
-             dtyp .
-             set joker [lastrep id x y b]
-	}
-        foreach var [info globals $joker] { 
-	   if { $var == "." } {
-               dtyp .
-               set var [lastrep id x y b]
-	   }
-	   if [isgdraw $var] {lappend res $var}
-        }
-    }
-    uplevel #0 eval donly $res
-    return $res
-}
 
 proc don { args } {
     set res ""
@@ -369,3 +351,92 @@ proc don { args } {
     uplevel #0 eval donly $res
     return $res
 }
+
+help del {unset (remove) variables matched by glob pattern} "DRAW Variables management"
+
+proc del args {
+    set res ""
+    foreach joker [eval concat $args] {
+        if { $joker == "." } {
+            dtyp .
+            set joker [lastrep id x y b]
+        }
+        foreach var [directory $joker] {
+            global $var
+            if ![isprot $var] {
+                lappend res $var; unset $var
+            }
+        }
+    }
+    return $res
+}
+
+help era {erase variables matched by glob pattern} "DRAW Variables management"
+
+proc era args {
+    set res ""
+    foreach joker [eval concat $args] {
+        if { $joker == "." } {
+            dtyp .
+            set joker [lastrep id x y b]
+        }
+        eval lappend res [directory $joker]
+    }
+    if [llength $res] {
+        uplevel \#0 eval erase $res
+    }
+}
+
+# The following commands (definitions are surrounded by if) are
+# available in extended Tcl (Tclx).
+# These procedures are added just to make full-working simulations of them.
+
+if {[info commands lvarpop] == ""} {
+    proc lvarpop args {
+	upvar [lindex $args 0] lvar
+	set index 0
+	set len [llength $lvar]
+	if {[llength $args] > 1} {
+	    set ind [lindex $args 1]
+	    if [regexp "^end" $ind] {
+		set index [expr $len-1]
+	    } elseif [regexp "^len" $ind] {
+		set index $len
+	    } else {set index $ind}
+	}
+	set el [lindex $lvar $index]
+	set newlvar {}
+	for {set i 0} {$i < $index} {incr i} {
+	    lappend newlvar [lindex $lvar $i]
+	}
+	if {[llength $args] > 2} {
+	    lappend newlvar [lindex $args 2]
+	}
+	for {set i [expr $index+1]} {$i < $len} {incr i} {
+	    lappend newlvar [lindex $lvar $i]
+	}
+	set lvar $newlvar
+	return $el
+    }
+}
+
+if {[info commands lmatch] == ""} {
+    proc lmatch args {
+	set mode [switch -- [lindex $args 0] {
+	    -exact {format 0}
+	    -glob {format 1}
+	    -regexp {format 2}}]
+	if {$mode == ""} {set mode 1} else {lvarpop args}
+	if {[llength $args] < 2} {puts "usage: lmatch ?mode? list pattern";return}
+	set list [lindex $args 0]
+	set pattern [lindex $args 1]
+	set res {}
+	foreach a $list {
+	    if [switch $mode {
+		0 {expr [string compare $a $pattern] == 0}
+		1 {string match $pattern $a}
+		2 {regexp $pattern $a}}] {lappend res $a}
+	}
+	return $res
+    }
+}