Changeset 589 for trunk/ab5.0


Ignore:
Timestamp:
Aug 15, 2008, 1:00:15 AM (16 years ago)
Author:
イグトランス (egtra)
Message:

数学関数をActiveBasic.Mathへ統合

Location:
trunk/ab5.0/ablib/src
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • trunk/ab5.0/ablib/src/Classes/ActiveBasic/Math/Math.ab

    r426 r589  
    33Namespace ActiveBasic
    44Namespace Math
     5'----
     6'浮動小数点数補助
     7Function ldexp(x As Double, n As Long) As Double
     8    If x = 0 Then
     9        ldexp = 0
     10        Exit Function
     11    End If
     12    Dim pSrc = VarPtr(x) As *QWord
     13    Dim pDest = VarPtr(ldexp) As *QWord
     14    n += (pSrc[0] >> 52) As DWord And &h7FF
     15    pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)
     16End Function
     17
     18Function frexp(x As Double, ByRef n As Long) As Double
     19    If x = 0 Then
     20        n = 0
     21        frexp = 0
     22        Exit Function
     23    End If
     24
     25    Dim pSrc = VarPtr(x) As *QWord
     26    Dim pDest = VarPtr(frexp) As *QWord
     27    n = ((pSrc[0] >> 52) As DWord And &h7FF) - 1022
     28    pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000
     29End Function
     30
     31Function frexp(x As Single, ByRef n As Long) As Single
     32    If x = 0 Then
     33        n = 0
     34        frexp = 0
     35        Exit Function
     36    End If
     37
     38    Dim pSrc As *DWord, pDest As *DWord
     39    pSrc = VarPtr(x) As *DWord
     40    pDest = VarPtr(frexp) As *DWord
     41    n = ((pSrc[0] >> 23) And &hFF) - 126
     42    pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000
     43End Function
     44
     45'----
     46'冪乗
     47Function pow(x As Double, n As Long) As Double
     48    Dim abs_n As Long
     49    Dim r = 1 As Double
     50
     51    abs_n=Abs(n) As Long
     52    While abs_n<>0
     53        If abs_n and 1 Then r *= x
     54        x = x * x
     55        abs_n >>= 1 ' abs_n \= 2
     56    Wend
     57
     58    If n>=0 Then
     59        pow=r
     60    Else
     61        pow=1/r
     62    End If
     63End Function
     64
     65Function pow(x As Double, y As Double) As Double
     66    Dim yi = y As Long
     67    If y = yi Then
     68        pow = pow(x, yi)
     69    ElseIf x>0 Then
     70        pow = Exp(y * Log(x))
     71        Exit Function
     72    ElseIf x<>0 or y<=0 Then
     73        pow = Detail.GetNaN()
     74    Else
     75        pow = 0
     76    End If
     77End Function
     78
     79Function Sqrt(x As Double) As Double
     80    If x > 0 Then
     81        If IsInf(x) Then
     82            Sqrt = x
     83        Else
     84            Sqrt = x
     85            Dim i = (VarPtr(Sqrt) + 6) As *Word
     86            Dim jj = GetWord(i) As Long
     87            Dim j = jj >> 5 As Long
     88            Dim k = (jj And &h0000001f) As Long
     89            j = (j + 511) << 4 + k
     90            SetWord(i, j)
     91            Dim last As Double
     92            Do
     93                last = Sqrt
     94                Sqrt = (x / Sqrt + Sqrt) * 0.5
     95            Loop While Sqrt <> last
     96        End If
     97    ElseIf x < 0 Then
     98        Sqrt = Detail.GetNaN()
     99    Else
     100        'x = 0 Or NaN
     101        Sqrt = x
     102    End If
     103End Function
    5104
    6105'xの符号だけをyのものにした値を返す。
    … …  
    15114End Function
    16115
     116'----
     117'絶対値
     118Function Abs(n As Double) As Double
     119    If n < 0 Then
     120        Abs = -n
     121    Else
     122        Abs = n
     123    End If
     124End Function
     125
     126Function Abs(n As Single) As Single
     127    If n < 0 Then
     128        Abs = -n
     129    Else
     130        Abs = n
     131    End If
     132End Function
     133
     134Function Abs(n As Int64) As Int64
     135    If n < 0 Then
     136        Abs = -n
     137    Else
     138        Abs = n
     139    End If
     140End Function
     141
     142Function Abs(n As Long) As Long
     143    If n < 0 Then
     144        Abs = -n
     145    Else
     146        Abs = n
     147    End If
     148End Function
     149
     150Function Abs(n As Integer) As Integer
     151    If n < 0 Then
     152        Abs = -n
     153    Else
     154        Abs = n
     155    End If
     156End Function
     157
     158Function Abs(n As SByte) As SByte
     159    If n < 0 Then
     160        Abs = -n
     161    Else
     162        Abs = n
     163    End If
     164End Function
     165
     166'----
     167'指数・対数
     168
     169Function Exp(x As Double) As Double
     170    If IsNaN(x) Then
     171        Return x
     172    Else If IsInf(x) Then
     173        If 0 > x Then
     174            Return 0
     175        Else
     176            Return x
     177        End If
     178    End If
     179    Dim k As Long
     180    If x >= 0 Then
     181        k = Fix(x / Detail._System_LOG2 + 0.5)
     182    Else
     183        k = Fix(x / Detail._System_LOG2 - 0.5)
     184    End If
     185
     186    x -= k * Detail._System_LOG2
     187
     188    Dim x2 = x * x
     189    Dim w = x2 / 22
     190
     191    Dim i = 18
     192    While i >= 6
     193        w = x2 / (w + i)
     194        i -= 4
     195    Wend
     196
     197    Return ldexp((2 + w + x) / (2 + w - x), k)
     198End Function
     199
     200Function Log1p(x As Double) As Double
     201    If x < -1 Or IsNaN(x) Then
     202        Log1p = Detail.GetNaN()
     203    ElseIf x = 0 Then
     204        x = 0
     205    ElseIf IsInf(x) Then
     206        Log1p = x
     207    Else
     208        Log1p = Detail.Log1p(x)
     209    End If
     210End Function
     211
     212Function Log(x As Double) As Double
     213    If x = 0 Then
     214        Log = Detail.GetInf(True)
     215    ElseIf x < 0 Or IsNaN(x) Then
     216        Log = Detail.GetNaN()
     217    ElseIf IsInf(x) Then
     218        Log = x
     219    Else
     220        Dim tmp = x * Detail._System_InverseSqrt2
     221        Dim p = VarPtr(tmp) As *QWord
     222        Dim m = GetQWord(p) And &h7FF0000000000000
     223        Dim k = ((m >> 52) As DWord) As Long - 1022
     224        SetQWord(p, m + &h0010000000000000)
     225        x /= tmp
     226        Log = Detail._System_LOG2 * k + Detail.Log1p(x - 1)
     227    End If
     228End Function
     229
     230Function Log10(x As Double) As Double
     231    Return Log(x) * Detail._System_InverseLn10
     232End Function
     233
     234'----
     235'三角関数
     236Function Sin(x As Double) As Double
     237    If IsNaN(x) Then
     238        Return x
     239    ElseIf IsInf(x) Then
     240        Return Detail.GetNaN()
     241        Exit Function
     242    End If
     243
     244    Dim k As Long
     245    Dim t As Double
     246
     247    t = Detail._Support_tan((x * 0.5) As Double, k)
     248    t = 2 * t / (1 + t * t)
     249    If (k And 1) = 0 Then 'k mod 2 = 0 Then
     250        Return t
     251    Else
     252        Return -t
     253    End If
     254End Function
     255
     256Function Cos(x As Double) As Double
     257    If IsNaN(x) Then
     258        Return x
     259    ElseIf IsInf(x) Then
     260        Return Detail.GetNaN()
     261    End If
     262
     263    Return Sin((Detail._System_HalfPI - Abs(x)) As Double)
     264End Function
     265
     266Function Tan(x As Double) As Double
     267    If IsNaN(x) Then
     268        Tan = x
     269        Exit Function
     270    ElseIf IsInf(x) Then
     271        Tan = Detail.GetNaN()
     272        Exit Function
     273    End If
     274
     275    Dim k As Long
     276    Dim t As Double
     277    t = Detail._Support_tan(x, k)
     278    If (k And 1) = 0 Then 'k mod 2 = 0 Then
     279        Return t
     280    ElseIf t <> 0 Then
     281        Return -1 / t
     282    Else
     283        Return CopySign(Detail.GetInf(False), -t)
     284    End If
     285End Function
     286
     287'--
     288'三角関数の逆関数
     289Function Asin(x As Double) As Double
     290    If x < -1 Or x > 1 Then
     291        Asin = Detail.GetNaN()
     292    Else
     293        Asin = Atan(x / Sqrt(1 - x * x))
     294    End If
     295End Function
     296
     297Function Acos(x As Double) As Double
     298    If x < -1 Or x > 1 Then
     299        Acos = Detail.GetNaN()
     300    Else
     301        Acos = Detail._System_HalfPI - Asin(x)
     302    End If
     303End Function
     304
     305Function Atan(x As Double) As Double
     306    If IsNaN(x) Then
     307        Atan = x
     308        Exit Function
     309    ElseIf IsInf(x) Then
     310        Atan = CopySign(_System_PI, x)
     311        Exit Function
     312    End If
     313    Dim i As Long
     314    Dim sgn As Long
     315    Dim dbl = 0 As Double
     316
     317    If x > 1 Then
     318        sgn = 1
     319        x = 1 / x
     320    ElseIf x < -1 Then
     321        sgn = -1
     322        x = 1 / x
     323    Else
     324        sgn = 0
     325    End If
     326
     327    For i = Detail._System_Atan_N To 1 Step -1
     328        Dim t As Double
     329        t = i * x
     330        dbl = (t * t) / (2 * i + 1 + dbl)
     331    Next
     332
     333    If sgn > 0 Then
     334        Atan = Detail._System_HalfPI - x / (1 + dbl)
     335    ElseIf sgn < 0 Then
     336        Atan = -Detail._System_HalfPI - x / (1 + dbl)
     337    Else
     338        Atan = x / (1 + dbl)
     339    End If
     340End Function
     341
     342Function Atan2(y As Double, x As Double) As Double
     343    If x = 0 Then
     344        Atan2 = Sgn(y) * Detail._System_HalfPI
     345    Else
     346        Atan2 = Atn(y / x)
     347        If x < 0 Then
     348            Atan2 += CopySign(_System_PI, y)
     349        End If
     350    End If
     351End Function
     352
     353'----
     354'双曲線関数
     355Function Sinh(x As Double) As Double
     356    If Abs(x) > Detail._System_EPS5 Then
     357        Dim t As Double
     358        t = Exp(x)
     359        Return (t - 1 / t) * 0.5
     360    Else
     361        Return x * (1 + x * x * 0.166666666666667) ' x * (1 + x * x / 6)
     362    End If
     363End Function
     364
     365Function Tanh(x As Double) As Double
     366    If x > Detail._System_EPS5 Then
     367        Return 2 / (1 + Exp(-2 * x)) - 1
     368    ElseIf x < -Detail._System_EPS5 Then
     369        Return 1 - 2 / (Exp(2 * x) + 1)
     370    Else
     371        Return x * (1 - x * x * 0.333333333333333) 'x * (1 - x * x / 3)
     372    End If
     373End Function
     374
     375
     376'----
     377'浮動小数点数判定
     378Function IsNaN(ByVal x As Double) As Boolean
     379    Dim p = VarPtr(x) As *DWord
     380    IsNaN = False
     381    If (p[1] And &H7FF00000) = &H7FF00000 Then
     382        If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then
     383            IsNaN = True
     384        End If
     385    End If
     386End Function
     387
     388Function IsInf(x As Double) As Boolean
     389    Dim p = VarPtr(x) As *DWord
     390    p[1] And= &h7fffffff
     391    Dim inf = Detail.GetInf(False)
     392    IsInf = (memcmp(p As *Byte, VarPtr(inf), SizeOf (Double)) = 0)
     393End Function
     394
     395Function IsFinite(x As Double) As Boolean
     396    Dim p = VarPtr(x) As *DWord
     397    p[1] And= &H7FF00000
     398    IsFinite = ( p[1] And &H7FF00000 ) = &H7FF00000
     399End Function
     400
     401'----
     402'その他
    17403Function Hypot(x As Double, y As Double) As Double
    18404    If x = 0 Then
    … …  
    33419End Function
    34420
    35 Function 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
    45 End Function
    46 
    47 Function IsNaN(ByVal x As Double) As Boolean
    48     Dim p = VarPtr(x) As *DWord
    49     IsNaN = False
    50     If (p[1] And &H7FF00000) = &H7FF00000 Then
    51         If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then
    52             IsNaN = True
    53         End If
    54     End If
    55 End Function
    56 
    57 Function IsInf(x As Double) As Boolean
    58     Dim p = VarPtr(x) As *DWord
    59     p[1] And= &h7fffffff
    60     Dim inf = ActiveBasic.Math.Detail.GetInf(False)
    61     IsInf = (memcmp(p As *Byte, VarPtr(inf), SizeOf (Double)) = 0)
    62 End Function
    63 
    64 Function IsFinite(x As Double) As Boolean
    65     Dim p = VarPtr(x) As *DWord
    66     p[1] And= &H7FF00000
    67     IsFinite = ( p[1] And &H7FF00000 ) = &H7FF00000
    68 End Function
    69 
    70421Namespace Detail
    71422
    … …  
    111462Function Log1p(x As Double) As Double
    112463    Dim s = 0 As Double
    113     Dim i = 7 As Long
     464    Dim i = _System_Log_N As Long
    114465    While i >= 1
    115466        Dim t = (i * x) As Double
    … …  
    121472
    122473Function _Support_tan(x As Double, ByRef k As Long) As Double
    123     If x>=0 Then
    124         k=Fix(x/(_System_PI/2)+0.5)
    125     Else
    126         k=Fix(x/(_System_PI/2)-0.5)
    127     End If
    128 
    129     x=(x-(CDbl(3217)/CDbl(2048))*k)+4.4544551033807686783083602485579e-6*k
     474    If x >= 0 Then
     475        k = ( Fix(x * _System_InverseHalfPI) + 0.5 ) As Long
     476    Else
     477        k = ( Fix(x * _System_InverseHalfPI) - 0.5 ) As Long
     478    End If
     479
     480    x = (x - (3217.0 / 2048.0) * k) + _System_D * k
    130481
    131482    Dim x2 = x * x
    … …  
    133484
    134485    Dim i As Long
    135     For i=19 To 3 Step -2
    136         t=x2/(i-t)
     486    For i = _System_UrTan_N To 3 Step -2
     487        t = x2 / (i - t)
    137488    Next
    138489
    139     _Support_tan=x/(1-t)
    140 End Function
     490    _Support_tan = x / (1 - t)
     491End Function
     492
     493Const _System_D = 4.4544551033807686783083602485579e-6 As Double
     494Const _System_UrTan_N = 19 As Long
     495Const _System_EPS5 = 0.001 As Double
     496Const _System_Atan_N = 20 As Long
     497Const _System_HalfPI = (_System_PI * 0.5)
     498Const _System_InverseHalfPI = (2 / _System_PI) '1 / (PI / 2)
     499Const _System_InverseLn10 = 0.43429448190325182765112891891661 '1 / (ln 10)
     500Const _System_InverseSqrt2 = 0.70710678118654752440084436210485 '1 / (√2)
     501Const _System_LOG2 = 0.6931471805599453094172321214581765680755
     502Const _System_Log_N = 7 As Long
    141503
    142504End Namespace 'Detail

  • trunk/ab5.0/ablib/src/Classes/ActiveBasic/Strings/SPrintF.ab

    r521 r589  
    376376Sub FormatFloatG_RemoveLowDigit(sb As System.Text.StringBuilder, start As Long, flags As FormatFlags)
    377377    Imports ActiveBasic.Strings
    378    
     378
    379379    Dim count = sb.Length
    380380    If (flags And Alt) = 0 Then
    … …  
    694694*/
    695695Function IntegerD_Convert(buf As *Char, xq As QWord, flags As FormatFlags) As DWord
    696     Return IntegerU_Convert(buf, Abs((xq As DWord) As Long) As DWord, flags)
     696    Return IntegerU_Convert(buf, Math.Abs((xq As DWord) As Long) As DWord, flags)
    697697End Function
    698698
    … …  
    703703*/
    704704Function IntegerLD_Convert(buf As *Char, x As QWord, flags As FormatFlags) As DWord
    705     Return IntegerLU_Convert(buf, Abs(x As Int64) As QWord, flags)
     705    Return IntegerLU_Convert(buf, Math.Abs(x As Int64) As QWord, flags)
    706706End Function
    707707

  • trunk/ab5.0/ablib/src/Classes/System/Math.ab

    r497 r589  
    2424
    2525    Static Function Abs(value As SByte) As SByte
    26         If value<0 then
     26        If value<0 Then
    2727            return -value
    2828        Else
    … …  
    3232
    3333    Static Function Abs(value As Integer) As Integer
    34         If value<0 then
     34        If value<0 Then
    3535            return -value
    3636        Else
    … …  
    4040
    4141    Static Function Abs(value As Long) As Long
    42         If value<0 then
     42        If value<0 Then
    4343            return -value
    4444        Else
    … …  
    4848
    4949    Static Function Abs(value As Int64) As Int64
    50         If value<0 then
     50        If value<0 Then
    5151            return -value
    5252        Else
    … …  
    5656
    5757    Static Function Acos(x As Double) As Double
    58         If x < -1 Or x > 1 Then
    59             Acos = ActiveBasic.Math.Detail.GetNaN()
    60         Else
    61             Acos = _System_HalfPI - Asin(x)
    62         End If
     58        Acos = ActiveBasic.Math.Acos(x)
    6359    End Function
    6460
    6561    Static Function Asin(x As Double) As Double
    66         If x < -1 Or x > 1 Then
    67             Asin = ActiveBasic.Math.Detail.GetNaN()
    68         Else
    69             Asin = Math.Atan(x / Sqrt(1 - x * x))
    70         End If
     62        Asin = ActiveBasic.Math.Asin(x)
    7163    End Function
    7264
    7365    Static Function Atan(x As Double) As Double
    74         If ActiveBasic.Math.IsNaN(x) Then
    75             Atan = x
    76             Exit Function
    77         ElseIf ActiveBasic.Math.IsInf(x) Then
    78             Atan = ActiveBasic.Math.CopySign(_System_PI, x)
    79             Exit Function
    80         End If
    81         Dim i As Long
    82         Dim sgn As Long
    83         Dim dbl = 0 As Double
    84 
    85         If x > 1 Then
    86             sgn = 1
    87             x = 1 / x
    88         ElseIf x < -1 Then
    89             sgn = -1
    90             x = 1 / x
    91         Else
    92             sgn = 0
    93         End If
    94 
    95         For i = _System_Atan_N To 1 Step -1
    96             Dim t As Double
    97             t = i * x
    98             dbl = (t * t) / (2 * i + 1 + dbl)
    99         Next
    100 
    101         If sgn > 0 Then
    102             Atan = _System_HalfPI - x / (1 + dbl)
    103         ElseIf sgn < 0 Then
    104             Atan = -_System_HalfPI - x / (1 + dbl)
    105         Else
    106             Atan = x / (1 + dbl)
    107         End If
     66        Atan = ActiveBasic.Math.Atan(x)
    10867    End Function
    10968
    11069    Static Function Atan2(y As Double, x As Double) As Double
    111         If x = 0 Then
    112             Atan2 = Sgn(y) * _System_HalfPI
    113         Else
    114             Atan2 = Atn(y / x)
    115             If x < 0 Then
    116                 Atan2 += ActiveBasic.Math.CopySign(_System_PI, y)
    117             End If
    118         End If
     70        Atan2 = ActiveBasic.Math.Atan2(y, x)
    11971    End Function
    12072
    … …  
    13183
    13284    Static Function Cos(x As Double) As Double
    133         If ActiveBasic.Math.IsNaN(x) Then
    134             Return x
    135         ElseIf ActiveBasic.Math.IsInf(x) Then
    136             Return ActiveBasic.Math.Detail.GetNaN()
    137         End If
    138 
    139         Return Math.Sin((_System_HalfPI - Math.Abs(x)) As Double)
     85        Cos = ActiveBasic.Math.Cos(x)
    14086    End Function
    14187
    14288    Static Function Cosh(value As Double) As Double
    14389        Dim t = Math.Exp(value)
    144         return (t + 1 / t) * 0.5
     90        Return (t + 1 / t) * 0.5
    14591    End Function
    14692
    14793    Static Function DivRem(x As Long, y As Long, ByRef ret As Long) As Long
    14894        ret = x Mod y
    149         return x \ y
     95        Return x \ y
    15096    End Function
    15197
    … …  
    155101    End Function
    156102
    157     'Equals
    158 
    159103    Static Function Exp(x As Double) As Double
    160         If ActiveBasic.Math.IsNaN(x) Then
    161             Return x
    162         Else If ActiveBasic.Math.IsInf(x) Then
    163             If 0 > x Then
    164                 Return 0
    165             Else
    166                 Return x
    167             End If
    168         End If
    169         Dim k As Long
    170         If x >= 0 Then
    171             k = Fix(x / _System_LOG2 + 0.5)
    172         Else
    173             k = Fix(x / _System_LOG2 - 0.5)
    174         End If
    175 
    176         x -= k * _System_LOG2
    177 
    178         Dim x2 = x * x
    179         Dim w = x2 / 22
    180 
    181         Dim i = 18
    182         While i >= 6
    183             w = x2 / (w + i)
    184             i -= 4
    185         Wend
    186 
    187         Return ldexp((2 + w + x) / (2 + w - x), k)
     104        Exp = ActiveBasic.Math.Exp(x)
    188105    End Function
    189106
    … …  
    216133
    217134    Static Function Log(x As Double) As Double
    218         If x = 0 Then
    219             Log = ActiveBasic.Math.Detail.GetInf(True)
    220         ElseIf x < 0 Or ActiveBasic.Math.IsNaN(x) Then
    221             Log = ActiveBasic.Math.Detail.GetNaN()
    222         ElseIf ActiveBasic.Math.IsInf(x) Then
    223             Log = x
    224         Else
    225             Dim tmp = x * _System_InverseSqrt2
    226             Dim p = VarPtr(tmp) As *QWord
    227             Dim m = GetQWord(p) And &h7FF0000000000000
    228             Dim k = ((m >> 52) As DWord) As Long - 1022
    229             SetQWord(p, m + &h0010000000000000)
    230             x /= tmp
    231             Log = _System_LOG2 * k + ActiveBasic.Math.Detail.Log1p(x - 1)
    232         End If
     135        Log = ActiveBasic.Math.Log(x)
    233136    End Function
    234137
    235138    Static Function Log10(x As Double) As Double
    236         Return Math.Log(x) * _System_InverseLn10
     139        Log = ActiveBasic.Math.Log10(x)
    237140    End Function
    238141
    239142    Static Function Max(value1 As Byte, value2 As Byte) As Byte
    240         If value1>value2 then
     143        If value1>value2 Then
    241144            return value1
    242145        Else
    … …  
    246149
    247150    Static Function Max(value1 As SByte, value2 As SByte) As SByte
    248         If value1>value2 then
     151        If value1>value2 Then
    249152            return value1
    250153        Else
    … …  
    254157
    255158    Static Function Max(value1 As Word, value2 As Word) As Word
    256         If value1>value2 then
     159        If value1>value2 Then
    257160            return value1
    258161        Else
    … …  
    262165
    263166    Static Function Max(value1 As Integer, value2 As Integer) As Integer
    264         If value1>value2 then
     167        If value1>value2 Then
    265168            return value1
    266169        Else
    … …  
    270173
    271174    Static Function Max(value1 As DWord, value2 As DWord) As DWord
    272         If value1>value2 then
     175        If value1>value2 Then
    273176            return value1
    274177        Else
    … …  
    278181
    279182    Static Function Max(value1 As Long, value2 As Long) As Long
    280         If value1>value2 then
     183        If value1>value2 Then
    281184            return value1
    282185        Else
    … …  
    286189
    287190    Static Function Max(value1 As QWord, value2 As QWord) As QWord
    288         If value1>value2 then
     191        If value1>value2 Then
    289192            return value1
    290193        Else
    … …  
    294197
    295198    Static Function Max(value1 As Int64, value2 As Int64) As Int64
    296         If value1>value2 then
     199        If value1>value2 Then
    297200            return value1
    298201        Else
    … …  
    302205
    303206    Static Function Max(value1 As Single, value2 As Single) As Single
    304         If value1>value2 then
     207        If value1>value2 Then
    305208            return value1
    306209        Else
    … …  
    310213
    311214    Static Function Max(value1 As Double, value2 As Double) As Double
    312         If value1>value2 then
     215        If value1>value2 Then
    313216            return value1
    314217        Else
    … …  
    318221
    319222    Static Function Min(value1 As Byte, value2 As Byte) As Byte
    320         If value1<value2 then
     223        If value1<value2 Then
    321224            return value1
    322225        Else
    … …  
    326229
    327230    Static Function Min(value1 As SByte, value2 As SByte) As SByte
    328         If value1<value2 then
     231        If value1<value2 Then
    329232            return value1
    330233        Else
    … …  
    334237
    335238    Static Function Min(value1 As Word, value2 As Word) As Word
    336         If value1<value2 then
     239        If value1<value2 Then
    337240            return value1
    338241        Else
    … …  
    342245
    343246    Static Function Min(value1 As Integer, value2 As Integer) As Integer
    344         If value1<value2 then
     247        If value1<value2 Then
    345248            return value1
    346249        Else
    … …  
    350253
    351254    Static Function Min(value1 As DWord, value2 As DWord) As DWord
    352         If value1<value2 then
     255        If value1<value2 Then
    353256            return value1
    354257        Else
    … …  
    358261
    359262    Static Function Min(value1 As Long, value2 As Long) As Long
    360         If value1<value2 then
     263        If value1<value2 Then
    361264            return value1
    362265        Else
    … …  
    366269
    367270    Static Function Min(value1 As QWord, value2 As QWord) As QWord
    368         If value1<value2 then
     271        If value1<value2 Then
    369272            return value1
    370273        Else
    … …  
    374277
    375278    Static Function Min(value1 As Int64, value2 As Int64) As Int64
    376         If value1<value2 then
     279        If value1<value2 Then
    377280            return value1
    378281        Else
    … …  
    382285
    383286    Static Function Min(value1 As Single, value2 As Single) As Single
    384         If value1<value2 then
     287        If value1<value2 Then
    385288            return value1
    386289        Else
    … …  
    390293
    391294    Static Function Min(value1 As Double, value2 As Double) As Double
    392         If value1<value2 then
     295        If value1<value2 Then
    393296            return value1
    394297        Else
    … …  
    404307
    405308    Static Function Round(value As Double) As Double'他のバージョン、誰か頼む。
    406         If value+0.5<>Int(value+0.5) then
     309        If value+0.5<>Int(value+0.5) Then
    407310            value=Int(value+0.5)
    408         ElseIf Int(value+0.5)=Int(value*2+1)/2 then
     311        ElseIf Int(value+0.5)=Int(value*2+1)/2 Then
    409312            value=Int(value+0.5)
    410313        Else
    … …  
    414317
    415318    Static Function Sign(value As Double) As Long
    416         If value = 0 then
    417             return 0
    418         ElseIf value > 0 then
    419             return 1
    420         Else
    421             return -1
    422         End If
    423     End Function
    424 
     319        If value = 0 Then
     320            return 0
     321        ElseIf value > 0 Then
     322            return 1
     323        Else
     324            return -1
     325        End If
     326    End Function
     327/*
    425328    Static Function Sign(value As SByte) As Long
    426         If value = 0 then
    427             return 0
    428         ElseIf value > 0 then
     329        If value = 0 Then
     330            return 0
     331        ElseIf value > 0 Then
    429332            return 1
    430333        Else
    … …  
    434337
    435338    Static Function Sign(value As Integer) As Long
    436         If value = 0 then
    437             return 0
    438         ElseIf value > 0 then
     339        If value = 0 Then
     340            return 0
     341        ElseIf value > 0 Then
    439342            return 1
    440343        Else
    … …  
    444347
    445348    Static Function Sign(value As Long) As Long
    446         If value = 0 then
    447             return 0
    448         ElseIf value > 0 then
     349        If value = 0 Then
     350            return 0
     351        ElseIf value > 0 Then
    449352            return 1
    450353        Else
    … …  
    454357
    455358    Static Function Sign(value As Int64) As Long
    456         If value = 0 then
    457             return 0
    458         ElseIf value > 0 then
     359        If value = 0 Then
     360            return 0
     361        ElseIf value > 0 Then
    459362            return 1
    460363        Else
    … …  
    464367
    465368    Static Function Sign(value As Single) As Long
    466         If value = 0 then
    467             return 0
    468         ElseIf value > 0 then
    469             return 1
    470         Else
    471             return -1
    472         End If
    473     End Function
    474 
    475     Static Function Sin(value As Double) As Double
    476         If ActiveBasic.Math.IsNaN(value) Then
    477             Return value
    478         ElseIf ActiveBasic.Math.IsInf(value) Then
    479             Return ActiveBasic.Math.Detail.GetNaN()
    480             Exit Function
    481         End If
    482 
    483         Dim k As Long
    484         Dim t As Double
    485 
    486         t = urTan((value * 0.5) As Double, k)
    487         t = 2 * t / (1 + t * t)
    488         If (k And 1) = 0 Then 'k mod 2 = 0 Then
    489             Return t
    490         Else
    491             Return -t
    492         End If
     369        If value = 0 Then
     370            return 0
     371        ElseIf value > 0 Then
     372            return 1
     373        Else
     374            return -1
     375        End If
     376    End Function
     377*/
     378    Static Function Sin(x As Double) As Double
     379        Sin = ActiveBasic.Math.Sin(x)
    493380    End Function
    494381
    495382    Static Function Sinh(x As Double) As Double
    496         If Math.Abs(x) > _System_EPS5 Then
    497             Dim t As Double
    498             t = Math.Exp(x)
    499             Return (t - 1 / t) * 0.5
    500         Else
    501             Return x * (1 + x * x * 0.166666666666667) ' x * (1 + x * x / 6)
    502         End If
     383        Sinh = ActiveBasic.Math.Sinh(x)
    503384    End Function
    504385
    505386    Static Function Sqrt(x As Double) As Double
    506         If x > 0 Then
    507             If ActiveBasic.Math.IsInf(x) Then
    508                 Sqrt = x
    509             Else
    510                 Sqrt = x
    511                 Dim i = (VarPtr(Sqrt) + 6) As *Word
    512                 Dim jj = GetWord(i) As Long
    513                 Dim j = jj >> 5 As Long
    514                 Dim k = (jj And &h0000001f) As Long
    515                 j = (j + 511) << 4 + k
    516                 SetWord(i, j)
    517                 Dim last As Double
    518                 Do
    519                     last = Sqrt
    520                     Sqrt = (x / Sqrt + Sqrt) * 0.5
    521                 Loop While Sqrt <> last
    522             End If
    523         ElseIf x < 0 Then
    524             Sqrt = ActiveBasic.Math.Detail.GetNaN()
    525         Else
    526             'x = 0 Or NaN
    527             Sqrt = x
    528         End If
     387        Sqrt = ActiveBasic.Math.Sqrt(x)
    529388    End Function
    530389
    531390    Static Function Tan(x As Double) As Double
    532         If ActiveBasic.Math.IsNaN(x) Then
    533             Tan = x
    534             Exit Function
    535         ElseIf ActiveBasic.Math.IsInf(x) Then
    536             Tan = ActiveBasic.Math.Detail.GetNaN()
    537             Exit Function
    538         End If
    539 
    540         Dim k As Long
    541         Dim t As Double
    542         t = urTan(x, k)
    543         If (k And 1) = 0 Then 'k mod 2 = 0 Then
    544             Return t
    545         ElseIf t <> 0 Then
    546             Return -1 / t
    547         Else
    548             Return ActiveBasic.Math.CopySign(ActiveBasic.Math.Detail.GetInf(False), -t)
    549         End If
     391        Tan = ActiveBasic.Math.Tan(x)
    550392    End Function
    551393
    552394    Static Function Tanh(x As Double) As Double
    553         If x > _System_EPS5 Then
    554             Return 2 / (1 + Math.Exp(-2 * x)) - 1
    555         ElseIf x < -_System_EPS5 Then
    556             Return 1 - 2 / (Math.Exp(2 * x) + 1)
    557         Else
    558             Return x * (1 - x * x * 0.333333333333333) 'x * (1 - x * x / 3)
    559         End If
    560     End Function
    561 
    562     'ToString
     395        Tanh = ActiveBasic.Math.Tanh(x)
     396    End Function
    563397
    564398    Static Function Truncate(x As Double) As Double
    565399        Return Fix(x)
    566400    End Function
    567 
    568 'Private
    569     Static Function urTan(x As Double, ByRef k As Long) As Double
    570         Dim i As Long
    571         Dim t As Double, x2 As Double
    572 
    573         If x >= 0 Then
    574             k = ( Fix(x * _System_InverseHalfPI) + 0.5 ) As Long
    575         Else
    576             k = ( Fix(x * _System_InverseHalfPI) - 0.5 ) As Long
    577         End If
    578         x = (x - (3217.0 / 2048.0) * k) + _System_D * k
    579         x2 = x * x
    580         t = 0
    581         For i = _System_UrTan_N To 3 Step -2
    582             t = x2 / (i - t)
    583         Next i
    584         urTan =  x / (1 - t)
    585     End Function
    586 Private
    587     Static Const _System_Atan_N = 20 As Long
    588     Static Const _System_UrTan_N = 17 As Long
    589     Static Const _System_D = 4.4544551033807686783083602485579e-6 As Double
    590     Static Const _System_EPS5 = 0.001 As Double
    591401End Class
    592402
    593403End Namespace
    594 
    595 Const _System_HalfPI = (_System_PI * 0.5)
    596 Const _System_InverseHalfPI = (2 / _System_PI) '1 / (PI / 2)
    597 Const _System_InverseLn10 = 0.43429448190325182765112891891661 '1 / (ln 10)
    598 Const _System_InverseSqrt2 = 0.70710678118654752440084436210485 '1 / (√2)

  • trunk/ab5.0/ablib/src/basic/function.sbp

    r581 r589  
    22
    33Const _System_PI = 3.14159265358979323846264
    4 Const _System_LOG2 = 0.6931471805599453094172321214581765680755
    54Const _System_SQRT2 = 1.41421356237309504880168872421
    6 Const _System_Log_N = 7 As Long
    75
    86'------------- サポート関数の定義 -------------
    97
    10 Function ldexp(x As Double, n As Long) As Double
    11     If x = 0 Then
    12         ldexp = 0
    13         Exit Function
    14     End If
    15     Dim pSrc = VarPtr(x) As *QWord
    16     Dim pDest = VarPtr(ldexp) As *QWord
    17     n += (pSrc[0] >> 52) As DWord And &h7FF
    18     pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)
    19 End Function
    20 
    21 Function frexp(x As Double, ByRef n As Long) As Double
    22     If x = 0 Then
    23         n = 0
    24         frexp = 0
    25         Exit Function
    26     End If
    27 
    28     Dim pSrc = VarPtr(x) As *QWord
    29     Dim pDest = VarPtr(frexp) As *QWord
    30     n = ((pSrc[0] >> 52) As DWord And &h7FF) - 1022
    31     pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000
    32 End Function
    33 
    34 Function frexp(x As Single, ByRef n As Long) As Single
    35     If x = 0 Then
    36         n = 0
    37         frexp = 0
    38         Exit Function
    39     End If
    40 
    41     Dim pSrc As *DWord, pDest As *DWord
    42     pSrc = VarPtr(x) As *DWord
    43     pDest = VarPtr(frexp) As *DWord
    44     n = ((pSrc[0] >> 23) And &hFF) - 126
    45     pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000
    46 End Function
    47 
    488Function ipow(x As Double, n As Long) As Double
    49     Dim abs_n As Long
    50     Dim r = 1 As Double
    51 
    52     abs_n=Abs(n) As Long
    53     While abs_n<>0
    54         If abs_n and 1 Then r *= x
    55         x = x * x
    56         abs_n >>= 1 ' abs_n \= 2
    57     Wend
    58 
    59     If n>=0 Then
    60         ipow=r
    61     Else
    62         ipow=1/r
    63     End If
     9    ipow = ActiveBasic.Math.pow(x, n)
    6410End Function
    6511
    6612Function pow(x As Double, y As Double) As Double
    67 '   If -LONG_MAX<=y and y<=LONG_MAX and y=CDbl(Int(y)) Then
    68     If y = (y As Long) Then
    69         pow = ipow(x, y As Long)
    70     ElseIf x>0 Then
    71         pow = Exp(y * Log(x))
    72         Exit Function
    73     ElseIf x<>0 or y<=0 Then
    74         pow = ActiveBasic.Math.Detail.GetNaN()
    75     Else
    76         pow = 0
    77     End If
     13    pow = ActiveBasic.Math.pow(x, y)
    7814End Function
    7915
    … …  
    8925    _System_RndNext = dwSeek
    9026End Sub
    91 
    9227
    9328'------------- ここからBasic標準関数の定義 -------------
    … …  
    15489'----------
    15590
    156 Function Abs(number As Double) As Double
    157     'Abs = System.Math.Abs(number)
    158     If number < 0 then
    159         Abs = -number
    160     Else
    161         Abs = number
    162     End If
    163 End Function
    164 
    165 Function Abs(number As Int64) As Int64
    166     If number < 0 then
    167         Abs = -number
    168     Else
    169         Abs = number
    170     End If
    171 End Function
    172 
    173 Function Abs(number As Long) As Long
    174     If number < 0 then
    175         Abs = -number
    176     Else
    177         Abs = number
    178     End If
     91/*
     92Function Abs(n As Double) As Double
     93    Abs = ActiveBasic.Math.Abs(n)
     94End Function
     95
     96Function Abs(n As Single) As Single
     97    Abs = ActiveBasic.Math.Abs(n)
     98End Function
     99
     100Function Abs(n As Int64) As Int64
     101    Abs = ActiveBasic.Math.Abs(n)
     102End Function
     103
     104Function Abs(n As Long) As Long
     105    Abs = ActiveBasic.Math.Abs(n)
     106End Function
     107
     108Function Abs(n As Integer) As Integer
     109    Abs = ActiveBasic.Math.Abs(n)
     110End Function
     111
     112Function Abs(n As SByte) As SByte
     113    Abs = ActiveBasic.Math.Abs(n)
    179114End Function
    180115
    181116Function Exp(x As Double) As Double
    182     Exp = System.Math.Exp(x)
     117    Exp = ActiveBasic.Math.Exp(x)
    183118End Function
    184119
    185120Function Log(x As Double) As Double
    186     Log = System.Math.Log(x)
    187 End Function
    188 
    189 Function Sgn(number As Double) As Long
    190     Sgn = System.Math.Sign(number)
    191 End Function
    192 
    193 Function Sqr(number As Double) As Double
    194     Sqr = System.Math.Sqrt(number)
    195 End Function
    196 
    197 Function Atn(number As Double) As Double
    198     Atn = System.Math.Atan(number)
     121    Log = ActiveBasic.Math.Log(x)
     122End Function
     123*/
     124Function Sgn(n As Double) As Long
     125'   Sgn = ActiveBasic..Math.Sign(n)
     126End Function
     127
     128Function Sqr(x As Double) As Double
     129    Sqr = ActiveBasic.Math.Sqrt(x)
     130End Function
     131
     132Function Atn(x As Double) As Double
     133    Atn = ActiveBasic.Math.Atan(x)
    199134End Function
    200135
    201136Function Atn2(y As Double, x As Double) As Double
    202     Atn2 = System.Math.Atan2(y, x)
    203 End Function
    204 
    205 Function Sin(number As Double) As Double
    206     Sin = System.Math.Sin(number)
    207 End Function
    208 
    209 Function Cos(number As Double) As Double
    210     Cos = System.Math.Cos(number)
    211 End Function
    212 
    213 Function Tan(number As Double) As Double
    214     Tan = System.Math.Tan(number)
    215 End Function
    216 
     137    Atn2 = ActiveBasic.Math.Atan2(y, x)
     138End Function
     139/*
     140Function Sin(x As Double) As Double
     141    Sin = ActiveBasic.Math.Sin(x)
     142End Function
     143
     144Function Cos(x As Double) As Double
     145    Cos = ActiveBasic.Math.Cos(x)
     146End Function
     147
     148Function Tan(x As Double) As Double
     149    Tan = ActiveBasic.Math.Tan(x)
     150End Function
     151*/
    217152Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))
    218153Function Rnd() As Double
Note: See TracChangeset for help on using the changeset viewer.