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


{$DEFINE extended}
{$N+}


interface
uses  SysUtils,Math,
    variabl;
function NotExistFnc:TPrincipal;

implementation
uses
    base,float,arithmet,struct,express,rational,
    texthand,confopt,helpctex,graphic,math2sub,sconsts;

{*******}
{Classes}
{*******}

{********************}
{Indivisual functions}
{********************}

{*************}
{Trigonometric}
{*************}
(*
//double   DecimalHalfpi -π/2 =  .0000000000000033807686783083602485579014153003124470895125277038460917968568955006859825873289414660089259567433588466764530776952247088841373202959357594412748579486490307394472201776885255225348090177855945121670332769357621758831066084173643990454271757165382698256947728366758933031963698754293631377064966968422059125592395395185853729541423178160537048199943347347255897667393079265240292441952834713648171202040234539069413090336941034474407259627688100186252163240571236375543860309084940254350831633187796716784569893025268023876314046489100695281486147303914118534116238076625907661652974339997159364273682195861071143286211051954131814106392657795493875232849267252073144746038601553705382289900219439354890195679827909200931851126143450197406463943250000008135109750244701341335919518407024877702723265458486787388458733276574823690344059144949984310806235567062333958092896914111654263482008732547856222656344202185680588231062031240211090711097339143865966934990360616944020453917899005
//extended DecimalHalfpi -π/2 =  .0000000000000003807686783083602485579014153003124470895125277038460917968568955006859825873289414660089259567433588466764530776952247088841373202959357594412748579486490307394472201776885255225348090177855945121670332769357621758831066084173643990454271757165382698256947728366758933031963698754293631377064966968422059125592395395185853729541423178160537048199943347347255897667393079265240292441952834713648171202040234539069413090336941034474407259627688100186252163240571236375543860309084940254350831633187796716784569893025268023876314046489100695281486147303914118534116238076625907661652974339997159364273682195861071143286211051954131814106392657795493875232849267252073144746038601553705382289900219439354890195679827909200931851126143450197406463943250000008135109750244701341335919518407024877702723265458486787388458733276574823690344059144949984310806235567062333958092896914111654263482008732547856222656344202185680588231062031240211090711097339143865966934990360616944020453917899005
const error_pi_div2:extended=
{$IFDEF FPC_HAS_TYPE_EXTENDED}  3.8076867830836025E-16 ;
{$ELSE}                        3.38076867830836E-15    ;
{$ENDIF}

procedure shrinks(var n:number;var y:extended;var i:longint);
var
   c:integer;
   sign:integer;
   x,q,xx:number;
begin
    sign:=1;
    x.init(@n);
    if arithmet.sgn(@x)<0 then begin arithmet.oppose(x); sign:=-1 end;
    divide(x,decimalhalfpi^,q,x);
    i:=longintval(q,c);
    while c<>0 do
        begin
            initinteger(xx,4);
            remainder(q,xx,q);
            i:=longintval(q,c)
        end;
     if (i and 1)<>0 then arithmet.sbt(decimalhalfpi^,x,x);
    y:=doubleval(x);
    if (i and 1)=0 then
       y:=y+i*error_pi_div2
    else
       y:=y+(i-1)*error_pi_div2;
   if sign<0 then y:=-y;
end;

function sinrad(var x:number):extended;
var
   y:extended;
   i:longint;
begin
   shrinks(x,y,i);
   if (i and 2)=0 then
      sinrad:=system.sin(y)
   else
      sinrad:=-system.sin(y)
end;

procedure shrinkc(var n:number;var y:extended;var i:longint);
var
   c:integer;
   x,q,xx:number;
begin
    x.init(@n);
    arithmet.absolute(x);
    divide(x,decimalhalfpi^,q,x);
    i:=longintval(q,c);
    while c<>0 do
        begin
            initinteger(xx,4);
            remainder(q,xx,q);
            i:=longintval(q,c)
        end;
     if (i and 1)=0 then arithmet.sbt(decimalhalfpi^,x,x);
    y:=doubleval(x);
    if (i and 1)=0 then
       y:=y+(i-1)*error_pi_div2
    else
       y:=y+i*error_pi_div2;
end;
function cosrad(var x:number):extended;
var
   y:extended;
   i:longint;
begin
   shrinkc(x,y,i);
   dec(i);
   if (i and 2)<>0 then
      cosrad:=system.sin(y)
   else
      cosrad:=-system.sin(y)
end;
*)
const constdecimalHalfPI:number=
{$IFDEF FPC_HAS_TYPE_EXTENDED}  (SIG:15707963267948970; EXP:-16);
{$ELSE}                         (SIG:157079632679490;   EXP:-14);
{$ENDIF}

const error_pi_div2:extended=     // π/2 - DecimalHalfPi
{$IFDEF FPC_HAS_TYPE_EXTENDED}  -3.807686783083602485579E-16  ;
{$ELSE}                        -3.380768678308360248558E-15     ;
{$ENDIF}

procedure shrinks(var n:number;var y:extended;var i:longint);
var
   c:integer;
   sign:integer;
   x,q,xx:number;
begin
    sign:=1;
    x.init(@n);
    if arithmet.sgn(@x)<0 then begin arithmet.oppose(x); sign:=-1 end;
    divide(x,constdecimalhalfpi,q,x);
    i:=longintval(q,c);
    while c<>0 do
        begin
            initinteger(xx,4);
            remainder(q,xx,q);
            i:=longintval(q,c)
        end;
     if (i and 1)<>0 then arithmet.sbt(constdecimalhalfpi,x,x);
    y:=doubleval(x);
    if (i and 1)=0 then
       y:=y-i*error_pi_div2
    else
       y:=y+(i+1)*error_pi_div2;
   if sign<0 then y:=-y;
end;

function sinrad(x:number):extended;
var
   y:extended;
   i:longint;
begin
   shrinks(x,y,i);
   if (i and 2)=0 then
      sinrad:=system.sin(y)
   else
      sinrad:=-system.sin(y)
end;

procedure shrinkc(var n:number;var y:extended;var i:longint);
var
   c:integer;
   x,q,xx:number;
begin
    x.init(@n);
    arithmet.absolute(x);
    divide(x,constdecimalhalfpi,q,x);
    i:=longintval(q,c);
    while c<>0 do
        begin
            initinteger(xx,4);
            remainder(q,xx,q);
            i:=longintval(q,c)
        end;
     if (i and 1)=0 then arithmet.sbt(constdecimalhalfpi,x,x);
    y:=doubleval(x);
    if (i and 1)=0 then
       y:=y+(i+1)*error_pi_div2
    else
       y:=y-i*error_pi_div2;
end;
function cosrad(x:number):extended;
var
   y:extended;
   i:longint;
begin
   shrinkc(x,y,i);
   dec(i);
   if (i and 2)<>0 then
      cosrad:=system.sin(y)
   else
      cosrad:=-system.sin(y)
end;


procedure TestExtended(var x:extended; const opName:string; overflowcode, invalidcode:integer);
begin
    if isInfinite(x) then
            setexceptionwith(opName,overflowcode)
    else if isNan(x) then
            setexceptionwith(oPname,invalidcode) ;
end;

function tanrad(var x:number):extended;
begin
   result:=sinrad(x)/cosrad(x);
   TestExtended(result,'TAN',1003,1003);
end;

function cotrad(var x:number):extended;
begin
   result:=cosrad(x)/sinrad(x);
   TestExtended(result,'COT',1003,1003);
end;

function cscrad(var x:number):extended;
begin
    result:=1./sinrad(x);
    TestExtended(result,'CSC',1003,1003);
end;

function secrad(var x:number):extended;
begin
    result:=1./cosrad(x);
    TestExtended(result,'SEC',1003,1003);
end;


procedure NSinRad(var n:number);
begin
    convert(sinrad(n),n);
end;

procedure NCosRad(var n:number);
begin
    convert(cosrad(n),n);
end;

procedure NTANRad(var n:number);
begin
    convert(TANrad(n),n);
end;

procedure NSECRad(var n:number);
begin
    convert(secrad(n),n);
end;

procedure NCSCRad(var n:number);
begin
    convert(cscrad(n),n);
end;

procedure NCOTrad(var n:number);
begin
    convert(COTrad(n),n);
end;

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;
begin
    if confirmedDegrees then
         SINfnc:=UnaryX(sindeg,1003,'SIN')
    else
         SINfnc:=Unary(Nsinrad,FSIN,1003,'SIN')
end;

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

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

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

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

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

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


function asinN(var n:number):extended;
var
  h,j:number;
begin
  arithmet.sbt(one^,n,h);
  arithmet.add(one^,n,j);
  asinN:=asinsub(doubleval(n),doubleval(h),doubleval(j))
end;

function acosN(var n:number):extended;
var
  h,j:number;
begin
  arithmet.sbt(one^,n,h);
  arithmet.add(one^,n,j);
  acosN:=acossub(doubleval(n),doubleval(h),doubleval(j))
end;

function asinNdeg(var n:number):extended;
begin
   asinNdeg:=asinN(n)*degree;
end;

function acosNdeg(var n:number):extended;
begin
    acosNdeg:=acosN(n)*degree;
end;


procedure NASIN(var n:number);
begin
    convert(ASINN(n),n);
end;

procedure NACOS(var n:number);
begin
    convert(ACOSN(n),n);
end;

procedure NASINdeg(var n:number);
begin
    convert(ASinNdeg(n),n);
end;

procedure NACOSdeg(var n:number);
begin
    convert(ACOSNdeg(n),n);
end;

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;
begin
    if confirmedDegrees then
      ASINfnc:=Unary(NASINdeg,FASINdeg,3007,'ASIN')
    else
      ASINfnc:=Unary(NASIN,FASIN,3007,'ASIN')
end;

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


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

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

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

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

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

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

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

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

function MyEXP(x:extended):extended;
begin
    //seems to be a bug on FPC.
    if x>=709.782712893384 then setexception(1003);
    result:=exp(x)
end;

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



procedure Nlog(var n:number);
begin
    convert(logN(n),n);
end;

procedure FLOG(var x:double);
begin
    if x<=0 then setexception(3004);
    x:=ln(x)
end;

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

procedure Nlog2(var n:number);
begin
    convert(logN(n)/ln2,n);
end;

procedure FLOG2(var x:double);
begin
    if x<=0 then setexception(3004);
    x:=ln(x)/ln2
end;

function LOG2fnc:TPrincipal;
begin
    LOG2fnc:=Unary(NlOG2,FLOG2,3004,'LOG')
end;

procedure Nlog10(var n:number);
begin
    convert(logN(n)/ln10,n);
end;

procedure FLOG10(var x:double);
begin
   if x<=0 then setexception(3004);
   x:=ln(x)/ln10
end;

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

function RADfnc:TPrincipal;
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;

procedure TmiscX.evalN(var n:number);
begin
   convert(evalX,n)
end;

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

procedure TmiscX.evalC(var x:complex);
begin
   x.x:=evalX;
   x.y:=0
end;

procedure TmiscX.evalR(var r:PNumeric);
var
   n:number;
begin
   convert(evalX,n);
   disposeNumeric(r);
   r:=NewRationalfromNumber(@n);
end;

type
   TMiscUnaryX=class(TMiscX)
       exp:TPrincipal;
       f:extendedfunction1;
    constructor create(f1:extendedfunction1);
    destructor destroy;override;
    function evalX:extended;override;
   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;

type
    doublefunction1=function(x:double):double;
type
   TMiscUnaryXdouble=class(TMiscX)
       exp:TPrincipal;
       f:doublefunction1;
    constructor create(f1:doublefunction1);
    destructor destroy;override;
    function evalX:extended;override;
   end;

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

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

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


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

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

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

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


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

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



procedure  FunctionTableInit;
begin
   if (PrecisionMode in [PrecisionNormal,PrecisionNative,PrecisionComplex] )
   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;
       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;
begin
end;

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

