source: Include/Classes/ActiveBasic/Math/Math.ab@ 285

'Classes/ActiveBasic/Math/Math.ab

Namespace ActiveBasic
Namespace Math

'xの符号だけをyのものにした値を返す。
'引数 x 元となる絶対値
'引数 y 元となる符号
Function CopySign(x As Double, y As Double) As Double
    SetQWord(VarPtr(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (GetQWord(VarPtr(y)) And &h8000000000000000))
End Function

Function CopySign(x As Single, y As Single) As Single
    SetDWord(VarPtr(CopySign), (GetDWord(VarPtr(x)) And &h7fffffff) Or (GetDWord(VarPtr(y)) And &h80000000))
End Function

Function Hypot(x As Double, y As Double) As Double
    If x = 0 Then
        Hypot = Abs(y)
    Else If y = 0 Then
        Hypot = Abs(x)
    Else
        Dim ax = Abs(x)
        Dim ay = Abs(y)
        If ay > ax Then
            Dim t = x / y
            Hypot = ay * Sqr(1 + t * t)
        Else
            Dim t = y / x
            Hypot = ax * Sqr(1 + t * t)
        End If
    End If
End Function

Function Log1p(x As Double) As Double
    If x < -1 Or IsNaN(x) Then
        Log1p = ActiveBasic.Math.Detail.GetNaN()
    ElseIf x = 0 Then
        x = 0
    ElseIf IsInf(x) Then
        Log1p = x
    Else
        Log1p = ActiveBasic.Math.Detail.Log1p(x)
    End If
End Function

Function IsNaN(ByVal x As Double) As Boolean
    Dim p As *DWord
    p = VarPtr(x) As *DWord
    IsNaN = False
    If (p[1] And &H7FF00000) = &H7FF00000 Then
        If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then
            IsNaN = True
        End If
    End If
End Function

Function IsInf(x As Double) As Boolean
    Dim p = VarPtr(x) As *DWord
    p[1] And= &h7fffffff
    Dim inf = ActiveBasic.Math.Detail.GetInf(False)
    IsInf = (memcmp(p As *Byte, VarPtr(inf), SizeOf (Double)) = 0)
End Function

Function IsFinite(x As Double) As Boolean
    Dim p = VarPtr(x) As *DWord
    p[1] And= &H7FF00000
    IsFinite = p[1] And &H7FF00000 = &H7FF00000
End Function

Namespace Detail

Function SetSign(x As Double, isNegative As Long) As Double
#ifdef _WIN64
    SetQWord(AddressOf(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (isNegative << 63))
#else
    SetDWord(AddressOf(CopySign), GetDWord(VarPtr(x)))
    SetDWord(AddressOf(CopySign) + SizeOf (DWord), GetQWord(VarPtr(x) + SizeOf (DWord)) And &h7fffffff Or (isNegative << 31))
#endif
End Function

#ifdef _WIN64

Function GetNaN() As Double
    SetQWord(VarPtr(GetNaN) As *QWord, &H7FF8000000000000)
End Function

Function GetInf(sign As Boolean) As Double
    Dim s = 0 As QWord
    If sign Then s = 1 << 63
    SetQWord(VarPtr(GetInf) As *QWord, &h7FF0000000000000 Or s)
End Function

#else

Function GetNaN() As Double
    Dim p = VarPtr(GetNaN) As *DWord
    p[0] = 0
    p[1] = &H7FF80000
End Function

Function GetInf(sign As Boolean) As Double
    Dim s = 0 As DWord
    If sign Then s = (1 As DWord) << 31
    Dim p As *DWord
    p = VarPtr(GetInf) As *DWord
    p[0] = 0
    p[1] = &h7FF00000 Or s
End Function

#endif

Function Log1p(x As Double) As Double
    Dim s = 0 As Double
    Dim i = 7 As Long
    While i >= 1
        Dim t = (i * x) As Double
        s = t * (2 * i + 1 + s) / (2 + t)
        i--
    Wend
    Return x / (1 + s)
End Function

Function _Support_tan(x As Double, ByRef k As Long) As Double
    If x>=0 Then
        k=Fix(x/(_System_PI/2)+0.5)
    Else
        k=Fix(x/(_System_PI/2)-0.5)
    End If

    x=(x-(CDbl(3217)/CDbl(2048))*k)+4.4544551033807686783083602485579e-6*k

    Dim x2 = x * x
    Dim t = 0 As Double

    Dim i As Long
    For i=19 To 3 Step -2
        t=x2/(i-t)
    Next

    _Support_tan=x/(1-t)
End Function

End Namespace 'Detail
End Namespace 'Math
End Namespace 'ActiveBasic