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


interface
uses sysUtils,math;

function LongIntRound(x:extended):Integer;

type
    floatFunction1=procedure (var x:double);
    floatFunction2=procedure (var x,y:double);

procedure  add(var x,y:extended);
procedure  sbt(var x,y:extended);
procedure  mlt(var x,y:extended);
procedure  qtt(var x,y:extended);
procedure  power(var x,y:extended);
procedure  opposite(var x:extended);


procedure  basicMOD(var x,y:double);
procedure  square(var x:double);
procedure  FMAX(var x,y:double);
procedure  FMIN(var x,y:double);
procedure  FABS  (var x:double);
procedure  FCEIL (var x:double);
procedure  FFLOOR(var x:double);
procedure  FSQRT (var x:double);
procedure  FROUND(var x:double);
procedure  FEPS  (var x:double);
procedure  FSIN  (var x:double);
procedure  FCOS  (var x:double);
procedure  FTAN  (var x:double);
procedure  FCOT  (var x:double);

function fcompare(var x,y:double):integer;
function fsign(var x:double):integer;

function NPXpower(x,y:extended):extended;
function NPXpower1plus(x,y:extended):extended;


implementation
 uses
      base;

{$ASMMODE intel}

type Int64Type=record
     low32:integer;
     high32:integer;
end;
function longIntRound(x:extended):longint;
var
 i:int64;
begin
  i:=System.Round(x);
  if i>=0 then
     if (int64type(i).low32>=0) and (Int64Type(i).high32=0) then
        result:=i
     else
        raise EInvalidOp.Create('')
  else
     if (Int64Type(i).low32<0) and (Int64Type(i).high32=-1) then
        result:=i
     else
         raise EInvalidOp.create('')
end;

 procedure  opposite(var x:extended);
begin
   x:=-x
end;


procedure  add(var x,y:extended);
begin
   x:=x+y
end;

procedure  sbt(var x,y:extended);
begin
   x:=x-y
end;

procedure  mlt(var x,y:extended);
begin
   x:=x*y
end;

procedure  qtt(var x,y:extended);
begin
   x:=x/y
end;

procedure square(var x:double);
begin
   x:=sqr(x)
end;


function fsign(var x:double):integer;
begin
  if x>0 then
     result:=1
  else if x<0 then
     result:=-1
       else
          result:=0
end;

function fcompare(var x,y:double):integer;
var
   t:double;
begin
  t:=x-y;
  result:=fsign(t)
end;

procedure  FMAX(var x,y:double);
begin
  if x<y then
     x:=y
end;

procedure  FMIN(var x,y:double);
begin
   if x>y then
      x:=y
end;

procedure  FABS  (var x:double);
begin
   x:=system.abs(x)
end;

{$IFDEF CPU386}
procedure  FCEIL (var x:double);assembler;
asm
    FLDCW RoundPlus
    fld qword ptr [x]
    FRNDINT
    FLDCW ControlWord
    fstp qword ptr [x]
end;

procedure  FFLOOR(var x:double);assembler;
asm
    FLDCW RoundNins
    fld qword ptr [x]
    FRNDINT
    FLDCW ControlWord
    fstp qword ptr [x]
end;

procedure  FROUND(var x:double);assembler;
asm
    fld qword ptr [x]
    FRNDINT
    fstp qword ptr [x]
end;

 procedure  BasicMOD(var x,y:double);assembler;
asm
    fld qword ptr [y]
    fld qword ptr [x]
    FLD ST(0)
    FDIV ST(0),ST(2)
    FLDCW RoundNins
    FRNDINT
    FLDCW ControlWord
    FMULP ST(2),ST(0)
    FSUB  ST(0),ST(1)
   fstp qword ptr [x]
   fstp st(0)
   wait
end;

{$ELSE}

procedure  FFLOOR(var x:double);
begin
   if x>=0 then
      x:=system.int(x)
   else if system.frac(x)<>0 then
      x:=system.int(x)-1
end;

procedure  FCEIL (var x:double);
begin
   x:=-x;
   FFLOOR(x);
   x:=-x;
end;

procedure  FROUND(var x:double);
begin
   if abs(x)<2.e16 then
      x:=system.round(x)
end;

procedure  BasicMOD(var x,y:double);
var
   t:double;
begin
   t:=x/y;
   FFLOOR(t);
   x:=x-t*y
end;
{$ENDIF}


procedure  FSQRT (var x:double);
begin
   x:=system.sqrt(x)
end;

procedure  FSIN (var x:double) ;
begin
   x:=system.sin(x)
end;

procedure  FCOS (var x:double);
begin
    x:=system.cos(x);
end;

procedure  FTAN (var x:double);
begin
   x:=system.arctan(x);
end;

procedure  FCOT (var x:double);
begin
   x:=math.cot(x)
end;

procedure FASIN (var x:double);
begin
   x:=math.arcsin(x)
end;

procedure  FACOS (var x:double);
begin
   x:=math.arccos(x)
end;

(*
function NPXpower1plus(x,y:extended):extended;assembler;
asm
   fld   y
   fld   x
   fyl2xp1
   fld   st
   frndint
   fxch
   fsub  st,st(1)
   f2xm1
   fld1
   fadd
   fscale
   fxch
   fstp st(0)
end;

function NPXpower(x,y:extended):extended;assembler;
asm
   fld   y
   fld   x
   fyl2x
   fld   st
   frndint
   fxch
   fsub  st,st(1)
   f2xm1
   fld1
   fadd
   fscale
   fxch
   fstp st(0)
end;
*)

function NPXpower1plus(x,y:extended):extended;
begin
asm
   fld   y
   fld   x
   fyl2xp1
   fld   st
   frndint
   fxch
   fsub  st,st(1)
   f2xm1
   fld1
   fadd
   fscale
   fxch
   fstp st(0)
   fstp x
end;
result:=x
end;

function NPXpower(x,y:extended):extended;
begin
asm
   fld   y
   fld   x
   fyl2x
   fld   st
   frndint
   fxch
   fsub  st,st(1)
   f2xm1
   fld1
   fadd
   fscale
   fxch
   fstp st(0)
   fstp x
end;
result:=x
end;


procedure  power(var x,y:extended);
var
   t:extended;
begin
   if x>0 then
      begin
         t:=x-1;
         if abs(t)<0.125 then
            x:=NPXpower1plus(t,y)
         else
            x:=NPXPower(x,y)
      end
   else if x=0 then
      if y>0 then
         x:=0
      else if y=0 then
         x:=1
      else
         setexception(1002)
   else
      begin
         if int(y)=y then
            begin
               x:=-x;
               power(x,y);
               t:=y/2;
               if int(t)<>t then
                   x:=-x;
            end
         else
            setexception(1002)
      end;
end;

var
   number2:array[0..3]of word=($ffff,$ffff,$ffff,$7fef);
var
   number0:double absolute number2;

procedure  FEPS(var x:double);
//const
//   number2:array[0..3]of word=($ffff,$ffff,$ffff,$7fef);
//var
//   number0:double absolute number2;
var
   e:word;
begin
    number0:=x;
    e:=(number2[3] and $7ff0) div $10;
    if e>0 then
       begin
         number2[3]:=e*$10 ;
         number2[2]:=0;
         number2[1]:=0;
         number2[0]:=0;
         x:=number0/4503599627370496.
       end
    else
       begin
         number2[3]:=0;
         number2[2]:=0;
         number2[1]:=0;
         number2[0]:=1;
         x:=number0
       end;
end;

function FStr(x:extended):ansistring;
var
     s          :string[21];
     sign,sign1 :string[1];
     exrad      :string[6];
     i,e        :integer;
const places=18;
    function pureInt(x :extended):extended;
    var
       i:extended;
    begin
       i:=int(x);
       if x>=0 then
              pureInt:=i
       else
              if i=x then
                 pureint:=i
              else
                 pureint:=i-1
    end;
begin

 if x<>0 then
   begin
    e:=system.round(pureint(system.ln(abs(x)) / system.ln(10)))  ;
    if (-5<=e) and (e<places) then
        begin
            if e>=-2 then str(x:1:17,s)
                     else str(x:1:16,s);

            i:=length(s);
            while s[i]='0' do dec(i);
            if s[i]='.' then dec(i);
            s:=copy(s,1,i);

            if s[1]='-' then
                begin
                   s:=copy(s,2,19);
                   sign:='-'
                end
            else
                sign:='';

            if s[1]='0' then  s:=copy(s,2,19);
            s:=sign+s
        end
    else
        begin
           if (e>=-999) and (e<=999) then
              str(x:20,s)
           else
              str(x:19,s);
           i:=pos('E',s);
           sign1:=copy(s,i+1,1);
           exrad:=copy(s,i+2,4);
           s:=copy(s,1,i-1);

            i:=length(s);
            while s[i]='0' do dec(i);
            s:=copy(s,1,i);
            i:=1;
            while s[i]=' ' do inc(i);
            s:=copy(s,i,19);

           if sign1='+' then sign1:='';

           i:=1;
           while exrad[i]='0' do inc(i);
           exrad:=copy(exrad,i,4);

           s:=s+'E'+sign1+exrad
        end;
   end
 else if (x=0) then
        s:='0';
 if s[1]<>'-' then s:=' '+s;
   FStr:=s
end;





end.
