svn/view/math2.pas

unit math2;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}
(***************************************)
(* Copyright (C) 2003, SHIRAISHI Kazuo *)
(***************************************)


{$DEFINE extended}
{$N+}


interface
uses variabl;
function NotExistFnc:TPrincipal;far;

implementation

uses SysUtils,
    base,float,arithmet,mathc,
    struct,express,
    texthand,confopt,helpctex,graphic,math2sub,sconsts;


procedure FSEC(var x:double);
begin
   x:=1/cos(x)
end;

procedure Fcsc(var x:double);
begin
     x:=1/sin(x)
end;

function SINfnc:TPrincipal;far;
begin
    if confirmedDegrees then
         SINfnc:=UnaryX(sindeg,1003,'SINdeg')
    else
         SINfnc:=Unary({Nsinrad,}FSIN,1003,'SIN')
end;

function COSfnc:TPrincipal;far;
begin
    if confirmedDegrees then
         COSfnc:=UnaryX(cosdeg,1003,'COSdeg')
    else
         COSfnc:=Unary({Ncosrad,}FCOS,1003,'COS')
end;

function TANfnc:TPrincipal;far;
begin
    if confirmedDegrees then
         TANfnc:=UnaryX(tandeg,1003,'TANdeg')
    else
         TANfnc:=Unary({Ntanrad,}FTAN,1003,'TAN')
end;

function CSCfnc:TPrincipal;far;
begin
    if confirmedDegrees then
         CSCfnc:=UnaryX(CSCdeg,1003,'CSCdeg')
    else
         CSCfnc:=Unary({NCSCrad,}FCSC,1003,'CSC')
end;

function SECfnc:TPrincipal;far;
begin
    if confirmedDegrees then
         SECfnc:=UnaryX(secdeg,1003,'SECdeg')
    else
         SECfnc:=Unary({Nsecrad,}FSEC,1003,'SEC')
end;

function COTfnc:TPrincipal;far;
begin
    if confirmedDegrees then
         COTfnc:=UnaryX(cotdeg,1003,'COTdeg')
    else
         COTfnc:=Unary({Ncotrad,}FCOT,1003,'COT')
end;

{*********************}
{inverse trigonometric}
{*********************}


procedure FASINdeg(var x:double);
begin
   x:=asin(x)*degree
end;

procedure FASIN(var x:double);
begin
   x:=asin(x)
end;

procedure FACOS(var x:double);
begin
    x:=acos(x)
end;

procedure FACOSdeg(var x:double);
begin
    x:=acos(x)*degree
end;

function ATN(x:extended):extended;
begin
   result:=arctan(x)
end;

function ATNdeg(x:extended):extended;
begin
   result:=arctan(x)*degree
end;

function ASINfnc:TPrincipal;far;
begin
    if confirmedDegrees then
      ASINfnc:=Unary({NASINdeg,}FASINdeg,3007,'ASINdeg')
    else
      ASINfnc:=Unary({NASIN,}FASIN,3007,'ASIN')
end;

function ACOSfnc:TPrincipal;far;
begin
    if confirmedDegrees then
      ACOSfnc:=Unary({NACOSdeg,}FACOSdeg,3007,'ACOSdeg')
    else
      ACOSfnc:=Unary({NACOS,}FACOS,3007,'ACOS')
end;


function ATNfnc:TPrincipal;far;
begin
    if confirmedDegrees then
      ATNfnc:=UnaryX(ATNdeg,1003,'ATNdeg')
    else
      ATNfnc:=UnaryX(ATN,1003,'ATN')
end;

function ANGLEfnc:TPrincipal;far;
begin
    if confirmedDegrees then
      ANGLEfnc:=BinaryX(Angledeg,3008,'ANGLEdeg')
    else
      ANGLEfnc:=BinaryX(angle,3008,'ANGLE')
end;

{********************}
{hyperbolic functions}
{********************}

function SINHfnc:TPrincipal;far;
begin
    SINHfnc:=UnaryX(sinh,1003,'SINH')
end;

function COSHfnc:TPrincipal;far;
begin
    COSHfnc:=UnaryX(cosh,1003,'COSH')
end;

function TANHfnc:TPrincipal;far;
begin
    TANHfnc:=UnaryX(tanh,1003,'TANH')
end;

{******}
{Others}
{******}

function DEGfnc:TPrincipal;far;
begin
    DEGfnc:=UnaryX(deg,1003,'DEG')
end;

function MyEXP(x:extended):extended;
begin
    result:=system.exp(x)
end;

function EXPfnc:TPrincipal;far;
begin
    EXPfnc:=UnaryX(MyExp,1003,'EXP')
end;


procedure FLOG(var x:double);
begin
    x:=ln(x)
end;

function LOGfnc:TPrincipal;far;
begin
    LOGfnc:=Unary({NLOG,}FLOG,3004,'LOG')
end;

procedure FLOG2(var x:double);
begin
    x:=ln(x)/ln2
end;

function LOG2fnc:TPrincipal;far;
begin
    LOG2fnc:=Unary({NlOG2,}FLOG2,3004,'LOG2')
end;

procedure FLOG10(var x:double);
begin
    x:=ln(x)/ln10
end;

function LOG10fnc:TPrincipal;far;
begin
    LOG10fnc:=Unary({NLOG10,}FLOG10,3004,'LOG10')
end;

function RADfnc:TPrincipal;far;
begin
    RADfnc:=UnaryX(Rad,1003,'RAD')
end;


{********}
{Graphics}
{********}
type
  TmiscX=class(TPrincipal)
     // evalX������������������������������������������������operation
    //procedure evalN(var n:number);override;
    function evalF:double;override;
    //procedure evalC(var x:complex);override;
    //procedure evalR(var r:PNumeric);override;
   end;

function TmiscX.evalF:double;
begin
     result:=evalX
end;


type
   TMiscUnaryX=class(TMiscX)
       exp:TPrincipal;
       f:extendedfunction1;
    constructor create(f1:extendedfunction1);
    destructor destroy;override;
    function evalX:extended;override;
    function Code:ansistring;override;
    function QueryInteger:TSubstanceList;override;   // Integer������������������������������nil������������������
   end;


constructor TMiscUnaryX.create;
begin
    inherited create;
    f:=f1;
    check('(',IDH_ARRAY_FUNCTION);
    exp:=NExpression;
   check(')',IDH_ARRAY_FUNCTION);
end;

destructor TMiscUnaryX.destroy;
begin
     exp.free;
    inherited destroy;
end;

function TMiscUnaryX.evalX:extended;
begin
   result:=f(exp.evalX);
end;


function TMiscUnaryX.Code:ansistring;
begin
   if @f=@PixelX then
      result:='PixelX('
   else if @f=@PixelY then
      result:='PixelY('
   else if @f=@WindowX then
      result:='WindowX('
   else if @f=@WindowY then
      result:='WindowY(';
   result:=result+exp.code+')'
end;

function TMiscUnaryX.QueryInteger:TSubstanceList;   // Integer������������������������������nil������������������
begin
   if (@f=@PixelX) or (@f=@PixelY) then
      result:=TSubstanceList.create
   else
      result:=nil;
end;


function PixelXfnc:TPrincipal;far;
begin
    PixelXfnc:=NOperation(TMIscUnaryX.create(PixelX))
end;

function PixelYfnc:TPrincipal;far;
begin
    PixelYfnc:=NOperation(TMIscUnaryX.create(PixelY))
end;

function ProblemXfnc:TPrincipal;far;
begin
    ProblemXfnc:=NOperation(TMIscUnaryX.create(WindowX))
end;

function ProblemYfnc:TPrincipal;far;
begin
    ProblemYfnc:=NOperation(TMIscUnaryX.create(WindowY))
end;


{*************}
{Registeration}
{*************}

function NotExistFnc:TPrincipal;far;
begin
    NotExistFnc:=nil;
    seterr(Format(s_InvalidFunctionOnMode,
                  [prevtoken,PrecisionText[PrecisionMode]]),RUN_OPTION)
end;


procedure  FunctionTableInit;far;
begin
   if (PrecisionMode in [PrecisionNormal,PrecisionNative,PrecisionComplex] )
   or (PrecisionMode in [PrecisionHigh,PrecisionRational])
                         and UseTranscendentalFunction  then
   begin
       if PrecisionMode<>PrecisionComplex then
        begin
          SuppliedFunctionTableInit('EXP' ,EXPfnc );
          SuppliedFunctionTableInit('LOG' ,LOGfnc);
        end;
       SuppliedFunctionTableInit('ACOS', ACOSfnc);
       SuppliedFunctionTableInit('ANGLE',ANGLEfnc );
       SuppliedFunctionTableInit('ASIN', ASINfnc );
       SuppliedFunctionTableInit('ATN' , ATNfnc );
       SuppliedFunctionTableInit('COS' , COSfnc);
       SuppliedFunctionTableInit('COSH', COSHfnc );
       SuppliedFunctionTableInit('COT',  COTfnc);
       SuppliedFunctionTableInit('CSC' , CSCfnc);
       SuppliedFunctionTableInit('DEG' , DEGfnc );
       SuppliedFunctionTableInit('LOG10',LOG10fnc );
       SuppliedFunctionTableInit('LOG2' ,LOG2fnc);
       SuppliedFunctionTableInit('RAD' , RADfnc);
       SuppliedFunctionTableInit('SEC',  SECfnc);
       SuppliedFunctionTableInit('SIN',  SINfnc);
       SuppliedFunctionTableInit('SINH', SINHfnc);
       SuppliedFunctionTableInit('TAN' , TANfnc);
       SuppliedFunctionTableInit('TANH' ,TANHfnc);
   end
else if  (PrecisionMode in [PrecisionHigh,PrecisionRational])
                         and not UseTranscendentalFunction  then
   begin
       SuppliedFunctionTableInit('ACOS' ,NotExistFnc);
       SuppliedFunctionTableInit('ANGLE',NotExistFnc);
       SuppliedFunctionTableInit('ASIN' ,NotExistFnc);
       SuppliedFunctionTableInit('ATN'  ,NotExistFnc);
       SuppliedFunctionTableInit('COS'  ,NotExistFnc);
       SuppliedFunctionTableInit('COSH' ,NotExistFnc);
       SuppliedFunctionTableInit('COT'  ,NotExistFnc);
       SuppliedFunctionTableInit('CSC'  ,NotExistFnc);
       SuppliedFunctionTableInit('DEG'  ,NotExistFnc);
       SuppliedFunctionTableInit('EXP'  ,NotExistFnc);
       SuppliedFunctionTableInit('LOG'  ,NotExistFnc);
       SuppliedFunctionTableInit('LOG10',NotExistFnc);
       SuppliedFunctionTableInit('LOG2' ,NotExistFnc);
       SuppliedFunctionTableInit('RAD'  ,NotExistFnc);
       SuppliedFunctionTableInit('SEC'  ,NotExistFnc);
       SuppliedFunctionTableInit('SIN'  ,NotExistFnc);
       SuppliedFunctionTableInit('SINH' ,NotExistFnc);
       SuppliedFunctionTableInit('TAN'  ,NotExistFnc);
       SuppliedFunctionTableInit('TANH' ,NotExistFnc);
  end;

       SuppliedFunctionTableInit('PIXELX',PixelXfnc);
       SuppliedFunctionTableInit('PIXELY',PixelYfnc);
       SuppliedFunctionTableInit('WORLDX',ProblemXfnc);
       SuppliedFunctionTableInit('WORLDY',ProblemYfnc);
       SuppliedFunctionTableInit('PROBLEMX',ProblemXfnc);
       SuppliedFunctionTableInit('PROBLEMY',ProblemYfnc);
       SuppliedFunctionTableInit('WINDOWX',ProblemXfnc);
       SuppliedFunctionTableInit('WINDOWY',ProblemYfnc);
end;


procedure statementTableinit;far;
begin
end;

begin
   tableInitProcs.accept(statementTableinit);
   tableInitProcs.accept(FunctionTableInit);
end.