(* Multivariate Analysis Package - Data Transformation Module
   Copyright 1985 Douglas L. Anderton.  This program may be
   freely circulated so long as it is not sold for profit
   and any charge does not exceed costs of reproduction *)

Program Transfrm(Input,Output);
Const
   N=100;
Type
   SUBS=1..N;
   RVEC = Array [SUBS] Of Real;
   RVE2 = Array [1..200] Of Real;
   IVEC = Array [SUBS] Of Integer;
   IVE2 = Array [1..200] Of SUBS;
   ST12 = String[12];
   TR = String[79];
   TS = Array [SUBS] of TR;
Var
   dfile, ofile, tfile : Text;
   sel : IVEC;
   sub : IVE2;
   miss, vars, ho : RVEC;
   cns : RVE2;
   dv, fo, t : SUBS;
   i, k, l, nv, nt : Integer;
   trans: TS;

{$I TRANSBUF.LIB}

Procedure openfiles(Var dfile, ofile, tfile:Text; Var fo:SUBS);
Var
   dfl, ofl:String[12];
Begin
   ClrScr; Writeln(' *** TRANSFRM: DATA TRANSFORMATION ***');
   Writeln; Write('Name of the input data file? ');
   Readln(dfl); Assign(dfile,dfl); Reset(dfile);
   Write('Name of output data file (con:/lst: not allowed)? ');
   Readln(ofl);
   If (ofl='CON:') Or (ofl='con:') Then ofl:='CONSOLE.TMP';
   If (ofl='LST:') Or (ofl='lst:') Then ofl:='LIST.TMP';
   initwrite(ofl);
   Write('Name of the transformation file (or con:)? ');
   Readln(dfl); Assign(tfile,dfl); Reset(tfile);
   If (dfl='CON:') Or (dfl='con:') Then fo:=1 Else fo:=0;
   End; (* Of openfiles *)

Procedure selectvar(Var sel:IVEC; Var miss:RVEC; Var nv:Integer; Var dv:SUBS);
Var
  cfile:Text;
  cfl:String[12];
  i,j,f:Integer;
  mis:Real;
  van:String[8];
Begin
   Write('Name of the codebook file (or NONE)? '); Readln(cfl);
   If (cfl<>'NONE') And (cfl<>'none') Then f:=1 Else f:=0;
   If f=1 Then Begin Assign(cfile,cfl); Reset(cfile); End;
   Writeln;
   Write('How many variables in data file? '); Readln(nv);
   Write('Number of variables to use in TRANSFRM? '); Readln(dv);
   For i := 1 To dv Do
     Begin
     Write('Column number for variable ',i,'? '); Readln(sel[i]);
     miss[i]:=-1E37;
     End;
  If f=1 Then Begin
    For j:=1 to nv Do Begin
      mis:=-1E37;
      Readln(cfile,f,van,mis);
      For i:=1 to dv Do
        If f=sel[i] Then Begin
          miss[i]:=mis;
          Writeln('Col: ',sel[i],' Name: ',van,' Missing: ',miss[i]:6);
          End;
      End;
    Close(cfile);
    End;
  End; (* Of selectvar *)

Procedure prmenu2;
Begin
   ClrScr; Writeln(' *** TRANSFRM: DATA TRANSFORMATION ***'); Writeln;
   Writeln('Valid Arithmetic Operators:');
   Writeln('     +         -        *       /       =');
   Writeln('Turbo Pascal Functions Supported:');
   Writeln('     ABS     ARCTAN    COS      EXP     FRAC     INT');
   Writeln('     LN      SIN       SQR      SQRT    ROUND    TRUNC');
   Writeln('     RANDOM');
   Writeln('Nonstandard MAP functions supported:');
   Writeln('     IF      IFS       LAG      NORMAL  POW      REC');
   Writeln('Number Entry:');
   Writeln('     Leading minus allowed (not plus) number must be less than');
   Writeln('     or equal to 11 digits, e.g. .001  12   -.0000005  etc.');
   Writeln;
   Writeln('Note: no check of statements is provided until runtime. [n]');
   Writeln('      refers to the nth variable read, not the nth column.');
   Writeln('      Comments may follow transformations on the same line');
   Writeln('      except END statement.  Functions must be UPPERCASE.');
   Writeln;
   End; (* of prmenu2 *)

Procedure prmenu;
Begin
   ClrScr; Writeln(' *** TRANSFRM: DATA TRANSFORMATION ***'); Writeln;
   Write('Data transformation statements are entered in RPN (reverse');
   Writeln(' polish notation)');
   Write('with blanks separating each operator, constant, or variable.');
   Writeln(' Statements are');
   Write('terminated by ''='' to end  the statement and the variable');
   Writeln(' number  to receive');
   Write('the value.  Variables are referred  to by column number');
   Writeln(' in  brackets ''[n]''.');
   Write('New variables created by  transformations are  added to');
   Writeln(' the data file.  Use');
   Write('successive numbers for new variables (if you read  four');
   Writeln(' variables the first');
   Write('you create should be ''[5]'' etc.)  ''END'' in the first');
   Writeln(' three columns will end');
   Writeln('input of transformations.');
   Writeln;
   Writeln('Examples:');
   Write('   To put the square root of 3.2 times the first variable into');
   Writeln(' the first -');
   Writeln('     ->3.2 [1] * SQRT = [1]');
   Write('   To create a new sixth variable as the natural logarithm of');
   Writeln(' the second');
   Writeln('   divided by the fifth -');
   Writeln('     ->[5] [2] LN / = [6]');
   Writeln('   To recode second variable if between 10 and 50 to value 3 -');
   Writeln('     ->[2] 10 50 3 REC = [2]'); Writeln;
   Writeln('A summary of available operators is displayed during entry.');
   Writeln;
   Write('- Press any key to continue -'); While Not KeyPressed Do;
   ClrScr; prmenu2;
   End; (* Of prmenu *)

Procedure getcase(Var vars:RVEC; sel:IVEC; nv, dv:SUBS; Var dfile:Text);
Var
   i, j:SUBS;
   x:Real;
Begin
   For i := 1 To nv Do
      Begin
      Read(dfile,x);
      For j := 1 To dv Do If (sel[j]=i) Then vars[j] := x;
      End;
   End; (* Of getcase *)

Procedure nextop(temp:TR; Var tstr: ST12; Var sgp:Integer);
Var k,l: SUBS;
Begin
   k:=Pos(' ',Copy(temp,sgp,11));
   tstr:=Copy(temp,sgp,k);
   sgp:=sgp+k;
   End; (* Of nextop *)

Function Tnum(Var t:Char): Boolean;
Begin Tnum:=false;
 If(((t>='0') and (t<='9')) or (t='.')) Then Tnum:=True; End;

Procedure ParseNums(Var trans:TS; Var cns:RVE2; Var sub:IVE2);
Var
   opr: Real;
   i, t, f, cntp, subp: SUBS;
   j, sgp, varn: Integer;
   tstr: ST12;
   temp: TR;
   tstr1: Char;
Begin
   FillChar(cns,6*200,0); FillChar(sub,200,0); cntp:=0; subp:=0;
   i:=1; t:=0;
   While (t=0) Do
     Begin
     sgp:=1; temp:=trans[i]; f:=0;
     While (f<2) Do
       Begin
       nextop(temp,tstr,sgp);
       tstr1:=tstr[1];
       case tstr1 of
         '-':If(Tnum(tstr[2])) Then Begin
               Val(Copy(tstr,2,(Pos(' ',tstr)-1)),opr,j);
               cntp:=cntp+1; cns[cntp]:=-opr; End;
         '[':Begin Val(Copy(tstr,2,(Pos(']',tstr)-2)),varn,j);
               subp:=subp+1; sub[subp]:=varn;
               If(f>0) then f:=2; End;
         'E':If(tstr[2]='N') Then Begin t:=1; f:=2; End;
         '=':f:=1;
         Else {of case check to see if it is a constant}
           If(Tnum(tstr1)) Then Begin
                Val(Copy(tstr,2,(Pos(' ',tstr)-1)),opr,j);
                cntp:=cntp+1; cns[cntp]:=-opr; End;
         End; (* of case *)
       End; (* of this transform *)
     i:=i+1;
     End;
  End; (* Of ParseNums *)

Procedure transform(Var vars, hold, miss:RVEC; cns:RVE2; sub:IVE2;
                    Var dv, t:SUBS; trans:TS);
Var
   op1, op2, op3, op4: Real;
   st: RVEC;
   i, sp, tag, flg: SUBS;
   j, sgp, varn, cntp, subp: Integer;
   tstr: ST12;
   temp: TR;
   tstr1: Char;

Procedure push(ac: Real; Var st:RVEC; Var sp:SUBS);
Begin sp:=sp+1; st[sp]:=ac; End; (* Of push *)

Function pop(Var st:RVEC; Var sp:SUBS): Real;
Begin pop:=st[sp]; sp:=sp-1; End; (* Of pop *)

Procedure nextcnt(Var cntp:Integer; Var cns:RVE2; Var x:Real);
Begin cntp:=cntp+1; x:=cns[cntp]; End;

Procedure nextint(Var subp:Integer; Var sub:IVE2; Var x:Integer);
Begin subp:=subp+1; x:=sub[subp]; End;

Begin (* Of Transform *)
   i:=1; t:=0; flg:=0; tstr:='?'; cntp:=0; subp:=0;
   While ((tstr[1]<>'E') or (tstr[2]<>'N')) and (t=0) Do
      Begin
      FillChar(st,6*N,0);
      sp:=0; sgp:=1; tag:=0; temp:=trans[i];
      While (tag=0) Do
       Begin
       nextop(temp,tstr,sgp);
       tstr1:=tstr[1];
       case tstr1 of
         '=': tag:=4;
         '+': push((pop(st,sp)+pop(st,sp)),st,sp);
         '*': push((pop(st,sp)*pop(st,sp)),st,sp);
         '/': push((pop(st,sp)/pop(st,sp)),st,sp);
         '-': If(Tnum(tstr[2])) Then Begin nextcnt(cntp,cns,op1);
                op1:=-op1; push(op1,st,sp); End
              Else push((pop(st,sp)-pop(st,sp)),st,sp);
         '[':Begin nextint(subp,sub,varn); push(vars[varn],st,sp);
              If(vars[varn]=miss[varn]) Then Begin
                While (tstr[1]<>'=') Do nextop(temp,tstr,sgp); tag:=3; End;
             End;
         'I':If (tstr[3]='S') Then {ifs, if and int}
                If(pop(st,sp)<0.0) Then tag:=2
                Else tag:=5 (* keep record but stop loop *)
              Else If(tstr[3]='T') Then push(Int(pop(st,sp)),st,sp)
              Else If(pop(st,sp) < 0.0) Then tag:=1;
         'E':If(tstr[2]='N') Then tag:=4 {exp and end}
             Else push(Exp(pop(st,sp)),st,sp);
         'L':If(tstr[2]='N') Then push(Ln(pop(st,sp)),st,sp) {ln and lag}
             Else Begin op1:=pop(st,sp); push(hold[varn],st,sp);
                  hold[varn]:=op1; End;
         'P':push(exp(pop(st,sp)*ln(pop(st,sp))),st,sp); {pow}
         'S':If(tstr[2]='Q') Then {sqrt sqr and sin}
               If(tstr[4]='T') Then push(Sqrt(pop(st,sp)),st,sp)
               Else push(Sqr(pop(st,sp)),st,sp)
             Else push(Sin(pop(st,sp)),st,sp);
         'C':push(Cos(pop(st,sp)),st,sp); {cos}
         'A':If(tstr[2]='B') Then push(abs(pop(st,sp)),st,sp) {abs and arctan}
             Else push(ArcTan(pop(st,sp)),st,sp);
         'T':push(Trunc(pop(st,sp)),st,sp); {trunc}
         'F':push(Frac(pop(st,sp)),st,sp); {frac}
         'R':If(tstr[2]='A') Then push(Random,st,sp) {random round and rec}
             Else If(tstr[2]='O') Then push(Round(pop(st,sp)),st,sp)
                  Else Begin
                  op1:=pop(st,sp);op2:=pop(st,sp);
                  op3:=pop(st,sp);op4:=pop(st,sp);
                  If((op3<=op4) and (op4<=op2)) Then push(op1,st,sp)
                    Else push(op4,st,sp); End;
         'N':Begin push(0.0,st,sp); {normal}
            For j:=1 To 12 Do push((pop(st,sp)+Random),st,sp);
            push((pop(st,sp)-6.0),st,sp); End;
         Else {of case check to see if it is a constant}
           If(Tnum(tstr1)) Then Begin nextcnt(cntp,cns,op1);
             push(op1,st,sp); End;
         End; (* of case *)
       End; (* of this transform *)
     If(tstr1='=') Then nextop(temp,tstr,sgp);
     If(tstr[1]='[') Then
        Begin
        nextint(subp,sub,varn);
        If(varn>dv) Then dv:=varn;
        vars[varn]:=pop(st,sp);
        If(tag=3) Then vars[varn]:=-1E37;
        End;
     If(tag=2) Then t:=1;
     i:=i+1;
     End;
  End; (* Of transform *)

Begin (* main *)
   openfiles(dfile,ofile,tfile,fo);
   selectvar(sel,miss,nv,dv);
   (* intialize *)
   nt:=0; Randomize;
   (* build transformations *)
   If (fo=1) Then prmenu;
   Writeln;
   i:=1;
   While i>0 Do
     Begin
     If(fo=1) Then
       Begin
       Writeln; Write(' ->');
       Read(tfile,trans[i]);
       End;
     If(fo<>1) Then
       Begin
       Readln(tfile,trans[i]);
       Writeln(' -> ',trans[i]);
       End;
     trans[i]:=Concat(trans[i],' ');
     If (trans[i][1]='E') Then i:=0 Else i:=i+1;
     End;
   ParseNums(trans,cns,sub);
   (* read and transform *)
   k:=0;
   For i:=1 To dv Do ho[i]:=-1E37;
   While Not EOF(dfile) Do
     Begin
     k:=k+1;
     getcase(vars,sel,nv,dv,dfile);
     If (Frac(k/10)=0.0) Then Write('+');
     If Not EOF(dfile) Then
       Begin
       transform(vars,ho,miss,cns,sub,dv,t,trans);
       (* Output *)
       If (t=0) Then Begin
         For i:=1 To dv Do Write(usr,vars[i]:11,' '); Writeln(usr);
         End;
       End;
     End;
   Close(dfile); endwrite;
   Assign(dfile,'MAPSTAT.COM'); Execute(dfile);
End.