Language: Turbo Pascal.
Objective: This program performs the linear regression between a set of (X,Y) points, including the following transformations:
The program has graphical capability, so you can plot dispersion graphics to verify grafically the fit between data and the proposed function.
Notes: The compilation of this program must be done under the Turbo Pascal compiler, version 5.0 or superior. It requires the Turbo Pascal Graphics Toolbox. After the compiling, the following files must be included in the same directory of the executable file:
***** Begin of Program Listing *****
Program Zardoz;
{--------------------------------------------------------------------------}
{- -}
{- Z A R D O Z -}
{- -}
{- -}
{- Linear Regression Program with Several Transformations -}
{- and Graphical Capability -}
{- -}
{- -}
{- Used Units: -}
{- GDriver.TPU, GKernel.TPU, GWindow.TPU, GShell.TPU -}
{- -}
{- Used Files: -}
{- 4x6.fon, 8x8.fon (IBM color graphics), -}
{- 4x9.fon (Hercules mono graphics) and Error.msg. -}
{- -}
{- -}
{- Antonio Augusto Gorni --- March 6, 1990 -}
{- -}
{- Lattest Revision: June 6, 1992 -}
{- -}
{--------------------------------------------------------------------------}
uses
Dos, Crt, Printer, GDriver, GKernel, GWindow, GShell;
type
Boolean7 = array [1..7] of boolean;
Real7 = array [1..7] of real;
ColorArray = array[1..4] of byte;
GorniArray = array[1..600] of real;
const
IOerr : boolean = false; { Detecta Erro de E/S }
LinSup : integer = 2; { EGA = 2; CGA = 3 }
LinInf : integer = 25; { EGA = 25; CGA = 24 }
PrinterMode = 6; { EGA = 6; CGA = 1 }
NroFuncoes = 7;
WindowColor : ColorArray = (Green, Magenta, LightCyan, White);
BackColor : ColorArray = (Black, Black, Black, Black);
var
XData, YData : GorniArray;
Func, i : integer;
NumPoints : integer;
a, b : Real7;
Narq : string;
SalvaDados : boolean;
Estado : Boolean7;
GraphArray : PlotArray;
procedure IOCheck;
{---------------------------------------------------}
{- Check for I/O error; print message if needed. -}
{---------------------------------------------------}
type
String80 = string[80];
var
IOcode : integer;
procedure Error(Msg : String80);
begin
Writeln;
Write(^G); { Beep! }
Writeln(Msg);
Writeln;
end; { procedure Error }
begin { procedure IOCheck }
IOcode := IOresult;
IOerr := IOcode <> 0;
if IOerr then
case IOcode of
2 : Error('File not found.');
3 : Error('Path not found.');
4 : Error('Too many open files.');
5 : Error('File access denied.');
6 : Error('Invalid file handle.');
12 : Error('Invalid file access code.');
15 : Error('Invalid drive number.');
16 : Error('Cannot remove current directory.');
17 : Error('Cannot rename across drives.');
100 : Error('Disk read error.');
101 : Error('Disk write error.');
102 : Error('File not assigned.');
103 : Error('File not open.');
104 : Error('File not open for input.');
105 : Error('File not open for output.');
106 : Error('Invalid numeric format.');
else
begin
Writeln;
Writeln(^G);
Writeln('Unidentified error message = ', IOcode, '. See manual.');
Writeln;
end;
end; { case }
end; { procedure IOCheck }
function FileExists(Fname : String) : boolean;
var
CheckFile : file;
begin
Assign(CheckFile, Fname);
{$I-} Reset(CheckFile); {$I+}
if IOresult = 0 then
begin
FileExists := true;
Close(CheckFile)
end
else
FileExists := false;
end; { function FileExists }
procedure GetGraphData(var X, Y : GorniArray;
var GraphArray : PlotArray;
NumPoints : Integer);
var
Index : Integer;
begin
for Index := 1 to NumPoints do
begin
GraphArray[Index, 1] := X[Index];
GraphArray[Index, 2] := Y[Index];
end;
end; { procedure GetGraphData }
procedure SetColors(Fore, Back : Integer);
begin
if MaxForeGround = 15 then
begin
SetForeGroundColor(Fore);
SetBackGroundColor(Back);
end;
end; { Procedure SetColors }
procedure Tela1;
begin
TextMode(0);
GoToXY(1,6);
write('****************************************');
write('* *');
write('* Z A R D O Z *');
write('* *');
write('* *');
write('* Developed by: *');
write('* *');
write('* Antonio Augusto Gorni - EGT/T *');
write('* *');
write('* Lattest Revision: 11/06/1992 *');
write('* *');
write('****************************************');
delay(5000);
TextMode(2)
end; { procedure Tela1 }
procedure Flash;
begin
TextBackground(0);
TextColor(31);
end;
procedure Normal;
begin
TextBackground(0);
TextColor(7);
end;
procedure Inverse;
begin
TextBackground(7);
TextColor(0);
end;
procedure Centraliza(var Buffer : string);
begin
GotoXY(round((80-Length(Buffer))/2+1),1);
Inverse;
Writeln(Buffer);
Normal;
end; {procedure Centraliza}
procedure Tabula(var Buffer, BufImpr : string;
Posicao : integer);
var
i, Compr : integer;
begin
for i := 1 to Posicao - Length(BufImpr) do
Buffer := ' ' + Buffer;
BufImpr:=BufImpr+Buffer;
end; {Tabula}
procedure CabImpr(var BufImpr, Buffer : string;
var NroPag : integer);
var
Ano, Mes, Dia, DiaSemana, Hora, Minuto, Segundo, CentSegundo : word;
begin
Writeln(Lst,BufImpr);
Writeln(Lst,Buffer);
GetDate(Ano, Mes, Dia, DiaSemana);
GetTime(Hora, Minuto, Segundo, CentSegundo);
Write(Lst,'Page no. ',NroPag,' ***** ');
Write(Lst,Dia,'/',Mes,'/',Ano,', ',Hora,':');
If Minuto<10 then Write(Lst,'0');
Writeln(Lst,Minuto);
Writeln(Lst); Writeln(Lst); Writeln(Lst);
end; {CabImpr}
Procedure Eject;
begin
Writeln(Lst,#$C);
end; {Eject}
procedure Dir(var Caminho : string;
Espec : string);
var
Contador, i, j, NroLin : integer;
Flag : boolean;
Buffer : string;
Tipo : word;
ArqDados : SearchRec;
ArqRes : Array [1..255] of string[12];
begin
Contador := 0;
Tipo := 0;
FindFirst(Caminho + Espec, Tipo, ArqDados);
If DosError = 0 then
begin
ArqRes[Contador+1] := ArqDados.Name;
Contador := Contador + 1;
Flag := true;
While Flag do
begin
FindNext(ArqDados);
If DosError = 0 then
begin
ArqRes[Contador+1] := ArqDados.Name;
Contador := Contador + 1;
end
else Flag := false;
end;
end;
ClrScr;
Write('DIRETORIO: '); Inverse; Writeln(Caminho); Normal; Writeln;
if Contador = 0 then
begin
GotoXY(1,7); Flash;
Writeln('No File was Found in this Directory!');
Normal;
GotoXY(1,14); Write('Press to Continue... '); Readln(Buffer);
end
else
begin
For i:=1 to Trunc(Contador/5)+1 do
begin
if i mod 20 = 0 then
begin
Writeln; Writeln;
Write('Press to Continue... '); Readln(Buffer); ClrScr;
GotoXY(1,4);
Write('DIRECTORY: '); Inverse; Writeln(Caminho); Normal; Writeln;
end;
for j := 1 to 5 do
begin
if 5*(i-1)+j <= Contador then
begin
GotoXY((j-1)*15+1,WhereY);
write(ArqRes[5*(i-1)+j]);
end;
end;
Writeln;
end;
Writeln; Writeln;
Write('Press to Continue... '); Readln(Buffer);
end;
end; {Dir}
procedure IdentificaFuncao(var Funcao : integer;
var Saida : string);
begin
if Saida = 'Con' then
case Funcao of
1 : Writeln('<1> Y = A + B * X ');
2 : Writeln('<2> Y = A * EXP(B * X) ');
3 : Writeln('<3> Y = A * X ^ B ');
4 : Writeln('<4> Y = A + B / X ');
5 : Writeln('<5> Y = 1 / (A + B * X) ');
6 : Writeln('<6> Y = X / (A + B * X) ');
7 : Writeln('<7> Y = A + B * LN(X) ');
end {case}
else
if Saida = 'String' then
case Funcao of
1 : Saida:='<1> Y = A + B * X';
2 : Saida:='<2> Y = A * EXP(B * X)';
3 : Saida:='<3> Y = A * X ^ B';
4 : Saida:='<4> Y = A + B / X';
5 : Saida:='<5> Y = 1 / (A + B * X)';
6 : Saida:='<6> Y = X / (A + B * X)';
7 : Saida:='<7> Y = A + B * LN(X)';
end {case}
else
case Funcao of
1 : Writeln(Lst,'<1> Y = A + B * X ');
2 : Writeln(Lst,'<2> Y = A * EXP(B * X) ');
3 : Writeln(Lst,'<3> Y = A * X ^ B ');
4 : Writeln(Lst,'<4> Y = A + B / X ');
5 : Writeln(Lst,'<5> Y = 1 / (A + B * X) ');
6 : Writeln(Lst,'<6> Y = X / (A + B * X) ');
7 : Writeln(Lst,'<7> Y = A + B * LN(X) ');
end {case}
end; {Identifica Funcao}
function Potencia(x, y : real) : real;
begin
Potencia:=exp(Ln(x)*y);
end; {Potencia}
function CalculaFuncao(var i : integer;
var x : real;
var a, b : real;
var Bandeira : boolean) : real;
begin
Bandeira:=true;
case i of
1 : CalculaFuncao:=a+b*x;
2 : CalculaFuncao:=a*Exp(b*x);
3 : If x <= 0 then
begin
CalculaFuncao:=0.0;
Bandeira:=false;
end
else CalculaFuncao:=a*Potencia(x,b);
4 : If x = 0 then
begin
CalculaFuncao:=0.0;
Bandeira:=false;
end
else CalculaFuncao:=a+b/x;
5 : CalculaFuncao:=1/(a+b*x);
6 : CalculaFuncao:=x/(a+b*x);
7 : If x <= 0 then
begin
CalculaFuncao:=0.0;
Bandeira:=false;
end
else CalculaFuncao:=a+b*Ln(x);
end; {case}
end; {CalculaFuncao}
procedure MenuPrincipal(var Funcao : integer);
var
Buffer : string;
begin
Window(1,1,80,25);
ClrScr;
Buffer := 'LINEAR REGRESSION WITH SEVERAL TRANSFORMATIONS';
Centraliza(Buffer);
GotoXY(29,6); Writeln('<1> Data Input');
GotoXY(29,8); Writeln('<2> Data Correction');
GotoXY(29,10); Writeln('<3> Data Suppression');
GotoXY(29,12); Writeln('<4> Data Output');
GotoXY(29,14); Writeln('<5> Curve Fitting');
GotoXY(29,16); Writeln('<6> Graphics');
GotoXY(29,18); Writeln('<7> End');
Funcao:=100;
While (Funcao < 1) or (Funcao > NroFuncoes) do
Begin
GotoXY(29,22); Write('Your Choice? '); Readln(Funcao);
End;
end; {procedure MenuPrincipal}
procedure EntradaDados(var XData, YData : GorniArray;
var NumPoints : integer;
var Narq : string;
var SalvaDados : boolean);
var
Buffer, Xtr, Ytr, Espec, Caminho : string;
Funcao, Cod, Nr, i : integer;
InFile : text;
begin
ClrScr;
Buffer := 'ENTRADA DE DADOS';
Centraliza(Buffer);
Window(1,4,80,25);
if SalvaDados then
begin
ClrScr;
write(^G);
GotoXY(1,9); Flash; Writeln('Data Not Saved Yet!'); Normal;
Buffer := '';
While ((Buffer <> 'Y') and (Buffer <> 'N')) do
begin
GotoXY(1,13); Write('Do You Want to Continue (Y/N)? '); Readln(Buffer);
end;
ClrScr;
end;
if (Buffer = 'Y') or (not SalvaDados) then
begin
GotoXY(32,6); Writeln('<1> New Data');
GotoXY(32,10); Writeln('<2> More Data');
Funcao := 100;
While ((Funcao < 1) or (Funcao > 2)) do
begin
GotoXY(32,18); Write('Your Choice? '); Readln(Funcao);
end;
If Funcao = 1 then
begin
SalvaDados := False;
NumPoints := 0;
Narq:='';
end;
Buffer := 'INPUT OPTION';
Window(1,1,80,25);
ClrScr;
Centraliza(Buffer);
GotoXY(35,9); Writeln('<1> Keyboard');
GotoXY(35,13); Writeln('<2> Disk');
Funcao := 100;
While ((Funcao < 1) or (Funcao > 2)) do
begin
GotoXY(35,22); Write('Your Choice? '); Readln(Funcao);
end;
If Funcao = 1 then
begin
Buffer := 'INPUT VIA KEYBOARD';
Window(1,1,80,25);
ClrScr;
Centraliza(Buffer);
Window(1,4,80,25);
Writeln('Now Enter the Raw Data.');
Writeln('Write to Finish.');
Writeln; Xtr := ''; Ytr := '';
While ((Xtr <> 'END') and (Ytr <> 'END')) do
begin
NumPoints := NumPoints + 1;
Writeln;
Writeln('Conjunto #', NumPoints);
Write('X? ');
Readln(Xtr);
If Xtr <> 'END' then
begin
Write('Y? ');
Readln(Ytr);
Val(Xtr,XData[NumPoints],Cod);
Val(Ytr,YData[NumPoints],Cod);
end;
end;
NumPoints := NumPoints - 1;
if NumPoints <> 0 then SalvaDados := true;
end
else
begin
Buffer := 'DISK INPUT';
Window(1,1,80,25);
ClrScr;
Centraliza(Buffer);
Window(1,4,80,25);
Narq := '?';
While Narq = '?' do
begin
GotoXY(1,6);
Write('File Name (? to List Directory)? ');
Readln(Narq);
If Narq = '?' then
begin
Writeln; Write('Drive or Path? '); Readln(Caminho);
Dir(Caminho,'*.ZDZ'); ClrScr;
end;
end;
Narq := Narq + '.ZDZ';
If not FileExists(Narq) then
begin
ClrScr;
GotoXY(1,9);
Write(^G);
Flash; Writeln('File ',Narq,' Not Found!'); Normal;
Writeln; GotoXY(1,13);
Write('Press to Continue... ');
Readln(Buffer);
end
else
begin
If NumPoints <> 0 then SalvaDados := true;
GotoXY(1,16); Write('Reading '); Flash; Writeln(Narq);
Assign(InFile,Narq);
Reset(InFile);
{I-} Readln(InFile, Nr); {I+}
IOCheck;
for i := 1 to Nr do
begin
{I-} Readln(InFile, XData[NumPoints+i],
YData[NumPoints+i]); {I+}
IOCheck;
end;
Close(InFile);
NumPoints := NumPoints + Nr
end;
end;
end;
end; {EntradaDados}
Procedure CorrigeDados(var XData, YData : GorniArray;
var NumPoints : integer;
var SalvaDados : boolean);
var
Buffer, Buffer1 : string;
Cod, Nponto : integer;
begin
ClrScr;
Buffer := 'DATA CORRECTION';
Centraliza(Buffer);
Window(1,4,80,25);
While Buffer <> 'END' do
begin
ClrScr;
GotoXY(1,7); Writeln('Point Index ( to Finish)? ');
Readln(Buffer);
If Buffer <> 'END' then
begin
Val(Buffer, Nponto, Cod);
If ((Nponto >= 1) and (Nponto <= NumPoints)) then
begin
writeln;
write('X = ',XData[Nponto],'. New Value? ');
Readln(Buffer1);
If Buffer1 <> '' then Val(Buffer1, XData[Nponto], Cod);
write('Y = ',YData[Nponto],'. New Value? ');
Readln(Buffer1);
If Buffer1 <> '' then Val(Buffer1, YData[Nponto], Cod);
SalvaDados := True;
end;
end;
end;
end; {Corrige Dados}
Procedure SuprimeDados(var XData, YData : GorniArray;
var NumPoints : integer;
var SalvaDados : Boolean);
var
Cod, Nponto, NroSupr, i, j, Troca : integer;
Vsupr : array [1..30] of integer;
Buffer, Buffer1 : string;
begin
NroSupr := 0;
ClrScr;
Buffer := 'DATA SUPPRESSION';
Centraliza(Buffer);
Window(1,4,80,25);
While Buffer <> 'END' do
begin
ClrScr;
GotoXY(1,7); Writeln('Point Index ( para Terminar)? ');
Readln(Buffer);
If Buffer <> 'END' then
begin
Val(Buffer, Nponto, Cod);
If ((Nponto >= 1) and (Nponto <= NumPoints)) then
begin
writeln;
write('X = ',XData[Nponto],' ***** ',YData[Nponto]);
Buffer1 := '';
While ((Buffer1 <> 'Y') and (Buffer1 <> 'N')) do
begin
GotoXY(1,12); Write(^G); Write('Confirm (Y/N)! ');
Readln(Buffer1);
end;
If Buffer1 = 'Y' then
begin
NroSupr := NroSupr + 1; Vsupr[NroSupr] := Nponto;
end
else ClrScr;
end;
end;
end;
If NroSupr > 0 then
begin
GotoXY(1,14); Write(^G); Flash;
Writeln('Making Suppressions...');
Normal;
for i := 1 to NroSupr - 1 do for j := i + 1 to NroSupr do
If Vsupr[j] > Vsupr[i] then
begin
Troca := Vsupr[j]; Vsupr[j] := Vsupr[i]; Vsupr[i] := Troca;
end;
for j := 1 to NroSupr do
begin
For i := Vsupr[j] to NumPoints - 1 do
begin
XData[i] := XData[i+1]; YData[i] := YData[i+1];
end;
NumPoints := NumPoints - 1;
end;
end;
SalvaDados := True;
end; {SuprimeDados}
Procedure SaidaDados(var XData, YData : GorniArray;
var NumPoints : integer;
var Narq : string;
var SalvaDados : Boolean);
var
Opcao, Contador, i, NroPag : integer;
Buffer, BufImpr, Mensagem, Caminho : string;
OutFile : text;
begin
ClrScr;
Buffer := 'DATA OUTPUT';
Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(35,4); Writeln('<1> Screen');
GotoXY(35,8); Writeln('<2> Printer');
GotoXY(35,12); Writeln('<3> File');
Opcao := 100;
While ((Opcao < 1) or (Opcao > 3)) do
begin
GotoXY(35,18); Write('Your Choice? '); Readln(Opcao);
end;
Case Opcao of
1 : begin
Window(1,1,80,25); ClrScr;
Buffer := 'DATA OUTPUT';
Centraliza(Buffer);
Window(1,4,80,25);
Contador := 0;
For i := 1 to NumPoints do
begin
Writeln('Point # ',i);
Write('X = ',XData[i]);
GotoXY(30,WhereY);
Writeln('Y = ',YData[i]);
Writeln;
Contador := Contador + 3;
If ((Contador >= 17) and (i < Numpoints)) then
begin
GotoXY(1,21);
Flash; Write('Press to Continue...'); Normal;
Contador := 0;
Readln(Buffer);
ClrScr; GotoXY(1,1);
end;
end;
GotoXY(1,21);
Flash; Write('Press to Continue.'); Normal;
Readln(Buffer);
ClrScr;
end;
2 : begin
Window(1,1,80,25); ClrScr;
Buffer := 'DATA PRINTER OUTPUT';
Centraliza(Buffer);
Window(1,4,80,25); GotoXY(1,8);
Writeln('Enter Data Identification Message.');
Readln(Mensagem);
Writeln; Writeln; Writeln;
Write('Prepare Printer, Mark Start of Report.');
Writeln; Writeln;
Write('Press to Continue...');
NroPag := 1; Readln(Buffer);
BufImpr := 'Data for Curve Fitting';
CabImpr(BufImpr,Mensagem,NroPag); Contador := 0;
For i:=1 to NumPoints do
begin
Str(i,Buffer);
BufImpr := '#' + Buffer;
Str(XData[i],Buffer);
Tabula(Buffer,BufImpr,10);
Str(YData[i],Buffer);
Tabula(Buffer,BufImpr,35);
Writeln(Lst,BufImpr);
Contador := Contador + 1;
If ((Contador >= 55) and (i < NumPoints)) then
begin
NroPag := NroPag + 1; Eject;
BufImpr := 'Data for Curve Fitting';
CabImpr(BufImpr,Mensagem,NroPag); Contador := 0;
end;
end;
Eject;
ClrScr;
end;
3 : begin
Window(1,1,80,25); ClrScr;
Buffer := 'DATA SAVING IN DISK';
Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(1,6);
If Narq<>'' then
begin
Buffer:='';
While ((Buffer<>'Y') and (Buffer<>'N')) do
begin
GotoXY(1,8); Write('Do Your Want to Save in '); Flash; Write(Narq);
Normal; Write(' (Y/N)? '); Readln(Buffer); ClrScr;
end;
end;
If ((Narq='') or (Buffer='N')) then
begin
Narq := '?';
While Narq = '?' do
begin
GotoXY(1,6);
Write('File Name (? para listar Diretorio)? ');
Readln(Narq);
If Narq = '?' then
begin
Writeln; Write('Drive or Path? '); Readln(Caminho);
Dir(Caminho,'*.ZDZ'); ClrScr;
end
else Narq:=Narq+'.ZDZ';
end;
end;
GotoXY(1,16); Write('Writing '); Flash; Writeln(Narq);
Assign(OutFile,Narq);
Rewrite(OutFile);
{I-} Writeln(OutFile, NumPoints); {I+}
IOCheck;
for i := 1 to NumPoints do
begin
{I-} Writeln(OutFile, XData[i], ' ', YData[i]); {I+}
IOCheck;
end;
Close(OutFile); SalvaDados := false;
end;
end; {Case}
end; {SaidaDados}
Procedure AjustaCurvas(var XData, YData : GorniArray;
var NumPoints : integer;
var SalvaDados : Boolean;
var a, b : Real7;
var Estado : Boolean7);
var
i, j, Contador : integer;
Console, Impressora, Buffer, BufImpr, BufAux : string;
a1, b1, s1, s2, y, st, d, p1, d2, be, xe, z, ff, d1, ae, fe, ye,
SomXY, SomX, SomY, SomX2, z1, st1, st2, MediaY : real;
Ano, Mes, Dia, DiaSemana, Hora, Minuto, Segundo, CentSegundo : word;
Bandeira : boolean;
c, ep, p : real7;
Impressao : array[1..7,1..2] of string[80];
XTransf, YTransf : GorniArray;
Solution : array[1..2] of real;
begin
Console:='Con';
Impressora:='Lst';
ClrScr;
Buffer := 'CURVE FITTING';
Centraliza(Buffer);
Window(1,4,80,25);
Contador := 0;
For i:=1 to NroFuncoes do
begin
IdentificaFuncao(i,Console);
Estado[i]:=true;
for j:=1 to NumPoints do
begin
if Estado[i] then
case i of
1 : begin
XTransf[j]:=XData[j]; YTransf[j]:=YData[j];
end;
2 : if YData[j] <= 0 then Estado[i]:=false
else
begin
XTransf[j]:=XData[j]; YTransf[j]:=Ln(YData[j]);
end;
3 : if YData[j] <= 0 then Estado[i]:=false
else
if XData[j] <= 0 then Estado[i]:=false
else
begin
XTransf[j]:=Ln(XData[j]); YTransf[j]:=Ln(YData[j]);
end;
4 : begin
YTransf[j]:=YData[j];
if XData[j]=0 then Estado[i]:=false
else XTransf[j]:=1/XData[j];
end;
5 : begin
XTransf[j]:=XData[j];
if YData[j]=0 then Estado[i]:=false
else
YTransf[j]:=1/YData[j];
end;
6 : if YData[j]=0 then Estado[i]:=false
else
begin
YTransf[j]:=1/YData[j];
if XData[j]=0 then Estado[i]:=false
else XTransf[j]:=1/XData[j];
end;
7 : if XData[j] <= 0 then Estado[i]:=false
else
begin
XTransf[j]:=Ln(XData[j]);
YTransf[j]:=YData[j];
end
end; {case}
end;
If not Estado[i] then
begin
GotoXY(5,WhereY+1); Inverse; Writeln('IMPOSSIBLE!'); Normal;
Contador:=Contador+1; Writeln; Writeln;
end
else
begin
SomX:=0.; SomY:=0.; SomXY:=0.; SomX2:=0.;
for j:=1 to NumPoints do
begin
SomX:=SomX+XTransf[j]; SomY:=SomY+YTransf[j];
SomX2:=SomX2+Sqr(XTransf[j]); SomXY:=SomXY+XTransf[j]*YTransf[j];
end;
Solution[2]:=(SomXY-SomX*SomY/NumPoints)/(SomX2-Sqr(SomX)/NumPoints);
Solution[1]:=(SomY-Solution[2]*SomX)/NumPoints;
case i of
1 : begin
a[i]:=Solution[1]; b[i]:=Solution[2];
end;
2 : begin
a[i]:=Exp(Solution[1]); b[i]:=Solution[2];
end;
3 : begin
a[i]:=Exp(Solution[1]); b[i]:=Solution[2];
end;
4 : begin
a[i]:=Solution[1]; b[i]:=Solution[2];
end;
5 : begin
a[i]:=Solution[1]; b[i]:=Solution[2];
end;
6 : begin
a[i]:=Solution[2]; b[i]:=Solution[1];
end;
7 : begin
a[i]:=Solution[1]; b[i]:=Solution[2];
end;
end; {case}
st:=0.; st1:=0.;
for j:=1 to NumPoints do st1:=st1+YData[j];
MediaY:=st1/NumPoints;
st1:=0.;
for j:= 1 to NumPoints do
begin
y:=CalculaFuncao(i,XData[j],a[i],b[i],Bandeira);
d:=YData[j]-y; st:=st+d*d; d:=YData[j]-MediaY; st1:=st1+d*d;
end;
c[i]:=abs(1-(st/(NumPoints-2))/(st1/(NumPoints-1)));
if c[i]>1 then c[i]:=0.001;
ep[i]:=sqrt(st/NumPoints); ff:=c[i]*(NumPoints-2)/(1-c[i]);
p1:=1; d1:=1; d2:=NumPoints-2;
if ((d1=0) or (d2=0) or (ff=0)) then p[i]:=p1
else
begin
if ff < 1 then
begin
ae:=d2; be:=d1; fe:=1/ff
end
else
begin
ae:=d1; be:=d2; fe:=ff
end;
a1:=2/(9*ae); b1:=2/(9*be); xe:=(1-b1)*Potencia(fe,0.3333333)-1+a1;
ye:=sqrt(b1*Potencia(fe,0.66666667)+a1); z:=abs(xe/ye);
if be < 4 then z:=z*(1+0.08*Potencia(z,4)/Potencia(be,3));
z1:=0.115194+z*(0.000344+z*0.019527);
p1:=0.5/Potencia(1+z*(0.196854+z*z1),4);
if ff<0 then p[i]:=p1*100
else p[i]:=(1-p1)*100;
end;
if p[i]=100 then p[i]:=99.999999;
for j:=1 to 2 do Impressao[i,j]:='';
BufImpr:=''; Str(a[i],BufAux);
BufImpr:='A = '+BufAux; Str(b[i],BufAux); Buffer:='B = '+BufAux;
Tabula(Buffer,BufImpr,27); Str(c[i],BufAux); Buffer:='r2 = '+BufAux;
Tabula(Buffer,BufImpr,54); Writeln(BufImpr);
Impressao[i,1]:=BufImpr; Buffer:='';
Str(ep[i],BufAux); BufImpr:='E = '+BufAux; Str(p[i],BufAux);
Buffer:='% Conf = '+BufAux; Tabula(Buffer,BufImpr,27);
Writeln(BufImpr); Writeln; Writeln; Contador:=Contador+1;
Impressao[i,2]:=BufImpr;
if Contador >= 4 then
begin
Writeln(^G);
Flash; Write('Press to Continue...'); Normal; Readln(Buffer);
Contador:=0; ClrScr; GotoXY(1,1);
end;
end;
end;
Writeln(^G);
Flash; Write('Press to Continue...'); Normal; Readln(Buffer);
Buffer:='';
While ((Buffer<>'Y') and (Buffer<>'N')) do
begin
ClrScr; GotoXY(1,9); Write('Do You Want to Print Results (Y/N)? ');
Readln(Buffer);
end;
if Buffer = 'Y' then
begin
ClrScr; GotoXY(1,8);
Writeln('Enter Results Identification Message.'); Readln(BufImpr);
GotoXY(1,12); Writeln('Prepare Printer and Press !');
Readln(Buffer);
Writeln(Lst,'LINEAR REGRESSION WITH SEVERAL TRANSFORMATIONS');
If Narq<>'' then
begin
Write(Lst,'Data from');
If SalvaDados then Write(Lst,' (partially)');
Write(Lst,' from the File ',Narq,' *** ')
end
else
Write(Lst,'Data Entered via Keyboard *** ');
GetDate(Ano, Mes, Dia, DiaSemana);
GetTime(Hora, Minuto, Segundo, CentSegundo);
Write(Lst,Dia,'/',Mes,'/',Ano,', ',Hora,':');
If Minuto<10 then Write(Lst,'0');
Writeln(Lst,Minuto);
Writeln(Lst,''); Writeln(Lst,BufImpr); Writeln(Lst,''); Writeln(Lst,'');
for i:=1 to NroFuncoes do
begin
IdentificaFuncao(i,Impressora);
if Estado[i] then
begin
Writeln(Lst,Impressao[i,1]); Writeln(Lst,Impressao[i,2]);
Writeln(Lst,'');
end
else
begin
Writeln(Lst,' IMPOSSIBLE!'); Writeln(Lst,''); Writeln(Lst,'');
end;
end;
end;
end; {AjustaCurvas}
Procedure PlotaCurvas(var XData,YData : GorniArray;
NumPoints : integer;
a, b : Real7;
Estado : Boolean7);
var
i, j, k, Opcao, Funcao, Cod, NX, NY, CharCode : integer;
X0, X1, Y0, Y1, XCalc, Incr : real;
Buffer, Console, LabelX, LabelY : string;
Bandeira, Loop : boolean;
begin
Loop:=true;
Opcao:=0; Funcao:=0;
Console:='Con';
X0:=XData[1]; X1:=X0; Y0:=YData[1]; Y1:=Y0;
for i:=1 to NumPoints-1 do
for j:=i+1 to NumPoints do
begin
if XData[j]X1 then X1:=XData[j];
if YData[j]Y1 then Y1:=YData[j]
end;
NX:=5; NY:=5; LabelX:=''; LabelY:=''; CharCode:=8;
While Loop do
begin
Window(1,1,80,25); ClrScr;
Buffer := 'GRAPHIC PLOTTING';
Centraliza(Buffer);
GotoXY(29,7); Writeln('<1> Function Definition');
GotoXY(29,9); Writeln('<2> Axis Definition');
GotoXY(29,11); Writeln('<3> Plot Graphic');
GotoXY(29,13); Writeln('<4> Show Graphic');
GotoXY(29,15); Writeln('<5> Print Graphic');
GotoXY(29,17); Writeln('<6> Main Menu');
Opcao:=0;
While (Opcao < 1) or (Opcao > NroFuncoes) do
begin
GotoXY(29,23); Write('Your Choice? '); Readln(Opcao);
end;
case Opcao of
1 : begin
ClrScr; Buffer:='FUNCTION TO BE PLOTTED'; Centraliza(Buffer);
GotoXY(29,6);
for i:=1 to NroFuncoes do
begin
GotoXY(29,WhereY); IdentificaFuncao(i,Console); Writeln;
end;
Funcao:=0;
While (Funcao < 1) or (Funcao > NroFuncoes) do
begin
GotoXY(29,22); Write('Your Choice? '); Readln(Funcao);
If (Funcao >= 1) and (Funcao <= NroFuncoes) then
If not Estado[Funcao] then Funcao:=0;
end;
end;
2 : If (Funcao<>0) and (Estado[Funcao]) then
begin
ClrScr; Buffer:='AXIS DEFINITION'; Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(1,3);
Write('Current Minimum X: ',X0,' - New: '); Readln(Buffer);
If Buffer<>'' then Val(Buffer,X0,Cod);
Write('Current Maximum X: ',X1,' - New: '); Readln(Buffer);
If Buffer<>'' then Val(Buffer,X1,Cod);
Writeln; Writeln;
Write('Current Minimum Y: ',Y0,' - New: '); Readln(Buffer);
If Buffer<>'' then Val(Buffer,Y0,Cod);
Write('Current Maximum Y: ',Y1,' - New: '); Readln(Buffer);
If Buffer<>'' then Val(Buffer,Y1,Cod);
Writeln; Writeln;
Write('Current Tick Density in the X-Axis: ',NX,
' - New (-9 a +9): ');
Readln(Buffer);
If Buffer<>'' then Val(Buffer,NX,Cod);
Write('Current Tick Density in the Y-Axis: ',NY,
' - New (-9 a +9): ');
Readln(Buffer);
If Buffer<>'' then Val(Buffer,NY,Cod);
If (Abs(NX)>9) or (Abs(NY)>9) then
begin
Writeln(^G); Inverse;
Writeln('Illegal Tick Density!'); Normal
end;
Writeln; Writeln;
Write('Current X-Axis Label: ',LabelX,' - New: ');
Readln(Buffer);
If Buffer<>'' then LabelX:=Buffer;
Write('Current Y-Axis Label: ',LabelY,' - New: ');
Readln(Buffer);
If Buffer<>'' then LabelY:=Buffer;
Writeln; Writeln;
Write('Current Point Type: ',CharCode,' - New: ');
Readln(Buffer);
If Buffer<>'' then Val(Buffer,Charcode,Cod);
end;
3 : If (Funcao <> 0) and (Estado[Funcao]) then
begin
RAMScreenGlb := true;
Incr:=(X1-X0)/MaxPlotGlb; XCalc:=X0;
for k:=1 to MaxPlotGlb do
begin
GraphArray[k,1]:=XCalc;
GraphArray[k,2]:=CalculaFuncao(Funcao, XCalc,
a[Funcao], b[Funcao],
Bandeira);
XCalc:=XCalc+Incr;
If (GraphArray[k,1]X1) or
(GraphArray[k,2]Y1) or
not Bandeira then
begin
GraphArray[k,1]:=X0;
GraphArray[k,2]:=Y0;
end;
end;
EnterGraphic;
DefineWindow(1, 0, 0, XMaxGlb, YMaxGlb);
DefineWorld(1,X0,Y0,X1,Y1);
SelectWorld(1); SelectWindow(1); SetBackground(0);
ClearScreen;
Buffer:='String';
IdentificaFuncao(Funcao,Buffer);
Buffer:='Fitted Function ' + Buffer;
DefineHeader(1,Buffer);
GotoXY(1,LinSup); Writeln(LabelY);
GotoXY(80-Length(LabelX),LinInf); Writeln(LabelX);
SetHeaderOn; DrawBorder;
DrawAxis(NX, NY, 0, 15, 0, 15, -1, -1, true);
DrawPolygon(GraphArray, 1, MaxPlotGlb, -9, 1, 0);
ResetAxis;
GetGraphData(XData, YData, GraphArray, NumPoints);
DrawPolygon(GraphArray, 1, NumPoints, -CharCode, 2, 0);
Readln(Buffer);
SwapScreen;
LeaveGraphic;
end;
4 : begin
EnterGraphic;
SwapScreen;
Readln(Buffer);
SwapScreen;
LeaveGraphic;
end;
5 : begin
Window(1,1,80,25); ClrScr;
Buffer:='PRINTING GRAPHIC';
Centraliza(Buffer);
GotoXY(1,12);
Writeln('Prepare Printer and Press to Continue!');
Readln(Buffer);
EnterGraphic;
SwapScreen;
HardCopy(false,PrinterMode);
SwapScreen;
LeaveGraphic;
Writeln(Lst,Chr(27),'@');
end;
6 : Loop:=false;
end {case}
end
end; {PlotaCurvas}
procedure Fim(var SalvaDados : Boolean);
var
Buffer : string;
begin
If SalvaDados then
begin
ClrScr;
Buffer := 'END OF PROGRAM RUN';
Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(1,9); Flash;
Writeln(^G'Data Not Saved Yet!');
Normal;
Buffer := '';
While ((Buffer<>'Y') and (Buffer<>'N')) do
begin
GotoXY(1,12); Write('Do Your Really Want to Quit (Y/N)? '); Readln(Buffer);
end;
if Buffer = 'Y' then
begin
ClrScr;
Halt;
end;
end
else
begin
ClrScr;
Halt
end;
end; {Fim}
begin { program Zardoz }
InitGraphic;
SetColors(WindowColor[1], BackColor[1]);
LeaveGraphic;
Tela1;
SalvaDados := false;
for i:=1 to NroFuncoes do Estado[i]:=false;
While true do
begin
MenuPrincipal(Func);
case Func of
1 : EntradaDados(XData,YData,NumPoints,Narq,SalvaDados);
2 : CorrigeDados(XData,YData,NumPoints,SalvaDados);
3 : SuprimeDados(XData,YData,NumPoints,SalvaDados);
4 : SaidaDados(XData,YData,NumPoints,Narq,SalvaDados);
5 : AjustaCurvas(XData,YData,NumPoints,SalvaDados,a,b,Estado);
6 : PlotaCurvas(XData,YData,NumPoints,a,b,Estado);
7 : Fim(SalvaDados);
end; {case}
end;
end. { program Zardoz }
***** End of Program Listing ******
Return to the Software Menu.
 |
Last Update: 27 June 1996 | |
| © Antonio Augusto Gorni |