author | A.M. Thurnherr <athurnherr@yahoo.com> |
Sat, 24 Jul 2021 09:38:16 -0400 | |
changeset 46 | 70e566505a12 |
parent 40 | c1803ae2540f |
child 47 | dde46143288c |
permissions | -rw-r--r-- |
0 | 1 |
#!/usr/bin/perl |
2 |
#====================================================================== |
|
3 |
# A N T S U T I L S . P L |
|
4 |
# doc: Fri Jun 19 23:25:50 1998 |
|
40 | 5 |
# dlm: Fri Apr 5 16:21:54 2019 |
0 | 6 |
# (c) 1998 A.M. Thurnherr |
40 | 7 |
# uE-Info: 106 55 NIL 0 0 70 10 2 4 NIL ofnI |
0 | 8 |
#====================================================================== |
9 |
||
10 |
# Miscellaneous auxillary functions |
|
11 |
||
12 |
# HISTORY: |
|
13 |
# Mar 08, 1999: - added &antsFunUsage() |
|
14 |
# Mar 20, 1999: - added &fnr() |
|
15 |
# - BUG &numberp() returned TRUE on "sigma2" |
|
16 |
# Mar 21, 1999: - added semantics of &antsFunUsage() to specify min |
|
17 |
# args on negative number |
|
18 |
# Mar 22, 1999: - added round(); NB: there's a BUG: |
|
19 |
# int(2.155*10**2+0.5)/100 returns 215!!! |
|
20 |
# Jul 31, 1999: - added &cardinalp() and plugged into &fnr() |
|
21 |
# - change &numberp() to conform with &antsFloatArg() |
|
22 |
# Sep 13, 1999: - added &SQR() |
|
23 |
# - removed "" from valid numbers |
|
24 |
# Sep 18, 1999: - added &integerp() |
|
25 |
# - added typechecking to &antsFunUsage() |
|
26 |
# Sep 20, 1999: - cosmetics |
|
27 |
# Aug 24, 2000: - added #include directive to Description files |
|
28 |
# - added stringlengths to &antsFunUsage() |
|
29 |
# Aug 28, 2000: - added str2num to remove leading 0es & lead/trail spcs |
|
30 |
# - changed opt_P to opt_A |
|
31 |
# Aug 29, 2000: - added &antsRequireParam() |
|
32 |
# Sep 01, 2000: - added prefix as 2nd arg to #include directive |
|
33 |
# - disallow <> in #include directive |
|
34 |
# - debugged &str2num() |
|
35 |
# Sep 03, 2000: - allowed for %param to pass through fnr w/o error check |
|
36 |
# Sep 05, 2000: - str2num always kills leading/trailing spaces |
|
37 |
# Sep 19, 2000: - added interpretation to ./ to #include |
|
38 |
# - inherit prefix for chained inclusion (do not chain, however) |
|
39 |
# Nov 25, 2000: - backslashed leading + in regexp to increase portability |
|
40 |
# May 29, 2001: - adapted &antsNumbers() to handle %PARAMs |
|
41 |
# - added &antsVal() |
|
42 |
# Jul 6, 2001: - added degree notation to str2num() |
|
43 |
# Jul 12, 2001: - made $# notation 1-relative (awk, shell) |
|
44 |
# Jul 15, 2001: - added field name to Description open error |
|
45 |
# Jul 16, 2001: - added &localFnr() |
|
46 |
# Jul 19, 2001: - added &croak() |
|
47 |
# Aug 1, 2001: - BUG: numberp() returned false on "-.360" |
|
48 |
# May 7, 2002: - BUG: numberp() returned true on "." |
|
49 |
# Mar 8, 2003: - changed Description to Layout |
|
50 |
# Dec 7, 2005: - antsFName -> antsLayout (not tested) |
|
51 |
# Dec 8, 2005: - Version 3.2 (see [HISTORY]) |
|
52 |
# Dec 12, 2005: - BUG: &outFnr() was broken |
|
53 |
# - BUG: [Layout] overrode local #FIELDS# |
|
54 |
# Dec 23, 2005: - replaced defined(@array) (c.f. perlfunc(1)) |
|
55 |
# Jan 2, 2006: - changed numberp to allow for multiple args |
|
56 |
# - changed right back |
|
57 |
# Jan 9, 2006: - BUG: fnrNoErr() had not increased $antsBufNFields on |
|
58 |
# import of an externally defined field |
|
59 |
# Jan 10, 2006: - added &antsLoadModel() |
|
60 |
# Jan 12, 2006: - removed -A support |
|
61 |
# Jan 13: 2006: - BUG: str2num(3.00) did not yield 3 |
|
62 |
# Jul 1, 2006: - added isNaN (from perlfunc(1)) |
|
63 |
# - changed numberp() according to perldata(1) |
|
64 |
# Jul 24, 2006: - added $PRACTICALLY_ZERO, &equal() |
|
65 |
# Aug 23, 2006: - improved model loading (& added model w. params) |
|
66 |
# Aug 24, 2006: - made 2nd argument of round() optional |
|
67 |
# - added frac() |
|
68 |
# May 11, 2007: - added Floor(), Ceil() |
|
69 |
# Oct 17, 2007: - added default field names (w. caching) to &antsFunUsage() |
|
70 |
# Oct 18, 2007: - added support for optional parameters |
|
71 |
# Oct 19, 2007: - generalized antsFunUsage to allow default %PARAMs |
|
72 |
# - BUG: make sure usage is printed in abc when called with |
|
73 |
# wrong # of args |
|
74 |
# Nov 14, 2007: - made optional arguments to round, Floor, Ceil more intuitive |
|
75 |
# Dec 19, 2007: - added &numbersp() |
|
76 |
# Mar 2, 2008: - adapted fnr to partial matches |
|
77 |
# Mar 4, 2008: - added $antsFnrExactMatch flag |
|
78 |
# - BUG: couldn't select f1 if there is also an f10 |
|
79 |
# Mar 26, 2008: - BUG: abbreviated field names were imported from external |
|
80 |
# Layout |
|
81 |
# Mar 27, 2008: - added %pi |
|
82 |
# Mar 28, 2008: - move %pi to [argtest]; when set here filediff -e bombs |
|
83 |
# Apr 15, 2008: - added &log10() |
|
84 |
# Apr 16, 2008: - MAJOR CHANGE: suppress croak() STDOUT error output on -Q |
|
85 |
# Apr 29, 2008: - added &ismember() |
|
86 |
# Jun 11, 2008: - adder perl 5.8.8 bug workaround (0*-0.1 = -0) |
|
87 |
# Nov 12, 2008: - added opt_T |
|
88 |
# Mar 21, 2009: - added debug() |
|
89 |
# Nov 17, 2009: - added listAllRecs flag for list(1) |
|
90 |
# May 12, 2010: - BUG: round() did not work correctly for -ve numbers |
|
12
58c5aa230550
just before adding new special arg 'prefix(file)suffix'
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
6
diff
changeset
|
91 |
# May 21, 2011: - added support for $antsFnrNegativeOk |
0 | 92 |
# Nov 11, 2011: - added exact flag to fnrNoErr() |
93 |
# Feb 13, 2012: - BUG: failure to specify exact flag resulted in ignoring antsFnrExactMatch |
|
94 |
# - BUG: fnrNoErr disregarded exact flag for external layouts |
|
1 | 95 |
# May 16, 2012: - adapted to V5.0 |
96 |
# May 31, 2012: - changed ismember() semantics for use in psSamp |
|
3 | 97 |
# Jun 12, 2012: - added &compactList() |
4
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
98 |
# Dec 17, 2012: - added default to antsLoadModel() |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
99 |
# Sep 5, 2013: - FINALLY: added $pi |
6 | 100 |
# May 23, 2014: - made ismember understand "123,1-10" |
12
58c5aa230550
just before adding new special arg 'prefix(file)suffix'
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
6
diff
changeset
|
101 |
# Jul 22, 2014: - removed support for antsFnrNegativeOk |
20 | 102 |
# May 18, 2015: - added antsFindParam() |
103 |
# Jun 21, 2015: - added antsParam(), modified antsRequireParam() |
|
29
f41d125405a6
version after ECOGIG EN586 cruise
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
20
diff
changeset
|
104 |
# May 12, 2016: - added &div2() to prevent division by zero errors |
39 | 105 |
# Apr 5, 2019: - disabled weird line of code in antsFunUsage() (see comment) |
106 |
# - improved error messages in antsFunUsage() |
|
107 |
# - BUG: antsFunUsage did not work with -ve argc (variable argument funs) |
|
108 |
# Aug 30, 2019: - BUG: antsLoadModel() did not respect $ANTS |
|
0 | 109 |
|
110 |
# fnr notes: |
|
111 |
# - matches field names starting with the string given, i.e. "sig" is |
|
112 |
# really "^sig" |
|
113 |
# - if exact match is desired, a $ can be appended to the field name |
|
114 |
# - following regexp meta chars are auto-quoted: . |
|
115 |
||
116 |
#---------------------------------------------------------------------- |
|
117 |
# Flags |
|
118 |
#---------------------------------------------------------------------- |
|
119 |
||
120 |
$antsFnrExactMatch = 0; # set to force exact match, e.g. for antsNewField* [antsutils.pl] |
|
121 |
||
122 |
#---------------------------------------------------------------------- |
|
123 |
# Error-Exit |
|
124 |
#---------------------------------------------------------------------- |
|
125 |
||
126 |
sub croak($) |
|
127 |
{ |
|
128 |
print("#ANTS#ERROR# @_[0]") unless (-t 1 || $opt_Q); |
|
129 |
die(@_[0]); |
|
130 |
} |
|
131 |
||
132 |
#---------------------------------------------------------------------- |
|
133 |
# Number-related funs |
|
134 |
#---------------------------------------------------------------------- |
|
135 |
||
4
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
136 |
$pi = 3.14159265358979; # from $PI in [libvec.pl] |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
137 |
|
0 | 138 |
$PRACTICALLY_ZERO = 1e-9; |
139 |
$SMALL_AMOUNT = 1e-6; |
|
140 |
||
141 |
sub numberp(@) |
|
142 |
{ return $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; } |
|
143 |
||
144 |
sub numbersp(@) |
|
145 |
{ |
|
146 |
foreach my $n (@_) { |
|
147 |
return undef unless numberp($n); |
|
148 |
} |
|
149 |
return 1; |
|
150 |
} |
|
151 |
||
152 |
sub equal($$) |
|
153 |
{ return (@_ >= 2) && (abs($_[0]-$_[1]) < $PRACTICALLY_ZERO); } |
|
154 |
||
29
f41d125405a6
version after ECOGIG EN586 cruise
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
20
diff
changeset
|
155 |
sub div2($$) |
f41d125405a6
version after ECOGIG EN586 cruise
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
20
diff
changeset
|
156 |
{ return $_[1] ? $_[0]/$_[1] : inf; } |
f41d125405a6
version after ECOGIG EN586 cruise
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
20
diff
changeset
|
157 |
|
1 | 158 |
#---------------------------------------------------------------------- |
0 | 159 |
# check whether given val is member of a set |
1 | 160 |
# - set can either be an array or a comma-separated string |
161 |
#---------------------------------------------------------------------- |
|
162 |
||
0 | 163 |
sub ismember($@) |
164 |
{ |
|
165 |
my($val,@set) = @_; |
|
1 | 166 |
@set = split(',',$set[0]) |
167 |
if (@set == 1 && !numberp($set[0])); |
|
0 | 168 |
for (my($i)=0; $i<@set; $i++) { |
1 | 169 |
if (numberp($val) && numberp($set[$i])) { |
170 |
return 1 if ($val == $set[$i]); |
|
6 | 171 |
} elsif (numberp($val) && ($set[$i] =~ m{-}) && numberp($`) && numberp($')) { |
172 |
return 1 if (ismember($val,$`..$')); |
|
1 | 173 |
} else { |
174 |
return 1 if ($val eq $set[$i]); |
|
175 |
} |
|
0 | 176 |
} |
177 |
return undef; |
|
178 |
} |
|
179 |
||
180 |
sub isnan($) # perlfunc(1) |
|
181 |
{ return $_[0] != $_[0]; } |
|
182 |
||
183 |
sub cardinalp($) |
|
184 |
{ return $_[0] =~ /^\+?\d+$/; } |
|
185 |
||
186 |
sub integerp($) |
|
187 |
{ return $_[0] =~ /^[+-]?\d+$/; } |
|
188 |
||
189 |
sub antsNumbers(@) |
|
190 |
{ |
|
191 |
my($n); |
|
192 |
foreach $n (@_) { |
|
193 |
return 0 unless (&numberp(&antsVal($n))); |
|
194 |
} |
|
195 |
return 1; |
|
196 |
} |
|
197 |
||
198 |
sub round(@) |
|
199 |
{ |
|
200 |
my($accuracy) = defined($_[1]) ? $_[1] : 1; |
|
201 |
return $_[0] >= 0 ? int($_[0] / $accuracy + 0.5) * $accuracy |
|
202 |
: int($_[0] / $accuracy - 0.5) * $accuracy; |
|
203 |
} |
|
204 |
||
205 |
sub Ceil(@) |
|
206 |
{ |
|
207 |
my($accuracy) = defined($_[1]) ? $_[1] : 1; |
|
208 |
return int($_[0]/$accuracy + 1 - $PRACTICALLY_ZERO) * $accuracy; |
|
209 |
} |
|
210 |
||
211 |
sub Floor(@) |
|
212 |
{ |
|
213 |
my($accuracy) = defined($_[1]) ? $_[1] : 1; |
|
214 |
return int($_[0]/$accuracy) * $accuracy; |
|
215 |
} |
|
216 |
||
217 |
sub frac($) { return $_[0] - int($_[0]); } |
|
218 |
||
219 |
sub SQR($) { return $_[0] * $_[0]; } |
|
220 |
||
221 |
sub str2num($) |
|
222 |
{ |
|
223 |
my($num) = @_; |
|
224 |
$num =~ s/^\s*//; # kill leading spaces |
|
225 |
$num =~ s/\s*$//; # kill trailing spaces |
|
226 |
$num = (substr($1,0,1) eq '-') ? $1-$2/60 : $1+$2/60 # degrees |
|
227 |
if ($num =~ /^([+-]?\d*):(\d*\.?\d*)$/); |
|
228 |
return $num unless (numberp($num)); |
|
229 |
$num =~ s/^(-?)0*/\1/; # kill leading 0es |
|
230 |
$num =~ s/(\.\d*[1-9])0*$/\1/; # kill trailing fractional 0es |
|
231 |
$num =~ s/^\./0./; # ensure digit before decimal pnt |
|
232 |
$num =~ s/^-\./-0./; # ditto |
|
233 |
$num =~ s/\.$/.0/; # ensure digit after decimal pnt |
|
234 |
$num =~ s/^-0(\.0?)$/0/; # 0 is positive |
|
235 |
$num =~ s/\.0+$//; # kill trailing fractional 0es |
|
236 |
return ($num eq "") ? 0 : $num; |
|
237 |
} |
|
238 |
||
239 |
sub fmtNum($$) # format number for output |
|
240 |
{ |
|
241 |
my($num,$fname) = @_; |
|
242 |
||
243 |
$num = 0 if ($num eq '-0'); # perl 5.8.8: 0*-0.1 = -0, which is |
|
244 |
# not handled correctly by all progs |
|
245 |
$num = str2num($num) if ($opt_C); |
|
246 |
if ($opt_G && numberp($num)) { |
|
247 |
$num = sprintf("%d:%04.1f%s", |
|
248 |
abs(int($num)), |
|
249 |
(abs($num)-abs(int($num)))*60, |
|
250 |
$num>=0 ? "N" : "S") |
|
251 |
if (lc($fname) =~ /lat/); |
|
252 |
$num = sprintf("%d:%04.1f%s", |
|
253 |
abs(int($num)), |
|
254 |
(abs($num)-abs(int($num)))*60, |
|
255 |
$num>=0 ? "E" : "W") |
|
256 |
if (lc($fname) =~ /lon/); |
|
257 |
} |
|
258 |
if ($opt_T && numberp($num)) { |
|
259 |
$num = sprintf("\\lat%s{%d}{%04.1f}", |
|
260 |
$num>=0 ? "N" : "S", |
|
261 |
abs(int($num)), |
|
262 |
(abs($num)-abs(int($num)))*60) |
|
263 |
if (lc($fname) =~ /lat/); |
|
264 |
$num = sprintf("\\lon%s{%d}{%04.1f}", |
|
265 |
$num>=0 ? "E" : "W", |
|
266 |
abs(int($num)), |
|
267 |
(abs($num)-abs(int($num)))*60) |
|
268 |
if (lc($fname) =~ /lon/); |
|
269 |
} |
|
270 |
$num = sprintf($opt_M,$num) |
|
271 |
if defined($opt_M) && numberp($num); |
|
272 |
||
273 |
return $num; |
|
274 |
} |
|
275 |
||
3 | 276 |
sub log10 { my $n = shift; return ($n>0) ? log($n)/log(10) : nan; } # c.v. perlfunc(1) |
0 | 277 |
|
278 |
||
279 |
#---------------------------------------------------------------------- |
|
280 |
# Layout-related funs |
|
281 |
#---------------------------------------------------------------------- |
|
282 |
||
283 |
sub fname_match($$) # modified regexp match |
|
284 |
{ |
|
285 |
my($pat,$trg) = @_; |
|
286 |
return ($pat eq $trg) if ($antsFnrExactMatch); # exact match (pre 3.4 behavior) |
|
287 |
# print(STDERR "pattern: $pat -> "); |
|
288 |
$pat =~ s/\./\\\./g; # may want more of these |
|
289 |
$pat =~ s/^/\^/; |
|
290 |
# print(STDERR "$pat\n"); |
|
291 |
return $trg =~ /$pat/; |
|
292 |
} |
|
293 |
||
294 |
sub fnrInFile(...) |
|
295 |
{ |
|
296 |
my($fname,$file,$pref,$found) = @_; |
|
297 |
my($fullName); |
|
298 |
local(*D); |
|
299 |
open(D,$file) || return (undef,$fname); |
|
300 |
while (<D>) { |
|
301 |
s/\s\b/ $pref/g if m/^#\d+/; |
|
302 |
my(@fn) = split; |
|
303 |
if (/^#\s*include\s*([^\s]+)\s*([^\s]+)?/) { |
|
304 |
my($npref) = ($2 eq "") ? $pref : $2; |
|
305 |
if (substr($1,0,2) eq "./") { |
|
306 |
my($dirname) = $file; |
|
307 |
$file = $1; |
|
308 |
$dirname =~ s@[^/]+$@@; |
|
309 |
$file = $dirname . $file; |
|
310 |
} else { |
|
311 |
$file = $1; |
|
312 |
} |
|
313 |
($found,$fullName) = &fnrInFile($fname,$file,$npref,$found); |
|
314 |
} |
|
315 |
next unless ($fn[0] =~ /^#\d+$/); |
|
316 |
for (my($i)=1; $i<=$#fn; $i++) { |
|
317 |
close(D),return ($1,$fname) |
|
318 |
if (/^#(\d+)\b.*\b$fname\b/); |
|
319 |
} |
|
320 |
for (my($i)=1; $i<=$#fn; $i++) { |
|
321 |
next unless fname_match($fname,$fn[$i]); |
|
322 |
croak("$0: $fname matches multiple fields in Layout files\n") |
|
323 |
if defined($found); |
|
324 |
$fullName = $fn[$i]; |
|
325 |
($found) = ($fn[0] =~ /^#(\d+)/); |
|
326 |
} |
|
327 |
} |
|
328 |
close(D); |
|
329 |
return ($found,$fullName); |
|
330 |
} |
|
331 |
||
332 |
sub localFnr($@) |
|
333 |
{ |
|
334 |
my($fnm,@layout) = @_; |
|
335 |
my($i,$fnr); |
|
336 |
||
337 |
# print(STDERR "finding $fnm...\n"); |
|
338 |
croak("$0: illegal 0-length field name\n") |
|
339 |
if ($fnm eq ""); |
|
340 |
return $fnm if ($fnm =~ /^%/); |
|
341 |
if ($fnm =~ /^\$/) { |
|
342 |
croak("$0: invalid field identifier \$$'\n") |
|
343 |
unless (cardinalp($')); |
|
344 |
return $' - 1; |
|
345 |
} |
|
346 |
my($i,$found); |
|
347 |
if (@layout) { |
|
348 |
for ($i=0; $i<=$#layout; $i++) { |
|
349 |
return $i if ($layout[$i] eq $fnm); |
|
350 |
} |
|
351 |
for ($i=0; $i<=$#layout; $i++) { |
|
352 |
next unless fname_match($fnm,$layout[$i]); |
|
353 |
croak("$0: $fnm matches multiple fields ($layout[$found],$layout[$i],...)\n") |
|
354 |
if defined($found); |
|
355 |
$found = $i; |
|
356 |
} |
|
357 |
} else { |
|
358 |
for ($i=0; $i<=$#antsLayout; $i++) { |
|
359 |
return $i if ($antsLayout[$i] eq $fnm); |
|
360 |
} |
|
361 |
for ($i=0; $i<=$#antsLayout; $i++) { |
|
362 |
next unless fname_match($fnm,$antsLayout[$i]); |
|
363 |
croak("$0: $fnm matches multiple fields ($antsLayout[$found],$antsLayout[$i],...)\n") |
|
364 |
if defined($found); |
|
365 |
$found = $i; |
|
366 |
} |
|
367 |
} |
|
368 |
return $found; |
|
369 |
} |
|
370 |
||
371 |
sub fnrNoErr($) |
|
372 |
{ |
|
373 |
my($fnm,$exact) = @_; |
|
374 |
||
375 |
my($tmp) = $antsFnrExactMatch; |
|
376 |
$antsFnrExactMatch = $exact if defined($exact); |
|
377 |
my($fnr) = &localFnr($fnm); |
|
378 |
$antsFnrExactMatch = $tmp; |
|
379 |
||
380 |
my($fullName); |
|
381 |
||
382 |
return $fnr if defined($fnr); # internal layout |
|
383 |
||
384 |
my($tmp) = $antsFnrExactMatch; |
|
385 |
$antsFnrExactMatch = $exact if defined($exact); |
|
386 |
($fnr,$fullName) = &fnrInFile($fnm,"Layout",""); # external [Layout] |
|
387 |
$antsFnrExactMatch = $tmp; |
|
388 |
||
389 |
return undef unless defined($fnr); |
|
390 |
return undef # [Layout] cannod override |
|
391 |
if (defined($antsLayout[$fnr]) && # local definition |
|
392 |
!fname_match($fnm,$antsLayout[$fnr])); |
|
393 |
||
394 |
$antsLayout[$fnr] = $fullName if defined($fullName);# found -> add to local |
|
395 |
$antsBufNFields = $fnr+1 # can happen on externally |
|
396 |
if ($antsBufNFields < $fnr+1); # ... defined fields |
|
397 |
return($fnr); |
|
398 |
} |
|
399 |
||
400 |
sub fnr(@) |
|
401 |
{ |
|
402 |
my(@fnm) = @_; |
|
403 |
my($f,@fnr); |
|
404 |
for ($f=0; $f<=$#fnm; $f++) { |
|
405 |
$fnr[$f] = &fnrNoErr($fnm[$f]); |
|
406 |
next if defined($fnr[$f]); # normal case -> done |
|
407 |
croak("$0: Unknown field $fnm[$f]\n") |
|
408 |
unless defined($fnr[$f]); |
|
409 |
} |
|
410 |
return(@fnr>1 ? @fnr : $fnr[0]); |
|
411 |
} |
|
412 |
||
413 |
# fnr()-equivalent but checks in output format |
|
414 |
# - only used for -F processing => single argument only |
|
415 |
||
416 |
sub outFnr($) |
|
417 |
{ |
|
418 |
my($fnm) = @_; |
|
419 |
my($f,$fnr,$fullName); |
|
420 |
||
421 |
$fnr = &localFnr($fnm,@antsNewLayout); |
|
422 |
return $fnr if defined($fnr); # normal case -> done |
|
423 |
||
424 |
($fnr,$fullName) = &fnrInFile($fnm,"Layout",""); # look in [Layout] |
|
425 |
croak("$0: Unknown field $fnm\n") |
|
426 |
unless defined($fnr); |
|
427 |
||
428 |
$antsNewLayout[$fnr] = $fullName; |
|
429 |
return $fnr; |
|
430 |
} |
|
431 |
||
432 |
#---------------------------------------------------------------------- |
|
433 |
# model-loading funs |
|
434 |
#---------------------------------------------------------------------- |
|
435 |
||
4
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
436 |
sub antsLoadModel(...) |
0 | 437 |
{ |
4
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
438 |
my($opt,$pref,$default) = @_; |
0 | 439 |
my($name); |
440 |
||
441 |
for ($a=0; # find model name |
|
442 |
$a<=$#ARGV && !($ARGV[$a] =~ m/^-\S*$opt$/); |
|
443 |
$a++) { } |
|
4
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
444 |
$name = ($a < $#ARGV) ? $ARGV[$a+1] : $default; # use default if not found |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
445 |
|
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
446 |
return undef unless defined($name); |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
447 |
|
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
448 |
if (-r "$pref.$name") { # load in local directory |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
449 |
&antsInfo("loading local $pref.$name..."); |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
450 |
require "$pref.$name"; |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
451 |
return $name; |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
452 |
} else { # load from ANTSlib |
39 | 453 |
require "$ANTS/$pref.$name"; |
4
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
454 |
return $name; |
ff72b00b4342
after adding $pi and some other stuff
A.M. Thurnherr <athurnherr@yahoo.com>
parents:
3
diff
changeset
|
455 |
} |
0 | 456 |
} |
457 |
||
458 |
sub antsLoadModelWithArgs($$) |
|
459 |
{ |
|
460 |
my($opt,$pref) = @_; |
|
461 |
||
462 |
for ($a=0; # find model name |
|
463 |
$a<=$#ARGV && !($ARGV[$a] =~ m/^-\S*$opt$/); |
|
464 |
$a++) { } |
|
465 |
if ($a < $#ARGV) { # found |
|
466 |
my($name,$args) = ($ARGV[$a+1] =~ /([^\(]+)\(([^\)]*)\)$/); |
|
467 |
$name = $ARGV[$a+1] unless defined($name); |
|
468 |
if (-r "$pref.$name") { # local |
|
469 |
&antsInfo("loading local $pref.$name..."); |
|
470 |
require "$pref.$name"; |
|
471 |
return ($name,split(',',$args)); |
|
472 |
} else { |
|
39 | 473 |
require "$ANTS/$pref.$name"; |
0 | 474 |
return ($name,split(',',$args)); |
475 |
} |
|
476 |
} |
|
477 |
return undef; |
|
478 |
} |
|
479 |
||
480 |
#---------------------------------------------------------------------- |
|
3 | 481 |
# deal with lists of numbers |
482 |
#---------------------------------------------------------------------- |
|
483 |
||
484 |
sub compactList(@) |
|
485 |
{ |
|
486 |
my(@out); |
|
487 |
my($seqStart); |
|
488 |
my($lv) = -9e99; |
|
489 |
||
490 |
foreach my $v (@_) { |
|
491 |
if (numberp($v)) { |
|
492 |
if ($v == $lv+1) { # we're in a sequence |
|
493 |
$seqStart = $lv # record beginning value |
|
494 |
unless defined($seqStart); |
|
495 |
} elsif (defined($seqStart)) { # we've just completed a sequence |
|
496 |
pop(@out); |
|
497 |
push(@out,"$seqStart-$lv"); |
|
498 |
push(@out,$v); |
|
499 |
undef($seqStart); |
|
500 |
} else { # not in a sequence |
|
501 |
push(@out,$v); |
|
502 |
} |
|
503 |
$lv = $v; |
|
504 |
} else { |
|
505 |
push(@out,$v); |
|
506 |
$lv = -9e99; |
|
507 |
} |
|
508 |
} |
|
509 |
if (defined($seqStart)) { # list ends with a sequence |
|
510 |
pop(@out); |
|
511 |
push(@out,"$seqStart-$lv"); |
|
512 |
} |
|
513 |
||
514 |
return @out; |
|
515 |
} |
|
516 |
||
517 |
#---------------------------------------------------------------------- |
|
0 | 518 |
# Misc funs |
519 |
#---------------------------------------------------------------------- |
|
520 |
||
521 |
# return either current field value or PARAM |
|
522 |
sub antsVal($) |
|
523 |
{ return ($_[0] =~ /^%/) ? $P{$'} : $ants_[$ants_][$_[0]]; } |
|
524 |
||
525 |
# USAGE: |
|
526 |
# OLD: argc, type-string, errmesg, params to parse |
|
527 |
# NEW: adds between errmesg & params: |
|
528 |
# 1) reference to static array for caching fnrs |
|
529 |
# 2) list (argc elts) of field names |
|
530 |
||
531 |
# NOTES: |
|
532 |
# - backward compatible |
|
533 |
# - fnr_caching only works with fixed-argc funs |
|
534 |
# - undef field names denote required arguments that must be |
|
535 |
# supplied by the user, e.g. for dn2date |
|
536 |
||
537 |
sub antsFunUsage($$$@) |
|
538 |
{ |
|
539 |
my($argc,$types,$msg,@params) = @_; |
|
540 |
||
541 |
if (ref($params[0]) && @antsLayout>0 && @params<2*$argc+1) { # default params |
|
542 |
my(@newparams); # 2nd test is for abc |
|
39 | 543 |
my($npi) = abs($argc)+1; |
0 | 544 |
|
545 |
$listAllRecs = 1; # special flag for list(1) |
|
546 |
||
547 |
if (@{$params[0]} > 0) { # fnrs already in cache |
|
548 |
for (my($i)=0; $i<@{$params[0]}; $i++) { |
|
549 |
push(@newparams,defined($params[0]->[$i]) ? |
|
550 |
&antsVal($params[0]->[$i]) : |
|
551 |
$params[$npi++]); |
|
552 |
} |
|
553 |
return(@newparams); |
|
554 |
} |
|
555 |
||
39 | 556 |
for (my($i)=1; $i<=abs($argc); $i++) { # fill cache & do tests |
0 | 557 |
if (defined($params[$i])) { |
558 |
push(@{$params[0]},&fnr($params[$i])); |
|
559 |
push(@newparams,&antsVal($params[0]->[$#{$params[0]}])); |
|
560 |
} else { |
|
561 |
croak("usage: $msg\n") unless ($npi <= $#params); |
|
562 |
push(@{$params[0]},undef); |
|
563 |
push(@newparams,$params[$npi++]); |
|
564 |
} |
|
565 |
} |
|
566 |
croak("usage: $msg\n") unless ($npi > $#params); |
|
567 |
||
568 |
@params = @newparams; |
|
39 | 569 |
} elsif (ref($params[0])) { # remove array ref & list of field names |
570 |
splice(@params,0,abs($argc)+1); |
|
0 | 571 |
} |
572 |
||
573 |
if ($argc >= 0) { # argument count |
|
39 | 574 |
croak("usage: $msg [params = @params]\n") unless (@params == $argc); |
0 | 575 |
} else { |
39 | 576 |
croak("usage: $msg [params = @params])\n") unless (@params >= -$argc); |
0 | 577 |
} |
578 |
||
579 |
for (my($i)=0; $i<length($types); $i++) { # type checking |
|
580 |
$_ = substr($types,$i,1); |
|
581 |
SWITCH: { |
|
39 | 582 |
# 4/5/19: The following line of code prevents proper type checking when one of the |
583 |
# arguments is undefined. I do not know under what circumstances the code |
|
584 |
# is required. Therfore I disabled it temporarily. |
|
585 |
# last unless defined($params[$i]); |
|
586 |
&antsNoCardErr(sprintf("argument #%d in $msg (params = @params)",$i+1),$params[$i]),last SWITCH if (/c/); |
|
587 |
&antsNoIntErr(sprintf("argument #%d in $msg",$i+1),$params[$i]),last SWITCH if (/i/); |
|
588 |
&antsNoFloatErr(sprintf("argument #%d in $msg (params = @params)",$i+1),$params[$i]),last SWITCH if (/f/); |
|
589 |
&antsNoFileErr(sprintf("argument #%d in $msg",$i+1),$params[$i]),last SWITCH if (/F/); |
|
0 | 590 |
if (/\d/) { |
591 |
croak("$0: $params[$i] is not a string of length $_\n") |
|
592 |
unless ($_ == length($params[$i])); |
|
593 |
last SWITCH; |
|
594 |
} |
|
595 |
last SWITCH if (/\./); |
|
596 |
croak("&antsFunUsage: illegal type specifier $_\n"); |
|
597 |
} |
|
598 |
} |
|
599 |
||
600 |
return @params; |
|
601 |
} # sub antsfunusage() |
|
602 |
||
20 | 603 |
#---------------------------------------------------------------------- |
604 |
||
0 | 605 |
sub antsRequireParam($) |
606 |
{ |
|
607 |
my($pn) = @_; |
|
20 | 608 |
my($pv) = antsParam($pn); |
0 | 609 |
croak("$0: required PARAM $pn not set\n") |
20 | 610 |
unless defined($pv); |
611 |
return $pv; |
|
612 |
} |
|
613 |
||
614 |
||
615 |
sub antsFindParam($) # find parameter using RE (e.g. antsFindParam('dn\d\d')) |
|
616 |
{ |
|
617 |
my($re) = @_; |
|
618 |
foreach my $k (keys(%P)) { |
|
619 |
return ($k,$P{$k}) if ($k =~ /^$re$/); |
|
620 |
} |
|
621 |
return (undef,undef); |
|
0 | 622 |
} |
623 |
||
20 | 624 |
sub antsParam($) # get parameter value for any ::-prefix |
625 |
{ |
|
626 |
my($pn) = @_; |
|
627 |
my($nfound,$val); |
|
628 |
foreach my $k (keys(%P)) { |
|
629 |
next unless ($k eq $pn) || ($k =~ /::$pn$/); |
|
630 |
$val = $P{$k}; |
|
631 |
$nfound++; |
|
632 |
} |
|
633 |
croak("$0: %PARAM $pn ambiguous\n") |
|
634 |
if ($nfound > 1); |
|
635 |
return $val; |
|
636 |
} |
|
637 |
||
638 |
#---------------------------------------------------------------------- |
|
0 | 639 |
|
640 |
{ my($term); # STATIC |
|
641 |
||
642 |
sub debug($) |
|
643 |
{ |
|
644 |
my($prompt) = @_; |
|
645 |
unless (defined($term)) { # initialize |
|
646 |
use Term::ReadLine; |
|
647 |
$term = new Term::ReadLine $ARGV0; |
|
648 |
} |
|
649 |
do { |
|
650 |
my($expr) = $term->readline("$prompt>"); |
|
651 |
return if ($expr eq 'return'); |
|
652 |
$res = eval($expr); |
|
653 |
if (defined($res)) { # no error |
|
654 |
print(STDERR "$res\n"); |
|
655 |
} else { # error |
|
656 |
print(STDERR "$@"); |
|
657 |
} |
|
658 |
} while (1); |
|
659 |
} |
|
660 |
||
661 |
} # STATIC SCOPE |
|
662 |
||
663 |
1; |