00001 # Copyright (C) 1997-2004 The CDG Team <cdg@nats.informatik.uni-hamburg.de> 00002 # 00003 # This file is free software; as a special exception the author gives 00004 # unlimited permission to copy and/or distribute it, with or without 00005 # modifications, as long as this notice is preserved. 00006 # 00007 # This program is distributed in the hope that it will be useful, but 00008 # WITHOUT ANY WARRANTY, to the extent permitted by law; without even the 00009 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00010 00011 ## ---------------------------------------------------------------------------- 00012 ## \file textutils.tcl 00013 ## This file contains some arbitrary usefull textutilities, mainly used in 00014 ## the CdgShell. 00015 ## 00016 ## \author Michael Daum 00017 ## 00018 ## $Id: textutils.tcl,v 1.8 2004/09/06 13:40:54 micha Exp $ 00019 ## ---------------------------------------------------------------------------- 00020 00021 ##----------------------------------------------------------------------------- 00022 ## execute a script on every match in a text widget. 00023 ## \param w a text widget 00024 ## \param from the starting position from which to scan the text widget 00025 ## \param to the ending position from which to scan the text widget 00026 ## \param pattern the regular expression pattern to be matched 00027 ## \param script a pice of code executed in the callers context 00028 ##----------------------------------------------------------------------------- 00029 proc forAllMatches {w from to pattern script} {; ## \type TextWidget, Index, Index, TclString, TclCommand 00030 for {set i $from} {$i < $to} {incr i} { 00031 $w mark set last $i.0 00032 while {[regexp -indices $pattern [$w get last "last lineend"] indices]} { 00033 00034 $w mark set first "last + [lindex $indices 0] chars" 00035 $w mark set last "last + 1 chars + [lindex $indices 1] chars" 00036 uplevel $script 00037 } 00038 } 00039 } 00040 00041 ##----------------------------------------------------------------------------- 00042 ## filter out items from a TclList. 00043 ## \param list a TclList 00044 ## \param pattern a regular expression pattern to be matched on each list item 00045 ## \returns a new TclList only consisting of the items matching the \c pattern 00046 ##----------------------------------------------------------------------------- 00047 proc lfilter {list pattern} {; ## \type TclList, TclString 00048 set result "" 00049 foreach element $list { 00050 if {[regexp $pattern $element]} { 00051 lappend result $element 00052 } 00053 } 00054 return $result 00055 } 00056 00057 00058 ## ---------------------------------------------------------------------------- 00059 ## compare strings intelligently like ls -v does 00060 ## ---------------------------------------------------------------------------- 00061 proc smartCompare {a b} {; ## \type TclString, TclString 00062 00063 while {$a != "" && $b != ""} { 00064 00065 # remove common prefixes (except numbers) 00066 while {[string index $a 0] == [string index $b 0]} { 00067 if {[regexp {^[0-9]} $a]} { 00068 break 00069 } 00070 regsub {^.} $a "" a 00071 regsub {^.} $b "" b 00072 } 00073 00074 # if numbers follow, compare the numbers 00075 if {[regexp {^[0-9]+} $a numa] && [regexp {^[0-9]+} $b numb]} { 00076 # unequal numbers found? 00077 00078 # have to prefix 1 here so expr won't choke on numbers like `028' 00079 if {[expr "1$numa" < "1$numb"]} { 00080 return -1 00081 } 00082 if {[expr "1$numa" > "1$numb"]} { 00083 return 1 00084 } 00085 # remove equal numbers 00086 regsub {^[0-9]+} $a "" a 00087 regsub {^[0-9]+} $b "" b 00088 continue 00089 } else { 00090 # compare normally 00091 return [string compare $a $b] 00092 } 00093 } 00094 return 0; 00095 } 00096 00097 ## ---------------------------------------------------------------------------- 00098 ## \{ 00099 ## \name Distances between line segments 00100 ## 00101 ## The following code to compute distances between line segments and 00102 ## points stolen shamelessly from Rory Daulton (rorydaulton@email.com), 00103 ## who posted it to delphi-talk@elists.org. 00104 ## ---------------------------------------------------------------------------- 00105 00106 ## ---------------------------------------------------------------------------- 00107 ## Convert two directed line segments, starting from the same 00108 ## point, to vectors 00109 ## ---------------------------------------------------------------------------- 00110 proc segments_to_vectors {ex0 ey0 ex1 ey1 x y} {; ## \type TclNumber, TclNumber, TclNumber, TclNumber, TclNumber, TclNumber 00111 00112 set x1 [expr $ex1 - $ex0] 00113 set y1 [expr $ey1 - $ey0] 00114 set x2 [expr $x - $ex0] 00115 set y2 [expr $y - $ey0] 00116 00117 return [list $x1 $y1 $x2 $y2] 00118 00119 } 00120 00121 ## ---------------------------------------------------------------------------- 00122 ## Find the dot product of two vectors 00123 ## ---------------------------------------------------------------------------- 00124 proc dot {x0 y0 x1 y1} {; ## \type TclNumber, TclNumber, TclNumber, TclNumber 00125 return [expr $x0 * $x1 + $y0 * $y1] 00126 } 00127 00128 ## ---------------------------------------------------------------------------- 00129 ## Find the length of a line segment 00130 ## ---------------------------------------------------------------------------- 00131 proc segment_length {x0 y0 x1 y1} {; ## \type TclNumber, TclNumber, TclNumber, TclNumber 00132 return [expr sqrt (pow($x0-$x1, 2) + pow($y0-$y1, 2))] 00133 } 00134 00135 ## ---------------------------------------------------------------------------- 00136 ## Calculate the signed area of the parallelogram that is formed by 00137 ## two vectors (by the origin and two given points). 00138 ## ---------------------------------------------------------------------------- 00139 proc par_area {x1 y1 x2 y2} {; ## \type TclNumber, TclNumber, TclNumber, TclNumber 00140 return [expr $x1 * $y2 - $y1 * $x2] 00141 } 00142 00143 ## ---------------------------------------------------------------------------- 00144 ## Give distance of a point from a line segment. 00145 ## ---------------------------------------------------------------------------- 00146 proc point_segment_distance {x y ex0 ey0 ex1 ey1} {; ## \type TclNumber, TclNumber, TclNumber, TclNumber, TclNumber, TclNumber 00147 00148 # convert the points to vectors 00149 scan [segments_to_vectors $ex0 $ey0 $ex1 $ey1 $x $y]\ 00150 "%f %f %f %f" svx svy pvx pvy 00151 00152 # use the dot product to check the angles, to decide whether to use the 00153 # end points or a point in the segment 00154 set dp [dot $svx $svy $pvx $pvy] 00155 00156 if {$dp <= 0} { 00157 00158 # angle at segment start is not acute: use distance from point to 00159 # segment's start 00160 set result [expr sqrt ( $pvx*$pvx + $pvy*$pvy) ] 00161 00162 } else { 00163 00164 set sl [expr $svx*$svx + $svy*$svy] 00165 if {$dp >= $sl} { 00166 00167 # angle at segment end is not acute: use distance from point to 00168 # segment's end 00169 set result [segment_length $x $y $ex1 $ey1] 00170 } else { 00171 00172 # both angles are acute: use distance from point to the entire line 00173 set result [expr abs( [par_area $svx $svy $pvx $pvy] / sqrt( $sl ))] 00174 } 00175 } 00176 00177 return $result 00178 00179 } 00180 ## ---------------------------------------------------------------------------- 00181 ## \} end if chapter "Distances of line segments" 00182 ## ----------------------------------------------------------------------------