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

Last change on this file since 285 was 285, checked in by イグトランス (egtra), 16 years ago

wtypes.abを追加

File size: 3.4 KB
Line 
1'Classes/ActiveBasic/Math/Math.ab
2
3Namespace ActiveBasic
4Namespace Math
5
6'xの符号だけをyのものにした値を返す。
7'引数 x 元となる絶対値
8'引数 y 元となる符号
9Function CopySign(x As Double, y As Double) As Double
10    SetQWord(VarPtr(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (GetQWord(VarPtr(y)) And &h8000000000000000))
11End Function
12
13Function CopySign(x As Single, y As Single) As Single
14    SetDWord(VarPtr(CopySign), (GetDWord(VarPtr(x)) And &h7fffffff) Or (GetDWord(VarPtr(y)) And &h80000000))
15End Function
16
17Function Hypot(x As Double, y As Double) As Double
18    If x = 0 Then
19        Hypot = Abs(y)
20    Else If y = 0 Then
21        Hypot = Abs(x)
22    Else
23        Dim ax = Abs(x)
24        Dim ay = Abs(y)
25        If ay > ax Then
26            Dim t = x / y
27            Hypot = ay * Sqr(1 + t * t)
28        Else
29            Dim t = y / x
30            Hypot = ax * Sqr(1 + t * t)
31        End If
32    End If
33End Function
34
35Function Log1p(x As Double) As Double
36    If x < -1 Or IsNaN(x) Then
37        Log1p = ActiveBasic.Math.Detail.GetNaN()
38    ElseIf x = 0 Then
39        x = 0
40    ElseIf IsInf(x) Then
41        Log1p = x
42    Else
43        Log1p = ActiveBasic.Math.Detail.Log1p(x)
44    End If
45End Function
46
47Function IsNaN(ByVal x As Double) As Boolean
48    Dim p As *DWord
49    p = VarPtr(x) As *DWord
50    IsNaN = False
51    If (p[1] And &H7FF00000) = &H7FF00000 Then
52        If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then
53            IsNaN = True
54        End If
55    End If
56End Function
57
58Function IsInf(x As Double) As Boolean
59    Dim p = VarPtr(x) As *DWord
60    p[1] And= &h7fffffff
61    Dim inf = ActiveBasic.Math.Detail.GetInf(False)
62    IsInf = (memcmp(p As *Byte, VarPtr(inf), SizeOf (Double)) = 0)
63End Function
64
65Function IsFinite(x As Double) As Boolean
66    Dim p = VarPtr(x) As *DWord
67    p[1] And= &H7FF00000
68    IsFinite = p[1] And &H7FF00000 = &H7FF00000
69End Function
70
71Namespace Detail
72
73Function SetSign(x As Double, isNegative As Long) As Double
74#ifdef _WIN64
75    SetQWord(AddressOf(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (isNegative << 63))
76#else
77    SetDWord(AddressOf(CopySign), GetDWord(VarPtr(x)))
78    SetDWord(AddressOf(CopySign) + SizeOf (DWord), GetQWord(VarPtr(x) + SizeOf (DWord)) And &h7fffffff Or (isNegative << 31))
79#endif
80End Function
81
82#ifdef _WIN64
83
84Function GetNaN() As Double
85    SetQWord(VarPtr(GetNaN) As *QWord, &H7FF8000000000000)
86End Function
87
88Function GetInf(sign As Boolean) As Double
89    Dim s = 0 As QWord
90    If sign Then s = 1 << 63
91    SetQWord(VarPtr(GetInf) As *QWord, &h7FF0000000000000 Or s)
92End Function
93
94#else
95
96Function GetNaN() As Double
97    Dim p = VarPtr(GetNaN) As *DWord
98    p[0] = 0
99    p[1] = &H7FF80000
100End Function
101
102Function GetInf(sign As Boolean) As Double
103    Dim s = 0 As DWord
104    If sign Then s = (1 As DWord) << 31
105    Dim p As *DWord
106    p = VarPtr(GetInf) As *DWord
107    p[0] = 0
108    p[1] = &h7FF00000 Or s
109End Function
110
111#endif
112
113Function Log1p(x As Double) As Double
114    Dim s = 0 As Double
115    Dim i = 7 As Long
116    While i >= 1
117        Dim t = (i * x) As Double
118        s = t * (2 * i + 1 + s) / (2 + t)
119        i--
120    Wend
121    Return x / (1 + s)
122End Function
123
124Function _Support_tan(x As Double, ByRef k As Long) As Double
125    If x>=0 Then
126        k=Fix(x/(_System_PI/2)+0.5)
127    Else
128        k=Fix(x/(_System_PI/2)-0.5)
129    End If
130
131    x=(x-(CDbl(3217)/CDbl(2048))*k)+4.4544551033807686783083602485579e-6*k
132
133    Dim x2 = x * x
134    Dim t = 0 As Double
135
136    Dim i As Long
137    For i=19 To 3 Step -2
138        t=x2/(i-t)
139    Next
140
141    _Support_tan=x/(1-t)
142End Function
143
144End Namespace 'Detail
145End Namespace 'Math
146End Namespace 'ActiveBasic
Note: See TracBrowser for help on using the repository browser.