unit baslibd;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}
{$INLINE ON}
(***************************************)
(* Copyright (C) 2017, SHIRAISHI Kazuo *)
(***************************************)

interface
uses
  Classes, SysUtils,
  base,textfile,baslib,arithmet,mathd;

{Let Statements}
procedure LETD(const p:Array of PNumber; x:Number);

{ Ask Statement}
procedure AskFile(ch:TTextDEvice;
                  expAccess,expDatum,expErasable,expFileType,expName,
                  expOrganization,expPointer,expRecsize1,expRecType,
                  expSetter,expCharin,expTypeahead,expEchoControl,expEcho:TStrVar;
                  expMargin,expRecSize2,expZonewidth,expCharacterPending,expFilesize:PNumber);


{Misc.}
procedure swap(var x,y:Number);overload;

{Trigonometric}
function sin(x:number):extended;   overload;
function cos(x:number):extended;   overload;
function tan(x:number):extended;   overload;
function cot(x:number):extended;   overload;
function csc(x:number):extended;   overload;
function sec(x:number):extended;   overload;

implementation
uses math2sub;

 {$MAXFPUREGISTERS Default}

{Let Statements}

procedure LETD(const p:Array of PNumber; x:Number);
var
   i:integer;
begin
   RoundVariable(x);
   for i:=0 to High(p) do
       p[i]^:=x;
end;


{ Ask Statement}
procedure AskFile(ch:TTextDEvice;
                  expAccess,expDatum,expErasable,expFileType,expName,
                  expOrganization,expPointer,expRecsize1,expRecType,
                  expSetter,expCharin,expTypeahead,expEchoControl,expEcho:TStrVar;
                  expMargin,expRecSize2,expZonewidth,expCharacterPending,expFilesize:PNumber);
var
   xMargin,xRecSize2,xZonewidth,xCharacterPending,xFilesize:double;
   pMargin,pRecSize2,pZonewidth,pCharacterPending,pFilesize:Pdouble;
begin
   pMargin:=nil;pRecSize2:=nil;pZonewidth:=nil;pCharacterPending:=nil;pFilesize:=nil;
   if expMargin<>nil then pMargin:=@xmargin;
   if expRecSize2<>nil then pRecSize2:=@xRecSize2;
   if expZoneWidth<>nil then pZoneWidth:=@xZoneWidth;
   if expCharacterPending<>nil then pCharacterPending:=@xCharacterPending;
   if expFilesize<>nil then pFilesize:=@xFilesize;
   baslib.AskFile(ch,    expAccess,expDatum,expErasable,expFileType,expName,
                  expOrganization,expPointer,expRecsize1,expRecType,
                  expSetter,expCharin,expTypeahead,expEchoControl,expEcho,
                  @xMargin,@xRecSize2,@xZonewidth,@xCharacterPending,@xFilesize);
    if expMargin<>nil then expMargin^:=xmargin;
    if expRecSize2<>nil then expRecSize2^:=xRecSize2;
    if expZoneWidth<>nil then expZonewidth^:=xZonewidth;
    if expCharacterPending<>nil then expCharacterPending^:=xCharacterPending;
    if expFilesize<>nil then expFilesize^:=xFilesize;
end;

{Misc.}
procedure swap(var x,y:Number);overload;
var
   temp:Number;
begin
   temp:=x; x:=y; y:=temp
end;

{*************}
{Trigonometric}
{*************}
const error_pi_div2:extended=     // π/2 - DecimalHalfPi
{$IFDEF FPC_HAS_TYPE_EXTENDED}   1.92313216916397514420985847E-17  ;
{$ELSE}                        6.619231321691639751442E-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:=extendedval(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 sin(x:number):extended;
var
   y:extended;
   i:longint;
begin
   shrinks(x,y,i);
   if (i and 2)=0 then
      sin:=system.sin(y)
   else
      sin:=-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:=extendedval(x);
    if (i and 1)=0 then
       y:=y+(i+1)*error_pi_div2
    else
       y:=y-i*error_pi_div2;
end;
function cos(x:number):extended;
var
   y:extended;
   i:longint;
begin
   shrinkc(x,y,i);
   dec(i);
   if (i and 2)<>0 then
      cos:=system.sin(y)
   else
      cos:=-system.sin(y)
end;

function tan(x:number):extended;
begin
 try
   result:=sin(x)/cos(x);
 except
   //if FPUerror then
   {$IFNDEF WINDOWS}
   asm finit end;
   SetFPUMask(controlword);
   {$ENDIF}
   setexceptionwith('TAN',1003);
 end;
end;

function cot(x:number):extended;
begin
  try
   result:=cos(x)/sin(x);
  except
      // if FPUerror then
     {$IFNDEF WINDOWS}
     asm finit end;
     SetFPUMask(controlword);
     {$ENDIF}
     setexceptionwith('TAN',1003);
  end;
end;

function csc(x:number):extended;
begin
  try
    result:=1./sin(x);
  except
    //if FPUerror then
     {$IFNDEF WINDOWS}
     asm finit end;
     SetFPUMask(controlword);
     {$ENDIF}
     setexceptionwith('CSC',1003);
  end;
end;

function sec(x:number):extended;
begin
  try
    result:=1./cos(x);
  except
     //if FPUerror then
     {$IFNDEF WINDOWS}
     asm finit end;
     SetFPUMask(controlword);
     {$ENDIF}
     setexceptionwith('SEC',1003);
  end;
end;


initialization
   arithmet.setOpModeDecimal;
end.

