1  'Classes/ActiveBasic/Math/Math.ab


2 


3  Namespace ActiveBasic


4  Namespace Math


5 


6  'xの符号だけをyのものにした値を返す。


7  '引数 x 元となる絶対値


8  '引数 y 元となる符号


9  Function CopySign(x As Double, y As Double) As Double


10  SetQWord(VarPtr(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (GetQWord(VarPtr(y)) And &h8000000000000000))


11  End Function


12 


13  Function CopySign(x As Single, y As Single) As Single


14  SetDWord(VarPtr(CopySign), (GetDWord(VarPtr(x)) And &h7fffffff) Or (GetDWord(VarPtr(y)) And &h80000000))


15  End Function


16 


17  Function Log1p(x As Double) As Double


18  If x < 1 Or IsNaN(x) Then


19  Log1p = ActiveBasic.Math.Detail.GetNaN()


20  ElseIf x = 0 Then


21  x = 0


22  ElseIf IsInf(x) Then


23  Log1p = x


24  Else


25  Log1p = ActiveBasic.Math.Detail.Log1p(x)


26  End If


27  End Function


28 


29  Function IsNaN(ByVal x As Double) As Boolean


30  Dim p As *DWord


31  p = VarPtr(x) As *DWord


32  IsNaN = False


33  If (p[1] And &H7FF00000) = &H7FF00000 Then


34  If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then


35  IsNaN = True


36  End If


37  End If


38  End Function


39 


40  Function IsInf(x As Double) As Boolean


41  Dim p As *DWord, nan As Double


42  p = VarPtr(x) As *DWord


43  p[1] And= &h7fffffff


44  nan = ActiveBasic.Math.Detail.GetInf(False)


45  IsInf = (memcmp(p As *Byte, VarPtr(nan), SizeOf (Double)) = 0)


46  End Function


47 


48  Function IsFinite(x As Double) As Boolean


49  Dim p As *DWord, nan As Double


50  p = VarPtr(x) As *DWord


51  ' p[1] And= &h7ffe0000


52  p[1] And= &H7FF00000


53  p[0] = 0


54  nan = ActiveBasic.Math.Detail.GetInf(/*x,*/ False)


55  IsFinite = (memcmp(p As BytePtr, VarPtr(nan), SizeOf (Double)) = 0)


56  End Function


57 


58  Namespace Detail


59 


60  Function SetSign(x As Double, isNegative As Long) As Double


61  #ifdef _WIN64


62  SetQWord(AddressOf(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (isNegative << 63))


63  #else


64  SetDWord(AddressOf(CopySign), GetDWord(VarPtr(x)))


65  SetDWord(AddressOf(CopySign) + SizeOf (DWord), GetQWord(VarPtr(x) + SizeOf (DWord)) And &h7fffffff Or (isNegative << 31))


66  #endif


67  End Function


68 


69  #ifdef _WIN64


70 


71  Function GetNaN() As Double


72  SetQWord(VarPtr(GetNaN) As *QWord, &H7FF8000000000000)


73  End Function


74 


75  Function GetInf(sign As Boolean) As Double


76  Dim s = 0 As QWord


77  If sign Then s = 1 << 63


78  SetQWord(VarPtr(GetInf) As *QWord, &h7FF0000000000000 Or s)


79  End Function


80 


81  #else


82 


83  Function GetNaN() As Double


84  Dim p As *DWord


85  p = VarPtr(GetNaN) As *DWord


86  p[0] = 0


87  p[1] = &H7FF80000


88  End Function


89 


90  Function GetInf(sign As Boolean) As Double


91  Dim s = 0 As DWord


92  If sign Then s = (1 As DWord) << 31


93  Dim p As *DWord


94  p = VarPtr(GetInf) As *DWord


95  p[0] = 0


96  p[1] = &h7FF00000 Or s


97  End Function


98 


99  #endif


100 


101  Function Log1p(x As Double) As Double


102  Dim s = 0 As Double


103  Dim i = 7 As Long


104  While i >= 1


105  Dim t = (i * x) As Double


106  s = t / (2 + t / (2 * i + 1 + s))


107  i


108  Wend


109  Return x / (1 + s)


110  End Function


111 


112  Function _Support_tan(x As Double, ByRef k As Long) As Double


113  Dim i As Long


114  Dim t As Double, x2 As Double


115 


116  If x>=0 Then


117  k=Fix(x/(_System_PI/2)+0.5)


118  Else


119  k=Fix(x/(_System_PI/2)0.5)


120  End If


121 


122  x=(x(CDbl(3217)/CDbl(2048))*k)+4.4544551033807686783083602485579e6*k


123 


124  x2=x*x


125  t=0


126 


127  For i=19 To 3 Step 2


128  t=x2/(it)


129  Next


130 


131  _Support_tan=x/(1t)


132  End Function


133 


134  End Namespace 'Detail


135  End Namespace 'Math


136  End Namespace 'ActiveBasic

