datamaker.pas

常用数学计算工具

 I:=Int(Float);
 F:=Frac(Float);
 Result:=''; count:=0;
 while I>1e-18 do
  begin
   Result:=HexStr[Round(I-Int(I/16)*16)+1]+Result;
   I:=Int(I/16);  inc(count);
  end;
 if Data<0 then Result:='-'+Result;
 if F<1e-18 then exit;
 if Result='' then Result:='0';
 Result:=Result+'.'; j:=0;
 repeat
  Result:=Result+HexStr[Trunc(F*16)+1];
  F:=Frac(F*16);   inc(j);
 until (j+count>=15)or (F<1e-18);
end;

function HexToFC(S:String; var Float:Extended; Int:Boolean):Boolean;
var
 i,sp,Hi:Integer;
begin
 Result:=False; Float:=0; Hi:=Length(s)-1;
 for i:=0 to Hi do
  begin
   sp:=Pos(UpCase(s[i+1]),HexStr);
   if sp=0 then exit;
   if int then Float:=Float+(sp-1)*IntPower(16,Hi-i)   //整数部分
          else Float:=Float+(sp-1)/IntPower(16,i+1);  //小数部分
  end;
 Result:=True;
end;

function HexToFloat(HexStr:String; var Float:Extended):Boolean;
var
 temp,Hex:String;
 sp:Integer;
 Int,Fra:Extended;
begin
 Result:=False;  if HexStr='' then exit;
 if HexStr[1]<>'-' then Hex:=HexStr
    else Hex:=Copy(HexStr,2,Length(HexStr)-1);
 if Hex='' then exit;
 case CharNum(Hex,'.') of
  0: Result:=HexToFC(Hex,Float,True);
  1: begin
      sp:=Pos('.',Hex);
      temp:=Copy(Hex,1,sp-1);
      if not HexToFC(temp,int,True) then exit;
      temp:=Copy(Hex,sp+1,Length(Hex)-sp);
      Result:=True; Float:=Int;
      if temp<>'' then begin
      Result:=HexToFC(Temp,Fra,False);
      Float:=int+Fra;  end;
     end;
 end;
 if Hex<>HexStr then Float:=-Float;
end;
function DFMToFloat(DFM:String; Var Float:Extended):Boolean;
var
 temp,temp2:String;
 f:Extended;
 Num,Ps:Integer;
begin
 Result:=False;  if DFM='' then exit;
 Num:=CharNum(DFM,'-');
 if Num>2 then exit;
 Case Num of
  0: Result:=TextToFloat(PChar(DFM),Float,fvExtended);
  1: begin
      Ps:=Pos('-',DFM);
      Temp:=Copy(DFM,1,Ps-1);
      Result:=TextToFloat(PChar(temp),f,fvExtended);
      if not Result then exit;   Float:=f;
      Temp:=Copy(DFM,Ps+1,Length(DFM)-Ps);
      Result:=TextToFloat(PChar(temp),f,fvExtended);
      if not Result then exit;  Float:=Float+f/60;
     end;
  2: begin
      Ps:=Pos('-',DFM);
      Temp:=Copy(DFM,1,Ps-1);
      Result:=TextToFloat(PChar(temp),f,fvExtended);
      if not Result then exit;   Float:=f;
      Temp:=Copy(DFM,Ps+1,Length(DFM)-Ps);
      Ps:=Pos('-',Temp);
      Temp2:=Copy(Temp,1,Ps-1);
      Result:=TextToFloat(PChar(temp2),f,fvExtended);
      if not Result then exit;  Float:=Float+f/60;
      Temp2:=Copy(Temp,Ps+1,Length(Temp)-Ps);
      Result:=TextToFloat(PChar(temp2),f,fvExtended);
      if not Result then exit;  Float:=Float+f/60/60;
     end;
 end;
 float:=float*PI/180;
end;
function FloatToDFM(Float:Extended):String;
var
 f:Extended;
begin
 Result:='';
 float:=float*180/PI;
 Result:=IntToStr(Trunc(Float))+'-';
 f:=Frac(Abs(Float))*60;
 Result:=Result+IntToStr(Trunc(f))+'-';
 f:=Frac(f)*60;
 Result:=Result+FloatToStr(f);
end;

function CaculateComplex(Command:Char; S1,X1,S2,X2:Extended; var RS,RX:Extended):Boolean;
begin
 Result:=False;
end;
function CacuCompStrValue(Command:String; Var RS,RX:Extended;DefSs:TStrings=nil):Boolean;
function CCS(Com:String; var rs,rx:Extended):Boolean;
begin
 Result:=False;
end;
begin
 Result:=CCS(OptStr(Command),RS,RX);
end;

function Integral(FunCommand:TFunCommand; a,b:Extended; Cent:Integer):Extended;
const
 AK:Array [0..2] of Extended=(5/9,8/9,5/9);
 tk:Array [0..2] of Extended=(0.77459666924148337703585307995648,0,-0.77459666924148337703585307995648);
var
 Value,CV,temp,temp2:Extended;
 i:Integer;
begin
 CV:=(b-a)/Cent;
 Result:=0;
 for i:=0 to Cent-1 do
  begin
   Value:=CV*i+a; temp:=CV/2; temp2:=Value+temp;
   Result:=Result+temp*(AK[0]*GetFunValue(FunCommand, temp2+temp*tK[0])+
                        AK[1]*GetFunValue(FunCommand, temp2+temp*tK[1])+
                        AK[2]*GetFunValue(FunCommand, temp2+temp*tK[2]) );
  end;
end;

function NNewtonME(PFCA,PV,POldV:Pointer; T,h,EPS:Extended; A,B,Z:TMatrix; Count,MaxTime:Integer):Boolean;
var
 PFun:PFunComArray;
 V,OldV:PExtArray;
 i,j,times:Integer;
 TZ:Extended;

 function AccordPre:Boolean; //判断是否达到精度
 var
  i:Integer;
 begin
  Result:=False;
  for i:=0 to Count-1 do
   if Abs(V[i]-OldV[i])>EPS then exit;
  Result:=True;
 end;
begin
 PFun:=PFCA;
 V:=PV;
 OldV:=POldV;
 Result:=False;

 times:=0;
 repeat
   for i:=0 to Count-1 do B[i,0]:=GetFunValueN(PFun[i],V[0],V[1],V[2],V[3],V[4],V[5],@V[6]);

   for i:=0 to count-1 do
    for j:=0 to Count-1 do
     begin
      MoveMemory(@OldV[0],@V[0],Count*SizeOf(Extended));
      OldV[j]:=V[j]+h;
      A[i,j]:=GetFunValueN(PFun[i],OldV[0],OldV[1],OldV[2],OldV[3],OldV[4],OldV[5],@OldV[6]);
     end;
   if not SysLin(A,B,Z) then raise exception.Create('矩阵运算错误!');

   MoveMemory(@OldV[0],@V[0],Count*SizeOf(Extended));
   TZ:=0;
   for i:=0 to count-1 do TZ:=TZ+Z[i,0];
   TZ:=1-TZ;
   if TZ+1=1 then begin break; end;
   for i:=0 to Count-1 do V[i]:=V[i]-h*Z[i,0]/TZ;
   h:=t*h;
   inc(times);
 until AccordPre or (times>MaxTime);//MaxTime次运算之内
 if AccordPre then Result:=True;
end;

var A,B,C,D:Array [0..MaxVarNum-1] of Extended;
procedure Euler2(PFCA,PEA:Pointer; T, H, EPS:Extended;  Count:Integer);
var
 PFun:PFunComArray;
 PExt:PExtArray;
 HH,P,Q,x:Extended;
 i,j,N:Integer;
begin
 PFun:=PFCA;
 PExt:=PEA;
 HH:=H;
 N:=1;
 P:=1.0+EPS;
 for i:=0 to Count-1 do A[i]:=PExt[i];
 while P>=EPS do begin
  for i:=0 to count-1 do begin
   B[i]:=PExt[i];
   PExt[i]:=A[i];
  end;
  for j:=0 to N-1 do begin
   for i:=0 to count-1 do C[i]:=PExt[i];
   x:=T+(j-1)*HH;
   for i:=0 to count-1 do
    D[i]:=GetFunValueN(PFun[i],x,PExt[0],PExt[1],PExt[2],PExt[3],PExt[4],@PExt[5]);
   for i:=0 to count-1 do PExt[i]:=C[i]+HH*D[i];
   x:=T+j*HH;
   for i:=0 to count-1 do
    D[i]:=GetFunValueN(PFun[i],x,PExt[0],PExt[1],PExt[2],PExt[3],PExt[4],@PExt[5]);
   for i:=0 to count-1 do D[i]:=C[i]+HH*D[i];
   for i:=0 to count-1 do PExt[i]:=(PExt[i]+D[i])/2;
  end; //end for
  P:=0;
  for i:=0 to count-1 do begin
   Q:=Abs(PExt[i]-B[i]);
   if Q>P then P:=Q;
  end;
  HH:=HH/2;
  N:=2*N;
 end;//end while
end;

function ZXECDN(XV,YV,AV,SV,TV,BV:Pointer; N,M:Integer; var DT1,DT2,DT3:Extended):Boolean;
var
 X,Y,A,S,T,B:PExtArray;
 i,j,k:Integer;
 Z,D1,P,C,D2,G,Q,DT:Extended;
begin
 Result:=False;          //SizeOf(Extended)
 Integer(X):=Integer(XV)-10; Integer(Y):=Integer(YV)-10; Integer(A):=Integer(AV)-10;
 Integer(S):=Integer(SV)-10; Integer(T):=Integer(TV)-10; Integer(B):=Integer(BV)-10;
 for i:=1 to M do A[i]:=0;
 Z:=0;
 for i:=1 to N do Z:=Z+X[i]/N;
 B[1]:=1; D1:=N; P:=0; C:=0;
 for i:=1 to N do begin
  P:=P+(X[i]-Z);//减平均值，防止溢出
  C:=C+Y[i];
 end;
 C:=C/D1; P:=P/D1;
 A[1]:=C*B[1];

 if M>1 then begin
  T[2]:=1.0; T[1]:=-P;
  D2:=0; C:=0; G:=0;
  for i:=1 to N do begin
   Q:=X[i]-Z-P;
   D2:=D2+Q*Q;
   C:=Y[i]*Q+C;
   G:=(X[i]-Z)*Q*Q+G;
  end;
  C:=C/D2; P:=G/D2; Q:=D2/D1; D1:=D2;
  A[2]:=C*T[2];
  A[1]:=C*T[1]+A[1];

 for j:=3 to M do begin
  S[j]:=T[j-1];
  S[j-1]:=-P*T[j-1]+T[j-2];
  {if j>=3 then} for k:=j-2 downto 2 do
     S[K]:=-P*T[k]+T[k-1]-Q*B[k];
  s[1]:=-P*T[1]-Q*B[1];
  D2:=0; C:=0; G:=0;
  for i:=1 to N do begin
   Q:=S[j];
   for k:=j-1 downto 1 do
       Q:=Q*(X[i]-Z)+S[k];
   D2:=D2+Q*Q;
   C:=Y[i]*Q+C;
   G:=(X[i]-Z)*Q*Q+G;
  end;// end for i
  C:=C/D2; P:=G/D2; Q:=D2/D1; D1:=D2;
  A[j]:=C*S[j];
  T[j]:=S[j];
  for k:=j-1 downto 1 do begin
   A[k]:=C*S[k]+A[k];
   B[k]:=T[k];
   T[k]:=S[k];
  end;
 end;// end for j
 end; //end M>1
 //完成计算系数
 DT1:=0; DT2:=0; DT3:=0;
 for i:=1 to N do begin
  Q:=A[M];
  for k:=M-1 downto 1 do
      Q:=Q*(X[i]-Z)+A[K];
  DT:=Q-Y[i];
  if Abs(DT)>DT3 then DT3:=Abs(DT);
  DT1:=DT1+DT*DT;
  DT2:=DT2+Abs(DT);
 end;
end;

function IsQTM(X,Y:TMatrix; N,M:Integer; var A,V:TMatrix; var Q,S,R,U:Extended):Boolean;
var
 B:TMatrix;
 i,j,k:Integer;
 YY,DYY,P:Double;
begin
 IsQTM:=False;
 if N*M=0 then exit;
 if Length(X)<>M then exit; if Length(X[0])<>N then exit;
 if Length(Y)<>N then exit; if Length(Y[0])<>1 then exit;

 SetLength(B,M+1,M+1); SetLength(A,M+1,1); SetLength(V,M,1);
 try
 B[0,0]:=N;
 for j:=1 to M do begin
  B[0,j]:=0;
  for i:=0 to N-1 do B[0,j]:=B[0,j]+X[j-1,i];
  B[j,0]:=B[0,j];
 end;
 for i:=1 to M do
  for j:=i to M do begin //上半矩阵
   B[i,j]:=0;
   for k:=0 to N-1 do
    B[i,j]:=B[i,j]+X[i-1,k]*X[j-1,k];
   B[j,i]:=B[i,j];
  end;
 A[0,0]:=0;
 for i:=0 to N-1 do A[0,0]:=A[0,0]+Y[i,0];
 for i:=1 to M do begin
  A[i,0]:=0;
  for j:=0 to N-1 do A[i,0]:=A[i,0]+X[i-1,j]*Y[j,0];
 end;
 SysLin(B,A,A);//求出A
 YY:=0;
 for i:=0 to N-1 do YY:=YY+Y[i,0]/N;
 Q:=0;
 DYY:=0;
 U:=0;
 for i:=0 to N-1 do begin
  P:=A[0,0];
  for j:=0 to M-1 do P:=P+A[j+1,0]*X[j,i];
  Q:=Q+Sqr(Y[i,0]-P);
  DYY:=DYY+Sqr(Y[i,0]-YY);
  U:=U+Sqr(YY-P);
 end;
 S:=Sqrt(Q/N);
 R:=Sqrt(1-Q/DYY);
 for j:=0 to M-1 do begin
  P:=0;
  for i:=0 to N-1 do begin
   DYY:=A[0,0];
   for k:=0 to M-1 do
    if k<>j then DYY:=DYY+A[k+1,0]*X[k,i];
   P:=P+Sqr(Y[i,0]-DYY);
  end;
  V[j,0]:=Sqrt(1-Q/P);
 end;
 finally
 SetLength(B,0,0);
 end;
end;



end.