Trailing-Edge
-
PDP-10 Archives
-
decus_20tap4_198111
-
decus/20-0110/bintrp.sai
There are 2 other files named bintrp.sai in the archive. Click here to see a list.
ENTRY;
COMMENT
.SOSPAGE_1
.SEC(BINTRP - PROC10 Boundary Operation)
.index(BINTRP - PROC10 Boundary Operation)
.;
BEGIN "BINTRP.SAI"
COMMENT
P. LEMKIN, B. SHAPIRO, R. GORDON, L. LIPKIN
IMAGE PROCESSING UNIT
DIVISION OF CANCER BIOLOGY AND DIAGNOSIS
NATIONAL CANCER INSTITUTE
NATIONAL INSTITUTES OF HEALTH
BETHESDA, MD 20014
301-496-2394
Oct 12, 1976 - Lemkin del SMSG/DEBUG, and KL oprs
Revised Sept 28, 1976- Shapiro add Xdiff and Ydiff to ICIRT call
Revised Aug 23, 1976 - Lemkin, revised SMSGs
REVISED Aug 6, 1976 - Lemkin, removed AVBOUN-,AVCIR, 1DCON,2DCONV
Revised Aug 4, 1976 - reversed sense of savebox for BDISP
Revised July 7, 1976 - Lemkin - fixed READ
Revised May 28, 1976 - Lemkin - fixed read lookup
Revised May 25, 1976 - Lemkin - added null boundry check
Revised May 24, 1976 - Lemkin - fixed READ err msg
Revised May 19, 1976 - Lemkin made boundary data arrays SAFE
Revised April 27,1976 - Shapiro fixed CIRCLET display
Revised April 20, 1976 - Shapiro fixed parameter
extraction for CIRCLET
Revised April 19, 1976 - Lemkin fixed perimeter
Revised April 10, 1976 - Lemkin added READ/WRITE transforms
Revised April 9, 1976 - Lemkin fixed transforms, LISTTRANSFORM
Revised April 6, 1976 - Lemkin, Shapiro fixed TRANSFORMs
Revised April 5, 1976 - Lemkin, Shapiro fixed CIRCLETRANSFORM
Revised April 2, 1976 - Lemkin, Shapiro fixed READ
Revised April 3, 1976 - Lemkin, fixed interpreter
Revised March 31, 1976 - Lemkin, Shapiro added 1DPAK stuff
Revised March 30, 1976 - Lemkin, Shapiro working on CIRCLE transforms
Revised March 29, 1976 - Lemkin, Shapiro added CIRCLE transforms
March 20, 1976
;
COMMENT
.SS(BINTRP REQUIRE files)
.INDEX(BINTRP REQUIRE files)
.;
Comment
" ================================"
" = R E Q U I R E ="
" ================================"
" The following files are required for use by PROC10.
They all reside in the Image Processing Unit's common user area
";
Comment
note the following REQ's are for debugging and will be removed;
Require "ARINFO.REQ" source!file;
Comment Permanent REQ's;
Require "DEFINE.REQ" source!file;
Require "GETABL.REQ" source!file;
Require "IO.REQ" source!file;
Require "CVT.REQ" source!file;
Require "BOUND.REQ" source!file;
Require "1DPAK.REQ" source!file;
Require "PPAK.REQ" source!file;
Require "DARRAY.REQ" source!file;
Require "SYS:DISPRM.SAI" source!file;
Require "BDISP.REQ" source!file;
Require "HLFTON.REQ" source!file;
" The following require files are used to link this
interpreter with PROC10 itself"
Require "PRCMAX.REQ" source!file;
Require "PRCINV.REQ" source!file;
Require "PRCWRK.REQ" source!file;
Require "LINPAK.REQ" source!file;
COMMENT
.SS(Procedure BND!ASSIGNMENT)
.INDEX(Procedure BND!ASSIGNMENT)
.;
Internal Procedure BND!ASSIGNMENT;
Begin "BND!ASSIGNMENT"
Comment
This mini-interpreter semantically checks the existance
and requirements for output then input operands before
dispatching the operators in a CASE statement.
legal string array definitions need here
----------------------------------------
1. lgl!bops - ordered list of all boundary and boundary
transform operators.
2. lgl!bnames - set of legal boundary names.
3. lgl!tnames - set of legal transform names.
4. lgl!noutput!ops - sub set of all PROC10 operators
which expect null output operand (including transforms
which 'have' expected output operands).
5. lgl!ninput!ops - sub set of all PROC10 operators
which expect null input operand (including transforms
which 'have' expected input operands).
6. lglNoSHIFT!ops - sub set of boundary ops which although
nullary output ops should not be shifted.
7. l!T!output!ops - subset of transfer ops which require
output operand.
8. l!T!input!ops - subset of transfer ops which require
input operands.
;
Define DBB(x) ={ };
comment Define DBB(x) =
{OUTSTR(" x "&" - CMD="&cmd&", sout="&sout&", sip1="&sip1
&", sip2="&sip2&crlf)};
String
s1,
s2,
s3,
s,
ss,
sss;
Integer
Xdiff,
Ydiff,
savebox,
p,
q,
window!size,
number!features,
transform!array!size,
numtriples,
total!num!coefficients,
total!array!size,
num!coefficients,
lower!bound,
upper!bound,
perimeter,
area,
ival,
jval,
bnd!index1,
bnd!index2,
bnd!index3,
trn!index1,
trn!index2,
trn!index3,
index,
i,
j;
Label boundary!a!dispatch;
Real
startangle,
xpos,
ypos,
val;
" [1] Find the boundaryoperator index"
" [0] for now set xpos,ypos to (xp,yp)"
xpos_xp;
ypos_yp;
For index_1 Step 1 Until max!number!boundaryops Do
If equ(cmd, lgl!bops[index])
Then Done;
If db=2 Then Goto boundary!a!dispatch;
" [2] see if have required boundary or transforms are given"
bnd1_bnd2_bnd3_none;
trn1_trn2_trn3_none;
" [2.1] Get the output boundary if the command is not
output nullary"
If Equ(GUESSER(cmd,lgl!noutput!ops),null)
Then
Begin "Get the output boundary"
DBB([2.1] lgl!noutput!ops);
If (bnd3_GET!BOUNDARY(sout))= none Then Return;
bnd!index3_b!index;
" [2.1.1] Get the boundary output title if non-null and not READ"
If not Equ(sout,null) Then
If bnd!title[bnd!index3]=null and
not Equ(cmd,"READ")
Then
If auto!title
Then bnd!title[bnd!index3]_strcopy
Else
SBOUND(bnd!title[bnd!index3],"any",
"Boundary "&sout&" title", sout&" title");
End "Get the output boundary"
Else
Begin "test if shift"
DBB([2.1.2] lglNoSHIFT!ops);
" [2.1.2] Shift the input args right since sout is
really sip1 etc."
If Equ(GUESSER(cmd,lglNoSHIFT!ops),null)
Then
Begin "shift args right"
sip5_sip4;
sip4_sip3;
sip3_sip2;
sip2_sip1;
sip1_sout;
sout_null;
End "shift args right";
End "test if shift";
" [2.2] Get the output Transform if the command is not
output nullary for transforms"
If not Equ(GUESSER(cmd,l!T!output!ops),null)
Then
Begin "Get the output Transform"
DBB([2.2] l!T!output!ops);
If (trn3_GET!TRANSFORM(sout))= none Then Return;
trn!index3_t!index;
" [2.2.1] Get the Transform output title if non-null and
not READ"
If not Equ(sout,null)
Then
If trn!title[trn!index3]=null and
not Equ(cmd,"READ")
Then
If auto!title
Then
trn!title[trn!index3]_strcopy
Else
SBOUND(trn!title[trn!index3],"any",
"Transform "&sout&" title",
sout&" title");
End "Get the output Transform";
" [2.3] Get the input boundary if it is expected."
If Equ(GUESSER(cmd,lgl!ninput!ops),null)
Then
Begin "Get input boundary"
DBB([2.3] lgl!ninput!ops);
If (sip1_GUESSER(sip1,lgl!bnames)) =null
Then Begin "Bad input boundary"
Outstr("Bad input boundary"&crlf);
DEL!BOUNDARY(sout);
Return;
End "Bad input boundary";
bnd1_GET!BOUNDARY(sip1);
bnd!index1_b!index;
End "Get input boundary";
" [2.4] Get the input transform if expected"
If not Equ(GUESSER(cmd,l!T!input!ops),null)
Then
Begin "Get input transform"
DBB([2.4] l!T!input!ops);
If (sip1_GUESSER(sip1,lgl!tnames)) =null
Then Begin "Bad input transform"
Outstr("Bad input transform"&crlf);
DEL!TRANSFORM(sout);
Return;
End "Bad input transform";
trn1_GET!TRANSFORM(sip1);
trn!index1_t!index;
End "Get input transform";
" [2.5] Get the 2nd input boundary if exists"
If not Equ(GUESSER(sip2,lgl!bnames),null)
Then bnd2_GET!BOUNDARY(sip2);
bnd!index2_b!index;
" [2.6] Get the 2nd input transform if exists"
If not Equ(GUESSER(sip2,lgl!tnames),null)
Then trn2_GET!TRANSFORM(sip2);
trn!index2_t!index;
" [2.7] check for null boundary or transform input"
If (bnd1 neq none And PROPS(bnd1)=0) or
(bnd1 neq none And PROPS(bnd1)=0) or
(trn1 neq none And PROPS(trn1)=0) or
(trn2 neq none And PROPS(trn2)=0)
Then
Begin "Null input structure"
Outstr("Null input data structure"&crlf);
Return;
End "Null input structure";
" DISPATCH AND TEST FOR UNARY IN EACH CASE"
boundary!a!dispatch: CASE (index-1) of
Begin "DO boundary operations"
Begin "1 COPY"
COMMENT
.SSS(COPY)
.INDEX(COPY)
.;
ARRTRAN(Datum(bnd3),Datum(bnd1));
PROPS(bnd3)_PROPS(bnd1);
End "1 COPY";
Begin "2 ZERO"
COMMENT
.SSS(ZERO)
.INDEX(ZERO)
.;
ARRCLR(Datum(bnd3));
PROPS(bnd3)_0;
End "2 ZERO";
Begin "3 READ"
COMMENT
.SSS(READ)
.INDEX(READ)
.;
" Get the input file name if specified in sip1
else error msg"
header[0]_sip2;
If not Equ(sip1,null)
Then
Begin "From args"
file!name_sip1&proj!programmer;
" Lookup the file"
s_dev!name;
If s=":" or s=null
Then s_"DSK"
Else s_s[1 to inf-1];
Open(i_Getchan,s,0,0,0,1,j,flag);
Lookup(i,file!name,flag);
Release(i);
file!name_dev!name&file!name;
End "From args"
Else
flag_true;
If flag
Then
Begin "Not found"
Outstr("File not found."&crlf);
Return;
End "Not found";
If bnd3 neq none
Then
Begin "Read boundary"
outstr("Reading in boundary "&file!name&crlf);
If flag_GETBOUNDARY(Datum(bnd3), file!name,
bnd!title[bnd!index3], header,p)
Then
outstr("Bad boundary file header"&
crlf);
" Squish the boundary if successful"
If not flag
Then
Begin "Ok"
If p < 2047
Then
Begin "compress"
Safe Integer array
ia[0:(p/2)+1];
iname_NEW(ia);
ARRTRAN(Datum(iname),
Datum(bnd3));
Del!pname(bnd3);
Delete (bnd3);
New!Pname(iname,sout);
" load the number of points
into props field"
PROPS(iname)_p;
End "compress";
End "Ok";
" print the boundary title"
outstr("Title:"&crlf&bnd!title[bnd!index3]
&crlf);
If not flag
Then Return
Else DEL!BOUNDARY(sout);
End "Read boundary";
If trn3 neq none
Then
Begin "Read transform"
" Get the array size, then setup the array size"
" note that the transform type is kept in the
last data!array word as:
CIRCLETRANSFORM = 0,
FOURIERTRANSFORM = 1,
CENTROIDFOURIERTRANSFORM = 2,
WALSHTRANSFORM = 3,
HISTOGRAM = 4"
header[0]_1;
GETDDTG(file!name,header);
CLOSEINDATA;
" compute the total array size required"
total!array!size_header[3]+(4096*header[2]);
Begin "Inner read"
Integer Array itemp[0:total!array!size-1];
Outstr("Reading transform"&crlf);
If flag_GETARRAY(itemp,file!name,
trn!title[trn!index3], header,
total!array!size)
Then
Outstr("Bad transform file header"&
crlf);
" squish the array into real array if made it"
If not flag
Then
Begin "Compress"
Safe Real Array temp[0:total!array!size-1];
ARRTRAN(temp,itemp);
s_CVIS(trn3,flag);
Del!pname(trn3);
Delete (trn3);
trn3_NEW(temp);
New!Pname(trn3,s);
" Make the triple"
Case header[80] Of
Begin "set transform type"
"0" iname_v!CIRCLEtransform;
"1" iname_v!FOURIERtransform;
"2" iname_v!CENTFOURIERtransform;
"3" iname_v!WALSHtransform;
"4" iname_v!HISTtransform;
End "set transform type";
Make a!transform XOR trn3 EQV iname;
" get the number of tuples"
PROPS(trn3)_header[81];
End "Compress"
Else DEL!TRANSFORM(sout);
End "Inner read";
End "Read transform";
End "3 READ";
Begin "4 WRITE"
COMMENT
.SSS(WRITE)
.INDEX(WRITE)
.;
Integer boundary!length;
If not Equ(sout,null)
Then outfile_dev!name&sout&proj!programmer
Else
While FBOUND(outfile,"any","Output file",
"file") Do
outstr("file " & outfile &
" already exists" & crlf);
If bnd1 neq none
Then
Begin "Write boundary"
If equ(bnd!title[bnd!index1],null)
Then
SBOUND(bnd!title[bnd!index1],"any",
"Boundary title","Title");
outstr("Writing boundary " & outfile & crlf);
boundary!length_PROPS(bnd1);
" Force it to generate a boundary header"
header[0]_0;
PUTBOUNDARY(Datum(bnd1),outfile,
bnd!title[bnd!index1],
header,boundary!length);
End "Write boundary";
If trn1 neq none
Then
Begin "Write TRANSFORM"
If equ(trn!title[trn!index1],null)
Then
SBOUND(bnd!title[bnd!index1],"any",
"Transform title","Title");
outstr("Writing transform " & outfile & crlf);
num!coefficients_PROPS(bnd1);
Foreach iname Such That
a!transform XOR trn1 EQV iname Do Done;
If iname=v!CIRCLEtransform Then ival_0;
If iname=v!FOURIERtransform Then ival_1;
If iname=v!CENTFOURIERtransform Then ival_2;
If iname=v!WALSHtransform Then ival_3;
If iname=v!HISTtransform Then ival_4;
" Force it to generate a transform header"
header[0]_0;
PUTARRAY(Datum(bnd1),outfile,
trn!title[trn!index1],
header,total!array!size,ival,
num!coefficients);
End "Write TRANSFORM";
outstr(crlf);
End "4 WRITE";
Begin "5 DELETE"
COMMENT
.SSS(DELETE)
.INDEX(DELETE)
.;
If bnd3 neq none Then DEL!BOUNDARY(sout);
If trn3 neq none Then DEL!TRANSFORM(sout);
End "5 DELETE";
Begin "6 SHOW"
COMMENT
.SSS(SHOW)
.INDEX(SHOW)
.;
" get the x and y positions is specified"
If not Equ(sip2,null)
Then xpos_Intscan(sip2,flag)
Else
xpos_xp;
If not Equ(sip3,null)
Then ypos_Intscan(sip3,flag)
Else
ypos_yp;
" clean up OMNI numbers if requested"
If (equ(trm!name,"4012") or
Equ(trm!name,"GT40") )
Then
Begin "Omni display"
If (not autoOMNInumber)
Then
Begin "clearing"
Itemvar xxx;
Foreach xxx Such That
xxx In omni!post Do
Begin "kill"
DEL!OMNI!NUMBER(CVIS(
xxx,i));
End "kill";
DREL;
DGET;
End "clearing";
" Setup new OMNI numbers"
npict_GET!OMNI!NUMBER(sip1);
Put bnd1 In omni!post;
End "Omni display";
savebox_false;
BDISP(Datum(bnd1), firstrow, lastrow,
firstcolumn, lastcolumn,
bnd!title[bnd!index1],
PROPS(bnd1), xpos, ypos, trm!name,
savebox, npict);
End "6 SHOW";
Begin "7 AREA"
COMMENT
.SSS(AREA)
.INDEX(AREA)
.;
Integer ip,im,xi,yp,ym;
" The AREA algorithm is taken from a paper by Michael Shamos,
Comp. Sci. Dept. Yale U., 7th ACM Symposium on
The Theory of Computing, 1975."
area_0;
perimeter_PROPS(bnd1);
For i_0 step 1 until perimeter-1 Do
Begin "Compute area"
ip_i+1 Mod perimeter-1;
im_ If (i-1 > 0) Then i-1 Else perimeter-1;
xi_X!BND!FETCH({Datum(bnd1)},i);
ym_Y!BND!FETCH({Datum(bnd1)},im);
yp_Y!BND!FETCH({Datum(bnd1)},ip);
xi_X!BND!FETCH({Datum(bnd1)},i);
area_area+xi*(yp-ym);
End "Compute area";
area_Abs(area)/2;
Outstr("Area("&sip1&")="&cvs(area)&crlf);
End "7 AREA";
Begin "8 PERIMETER"
COMMENT
.SSS(PERIMETER)
.INDEX(PERIMETER)
.;
Integer x, y, xold, yold;
Real perimeter;
Outstr("Number boundary points("&sip1&")="&
cvs(ival_PROPS(bnd1))&crlf);
ival_ival-1;
perimeter_0;
x_X!BND!FETCH(Datum(bnd1),ival);
y_Y!BND!FETCH(Datum(bnd1),ival);
For i_0 step 1 Until ival Do
Begin "compute perimeter"
xold_x;
yold_y;
x_X!BND!FETCH(Datum(bnd1),i);
y_Y!BND!FETCH(Datum(bnd1),i);
If Abs(x-xold)+abs(y-yold) = 2
Then perimeter_perimeter+Sqrt(2.0)
Else perimeter_perimeter+1.0;
End "compute perimeter";
Outstr("Perimeter("&sip1&")="&
cvs(perimeter)&crlf);
End "8 PERIMETER";
Begin "9 CIRCLETRANSFORM"
COMMENT
.SSS(CIRCLETRANSFORM)
.INDEX(CIRCLETRANSFORM)
.;
Own Integer sampling!distance,displayflag,autoflag,oscflag;
" The circle transform computes a set n of curvature
triples: (RadiusOfCurvature,DeflectionAngle,ArcLength), where
n=perimeter/sampling distance."
" check for output Ti and sampling value"
If trn3=none
Then
Begin "bad param"
Outstr("Bad transform name"&crlf);
Return;
End "bad param";
perimeter_PROPS(bnd1);
If (sampling!distance_Intscan(sip2,flag))=0
Then
IBOUND(1,sampling!distance,perimeter/3,
"Sampling distance",null);
oscflag_false;
autoflag_true;
displayflag_false;
If Equ(sip3[1 for 3],"DIS")
Then
Begin "display boundary and test others"
displayflag_true;
If Equ(trm!name,"4023") or
Equ(trm!name,"ASR33")
Then
Begin "not implemented"
Outstr(trm!name&
" not implemented"&crlf);
displayflag_false;
End "not implemented";
If Equ(sip4[1 for 3],"WAI") or
Equ(sip5[1 for 3],"WAI")
Then autoflag_false;
If Equ(sip4[1 for 3],"OSC") or
Equ(sip5[1 for 3],"OSC")
Then oscflag_true;
npict_GET!OMNI!NUMBER(sip1);
If displayflag
Then
Begin "Display"
Put Cvsi(sip1,flag) in
OMNI!post;
savebox_false;
BDISP(Datum(bnd1),firstrow,lastrow,
firstcolumn,lastcolumn,
bnd!title[bnd!index1],
perimeter,
xpos,ypos,
trm!name, savebox, npict);
End "Display";
End "display boundary and test others";
" Go do the transform"
Begin "Inner Circle"
Real Array transform!temp[0:1023];
CIRT(Datum(bnd1),transform!temp,numtriples,
Displayflag,
Autoflag,
Oscflag,
Sampling!distance,
Xpos,
Ypos,
Perimeter,
Lastrow,
Npict);
" compress the array"
Begin "Compress"
Safe Real Array temp[0:3*numtriples-1];
ARRTRAN(temp,transform!temp);
s_CVIS(trn3,flag);
Del!pname(trn3);
Delete (trn3);
trn3_NEW(temp);
New!Pname(trn3,s);
" Make the triple"
Make a!transform XOR trn3 EQV v!CIRCLEtransform;
PROPS(trn3)_numtriples;
End "Compress";
End "Inner Circle";
End "9 CIRCLETRANSFORM";
Begin "10 ICIRCLETRANSFORM"
COMMENT
.SSS(ICIRCLETRANSFORM)
.INDEX(ICIRCLETRANSFORM)
.;
Real val;
If not a!transform XOR trn1 EQV v!circletransform
Then
Begin "wrong transform type"
Outstr("Wrong transform type!"&crlf);
Return;
End "wrong transform type";
If not Equ(sip2,null)
Then val_Realscan(sip2,flag)
Else
BOUND(-360.0,val,360.0,
"Starting angle?",null);
startangle_twopi*(val/360.0);
numtriples_PROPS(trn1);
Begin "Inner icircle"
Integer Array b!temp[0:1024];
Outstr("Reconstructing boundary at("&CVS(xpos)&
","&CVS(ypos)&"), at Angle="&CVF(val)&crlf);
ICIRT(b!temp,Datum(trn1),
numtriples,
perimeter,
startangle,
Xdiff,
Ydiff,
1,
Numtriples,
npict);
" compress the boundary and put in the perim"
Begin "Compress"
Safe Integer Array temp[0:(perimeter/2)+1];
ARRTRAN(temp,b!temp);
s_CVIS(bnd3,flag);
" fix up the omni number"
Del!Pname(bnd3);
Delete (bnd3);
bnd3_NEW(temp);
New!pname(bnd3,s);
PROPS(bnd3)_perimeter;
End "Compress";
End "Inner icircle";
End "10 ICIRCLETRANSFORM";
Begin "11 SUBARCS"
Integer p,q,numtriples;
COMMENT
.SSS(SUBARCS)
.INDEX(SUBARCS)
.;
numtriples_ARRINFO(Datum(trn1),0)/3;
If not Equ(sip2,null)
Then p_Intscan(sip2,flag)
Else
IBOUND(1,p,numtriples,"From arc p",null);
If not Equ(sip3,null)
Then q_Intscan(sip3,flag) Min p
Else
IBOUND(p,q,numtriples,"From arc q",null);
" copy p:q into new array then compress"
j_(3*p)-3;
For i_j step 1 until (3*q)+2 Do
Datum(trn3)[i-j]_Datum(trn1)[i];
" now compress it"
Begin "Compress"
Safe Real Array temp[0:3*(q-p+1)-1];
ARRTRAN(temp,Datum(trn3));
s_CVIS(trn3,flag);
Del!pname(trn3);
Delete (trn3);
trn3_NEW(temp);
New!Pname(trn3,s);
" Make the triple"
Make a!transform XOR trn3 EQV v!CIRCLEtransform;
PROPS(trn3)_q-p+1;
End "Compress";
End "11 SUBARCS";
Begin "12 LISTTRANSFORM"
COMMENT
.SSS(LISTTRANSFORM)
.INDEX(LISTTRANSFORM)
.;
Comment
List the transform data according to its transform type
including the extra trailer information.;
Getformat(p,q);
Setformat(6,7);
If a!transform XOR trn1 EQV v!CIRCLEtransform
Then
Begin "circle"
numtriples_PROPS(trn1);
Outstr("CIRCLE"&crlf);
For i_0 step 3 Until 3*(numtriples-1) Do
Outstr("["&cvs((i/3)+1)&
"](RofC,Dangle,Arclth)="&
CVF(Datum(trn1)[i])&","&
CVF(Datum(trn1)[i+1])&","&
CVF(Datum(trn1)[i+2])&crlf);
Return;
End "circle";
" Note: all of the rest of the transforms except
the circle transform have the following trailer data
starting at j"
If a!transform XOR trn1 EQV v!FOURIERtransform
Then
Begin "fourier"
num!coefficients_PROPS(trn1);
j_2*num!coefficients;
Outstr("FOURIER"&crlf&
"Perimeter of origional boundary ="&
CVS(Datum(trn1)[j])&crlf&
"Lower omega="&cvf(ival_Datum(trn1)[j+1])&
crlf&
"Upper omega="&cvf(Datum(trn1)[j+2])&
crlf);
ival_ival-1;
For i_0 step 2 Until
2*(num!coefficients-1) Do
Outstr("["&CVS(ival_ival+1)&"](r,i)="&
CVF(Datum(trn1)[i])&","&
CVF(Datum(trn1)[i+1])&crlf);
End "fourier";
If a!transform XOR trn1 EQV v!CENTFOURIERtransform
Then
Begin "centfourier"
Outstr("CENTFOURIER"&crlf);
num!coefficients_PROPS(trn1);
j_2*num!coefficients;
Outstr("Original boundary (x0,y0)="&
CVS(Datum(trn1)[j])&","&
CVS(Datum(trn1)[j+1])&crlf&
"Original centroid (xc,yc)="&
CVS(Datum(trn1)[j+2])&","&
CVS(Datum(trn1)[j+3])&crlf&
"Perimeter of origional boundary ="&
CVS(Datum(trn1)[j+4])&crlf&
"# coefficients="&cvf(num!coefficients)&
crlf);
For i_0 step 2 Until
2*(num!coefficients-1) Do
Outstr("["&CVS(i/2)&"](r,i)="&
CVF(Datum(trn1)[i])&","&
CVF(Datum(trn1)[i+1])&crlf);
End "centfourier";
If a!transform XOR trn1 EQV v!WALSHtransform
Then
Begin "Walsh"
num!coefficients_PROPS(trn1);
j_2*num!coefficients;
j_num!coefficients;
Outstr("WALSH"&crlf&
"Original boundary (x0,y0)="&
CVS(Datum(trn1)[j])&","&
CVS(Datum(trn1)[j+1])&crlf&
"Original centroid (xc,yc)="&
CVS(Datum(trn1)[j+2])&","&
CVS(Datum(trn1)[j+3])&crlf&
"Extended perimeter of origional boundary ="&
CVS(Datum(trn1)[j+4])&crlf&
"# coefficients="&cvf(num!coefficients)&
crlf);
For i_0 step 1 Until num!coefficients-1 Do
Outstr("["&CVS(i)&"](r,i)="&
CVF(Datum(trn1)[i])&crlf);
End "Walsh";
If a!transform XOR trn1 EQV v!HISTtransform
Then
Begin "HIST"
Outstr("HISTOGRAM"&crlf);
num!coefficients_PROPS(trn1);
For i_0 step 1 Until num!coefficients-1 Do
Outstr("["&CVS(i)&"](r,i)="&
CVF(Datum(trn1)[i])&crlf);
End "HIST";
Setformat(p,q);
End "12 LISTTRANSFORM";
Begin "14 FOURIERTRANSFORM"
COMMENT
.SSS(FOURIERTRANSFORM)
.INDEX(FOURIERTRANSFORM)
.;
" check for output Ti and omega values"
If trn3=none
Then
Begin "bad param"
Outstr("Bad transform name"&crlf);
Return;
End "bad param";
perimeter_PROPS(bnd1);
If (lower!bound_Intscan(sip2,flag))=0
Then
IBOUND("-inf",lower!bound,"inf",
"Lower bound",null);
If (upper!bound_Intscan(sip3,flag))=0
Then
IBOUND(lower!bound,upper!bound,"inf",
"Upper bound",null);
" Go do the transform"
Begin "Inner Fourier"
Real Array transform!temp[0:1023];
CFOURIER(Datum(bnd1),transform!temp,
lower!bound,
upper!bound,
perimeter,
transform!array!size);
" compress the array"
Begin "Compress"
Safe Real Array temp[0:transform!array!size-1];
ARRTRAN(temp,transform!temp);
s_CVIS(trn3,flag);
Del!pname(trn3);
Delete (trn3);
trn3_NEW(temp);
New!Pname(trn3,s);
" Make the triple"
Make a!transform XOR trn3 EQV v!FOURIERtransform;
PROPS(trn3)_(upper!bound-lower!bound)+1;
End "Compress";
End "Inner Fourier";
End "14 FOURIERTRANSFORM";
Begin "15 IFOURIERTRANSFORM"
COMMENT
.SSS(IFOURIERTRANSFORM)
.INDEX(IFOURIERTRANSFORM)
.;
If not a!transform XOR trn1 EQV v!FOURIERtransform
Then
Begin "wrong transform type"
Outstr("Wrong transform type!"&crlf);
Return;
End "wrong transform type";
i_ARRINFO(Datum(trn1),0)-1;
ival_Datum(trn1)[i-1];
jval_Datum(trn1)[i];
If (lower!bound_Intscan(sip2,flag))=0 or
(ival > lower!bound > jval)
Then
IBOUND(ival,lower!bound,jval,"lower bound",null);
If (upper!bound_Intscan(sip3,flag))=0 or
(lower!bound > upper!bound > jval)
Then
IBOUND(lower!bound,upper!bound,jval,
"upper bound",null);
total!num!coefficients_PROPS(trn1);
Begin "Inner icfourier"
Integer Array b!temp[0:1024];
ICFOURIER(b!temp,Datum(trn1),
total!num!coefficients,
lower!bound,
upper!bound,
perimeter);
" compress the boundary and put in the perim"
Begin "Compress"
Safe Integer Array temp[0:(perimeter/2)+1];
ARRTRAN(temp,b!temp);
s_CVIS(bnd3,flag);
" fix up OMNI number"
Del!Pname(bnd3);
Delete (bnd3);
bnd3_NEW(temp);
New!pname(bnd3,s);
PROPS(bnd3)_perimeter;
End "Compress";
End "Inner icfourier";
End "15 IFOURIERTRANSFORM";
Begin "16 WALSHTRANSFORM"
COMMENT
.SSS(WALSHTRANSFORM)
.INDEX(WALSHTRANSFORM)
.;
" check for output Ti and number coefficients value"
If trn3=none
Then
Begin "bad param"
Outstr("Bad transform name"&crlf);
Return;
End "bad param";
If (num!coefficients_Intscan(sip2,flag))=0
Then
IBOUND(1,num!coefficients,PROPS(bnd1)/2,
"Number coefficients",null);
perimeter_PROPS(bnd1);
" Go do the transform"
Begin "Inner Walsh"
Real Array transform!temp[0:1023];
WALSH(Datum(bnd1),transform!temp,
perimeter,
num!coefficients,
transform!array!size);
" compress the array"
Begin "Compress"
Safe Real Array temp[0:transform!array!size-1];
ARRTRAN(temp,transform!temp);
s_CVIS(trn3,flag);
Del!pname(trn3);
Delete (trn3);
trn3_NEW(temp);
New!Pname(trn3,s);
" Make the triple"
Make a!transform XOR trn3 EQV v!WALSHtransform;
PROPS(trn3)_num!coefficients;
End "Compress";
End "Inner Walsh";
End "16 WALSHTRANSFORM";
Begin "17 IWALSHTRANSFORM"
COMMENT
.SSS(IWALSHTRANSFORM)
.INDEX(IWALSHTRANSFORM)
.;
If not a!transform XOR trn1 EQV v!WALSHtransform
Then
Begin "wrong transform type"
Outstr("Wrong transform type!"&crlf);
Return;
End "wrong transform type";
If (num!coefficients_Intscan(sip2,flag))=0 or
(num!coefficients > PROPS(trn1))
Then
IBOUND(1,num!coefficients,PROPS(trn1),
"Number coefficients?",null);
total!num!coefficients_PROPS(trn1);
Begin "Inner iwalsh"
Integer Array b!temp[0:1024];
IWALSH(b!temp,Datum(trn1),
perimeter,
total!num!coefficients,
num!coefficients,
lastcolumn,
xpos,
ypos);
" compress the boundary and put in the perim"
Begin "Compress"
Safe Integer Array temp[0:(perimeter/2)+1];
ARRTRAN(temp,b!temp);
s_CVIS(bnd3,flag);
" fix up OMNI number"
Del!Pname(bnd3);
Delete (bnd3);
bnd3_NEW(temp);
New!pname(bnd3,s);
PROPS(bnd3)_perimeter;
End "Compress";
End "Inner iwalsh";
End "17 IWALSHTRANSFORM";
Begin "18 --free2--"
COMMENT
.SSS(--free2--)
.INDEX(--free2--)
.;
End "18 --free2--";
Begin "19 --free3--"
COMMENT
.SSS(--free3--)
.INDEX(--free3--)
.;
End "19 --free3--";
Begin "20 CENTFOURIER"
COMMENT
.SSS(CENTFOURIER)
.INDEX(CENTFOURIER)
.;
Own Integer num!coefficients;
" check for output Ti and Number value"
perimeter_PROPS(bnd1);
If trn3=none
Then
Begin "bad param"
Outstr("Bad transform name"&crlf);
Return;
End "bad param";
If (num!coefficients_Intscan(sip2,flag))=0
Then
IBOUND(1,num!coefficients,perimeter,
"Number coefficients",null);
" Go do the transform"
Begin "Inner Cfourier"
Real Array transform!temp[0:1023];
CENTFOURIER(Datum(bnd1),transform!temp,
perimeter,
num!coefficients,
transform!array!size);
" compress the array"
Begin "Compress"
Safe Real Array temp[0:transform!array!size-1];
ARRTRAN(temp,transform!temp);
s_CVIS(trn3,flag);
Del!pname(trn3);
Delete (trn3);
trn3_NEW(temp);
New!Pname(trn3,s);
" Make the triple"
Make a!transform XOR trn3 EQV v!CENTFOURIERtransform;
PROPS(trn3)_num!coefficients;
End "Compress";
End "Inner Cfourier";
End "20 CENTFOURIER";
Begin "21 ICENTFOURIER"
COMMENT
.SSS(ICENTFOURIER)
.INDEX(ICENTFOURIER)
.;
If not a!transform XOR trn1 EQV v!CENTFOURIERtransform
Then
Begin "wrong transform type"
Outstr("Wrong transform type!"&crlf);
Return;
End "wrong transform type";
total!num!coefficients_PROPS(trn1);
If (num!coefficients_Intscan(sip2,flag))=0 or
(num!coefficients > PROPS(trn1))
Then
IBOUND(1,num!coefficients,PROPS(trn1),
"Number coefficients?",null);
total!num!coefficients_PROPS(trn1);
Begin "Inner icentfourier"
Integer Array b!temp[0:1024];
ICENTFOURIER(b!temp,Datum(trn1),
total!num!coefficients,
num!coefficients,
lastcolumn,
xpos,
ypos,
perimeter);
" compress the boundary and put in the perim"
Begin "Compress"
Safe Integer Array temp[0:(perimeter/2)+1];
ARRTRAN(temp,b!temp);
s_CVIS(bnd3,flag);
" fix up OMNI number"
Del!Pname(bnd3);
Delete (bnd3);
bnd3_NEW(temp);
New!pname(bnd3,s);
PROPS(bnd3)_perimeter;
End "Compress";
End "Inner icentfourier";
End "21 ICENTFOURIER";
Begin "22 LISTBOUNDARY"
COMMENT
.SSS(LISTBOUNDARY)
.INDEX(LISTBOUNDARY)
.;
Integer x,y;
perimeter_PROPS(bnd1);
x_X!BND!FETCH({Datum(bnd1)},0);
y_Y!BND!FETCH({Datum(bnd1)},0);
Outstr("First ["&cvs(0)&"](x,y)=("&CVS(x)&
","&CVS(y)&")"&crlf);
x_X!BND!FETCH({Datum(bnd1)},{perimeter-1});
y_Y!BND!FETCH({Datum(bnd1)},{perimeter-1});
Outstr("Last ["&cvs(perimeter)&
"](x,y)=("&CVS(x)&
","&CVS(y)&")"&crlf);
For i_0 step 1 Until perimeter-1 Do
Begin "print boundary"
x_X!BND!FETCH({Datum(bnd1)},i);
y_Y!BND!FETCH({Datum(bnd1)},i);
Outstr("["&cvs(i)&"](x,y)=("&CVS(x)&
","&CVS(y)&")"&crlf);
End "print boundary";
End "22 LISTBOUNDARY";
End "DO boundary operations";
End "BND!ASSIGNMENT";
End "BINTRP.SAI";