Расчетная программа оценки точности статистическими методами на базе кривых распределения (Паскаль)

Program LR_2;

uses Graph,Nika_T, Printer;

const Num=500;

type Li_r= Array[1…Num] of real;

var GraphDr, GraphMod, I1, I2, J1, J2, i, j, k, I, n: integer;

ch, sh : byte;

f : text;

Number : integer;

Lup, LDn : real;

Li : Li_r;

G : real;

Lsr : real;

LMax, LMin : real;

YMax : real;

Dnom : real;

Dcsr : real;

n,x : real;

X1,Y1,X2,Y2: real;

Up, Dn : real;

Dop : real;

st : string;

Vnumber : integer;

VLup, VLDn : real;

Vli : Li_r;

VG : real;

VLsr : real;

VLMax,VLMin : real;

VYMax : real;

VDnom : real;

VUp,VDn : real;

VDop : real;

*****************************************************************

Procedure ALL_nil;

begin

Lup:=0; LDn:=0; for i:=1 to Num do Li[i]:=0;

G:=0; Lsr:=0; LMax:=0; LMin:=0;

YMax:=0; Dnom:=0; Dcsr:=0; Number:=0;

VLup:=0; VLDn:=0; for i:=1 to Num do VLi[i]:=0;

VG:=0; VLsr:=0; VLMax:=0; VLMin:=0;

VYMax:=0; VDnom:=0; VDcsr:=0; Vnumber:=0;

end;

*****************************************************************

function II(x: real): integer;

var d,xm: real;

begin

II:=I1+Trunc((I2-I1)*(x-X1)/(X2-X1));

end;

function JJ(y: real): integer;

begin

JJ:=J2+Trunc((J1-J2)*(y-Y1)/(y2-Y1));

end:

*****************************************************************

function Z(x,G: real): real;

begin

Z:=Exp (-(x*x)/(2.0*G*G))/(G*Num*Sqrt(2*Pi));

end;

*****************************************************************

Var Nak : array[1..Num] of string[10];

{SI lib_lr_2.pas}

*****************************************************************

Procedure Input_Path(var Number: integer;

var Dcsr,Lup,Ldn,Dnom: real;

var Li: Li_r; Zagl,Small_Zagl: String);

var ExCod : integer;

i : integer;

s : string;

k : byte;

fl : boolean;

begin

Clr_Wnd(0,0,79,24,$39,176);

Clr_Wnd(4,2,51,13,$70,32);

Frame(3,2,52,14,2,1,$7F,$07,’ ‘+Zagl+’ ‘);

WriteL(5,4, ‘Введите количество деталей в выборке:’);

WriteL(5,6, ‘Введите средний диаметр:’);

WriteL(5,8, ‘Введите верхнее отклонение:’);

WriteL(5,10, ‘Введите нижнее отклонение:’);

WriteL(5,12, ‘Введите номинальный диаметр:’);

k:=1; fI:=false;

s:=’0.000’;

WriteL(50,4,’0’);

for i:=1 to 4 do WriteL(44,i*2+4,5);

for i:=0 to 4 do Change _AttrL(44,i*2+4,7,$1F);

repeat

Change_Attr(5,(k-1)*2+4,43,$7F)

case k of

1: Str(Number:7,s);

2: Str(Dcsr:7:3,s);

3: Str(LUp:7:3,s);

4: Str(LDn:7:3,s);

5: Str(Dnom:7:3,s);

end;

if s[0]>#7 then Delete(s,8,7);

Edst (44,(k-1)*2+4,7,$1F,s,ExCod);

Change_Attr(5,(k-1)*2+4,43,$70);

case k of

1: begin

Val(s,Number,i); Str(Number:7,s);

if s[0]>#7 then Delete(s,8,7); WriteL(44, (k-1)*2+4,s);

end;

2: begin

Val(s,Dcsr,i); Str(Dcsr:7:3,s);

if s[0]>#7 then Delete(s,8,7); WriteL(44, (k-1)*2+4,s);

end;

3: begin

Val(s,LUp,i); Str(LUp:7:3,s);

if s[0]>#7 then Delete(s,8,7); WriteL(44, (k-1)*2+4,s);

end;

4: begin

Val(s,LDn,i); Str(LDn:7:3,s);

if s[0]>#7 then Delete(s,8,7); WriteL(44, (k-1)*2+4,s);

end;

5: begin

Val(s,Dnom,i); Str(Dnom:7:3,s);

if s[0]>#7 then Delete(s,8,7); WriteL(44, (k-1)*2+4,s);

end;

end;

case ExCod of

38: begin

i:=0

if LUp=0 then Inc(i) else

if Number=0 then Inc(i) else

if LDn=0 then Inc(i) else

if Dcsr=0 then Inc(i) else

if Dnom=0 then Inc(i);

if i=0 then f1:=true;

end;

-72: if k>1 then Dec(k) else k:=5;

-28, -80: if k<5 then Inc(k) else k:=1;

end;

i:=0;

if LUp=0 then Inc(i) else

if Number=0 then Inc(i) else

if LDn=0 then Inc(i) else

if Dcsr=0 then Inc(i) else

if Dnom=0 then Inc(i);

if i=0 then

begin

WriteL(25,18,’Нажмите F10 для продолжения’);

Change_AttrL(25,18,29,$4F);

end;

else Clr_LineL(25,18,29,$39,176)

until fl;

Clr_Wnd(0,0,79,24,$39,176);

for i:=1 to Number do

begin

Str(i:3,Nak[i]);

Nak [i]:=’ ‘+Nak[i];

end;

if Number<=18 then

begin

Frame(5,3,20,4+Number,2,1,$1F,$09,’ ‘+Small_Zagl+’ ‘);

PickList(6,14,19,3+Number,$1E,$B0,$B4,Number,Li,ExCod);

end;

else

begin

Frame(5,3,20,22,2,1,$1F,$09,’ ‘+Small_Zagl+’ ‘);

PickList(6,14,19,21,$1E,$B0,$B4,Number,Li,ExCod);

end;

end;

*****************************************************************

Procedure Calculation(var Number: integer;

var Dcsr,LUp,LDn,DNom: real;

var Li: Li_r;

var Up,Dn,Dop,Lsr,G,LMax,LMin,YMax: real);

var S: Extended;

i: integer;

begin

Up:=LUp-Dcsr;

Dn:=LDn-Dcsr;

Dop:=Up-Dn;

S:=0.0; (вычисление Lsr)

for i:=1 to Number do s:=s+Li[i];

Lsr:=s/(Number*1.0);

S:=0.0; (вычисление сигмы)

for i:=1 to Number do s:=s+Sqr(Li[i]-Lsr);

G:=Sqrt(S/(Number-1.0));

LMax:=Li[1]; LMin:=Li[1];

for i:=2 to Number do

begin

if Li[i]>LMax then LMax:=Li[i];

if Li[i]<LMin then LMin:=Li[i];

end;

YMax:=Z(0,G);

end;

procedure EgaDriver; External;

($L EgaVgaDr.obj)

Procedure SmallFont; External;

($L Litt.obj)

*****************************************************************

Procedure Graph_Coord(x1,y1,x2,y2,Dop: real; ColorLn,Color: Byte);

Begin

SetColor(ColorLn);

Line(II(x1),JJ(y1),II(x2),JJ(y1)); (оси координат)

Line(II(x1+Dop/3.0),JJ(y1), II(x1+Dop/3.0),JJ(y2)); (допуск на три части)

Line(II(x1+Dop/3.0*2),JJ(y1)+3,II(x1+Dop/3.0*2),JJ(y1)-3);

Line(II(x1+Dop/3.0*3),JJ(y1)+3,II(x1+Dop/3.0*3),JJ(y1)-3);

SetColor(Color); SetTextStyle(2,0,4);

OutTextXY(II(x1+Dop/3.0)+5,JJ(y1)-12,’0’);

OutTextXY(II(x1+Dop/3.0*4)+5,JJ(y1)-12,’T’);

OutTextXY(II(x1+Dop/3.0*2)+5,JJ(y1)-12,’1/3T’);

OutTextXY(II(x1+Dop/3.0*3)+5,JJ(y1)-12,’2/3T’);

end;

*****************************************************************

Procedure Graph_Mark(x1,y1,Dop,Mark,LDn: real; Size,ColorLn,Color: byte);

var st: string;

begin

SetColor(ColorLn);

Line(II(x1+Dop/3.0+Mark-LDn),JJ(y1)+Size, (II(x1+Dop/3.0+Mark-LDn),JJ(y1)-Size);

SetColor(Color); SetTextStyle(2,0,4);

Str(Mark:6:3,st);

OutTextXY(II(x1+Dop/3.0+Mark-LDn)-12,JJ(y1)+8,st);

end;

*****************************************************************

{$I temp.pas}

*****************************************************************

Procedure Draw(x1,y1,x2,y2,Dop,Dcsr,:Lsr,LDn,G: real; Shift,ColorLn,Color: integer);

var i,n: integer;

x,h: real;

st: string;

G6: real;

S: real;

Pbr: real;

Pg: real;

Z1,Z2: real;

begin

SetColor(Color); SetTextStyle(2,0,4);

Str(Lsr:5:3,st);

OutTextXY(II(x1+Dop/3.0+Lsr-LDn)-12,JJ(y2)+12,st);

SetColor(ColorLn);

Str(G:6:4,st);

OutTextXY(GetMaxX div 2+150,Shift,’Диверсия G’+st);

Line(II(x1+Dop/3.0+Lsr-LDn),JJ(y1)+3, II(x1+Dop/3.0+Lsr-LDn),JJ(y2));

n:=(I2-I1) div 5; h:=(x2-x1)/n;

G6:=6*G;

s:=0;

while s<G6 do

begin

x:=x1+Dop/3.0+(Lsr-LDn-G*3)+s;

s;=s+h;

Line(II(x),JJ(Z(Dcsr+X-Lsr,G)),II(x+h),JJ(Z(Dcsr-Lsr+h,G)));

end;

Z1:=(Lsr-LDn)/G; Z1:=Simpson(Z1);

Z2:=(Dop(Lsr-LDn))/G; Z2:=Simpson(Z2);

Pbr:=(1-(Z1+Z2))*100; {b } Pg:=100-Pbr;

Str(Pbr:6:2,st); OutTextXY(30,Shift,’брак’+st+’ ‘);

Str(Pbr:6:2,st); OutTextXY(130,Shift,’Годные изделия’+st+’ ‘);

end;

*****************************************************************

var dLsr,G3,VG3: real;

f1: byte;

*****************************************************************

{$I print.pas}

begin

Blink(0);

All_nil;

Number:=103;

Assign (f,’f.dat’); Reset(f);

for i:=1 to Number do Readln(f,Li[i]);

Close(f);

LUp:=9.189; LDn:=9.123; DNom:=9.0; Dcsr:=9.156;

(Input_Psth(Number,Dcsr,LUp,LDn,DNom,Li,’Первая партия’,’1-ая партия’);

(Calculation(Number,Dcsr,LUp,LDn,DNom,Li,Up,Dn,Dop,Lsr,G,LMax,LMin,YMax); {Max координаты}

X1:=Dn-Dop/3.0; X2:=Up+Dop/3.0; Y1:=0; Y2:=YMax;

if RegisterBGIDriver(@EgaDriver)<0 then Halt(1);

if RegisterBGIFont(@SmallFont)<0 then Halt(1);

GraphDr:=Detect; InitGraph(GraphDr,GraphMod,’ ‘);

I1:=30; I2:=GetMaxX-30; J1:=100; J2:=GetMaxY; SetBkColor(1);

Graph_Coord(x1,y1,x2,y2,Dop,$F,$F);

Graph_Mark(x1,y1,Dop,Dcsr,LDn,6,$F,$F);

Graph_Mark(x1,y1,Dop,LUp,LDn,6,$F,$F);

Graph_Mark(x1,y1,Dop,LDn,LDn,6,$F,$F);

Draw(x1,y1,x2,y2,Dop,Dcsr,Lsr,LDn,G,10,($A),$F,$F);

ReadKey(ch,sc);

CloseGraph;

(2 Часть)

Vnumber:=10;

Assign (f,’d2.dat’); Reset(f);

For i:=1 to VNumber do Readln(f,VLi[i]);

Close (f);

VLUp:=9.189; VLDn:=9.123; VDNom:=9.0; VDcsr:=9.156;

VUp,VDn,VDop,VLsr,VG,VLMax,VLMin,VYMax);

GraphDr:=Detect; InitGraph(GraphDr,GraphMod,’ ‘);

I1:=30; I2:=GetMaxX-30; J1:=100; J2:=GetMaxY; SetBkColor(1);

Graph_Coord(x1,y1,x2,y2,Dop,$F,$F);

Graph_Mark(x1,y1,Dop,Dcsr,LDn,6,$F,$F);

Graph_Mark(x1,y1,Dop,LUp,LDn,6,$F,$F);

Graph_Mark(x1,y1,Dop,LDn,LDn,6,$F,$F);

Draw(x1,y1,x2,y2,Dop,Dcsr,Lsr,LDn,G,10,($A),$F,$F);

I1:=30; I2:=GetMaxX-30; J1:=J1+(J2-J1) div 2; J2:=GetMaxY-20;

Y1:=0; Y2:=VYMax;

Draw(x1,y1,x2,y2,VDop,Dcsr,VLsr,LDn,VG,30,($B),$F,$F);

DLsr:=VLsr-Lsr; G3:=3*G; VG3:=VG*3; f1:=0; {$1,$2,$4,$8,$10,$20,$40,$80}

if LDn>(Lsr-G3) then f1:=f1 or $1; {0}

if LUp<(Lsr-G3) then f1:=f1 or $2; {1}

if VLDn>(VLsr-VG3) then f1:=f1 or $4; {2}

if VLUp<(VLsr+VG3) then f1:=f1 or $8; {3}

if dLsr<0 then f1:=f1 or $10; {4}

SetColor($F);

OutTextXY(GetMaxX div 2-50,70,

’Сравните величину систематической погрешности с 1/3Т’);

case f1 of

$0..$3: OutTextXY(GetMaxX div 2+150,50,’Поднастройка не нужна’);

$4..$10: OutTextXY(GetMaxX div 2+150,50,’Поднастройка нужна’);

$10..$20: OutTextXY(GetMaxX div 2+150,50,’Поднастройка уже бала’);

end;

ReadKey(ch,sc); Prin(1,1,79,479);

CloseGraph;

end;

procedure EdSt (x,y,1,C3: byte; var sfl: string; var Swith: integer); Forward;

*****************************************************************

procedure PickList(x1,y1,x2,y2,C2,C3,CE: byte; Num: word; var Li: Li_r; var ExitCod: integer);

var i,m: integer;

j,k,Max,f1: byte;

n: integer;

ch,sc: byte;

ExCod: integer;

done: Boolean;

s: string;

Label a;

begin

done:=false; n:=1; Max:=y2-y1+1; k:=1;

Clr_Wnd(x1,y1,x2,y2,C2,32);

if num<=Max then f1:=num else f1:=Max;

if num <> 0 then for i:=1 to f1 do WriteL(x1,y1+i-1,Nak[i]);

if num <> 0 then for i:=1 to f1 do

begin

Str(Li[i]:7:3,s);

WriteL(x1+5,i+y1-1,s);

end;

repeat

a: Change_Attr(x1,k+y1-1,x2,C3);

Str(Li[n]:7:3,s);

Edst(x1+5,k+y1-1,7,CE,S,ExCod);

Val(s,Li[n],i); if Li[n]>=1000 then Li[n]:=0;

Str(Li[n]:7:3,s);

WriteL(x1+5,k+y1-1,s);

Change_Attr(x1,k+y1-1,x2,C2); i:=0;

for m:=1 to Num do if Li[m]=0 then Inc(i);

if i=0 then

begin

WriteL(45,18,’?????????????????????’);

Change_AttrL(45,18,29,$39,176);

case ExCod of

-68: if i=0 then begin done:=true; ExitCod:=-68; end;

-72: begin

if (k<1) and (n>1) then

begin

k:=k-1; n:=n-1;

end;

else

if Max>=num then begin k:=Max; n:=Max; end

else

if (k=1) and (n>1) then

begin

n:=n-1;

Scroll_Wnd(x1,y1,x2,y2,1,1,C2);

WriteL(x1,y1,Nak[n]);

end;

end;

-80,-28: begin

if (k<Max) and (n<num) then

begin

k:=k+1; n:=n+1;

end

else

if Max>=num then begin k:=1; n:=1; end

else

if (k=Max) and (n<num) then

begin

n:=n+1;

Scroll_Wnd(x1,y1,x2,y2,0,1,C2);

WriteL(x1,y2,Nak[n]);

end;

end;

end;

until done;

end;

*****************************************************************

procedure EdSt (x,y,1,C3: byte; var sfl: string; var Swith: integer);

var i,n,f1: byte; ch,sc: byte; done: boolean; sl: string;

procedure Son; begin {Sound(500); Delay(30); NoSound;} end;

label 1,3,2;

begin

while((sf1[Length(sf1)]=’ ‘) or (sf1[Length(sf1)]=#0)) and (Length(sf1)>0)

do sf1:=Copy(sf1,1,Length(sf1)-1);

i:=1; sl:=’ ‘;

while (i<=Length(sf1)) and (i<=1) to begin sl:=sl+sf1[i];

i:=i+1; end;

for i:=1 to 1 do WriteC(x+i-1 y,C3); done:=false; n:=1; f1:=0;

WriteL(x,y,s1); Pos_CRS(x,y); Show_CRS;

ReadKey(ch,sc);

Case sc of

28,1,72,80,77,75,82,71,79,59..68: goto 2;

else begin s1:=’ ‘; goto 2; end;

ehd;

repeat

while ((s1[Length(s1)]=’ ’) or ((s1[Length(s1)]=#0 and (Length(s1)>0)

do s1:=Copy(s1,1,Length(s1)-1);

WriteL(x,y,s1);

for i:=Length(s1)+1 to 1 do WriteS(x+i-1,y,’ ‘);

Pos_CRS(x+n-1,y); 3: ReadKey(ch,sc); 2:

case sc of

1: begin sf1:=s1; done:=true; Swith:=-1; end;

28: begin sf1:=s1; Swith:=-28; done:=true; end;

68: begin sf1:=s1; Swith:=-68; done:=true; end;

15: begin sf1:=s1; Swith:=-15; done:=true; end;

14: if n>1 then begin Delete(s1,n-1,1); n:=n-1; end;

72: if ch<>0 then Goto 1 else begin sf1:=sl; swith:=-72; done:=true; end;

80: if ch<>0 then Goto 1 else begin sf1:=sl; swith:=-80; done:=true; end;

77: if ch<>0 then Goto 1 else if n<1 then n:=n+1 else Son;

75: if ch<>0 then Goto 1 else if n>1 then n:=n-1 else Son;

83: if ch<>0 then Goto 1 else Delete(s1,n,1,);

71: if ch<>0 then Goto 1 else n:=1;

79: if ch<>0 then Goto 1 else if length(s1)<1 then n:=Length(s1)+1 else n:=1;

82: if ch<>0 then Goto 1 else if f1=0 then begin f1:=1; Mode_CRS(0,4); end

else begin f1:=0; Mode_CRS(3,4); end;

else 1:

if ch<32 then goto 3 else

if f1=0 then

begin

if length(s1)<1 then

if n<=Length(s1) then

begin

Insert(Chr(ch),s1,n); n:=n+1;

end

else

begin

for i:=length(sl)+1 to n-1 do sl:=sl+’ ‘;

sl:=sl+Chr(ch); if n<1 then n:=n+1;

end

else Son;

end

else

if n<=Length(sl) then

begin

sl[n]:=Chr(ch);

if n<1 then n:=n+1 else Son;

end

else

begin

for i:=length(sl)+1 to n-1 do sl:=sl+’ ‘;

sl:=sl+Chr(ch);

if n<1 then n:=n+1 else Son;

end;

end;

until done;

sfl:=sl; Hide_CRS;

end;

Function F_X(x: extended): extended;

begin

F_X:=Exp(-x*x/2)/Sqrt(2*Pi);

end;

*****************************************************************

Function Simpson(x: real): real;

var i,n: integer; s,h: Extended;

begin

n:=30; h:=x/n;

s:=h*(F_X(x) + F_X(0)/3;

for i:=1 to n div 2 do s:=s+h*4*F_X(h*(2*i-1))/3

for i:=1 to (n div 2)-1 do s:=s+h*2*F_X(2*i*h)/3

Simpson:=S

end;

procedure Prin (x1,y1,x2,y2: integer);

var c1,c2: char;

begin

Writeln(lst); c1:=chr((y2-y1) mod 256); c2:=chr((y2-y1) div 256);

Write(lst,#27,#51,#24);

for i:=x1 to x2 do

begin

Write(lst,#27,’K’,c1,c2);

for j:=y1 to y2 do Write(lst,chr((255-)Mam[$A000:(80*(479-j)+i)]));

Writeln(lst);

end;

end;

Приложение Б