datamaker.pas

常用数学计算工具

 SPos:=Stream.Position;
 Stream.Size:=Stream.Size+13*FunCommand.Len;
 Stream.Position:=SPos;
 for i:=0 to FunCommand.Len-1 do begin
  if FunCommand.DivFunction[i].SubFun<>nil then HasSubFun:=True else HasSubFun:=False;
  Stream.Write(HasSubFun,1);
  Stream.Write(FunCommand.DivFunction[i].Value2,10);
  Stream.Write(FunCommand.DivFunction[i].FunIndex,1);
  Stream.Write(FunCommand.DivFunction[i].NextIndex,1);
  if HasSubFun then SaveFunCom(FunCommand.DivFunction[i].SubFun^,Stream);
 end;
end;
procedure LoadFunCom(var FunCommand:TFunCommand; Stream:TStream);
var
 i:Integer;
 HasSubFun:Boolean;
begin
 Stream.Read(FunCommand.Len,4);
 for i:=0 to FunCommand.Len-1 do
  begin
   SetLength(FunCommand.DivFunction,i+1);
   Stream.Read(HasSubFun,1);
   Stream.Read(FunCommand.DivFunction[i].Value2,10);
   Stream.Read(FunCommand.DivFunction[i].FunIndex,1);
   Stream.Read(FunCommand.DivFunction[i].NextIndex,1);
   if HasSubFun then begin
    GetMem(FunCommand.DivFunction[i].SubFun,FunCSize);
    FillChar(FunCommand.DivFunction[0].SubFun^,FunCSize,0);
    LoadFunCom(FunCommand.DivFunction[i].SubFun^,Stream);
   end else FunCommand.DivFunction[i].SubFun:=nil;
  end;
end;
procedure SaveStr(var S:String; Stream:TStream);
var
 i:Integer;
begin
 i:=Length(S);
 Stream.Size:=Stream.Size+4+i;
 Stream.Position:=Stream.Size-(4+i);
 Stream.Write(i,4);
 Stream.Write(S[1],i);
end;
procedure LoadStr(var S:String; Stream:TStream);
var
 i:integer;
begin
 Stream.Read(i,4);
 SetLength(S,i);
 Stream.Read(S[1],i);
end;

function ExtendedToStr(V:Extended; Precision:Integer; Separator:Char=#0; SeparatorNum:Integer=3):String;
var
 FR:TFloatRec;
begin
 FloatToDecimal(FR,V,fvExtended,Precision,9999);
 Result:='';     //用指数表达
 //.....
end;
function StrToExtended(S:String; var V:Extended; Separator:Char):Boolean;
begin
 Result:=TextToFloat(PChar(KillChar(S,Separator)),V,fvExtended);
end;
function KillChar(S:String; Separator:Char):String;
var
 i:Integer;
begin
 Result:='';
 for i:=1 to Length(s) do
     if (s[i]<>Separator)and(S[i]<>' ') then Result:=Result+s[i];
end;
////////////////////
procedure MakeFunComData(CommandX,CommandY:String; Tb,Te:Extended; SectNum:Integer; DataX,DataY:TDataXY);
var
 FunComX,FunComY:TFunCommand;
 Pos,i:Integer;
 Frec:Extended;
begin
 if SectNum<=0 then exit;
 if High(DataX)<>High(DataY) then exit;
 Pos:=High(DataX)+1;
 SetLength(DataX,Pos+SectNum+1);
 SetLength(DataY,Pos+SectNum+1);
 try
  StrToFunCom(CommandX,FunComX,'T');
 except
  FreeFunCommand(FunComX);
  exit;
 end;
 try
  StrToFunCom(CommandY,FunComY,'T');
 except
  FreeFunCommand(FunComX); FreeFunCommand(FunComY);
  exit;
 end;
 FreC:=(Te-Tb)/SectNum;
 for i:=0 to SectNum do
  begin
   try
    DataX[Pos+i]:=GetFunValue(FunComX,te+Frec*i);
   except
    FreeFunCommand(FunComX); FreeFunCommand(FunComY);
    exit;
   end;
   try
    DataY[Pos+i]:=GetFunValue(FunComY,te+Frec*i);
   except
    FreeFunCommand(FunComX); FreeFunCommand(FunComY);
    exit;
   end;
  end;
 FreeFunCommand(FunComX); FreeFunCommand(FunComY);
end;

//////////////////////// //////// ////////
//以下是对函数库分析的函数,过程      /////
//////////////////////////////////////////

function IsOnlyStr(S:String; SubStr:String; Pos:Integer):Boolean;  //S中有被孤立的SubStr?
var
 i:Integer;
begin
 Result:=False;
 if Pos<1 then exit;
 if  Length(s)-Pos+1<Length(SubStr) then exit;
 for i:=1 to Length(SubStr) do
  if s[pos-1+i]<>SubStr[i] then exit;
 for i:=Pos+Length(SubStr) to Length(s) do//后方字符
  Case s[i] of
   ' ':;
   '(',')',',',
   '+','-',
   '*','/':    Break;
   else        Exit;
  end;
 for i:=Pos-1 downto 1 do  //前方字符
  Case s[i] of
   ' ':;
   '(',')',',','=',
   '+','-',
   '*','/':    Break;
   else        Exit;
  end; 
 Result:=True;
end;

function CharNum(S:String;C:Char):Integer;  //一个字符串中有多少个c字符
var
 i,Num:Integer;
begin
 Num:=0;
 for i:=1 to Length(s) do
  If S[i]=C then Inc(Num);
 Result:=Num;
end;
function Invalid(S:String; invalidStr:String):Boolean; //标志符号是否合法
var
 i:Integer;
 temp:String;
begin
 Result:=True;
 if Length(s)<2 then exit;               //至少有两个字符
 if ((s[1]='A')or(s[1]>='U')or(s[1]<='Z'))and
    (S[2]>='0')and(S[2]<='9') then exit;//A1XXX-A2XXX,U1XXX-Z9XXX不能使用,保留给A1234
 if (s[1]>='0')and(s[1]<='9') then exit; //第一个字符不能为数字
 for i:=1 to Length(S) do
  if Pos(S[i],inValidStr)<>0 then exit;  //不能含有非法字符
 temp:=UpperCase(s);
 for i:=0 to ReserveNums do
  if Temp=ReserveStrs[i] then exit;     //保留字符不能用
 Result:=False;
end;
function GetLeftStr(S:String; var VarNum:Integer):String;
begin
 Result:='';
//.......
end;

function GetRightStr(S:String):String;  //获得等式右边字符串
begin
 Result:='';
//......
end;
////检查一个简单式子的合理性
function IsValidFunStr(S:String):Boolean;
begin
 Result:=False;
//.....
end;

function Replace(S:String; SrcS,DestS:String):String;  // 在S中查找 SrcS并用DestS代替之
begin
 Result:=S;
 //....
end;
function ReplaceN(S:String; Count:Integer; Src:Array of String; Dest:TStrings):String;
begin
 Result:=S;
//......
end;

procedure GetDfsR(Cfs:String; PS:Integer; Result:TStrings); //将一个定义式的右边的某个函数的参量找到
begin
//......
end;

//复杂式子改为简单函数表达式
function CfsToSfs(Cfs,Dfs:String;{VarC:String; Varc2:String='UnKnow'; Varc3:String='UnKnow';}DataS:TStrings=nil):String;
begin
 Result:='';
//.....
end;
function CfdsToSfds(Cfds,Dfs:String; DataS:TStrings=nil):String;
begin
 Result:='';
//......
end;

Procedure GetDFS(CStrs:TStrings; Result:TStrings; CanVarC:Boolean=False); //在一个函数库中找到定义式
begin
end;
function HasOnlyStr(Str,SubStr:String):Boolean;  // Str有孤立的SubStr?
begin
 Result:=False;
end;
function GetConstValue(S:String):Extended;
begin
 Result:=0;
 //....
end;
function CStrsToSStrs(CStrs,SStrs:TStrings):string; //将复杂函数库变成简单函数库
begin
 Result:='';
end;
function AllBToB(S:String):String; //标准化字符串
begin
 Result:='';
//....
end;
function IsComment(S:String):Boolean;//是否是注释行
begin
 Result:=False;
 if Length(S)>=2 then
  begin
    if (S[1]='/')and(S[2]='/')then Result:=True;
//    if (S[1]='*')and(S[2]='*')then Result:=True;
  end;
end;
function OrgStrsToCStrs(OrgStrs,CStrs:TStrings; LastLine:Integer=-1):Boolean;
begin
 Result:=False;
end;
function OrgStrsToSStrs(OrgStrs,SStrs:TStrings; LastLine:Integer=-1):String;
begin
Result:=ErrorMsg;
end;
//
function CStrToSStr(CStr:String; DefSs:TStrings):String;
begin
 Result:=UpperCase(AllBToB(CStr));
//....
end;
//
function CStrToFloat(CStr:String; var Value:Extended; DefSs:TStrings=nil):Boolean;
var
 FunCom:TFunCommand;
 S:String;
begin
 if DefSs=nil then S:=CStr else S:=CStrToSStr(CStr,DefSs);
 Result:=StrToFunComN(S,FunCom,'UNKNOW');
 if Result then Value:=GetFunValue(FunCom,0);
 FreeFunCommand(FunCom);
end;
//////
function EqualBrakets(C1,C2:Char):Boolean;
begin
 Result:=False;
 //...
end;
function OnlyStrInStrs(XB,YB,XE,YE:Integer; Strs:TStrings):Boolean;
begin
 Result:=False;
end;
function FindWordInStrs(Strs:TStrings; Word:String; var Pos:Integer; var Head,Tail:TPoint; CaseTen:Boolean=False; BlankValid:Boolean=True; CanComment:Boolean=False; CanAddition:Boolean=True; XB:Integer=0;YB:Integer=0; BracketAll:Boolean=True):Boolean;
var
 x,y,  //X,Y循环变量
 i,RealXB,
 spos:Integer; //Word位置指针
 Comped:Boolean; //失败后的恢复标志
begin
 Result:=False;
 if Strs=nil then exit;
 if Length(Word)<1 then exit;
 Y:=YB;   RealXB:=XB;
 if (Y>=0)and(Y<=Strs.Count) then begin
  if RealXB<1 then RealXB:=1;
  if RealXB>Length(Strs[Y]) then begin Inc(y); RealXB:=1; end;
 end;
 spos:=1; Comped:=False;
 while Y<=Strs.Count do begin
  if CanComment then
     if IsComment(Strs[y]) then  //忽略注释
         begin inc(y); continue; end;
  if Y=YB then X:=RealXB else X:=1;  //开始行
  while X<=Length(Strs[Y]) do
   begin
    if (CaseTen and (Strs[Y][X]=Word[spos]))or //区分大小写且相等
       ((not CaseTen) and (UpCase(Strs[Y][X])=UpCase(Word[spos]))) //不区分大小写且相等
       or (BracketAll and EqualBrakets(Strs[Y][X],Word[spos]))     //允许不区分括号且相等
     then begin
      if spos=1 then begin Head.x:=x; Head.y:=y; Comped:=True; end;
      Inc(spos);
     end else begin
      if not (not BlankValid and(Strs[Y][X]=' ')) then     //不是空格且空格无效时
       begin
        sPos:=1;
        if Comped then begin X:=Head.X; Y:=Head.Y; Comped:=False; end;   //出栈
       end;
     end ;
    if sPos>Length(Word) then //已经找到了
     begin
      if OnlyStrInStrs(Head.X,Head.Y,X,Y,Strs)or(not CanAddition) then
       begin
        Tail.x:=X;
        Tail.y:=Y;
        Result:=True;
        Pos:=0;
        for i:=0 to Head.y-1 do Pos:=Pos+Length(Strs[i])+2;//回车分行符号加2
        Pos:=Pos+Head.x;
        exit;
       end else sPos:=1;
      end; //if end
     inc(x);
   end; // while x end
  inc(y);
 end;//while y end
end;

function GetStrFromStrs(Strs:TStrings; Head,Tail:TPoint; CanComment:Boolean=False):String;
var
 i:Integer;
begin
 Result:='';
 if Head.y<>Tail.y then begin
  if (Head.y>0) and (Head.Y<Strs.Count)
    then Result:=Result+Copy(Strs[Head.Y],Head.X,Length(Strs[Head.Y])-Head.X+1);
  for i:=Head.y+1 to Tail.y-1 do
    if (i>0) and (i<Strs.Count) then
     if (not CanComment)or( not(IsComment(Strs[i])) )
        then Result:=Result+Strs[i];
  if (Tail.y>0) and (Tail.Y<Strs.Count)
    then Result:=Result+Copy(Strs[Tail.Y],1,Tail.X);
 end else begin
  if (Head.y>0) and (Head.Y<Strs.Count)
     then Result:=Copy(Strs[Head.Y],Head.X,Tail.X-Head.X+1);
 end;
end;


const HexStr:String[16]=('0123456789ABCDEF');

function FloatToHex(Data:Extended):String;
var
 count,j:Integer;
 Float,I,F:Extended;
begin
 Float:=Abs(Data);
 Result:='???';  if Float>1e18 then exit;
 result:='0';    if Float<1e-18 then exit;