| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
Most efficient way to bui...
Forum: General Discussion
Last Post: ahenry3068
3 minutes ago
» Replies: 9
» Views: 82
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: madscijr
15 minutes ago
» Replies: 4
» Views: 112
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
2 hours ago
» Replies: 4
» Views: 83
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
5 hours ago
» Replies: 6
» Views: 77
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
Today, 05:50 AM
» Replies: 10
» Views: 223
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
Today, 02:33 AM
» Replies: 1
» Views: 51
|
Methods in types
Forum: General Discussion
Last Post: bobalooie
Today, 01:02 AM
» Replies: 0
» Views: 50
|
Cautionary tale of open, ...
Forum: General Discussion
Last Post: doppler
Yesterday, 10:23 AM
» Replies: 3
» Views: 109
|
Extended KotD #23 and #24...
Forum: Keyword of the Day!
Last Post: SMcNeill
Yesterday, 09:51 AM
» Replies: 0
» Views: 53
|
Big problem for me.
Forum: General Discussion
Last Post: JRace
Yesterday, 05:11 AM
» Replies: 11
» Views: 203
|
|
|
| Minimal Text Animator |
|
Posted by: James D Jarvis - 09-15-2022, 08:42 PM - Forum: Works in Progress
- Replies (5)
|
 |
Minimal Text Animator is exactly what this is. This is a very simple program to create and playback animations in 80x25 text mode.
It's simply structured with a main input loop, functions and subroutines are called from that loop. I want beginners to be able to look at this and modify it for their own needs. Currently there isn't much in the way of comments and there's a couple other commands I want to add but it certainly is a Minimal Text Animator right now.
Currently the user can Save and Load files, change the pen foreground and background color, change the character being drawn, and change the framerate. It's currently limited to 200 frames but that can easily be modified (just keep memory use and file size in mind).
Code: (Select All) 'Minimal Text Animator
'by James D. Jarvis Sept 15,2022 v 0.1
'
' a very minimal program to create and playback simple text screen animations
'S - Save file
'L - load file
'use mosue to draw
'N,n - create a new frame (limited to 200 as coded but you can edit that if you wish
'P,p - play animation
'F,f - change pen foreground color , you'll have to enter color number afterward
'B,b - change pen background color, you'll have to enter color number afterward
'esc - to quit program.... be careful this just dumps you out and you'll lose any work currently
'
'nothing fancy here at all, just a minimal program that functions
Screen _NewImage(80, 25, 0)
_Title "Minimal Text Animator"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxframes, pen$, fg_klr, bg_klr, pen_klr
Dim Shared showonion, framerate, lastframe
framerate = 20
maxtx = _Width
maxty = _Height
maxframes = 200
pen$ = "*"
showonion = 0
Print "Minimal Text Animator"
_ControlChr Off
Dim Shared gcell(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
For y = 1 To _Height
For x = 1 To _Width
gcell(f, x, y).t = " "
gcell(f, x, y).fgk = 15
gcell(f, x, y).bgk = 0
Next x
Next y
Next f
frameno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
Color fg_klr, bg_klr
'main program loop
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
gcell(frameno, mx, my).t = pen$
gcell(frameno, mx, my).fgk = pen_klr
gcell(frameno, mx, my).bgk = bg_klr
Color pen_klr, gcell(frameno, mx, my).bgk
_PrintString (mx, my), gcell(frameno, mx, my).t
End If
Color 15, 0
Loop
Select Case kk$
Case "n", "N"
Cls
frameno = frameno + 1
If frameno > maxframes Then frameno = 1
If showonion = 1 And frameno > 1 Then drawonion (frameno - 1)
drawframe frameno
lastframe = frameno
Case "o", "O"
If showonion = 0 Then
Cls
showonion = 1
drawonion (frameno - 1)
drawframe frameno
Else
showonion = 0
End If
Case "p", "P" 'play the animation
playanimation 1, lastframe
Case ",", "<" 'cycle down through drawn frames
frameno = frameno - 1
If frameno < 1 Then frameno = lastframe
drawframe frameno
Case ".", ">" 'cycle up through drawn frames
frameno = frameno + 1
If frameno > lastframe Then frameno = 1
Cls
drawframe frameno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawframe frameno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawframe frameno
Case "S"
savefile
Cls
drawframe frameno
Case "L"
loadfile
Cls
playanimation 1, lastframe
frameno = 1
Case "h", "H", "?"
helpme
Cls
drawframe frameno
Case "r", "R"
framerate = newrate
Cls
drawframe frameno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawframe frameno
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(frameno)
Loop Until kk$ = Chr$(27)
Sub drawframe (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
If onion = 0 Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Else
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
End If
End If
Next
Next
Color 15, 0
End Sub
Sub drawonion (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
Color 8, 0
_PrintString (x, y), gcell(f, x, y).t
Next
Next
Color 15, 0
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit framerate
For y = 1 To _Height
For x = 1 To _Width
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Next
Next
_Display
Next f
_AutoDisplay
Color 15, 0
End Sub
Function select_pencolor
Cls
Color 15, 0
Print "SELECT PEN COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0: Print "16.",: Color 16, 0: Print Chr$(219): Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219),: Color 15, 0: Print "17.",: Color 17, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0: Print "18.",: Color 18, 0: Print Chr$(219): Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219),: Color 15, 0: Print "19.",: Color 19, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0: Print "20.",: Color 20, 0: Print Chr$(219): Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219),: Color 15, 0: Print "21.",: Color 21, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0: Print "22.",: Color 22, 0: Print Chr$(219): Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219),: Color 15, 0: Print "23.",: Color 23, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0: Print "24.",: Color 24, 0: Print Chr$(219): Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219),: Color 15, 0: Print "25.",: Color 25, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0: Print "26.",: Color 26, 0: Print Chr$(219): Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219),: Color 15, 0: Print "27.",: Color 27, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0: Print "28.",: Color 28, 0: Print Chr$(219): Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219),: Color 15, 0: Print "29.",: Color 29, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0: Print "30.",: Color 30, 0: Print Chr$(219): Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219),: Color 15, 0: Print "31.",: Color 31, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 3: Input "enter color from 0 to 31 ", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_pencolor = Val(kk$)
End Function
Function newrate
Cls
Print "Change Frame Rate ?"
Print
Print "Current frame rate is "; framerate
Print
Do
Locate 20, 3: Input "enter color from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
End Function
Function select_backgroundcolor
Cls
Color 15, 0
Print "SELECT Background COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 1: Input "enter color from 0 to 31", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_backgroundcolor = Val(kk$)
End Function
Sub helpme
Cls
Print "HELP"
Print
Print "S - Save file "
Print "L - load file "
Print "use mosue to draw"
Print "N,n - create a new frame (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play animation"
Print "C,c - change pen foreground color , you'll have to enter color number afterward"
Print "B,b - change pen background color, you'll have to enter color number afterward"
Print "R,r - change framerate for animation"
Print "esc - to quit program.... be careful this just dumps you out and you'll lose any work currently"
Print
Print "Press any key to continue"
any$ = Input$(1)
End Sub
Function newchar
Dim mc(0 To 256, 2)
Cls
x = 0
y = 3
newc = -1
Print "Click on the Character you wish to use."
For c = 0 To 255
x = x + 2
If x > 60 Then
x = 2
y = y + 2
End If
_PrintString (x, y), Chr$(c)
mc(c, 1) = x
mc(c, 2) = y
Next c
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
c = 0
Do
If mc(c, 1) = mx And mc(c, 2) = my Then newc = c
c = c + 1
If c = 256 Then newc = -2
Loop Until newc <> -1
If newc = -2 Then newc = -1
End If
Color 15, 0
Loop
Loop Until newc <> -1
newchar = newc
End Function
Sub savefile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Output As #1
Write #1, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
Write #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Next x
Next y
Next f
Close #1
Locate 3, 1
Print filename$; " saved"
Print "press any key to continue"
any$ = Input$(1)
End Sub
Sub loadfile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Input As #1
Input #1, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
Input #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Next x
Next y
Next f
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End Sub
|
|
|
| Lakeshore 218 Temperature Monitor |
|
Posted by: CJAlva - 09-15-2022, 03:46 PM - Forum: Help Me!
- Replies (14)
|
|
Hey all!
I'm currently using a Lakeshore 218 Temperature monitor and was hoping to be able to grab readings using QBasic. Here's what I have so far:
CLS 'Clear screen
PRINT " SERIAL COMMUNICATION PROGRAM"
PRINT
TIMEOUT = 2000 'Read timeout (may need more)
BAUD$ = "9600"
TERM$ = CHR$(13) + CHR$(10) 'Terminators are <CR><LF>
OPEN "COM1:" + BAUD$ + ",O,7,1,RS" FOR RANDOM AS #1 LEN = 256
LOOP1: LINE INPUT "ENTER COMMAND (or EXIT):"; CMD$ 'Get command from keyboard
CMD$ = UCASE$(CMD$) 'Change input to upper case
IF CMD$ = "EXIT" THEN CLOSE #1: END 'Get out on Exit
CMD$ = CMD$ + TERM$
PRINT #1, CMD$; 'Send command to instrument
IF INSTR(CMD$, "?") <> 0 THEN 'Test for query
RS$ = "" 'If query, read response
N = 0 'Clr return string and count
WHILE (N < TIMEOUT) AND (INSTR(RS$, TERM$) = 0) 'Wait for response
IN$ = INPUT$(LOC(1), #1) 'Get one character at a time
IF IN$ = "" THEN N = N + 1 ELSE N = 0 'Add 1 to timeout if no chr
RS$ = RS$ + IN$ 'Add next chr to string
WEND 'Get chrs until terminators
IF RS$ <> "" THEN 'See if return string is empty
RS$ = MID$(RS$, 1, (INSTR(RS$, TERM$) - 1))'Strip off terminators
PRINT "RESPONSE:"; RS$ 'Print response to query
ELSE
PRINT "NO RESPONSE" 'No response to query
END IF
END IF 'Get next command
GOTO LOOP1
When I compile and run, I get an error calling out line 17 (IN$ = INPUT$(LOC(1), #1) 'Get one character at a time) and saying "Input past end of file". No clue how to mitigate this. Can anyone help out?
|
|
|
|
| Our 200th user registered today. |
|
Posted by: Pete - 09-14-2022, 01:51 AM - Forum: General Discussion
- Replies (19)
|
 |
That makes this place about half the size of the hussel and bussel busy off the carts QBasic Forum! I swear over there there are days Bob and I can barely wake keep up. Kidding aside, nice to see folks are still finding us here. I think our 200th member is from my old haunt, Italy.
Pete
|
|
|
|
| bug when using _Dest _Console |
|
Posted by: Jack - 09-13-2022, 10:18 PM - Forum: General Discussion
- Replies (27)
|
 |
this works Ok, you are prevented from entering a number that's too large for a long
Code: (Select All) Dim As Long n
Input "n "; n
Print n
Code: (Select All) $Console:Only
_Dest _Console
Dim As Long n
Input "n "; n
Print n
Code: (Select All) n ? 99999999999999999999
999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999 999999999
Press any key to continue
|
|
|
|
| decfloat -- again |
|
Posted by: Jack - 09-13-2022, 08:45 PM - Forum: Programs
- Replies (42)
|
|
Code: (Select All) _Title "decfloat-offset-v2 by Jack"
$Console:Only
_Dest _Console
Option _Explicit
Declare CustomType Library
Sub memcpy Alias "memmove" (ByVal dest As _Offset, ByVal source As _Offset, ByVal bytes As Long)
End Declare
Const NUMBER_OF_DIGITS = 10000
Const NUM_DIGITS = 8 * (1 + NUMBER_OF_DIGITS \ 8)
Const NUM_DWORDS = NUM_DIGITS \ 8
Const BIAS = 1073741824 '2 ^ 30
Const MANTISSA_BYTES = (NUM_DWORDS + 1) * 4
Type decfloat
As Long sign
As _Unsigned Long exponent
As String * Mantissa_bytes mantissa
End Type
' Error definitions
Const DIVZ_ERR = 1 'Divide by zero
Const EXPO_ERR = 2 'Exponent overflow error
Const EXPU_ERR = 3 'Exponent underflow error
Dim Shared As decfloat pi_dec, tan_half_num(15), tan_half_den(14)
Dim As decfloat p1, p2, p3
Dim As Double t1, t2, t3
Dim As Long i, n
Dim As String pie
initialize_fp
t1 = Timer(.0001)
pi_brent_salamin p1, NUM_DIGITS
t1 = Timer(.0001) - t1
t2 = Timer(.0001)
Pi_Ramanujan p2, NUM_DIGITS
t2 = Timer(.0001) - t2
t3 = Timer(.0001)
pi_chudnovsky_bs p3, NUM_DIGITS
t3 = Timer(.0001) - t3
pie = fp2str(p1, NUMBER_OF_DIGITS)
Print Left$(pie, 22); "..."; Right$(pie, 20)
pie = fp2str(p2, NUMBER_OF_DIGITS)
Print Left$(pie, 22); "..."; Right$(pie, 20)
pie = fp2str(p3, NUMBER_OF_DIGITS)
Print Left$(pie, 22); "..."; Right$(pie, 20)
Print
Print "Pi to "; NUMBER_OF_DIGITS; "digits"
Print "elapsed time for pi_brent_salamin "; t1; " seconds"
Print "elapsed time for Pi_Ramanujan "; t2; " seconds"
Print "elapsed time for pi_chudnovsky_bs "; t3; " seconds"
Sub str2fp (result As decfloat, value As String)
Dim As Long j, s, d, e, ep, ex, es, i, f, fp, fln, ln
Dim As String c, f1, f2, f3, ts
Dim n As decfloat
Dim As _Offset no, lno
no = _Offset(n.mantissa)
lno = _Offset(ln)
j = 1
s = 1
d = 0
e = 0
ep = 0
ex = 0
es = 1
i = 0
f = 0
fp = 0
f1 = ""
f2 = ""
f3 = ""
value = UCase$(value)
fln = Len(value)
While j <= fln
c = Mid$(value, j, 1)
If ep = 1 Then
If c = " " Then
j = j + 1
GoTo skip_while
End If
If c = "-" Then
es = -es
c = ""
End If
If c = "+" Then
j = j + 1
GoTo skip_while
End If
If (c = "0") And (f3 = "") Then
j = j + 1
GoTo skip_while
End If
If (c > "/") And (c < ":") Then 'c is digit between 0 and 9
f3 = f3 + c
ex = 10 * ex + (Asc(c) - 48)
j = j + 1
GoTo skip_while
End If
End If
If c = " " Then
j = j + 1
GoTo skip_while
End If
If c = "-" Then
s = -s
j = j + 1
GoTo skip_while
End If
If c = "+" Then
j = j + 1
GoTo skip_while
End If
If c = "." Then
If d = 1 Then
j = j + 1
GoTo skip_while
End If
d = 1
End If
If (c > "/") And (c < ":") Then 'c is digit between 0 and 9
If ((c = "0") And (i = 0)) Then
If d = 0 Then
j = j + 1
GoTo skip_while
End If
If (d = 1) And (f = 0) Then
e = e - 1
j = j + 1
GoTo skip_while
End If
End If
If d = 0 Then
f1 = f1 + c
i = i + 1
Else
If (c > "0") Then
fp = 1
End If
f2 = f2 + c
f = f + 1
End If
End If
If c = "E" Or c = "D" Then
ep = 1
End If
j = j + 1
skip_while:
Wend
If fp = 0 Then
f = 0
f2 = ""
End If
If s = -1 Then s = &H8000 Else s = 0
n.sign = s
ex = es * ex - 1 + i + e
f1 = f1 + f2
f1 = Mid$(f1, 1, 1) + Right$(f1, Len(f1) - 1)
fln = Len(f1)
If Len(f1) > (NUM_DIGITS + 1 + 8) Then
f1 = Mid$(f1, 1, (NUM_DIGITS + 1 + 8))
End If
While Len(f1) < (NUM_DIGITS + 1 + 8)
f1 = f1 + "0"
Wend
j = 1
For i = 0 To NUM_DWORDS
ts = Mid$(f1, j, 8)
ln = Val(ts)
memcpy no, lno, 4
If ln <> 0 Then fp = 1
no = no + 4
j = j + 8
Next
If fp Then n.exponent = (ex + BIAS + 1) Else n.exponent = 0
result = n
End Sub
Function fp2str_exp$ (n As decfloat, places As Long)
Dim As Long i, ex, ln
Dim As String v, f, ts
Dim As _Offset no, lno
no = _Offset(n.mantissa)
lno = _Offset(ln)
If n.exponent > 0 Then
ex = (n.exponent And &H7FFFFFFF) - BIAS - 1
Else
ex = 0
End If
If n.sign Then v = "-" Else v = " "
memcpy lno, no, 4
ts = Str$(ln)
ts = _Trim$(ts)
If Len(ts) < 8 Then
ts = ts + String$(8 - Len(ts), "0")
End If
v = v + Left$(ts, 1) + "." + Mid$(ts, 2)
For i = 1 To NUM_DWORDS - 1
no = no + 4
memcpy lno, no, 4
ts = Str$(ln)
ts = _Trim$(ts)
If Len(ts) < 8 Then
ts = String$(8 - Len(ts), "0") + ts
End If
v = v + ts
Next
v = Left$(v, places + 3)
f = _Trim$(Str$(Abs(ex)))
f = String$(5 - Len(f), "0") + f
If ex < 0 Then v = v + "E-" Else v = v + "E+"
v = v + f
fp2str_exp$ = v
End Function
Function fp2str_fix$ (n As decfloat, places As Long)
Dim As Long i, ex, ln
Dim As String v, ts, s
Dim As _Offset no, lno
no = _Offset(n.mantissa)
lno = _Offset(ln)
If n.exponent > 0 Then
ex = (n.exponent And &H7FFFFFFF) - BIAS - 1
Else
ex = 0
End If
If n.sign Then s = "-" Else s = " "
memcpy lno, no, 4
ts = _Trim$(Str$(ln))
If Len(ts) < 8 Then
ts = ts + String$(8 - Len(ts), "0")
End If
v = ts
For i = 1 To NUM_DWORDS - 1
no = no + 4
memcpy lno, no, 4
ts = _Trim$(Str$(ln))
If Len(ts) < 8 Then
ts = String$(8 - Len(ts), "0") + ts
End If
v = v + ts
Next
If places < NUM_DIGITS Then
v = Left$(v, places)
End If
If ex = 0 Then
v = Left$(v, 1) + "." + Mid$(v, 2)
ElseIf ex < 0 Then
v = "0." + String$(Abs(ex) - 1, "0") + v
ElseIf ex > 0 Then
v = Left$(v, ex + 1) + "." + Mid$(v, ex + 2)
End If
fp2str_fix$ = s + v
End Function
Function fp2str$ (n As decfloat, places As Long)
Dim As Long ex
If n.exponent > 0 Then
ex = (n.exponent And &H7FFFFFFF) - BIAS - 1
Else
ex = 0
End If
If Abs(ex) < places Then
fp2str = fp2str_fix(n, places)
Else
fp2str = fp2str_exp(n, places)
End If
End Function
'long part of num
Sub fpfix (result As decfloat, num As decfloat)
Dim As decfloat ip
Dim As Long ex, ex2, j, k, ln
Dim As _Offset ipo, no, lno
no = _Offset(num.mantissa)
ipo = _Offset(ip.mantissa)
lno = _Offset(ln)
ex = (num.exponent And &H7FFFFFFF) - BIAS
If ex < 1 Then
result = ip: Exit Sub
End If
If ex >= (NUM_DIGITS) Then
result = num: Exit Sub
End If
ex2 = ex \ 8
k = ex2
j = ex Mod 8
While ex2 > 0
ex2 = ex2 - 1
memcpy lno, no + ex2 * 4, 4
memcpy ipo + ex2 * 4, lno, 4
Wend
If j = 1 Then
memcpy lno, no + k * 4, 4
ln = 10000000 * (ln \ 10000000)
memcpy ipo + k * 4, lno, 4
ElseIf j = 2 Then
memcpy lno, no + k * 4, 4
ln = 1000000 * (ln \ 1000000)
memcpy ipo + k * 4, lno, 4
ElseIf j = 3 Then
memcpy lno, no + k * 4, 4
ln = 100000 * (ln \ 100000)
memcpy ipo + k * 4, lno, 4
ElseIf j = 4 Then
memcpy lno, no + k * 4, 4
ln = 10000 * (ln \ 10000)
memcpy ipo + k * 4, lno, 4
ElseIf j = 5 Then
memcpy lno, no + k * 4, 4
ln = 1000 * (ln \ 1000)
memcpy ipo + k * 4, lno, 4
ElseIf j = 6 Then
memcpy lno, no + k * 4, 4
ln = 100 * (ln \ 100)
memcpy ipo + k * 4, lno, 4
ElseIf j = 7 Then
memcpy lno, no + k * 4, 4
ln = 10 * (ln \ 10)
memcpy ipo + k * 4, lno, 4
ElseIf j = 8 Then
memcpy lno, no + k * 4, 4
memcpy ipo + k * 4, lno, 4
End If
ip.exponent = ex + BIAS
ip.sign = num.sign
result = ip
End Sub
Function fpfix_is_odd& (num As decfloat)
Dim As Long ex, j, k, ln
Dim As _Offset no, lno
no = _Offset(num.mantissa)
lno = _Offset(ln)
ex = (num.exponent And &H7FFFFFFF) - BIAS
If ex < 1 Then
fpfix_is_odd = 0: Exit Function
End If
If ex >= (NUM_DIGITS) Then
Print "error in function fpfix_is_odd"
fpfix_is_odd = 99999999: Exit Function
End If
k = ex \ 8
j = ex Mod 8
If j = 1 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = (ln \ 10000000) And 1: Exit Function
ElseIf j = 2 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = (ln \ 1000000) And 1: Exit Function
ElseIf j = 3 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = (ln \ 100000) And 1: Exit Function
ElseIf j = 4 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = (ln \ 10000) And 1: Exit Function
ElseIf j = 5 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = (ln \ 1000) And 1: Exit Function
ElseIf j = 6 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = (ln \ 100) And 1: Exit Function
ElseIf j = 7 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = (ln \ 10) And 1: Exit Function
ElseIf j = 8 Then
memcpy lno, no + k * 4, 4
fpfix_is_odd = ln And 1: Exit Function
End If
fpfix_is_odd = 0
End Function
Function fp2dbl# (n As decfloat)
Dim As Long ex, ln
Dim As String v, f, ts
Dim As _Offset no, lno
no = _Offset(n.mantissa)
lno = _Offset(ln)
If n.exponent > 0 Then
ex = (n.exponent And &H7FFFFFFF) - BIAS - 1
Else
ex = 0
End If
If n.sign Then v = "-" Else v = " "
memcpy lno, no, 4
ts = _Trim$(Str$(ln))
If Len(ts) < 8 Then
ts = ts + String$(8 - Len(ts), "0")
End If
v = v + Left$(ts, 1) + "." + Mid$(ts, 2)
memcpy lno, no + 4, 4
ts = _Trim$(Str$(ln))
If Len(ts) < 8 Then
ts = String$(8 - Len(ts), "0") + ts
End If
v = v + ts
f = Str$(Abs(ex))
f = String$(5 - Len(f), "0") + f
If ex < 0 Then v = v + "E-" Else v = v + "E+"
v = v + f
fp2dbl# = Val(v)
End Function
'Sub si2fp (result As decfloat, m As _Integer64, digits_in As Long)
' Dim As Long digits
' digits = digits_in
' If digits > NUM_DWORDS Then digits = NUM_DWORDS
' Dim As decfloat fac1
' Dim As Long i, ln
' Dim As _Integer64 n
' Dim As _Offset no, lno
' no = _Offset(fac1.mantissa)
' lno = _Offset(ln)
' n = Abs(m)
' If n > 9999999999999999 Then
' str2fp fac1, Str$(m)
' result = fac1: Exit Sub
' End If
' ln = 0
' For i = 1 To digits
' memcpy no + i * 4, lno, 4
' Next
' If m = 0 Then
' fac1.exponent = 0
' fac1.sign = 0
' result = fac1: Exit Sub
' End If
' fac1.exponent = BIAS
' If n < 100000000 Then
' If n < 10 Then
' ln = n * 10000000
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 1
' ElseIf n < 100 Then
' ln = n * 1000000
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 2
' ElseIf n < 1000 Then
' ln = n * 100000
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 3
' ElseIf n < 10000 Then
' ln = n * 10000
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 4
' ElseIf n < 100000 Then
' ln = n * 1000
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 5
' ElseIf n < 1000000 Then
' ln = n * 100
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 6
' ElseIf n < 10000000 Then
' ln = n * 10
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 7
' ElseIf n < 100000000 Then
' ln = n
' memcpy no, lno, 4
' fac1.exponent = fac1.exponent + 8
' End If
' End If
' If n > 99999999 Then
' fac1.exponent = fac1.exponent + 8
' If n < 1000000000 Then
' ln = n \ 10
' memcpy no, lno, 4
' ln = (n Mod 10) * 100000000
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 1
' ElseIf n < 10000000000 Then
' ln = n \ 100
' memcpy no, lno, 4
' ln = (n Mod 100) * 10000000
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 2
' ElseIf n < 100000000000 Then
' ln = n \ 1000
' memcpy no, lno, 4
' ln = (n Mod 1000) * 1000000
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 3
' ElseIf n < 1000000000000 Then
' ln = n \ 10000
' memcpy no, lno, 4
' ln = (n Mod 10000) * 100000
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 4
' ElseIf n < 10000000000000 Then
' ln = n \ 100000
' memcpy no, lno, 4
' ln = (n Mod 100000) * 10000
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 5
' ElseIf n < 100000000000000 Then
' ln = n \ 1000000
' memcpy no, lno, 4
' ln = (n Mod 1000000) * 1000
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 6
' ElseIf n < 1000000000000000 Then
' ln = n \ 10000000
' memcpy no, lno, 4
' ln = (n Mod 10000000) * 100
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 7
' ElseIf n < 10000000000000000 Then
' ln = n \ 100000000
' memcpy no, lno, 4
' ln = (n Mod 100000000) * 10
' memcpy no + 4, lno, 4
' fac1.exponent = fac1.exponent + 8
' End If
' End If
' If m < 0 Then
' fac1.sign = &H8000
' Else
' fac1.sign = 0
' End If
' result = fac1
'End Sub
Sub si2fp (result As decfloat, m As _Integer64, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat fac1
Dim As Long i, ln
Dim As _Integer64 n
Dim As _Offset no, lno
no = _Offset(fac1.mantissa)
lno = _Offset(ln)
n = Abs(m)
If n > 9999999999999999 Then
str2fp fac1, Str$(m)
result = fac1: Exit Sub
End If
ln = 0
For i = 1 To digits
memcpy no + i * 4, lno, 4
Next
If m = 0 Then
fac1.exponent = 0
fac1.sign = 0
result = fac1: Exit Sub
End If
fac1.exponent = BIAS
If n < 100000000 Then
If n < 10 Then
ln = n * 10000000
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 1
ElseIf n < 100 Then
ln = n * 1000000
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 2
ElseIf n < 1000 Then
ln = n * 100000
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 3
ElseIf n < 10000 Then
ln = n * 10000
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 4
ElseIf n < 100000 Then
ln = n * 1000
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 5
ElseIf n < 1000000 Then
ln = n * 100
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 6
ElseIf n < 10000000 Then
ln = n * 10
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 7
ElseIf n < 100000000 Then
ln = n
memcpy no, lno, 4
fac1.exponent = fac1.exponent + 8
End If
End If
If n > 99999999 Then
fac1.exponent = fac1.exponent + 8
If n < 1000000000 Then
ln = n \ 10
memcpy no, lno, 4
ln = (n Mod 10) * 10000000
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 1
ElseIf n < 10000000000 Then
ln = n \ 100
memcpy no, lno, 4
ln = (n Mod 100) * 1000000
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 2
ElseIf n < 100000000000 Then
ln = n \ 1000
memcpy no, lno, 4
ln = (n Mod 1000) * 100000
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 3
ElseIf n < 1000000000000 Then
ln = n \ 10000
memcpy no, lno, 4
ln = (n Mod 10000) * 10000
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 4
ElseIf n < 10000000000000 Then
ln = n \ 100000
memcpy no, lno, 4
ln = (n Mod 100000) * 1000
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 5
ElseIf n < 100000000000000 Then
ln = n \ 1000000
memcpy no, lno, 4
ln = (n Mod 1000000) * 100
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 6
ElseIf n < 1000000000000000 Then
ln = n \ 10000000
memcpy no, lno, 4
ln = (n Mod 10000000) * 10
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 7
ElseIf n < 10000000000000000 Then
ln = n \ 100000000
memcpy no, lno, 4
ln = n Mod 100000000
memcpy no + 4, lno, 4
fac1.exponent = fac1.exponent + 8
End If
End If
If m < 0 Then
fac1.sign = &H8000
Else
fac1.sign = 0
End If
result = fac1
End Sub
Sub RSHIFT_1 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * i, 4
v1 = ln \ 10
memcpy lno, no + 4 * (i - 1), 4
v2 = ln Mod 10
v2 = v2 * 10000000 + v1
ln = v2
memcpy no + 4 * i, lno, 4
Next
memcpy lno, no, 4
ln = ln \ 10
memcpy no, lno, 4
End Sub
Sub LSHIFT_1 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * i, 4
v1 = ln Mod 10000000
memcpy lno, no + 4 * (i + 1), 4
v2 = ln \ 10000000
ln = v1 * 10 + v2
memcpy no + 4 * i, lno, 4
memcpy lno, no + 4 * (i + 1), 4
ln = ln Mod 10000000
memcpy no + 4 * (i + 1), lno, 4
Next
memcpy lno, no + 4 * digits, 4
ln = 10 * (ln Mod 10000000)
memcpy no + 4 * digits, lno, 4
End Sub
Sub RSHIFT_2 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * i, 4
v1 = ln \ 100
memcpy lno, no + 4 * (i - 1), 4
v2 = ln Mod 100
v2 = v2 * 1000000 + v1
ln = v2
memcpy no + 4 * i, lno, 4
Next
memcpy lno, no, 4
ln = ln \ 100
memcpy no, lno, 4
End Sub
Sub LSHIFT_2 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * i, 4
v1 = ln Mod 1000000
memcpy lno, no + 4 * (i + 1), 4
v2 = ln \ 1000000
ln = v1 * 100 + v2
memcpy no + 4 * i, lno, 4
memcpy lno, no + 4 * (i + 1), 4
ln = ln Mod 1000000
memcpy no + 4 * (i + 1), lno, 4
Next
memcpy lno, no + 4 * digits, 4
ln = 100 * (ln Mod 1000000)
memcpy no + 4 * digits, lno, 4
End Sub
Sub RSHIFT_3 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * i, 4
v1 = ln \ 1000
memcpy lno, no + 4 * (i - 1), 4
v2 = ln Mod 1000
v2 = v2 * 100000 + v1
ln = v2
memcpy no + 4 * i, lno, 4
Next
memcpy lno, no, 4
ln = ln \ 1000
memcpy no, lno, 4
End Sub
Sub LSHIFT_3 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * i, 4
v1 = ln Mod 100000
memcpy lno, no + 4 * (i + 1), 4
v2 = ln \ 100000
ln = v1 * 1000 + v2
memcpy no + 4 * i, lno, 4
memcpy lno, no + 4 * (i + 1), 4
ln = ln Mod 100000
memcpy no + 4 * (i + 1), lno, 4
Next
memcpy lno, no + 4 * digits, 4
ln = 1000 * (ln Mod 100000)
memcpy no + 4 * digits, lno, 4
End Sub
Sub RSHIFT_4 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * i, 4
v1 = ln \ 10000
memcpy lno, no + 4 * (i - 1), 4
v2 = ln Mod 10000
v2 = v2 * 10000 + v1
ln = v2
memcpy no + 4 * i, lno, 4
Next
memcpy lno, no, 4
ln = ln \ 10000
memcpy no, lno, 4
End Sub
Sub LSHIFT_4 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * i, 4
v1 = ln Mod 10000
memcpy lno, no + 4 * (i + 1), 4
v2 = ln \ 10000
ln = v1 * 10000 + v2
memcpy no + 4 * i, lno, 4
memcpy lno, no + 4 * (i + 1), 4
ln = ln Mod 10000
memcpy no + 4 * (i + 1), lno, 4
Next
memcpy lno, no + 4 * digits, 4
ln = 10000 * (ln Mod 10000)
memcpy no + 4 * digits, lno, 4
End Sub
Sub RSHIFT_5 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * i, 4
v1 = ln \ 100000
memcpy lno, no + 4 * (i - 1), 4
v2 = ln Mod 100000
v2 = v2 * 1000 + v1
ln = v2
memcpy no + 4 * i, lno, 4
Next
memcpy lno, no, 4
ln = ln \ 100000
memcpy no, lno, 4
End Sub
Sub LSHIFT_5 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * i, 4
v1 = ln Mod 1000
memcpy lno, no + 4 * (i + 1), 4
v2 = ln \ 1000
ln = v1 * 100000 + v2
memcpy no + 4 * i, lno, 4
memcpy lno, no + 4 * (i + 1), 4
ln = ln Mod 1000
memcpy no + 4 * (i + 1), lno, 4
Next
memcpy lno, no + 4 * digits, 4
ln = 100000 * (ln Mod 1000)
memcpy no + 4 * digits, lno, 4
End Sub
Sub RSHIFT_6 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * i, 4
v1 = ln \ 1000000
memcpy lno, no + 4 * (i - 1), 4
v2 = ln Mod 1000000
v2 = v2 * 100 + v1
ln = v2
memcpy no + 4 * i, lno, 4
Next
memcpy lno, no, 4
ln = ln \ 1000000
memcpy no, lno, 4
End Sub
Sub LSHIFT_6 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * i, 4
v1 = ln Mod 100
memcpy lno, no + 4 * (i + 1), 4
v2 = ln \ 100
ln = v1 * 1000000 + v2
memcpy no + 4 * i, lno, 4
memcpy lno, no + 4 * (i + 1), 4
ln = ln Mod 100
memcpy no + 4 * (i + 1), lno, 4
Next
memcpy lno, no + 4 * digits, 4
ln = 1000000 * (ln Mod 100)
memcpy no + 4 * digits, lno, 4
End Sub
Sub RSHIFT_7 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * i, 4
v1 = ln \ 10000000
memcpy lno, no + 4 * (i - 1), 4
v2 = ln Mod 10000000
v2 = v2 * 10 + v1
ln = v2
memcpy no + 4 * i, lno, 4
Next
memcpy lno, no, 4
ln = ln \ 10000000
memcpy no, lno, 4
End Sub
Sub LSHIFT_7 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v1, v2
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * i, 4
v1 = ln Mod 10
memcpy lno, no + 4 * (i + 1), 4
v2 = ln \ 10
ln = v1 * 10000000 + v2
memcpy no + 4 * i, lno, 4
memcpy lno, no + 4 * (i + 1), 4
ln = ln Mod 10
memcpy no + 4 * (i + 1), lno, 4
Next
memcpy lno, no + 4 * digits, 4
ln = 10000000 * (ln Mod 10)
memcpy no + 4 * digits, lno, 4
End Sub
Sub RSHIFT_8 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = digits To 1 Step -1
memcpy lno, no + 4 * (i - 1), 4
memcpy no + 4 * i, lno, 4
Next
ln = 0
memcpy no, lno, 4
End Sub
Sub LSHIFT_8 (mantissa As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As Long i, ln
Dim As _Offset no, lno
no = _Offset(mantissa.mantissa)
lno = _Offset(ln)
For i = 0 To digits - 1
memcpy lno, no + 4 * (i + 1), 4
memcpy no + 4 * i, lno, 4
Next
ln = 0
memcpy no + 4 * digits, lno, 4
End Sub
Function fpcmp& (x As decfloat, y As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As Long c, i, lx, ly
Dim As _Offset xo, yo, lxo, lyo
If x.sign < y.sign Then fpcmp = -1: Exit Function
If x.sign > y.sign Then fpcmp = 1: Exit Function
xo = _Offset(x.mantissa)
yo = _Offset(y.mantissa)
lxo = _Offset(lx)
lyo = _Offset(ly)
If x.sign = y.sign Then
If x.exponent = y.exponent Then
For i = 0 To digits
memcpy lxo, xo + 4 * i, 4
memcpy lyo, yo + 4 * i, 4
c = lx - ly
If c <> 0 Then Exit For
Next
If c < 0 Then fpcmp = -1: Exit Function
If c = 0 Then fpcmp = 0: Exit Function
If c > 0 Then fpcmp = 1: Exit Function
End If
If x.exponent < y.exponent Then fpcmp = -1: Exit Function
If x.exponent > y.exponent Then fpcmp = 1: Exit Function
End If
' if we reach this point it means that the signs are different
' and if the sign of x is set meaning that x is negative then x < y
End Function
Sub NORM_FAC1 (fac1 As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
' normalize the number in fac1
' all routines exit through this one.
'see if the mantissa is all zeros.
'if so, set the exponent and sign equal to 0.
Dim As Long i, er, f, ln
Dim As _Offset no, lno
no = _Offset(fac1.mantissa)
lno = _Offset(ln)
er = 0: f = 0
For i = 0 To digits
memcpy lno, no + 4 * i, 4
If ln > 0 Then f = 1
Next
memcpy lno, no, 4
If f = 0 Then
fac1.exponent = 0
fac1.sign = 0
Exit Sub
'if the highmost Digit in fac1_man is nonzero,
'shift the mantissa right 1 Digit and
'increment the exponent
ElseIf ln > 99999999 Then
RSHIFT_1 fac1, digits
fac1.exponent = fac1.exponent + 1
Else
memcpy lno, no, 4
'now shift fac1_man 1 to the left until a
'nonzero digit appears in the next-to-highest
'Digit of fac1_man. decrement exponent for
'each shift.
While ln = 0
LSHIFT_8 fac1, digits
fac1.exponent = fac1.exponent - 8
If fac1.exponent = 0 Then
Print "NORM_FAC1=EXPU_ERR"
Exit Sub
End If
memcpy lno, no, 4
Wend
memcpy lno, no, 4
If ln < 10 Then
LSHIFT_7 fac1, digits
fac1.exponent = fac1.exponent - 7
ElseIf ln < 100 Then
LSHIFT_6 fac1, digits
fac1.exponent = fac1.exponent - 6
ElseIf ln < 1000 Then
LSHIFT_5 fac1, digits
fac1.exponent = fac1.exponent - 5
ElseIf ln < 10000 Then
LSHIFT_4 fac1, digits
fac1.exponent = fac1.exponent - 4
ElseIf ln < 100000 Then
LSHIFT_3 fac1, digits
fac1.exponent = fac1.exponent - 3
ElseIf ln < 1000000 Then
LSHIFT_2 fac1, digits
fac1.exponent = fac1.exponent - 2
ElseIf ln < 10000000 Then
LSHIFT_1 fac1, digits
fac1.exponent = fac1.exponent - 1
End If
End If
'check for overflow/underflow
If fac1.exponent < 0 Then
Print "NORM_FAC1=EXPO_ERR"
End If
End Sub
Sub fpadd_aux (fac1 As decfloat, fac2 As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As _Unsigned Long v, c, i
Dim As Long lx, ly
Dim As _Offset xo, yo, lxo, lyo
xo = _Offset(fac1.mantissa)
yo = _Offset(fac2.mantissa)
lxo = _Offset(lx)
lyo = _Offset(ly)
c = 0
For i = digits To 1 Step -1
memcpy lxo, xo + 4 * i, 4
memcpy lyo, yo + 4 * i, 4
v = lx + ly + c
If v > 99999999 Then
v = v - 100000000
c = 1
Else
c = 0
End If
lx = v
memcpy xo + 4 * i, lxo, 4
Next
memcpy lxo, xo, 4
memcpy lyo, yo, 4
lx = lx + ly + c
memcpy xo, lxo, 4
NORM_FAC1 fac1, digits
End Sub
Sub fpsub_aux (fac1 As decfloat, fac2 As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As Long v, c, i
Dim As Long lx, ly
Dim As _Offset xo, yo, lxo, lyo
xo = _Offset(fac1.mantissa)
yo = _Offset(fac2.mantissa)
lxo = _Offset(lx)
lyo = _Offset(ly)
c = 0
For i = digits To 1 Step -1
memcpy lxo, xo + 4 * i, 4
memcpy lyo, yo + 4 * i, 4
v = lx - ly - c
If v < 0 Then
v = v + 100000000
c = 1
Else
c = 0
End If
lx = v
memcpy xo + 4 * i, lxo, 4
Next
memcpy lxo, xo, 4
memcpy lyo, yo, 4
lx = lx - ly - c
memcpy xo, lxo, 4
NORM_FAC1 fac1, digits
End Sub
Sub fpadd (result As decfloat, x As decfloat, y As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat fac1, fac2
Dim As Long i, t, c, xsign, ysign
xsign = x.sign: x.sign = 0
ysign = y.sign: y.sign = 0
c = fpcmp(x, y, digits)
x.sign = xsign
y.sign = ysign
If c < 0 Then
fac1 = y
fac2 = x
Else
fac1 = x
fac2 = y
End If
t = fac1.exponent - fac2.exponent
t = ((fac1.exponent And &H7FFFFFFF) - BIAS - 1) - ((fac2.exponent And &H7FFFFFFF) - BIAS - 1)
If t < (NUM_DIGITS + 8) Then
'The difference between the two
'exponents indicate how many times
'we have to multiply the mantissa
'of FAC2 by 10 (i.e., shift it right 1 place).
'If we have to shift more times than
'we have digits, the result is already in FAC1.
t = fac1.exponent - fac2.exponent
If t > 0 And t < (NUM_DIGITS + 8) Then 'shift
i = t \ 8
While i > 0
RSHIFT_8 fac2, digits
t = t - 8
i = i - 1
Wend
If t = 7 Then
RSHIFT_7 fac2, digits
ElseIf t = 6 Then
RSHIFT_6 fac2, digits
ElseIf t = 5 Then
RSHIFT_5 fac2, digits
ElseIf t = 4 Then
RSHIFT_4 fac2, digits
ElseIf t = 3 Then
RSHIFT_3 fac2, digits
ElseIf t = 2 Then
RSHIFT_2 fac2, digits
ElseIf t = 1 Then
RSHIFT_1 fac2, digits
End If
End If
'See if the signs of the two numbers
'are the same. If so, add; if not, subtract.
If fac1.sign = fac2.sign Then 'add
fpadd_aux fac1, fac2, digits
Else
fpsub_aux fac1, fac2, digits
End If
End If
result = fac1
End Sub
Sub fpsub (result As decfloat, x As decfloat, y As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat fac1, fac2
fac1 = x
fac2 = y
fac2.sign = fac2.sign Xor &H8000
fpadd fac1, fac1, fac2, digits
result = fac1
End Sub
Sub fpmul (result As decfloat, x As decfloat, y As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat fac1, fac2
Dim As Long i, j, ex, er, den, num
Dim As _Integer64 digit, carry
Dim As _Unsigned _Integer64 fac3(0 To digits)
Dim As Long lx, ly
Dim As _Offset xo, yo, lxo, lyo
xo = _Offset(fac1.mantissa)
yo = _Offset(fac2.mantissa)
lxo = _Offset(lx)
lyo = _Offset(ly)
fac1 = x
fac2 = y
'check exponents. if either is zero,
'the result is zero
lx = 0
If fac1.exponent = 0 Or fac2.exponent = 0 Then 'result is zero...clear fac1.
fac1.sign = 0
fac1.exponent = 0
For i = 0 To digits
memcpy xo + 4 * i, lxo, 4
Next
'NORM_FAC1(fac1)
result = fac1: Exit Sub
Else
If ex < 0 Then
er = EXPO_ERR
result = fac1: Exit Sub
End If
'clear fac3 mantissa
For i = 0 To digits
fac3(i) = 0
Next
den = digits
memcpy lyo, yo + 4 * den, 4
While ly = 0
den = den - 1
memcpy lyo, yo + 4 * den, 4
Wend
num = digits
memcpy lxo, xo + 4 * num, 4
While lx = 0
num = num - 1
memcpy lxo, xo + 4 * num, 4
Wend
If num < den Then
Swap fac1, fac2
'fac1=y
'fac2=x
Swap den, num
End If
For j = den To 0 Step -1
carry = 0
memcpy lyo, yo + 4 * j, 4
digit = ly
For i = num To 0 Step -1
memcpy lxo, xo + 4 * i, 4
fac3(i) = fac3(i) + digit * lx
Next
For i = num To 0 Step -1
fac3(i) = fac3(i) + carry
carry = fac3(i) \ 100000000
fac3(i) = (fac3(i) Mod 100000000)
Next
For i = digits To 1 Step -1
fac3(i) = fac3(i - 1)
Next
fac3(0) = carry
Next
For i = 0 To digits
lx = fac3(i)
memcpy xo + 4 * i, lxo, 4
Next
End If
'now determine exponent of result.
'as you do...watch for overflow.
ex = fac2.exponent - BIAS + fac1.exponent
fac1.exponent = ex
'determine the sign of the product
fac1.sign = fac1.sign Xor fac2.sign
NORM_FAC1 fac1, digits
result = fac1
End Sub
Sub fpmul_si (result As decfloat, x As decfloat, y As _Integer64, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat fac1, fac2
Dim As Long count, ex, er, i, lx, ly
Dim As _Integer64 carry, digit, prod, value
Dim As _Offset xo, yo, lxo, lyo
xo = _Offset(fac1.mantissa)
yo = _Offset(fac2.mantissa)
lxo = _Offset(lx)
lyo = _Offset(ly)
fac1 = x
digit = Abs(y)
If digit > 99999999 Then
si2fp fac2, y, digits
fpmul fac1, fac1, fac2, digits
result = fac1: Exit Sub
End If
'check exponents. if either is zero,
'the result is zero
If fac1.exponent = 0 Or y = 0 Then 'result is zero...clear fac1.
fac1.sign = 0
fac1.exponent = 0
lx = 0
For count = 0 To digits
memcpy xo + 4 * count, lxo, 4
Next
NORM_FAC1 fac1, digits
result = fac1: Exit Sub
Else
If digit = 1 Then
If y < 0 Then
fac1.sign = fac1.sign Xor &H8000
End If
result = fac1: Exit Sub
End If
'now determine exponent of result.
'as you do...watch for overflow.
If ex < 0 Then
er = EXPO_ERR
result = fac1: Exit Sub
End If
carry = 0
For i = digits To 0 Step -1
memcpy lxo, xo + 4 * i, 4
prod = digit * lx + carry
value = (prod Mod 100000000)
lx = value
memcpy xo + 4 * i, lxo, 4
carry = prod \ 100000000
Next
If carry < 10 Then
RSHIFT_1 fac1, digits
fac1.exponent = fac1.exponent + 1
memcpy lxo, xo, 4
lx = lx + carry * 10000000
memcpy xo, lxo, 4
ElseIf carry < 100 Then
RSHIFT_2 fac1, digits
fac1.exponent = fac1.exponent + 2
memcpy lxo, xo, 4
lx = lx + carry * 1000000
memcpy xo, lxo, 4
ElseIf carry < 1000 Then
RSHIFT_3 fac1, digits
fac1.exponent = fac1.exponent + 3
memcpy lxo, xo, 4
lx = lx + carry * 100000
memcpy xo, lxo, 4
ElseIf carry < 10000 Then
RSHIFT_4 fac1, digits
fac1.exponent = fac1.exponent + 4
memcpy lxo, xo, 4
lx = lx + carry * 10000
memcpy xo, lxo, 4
ElseIf carry < 100000 Then
RSHIFT_5 fac1, digits
fac1.exponent = fac1.exponent + 5
memcpy lxo, xo, 4
lx = lx + carry * 1000
memcpy xo, lxo, 4
ElseIf carry < 1000000 Then
RSHIFT_6 fac1, digits
fac1.exponent = fac1.exponent + 6
memcpy lxo, xo, 4
lx = lx + carry * 100
memcpy xo, lxo, 4
ElseIf carry < 10000000 Then
RSHIFT_7 fac1, digits
fac1.exponent = fac1.exponent + 7
memcpy lxo, xo, 4
lx = lx + carry * 10
memcpy xo, lxo, 4
ElseIf carry < 100000000 Then
RSHIFT_8 fac1, digits
fac1.exponent = fac1.exponent + 8
memcpy lxo, xo, 4
lx = lx + carry
memcpy xo, lxo, 4
End If
End If
NORM_FAC1 fac1, digits
If y < 0 Then
fac1.sign = fac1.sign Xor &H8000
End If
result = fac1
End Sub
Function min& (a As Long, b As Long)
If a < b Then min& = a Else min& = b
End Function
Function RealW# (w() As Double, j As Long)
Dim wx As Double
wx = ((w(j - 1) * 10000 + w(j)) * 10000 + w(j + 1)) * 10000
If UBound(w) >= (j + 2) Then wx = wx + w(j + 2)
RealW# = wx
End Function
Sub subtract (w() As Double, q As Long, d() As Double, ka As Long, kb As Long)
Dim As Long j
For j = ka To kb
w(j) = w(j) - q * d(j - ka + 2)
Next
End Sub
Sub normalize (w() As Double, ka As Long, q As Long)
w(ka) = w(ka) + w(ka - 1) * 10000
w(ka - 1) = q
End Sub
Sub finalnorm (w() As Double, kb As Long)
Dim As Long carry, j
For j = kb To 3 Step -1
If w(j) < 0 Then
carry = ((-w(j) - 1) \ 10000) + 1
Else
If w(j) >= 10000 Then
carry = -(w(j) \ 10000)
Else
carry = 0
End If
End If
w(j) = w(j) + carry * 10000
w(j - 1) = w(j - 1) - carry
Next
End Sub
Sub fpdiv (result As decfloat, x As decfloat, y As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat fac1, fac2
Dim As Long i, er, is_power_of_ten
Dim As Long lx, ly
Dim As _Offset xo, yo, lxo, lyo
xo = _Offset(fac1.mantissa)
yo = _Offset(fac2.mantissa)
lxo = _Offset(lx)
lyo = _Offset(ly)
fac1 = x
fac2 = y
lx = 99999999
If fac2.exponent = 0 Then ' if fac2 = 0, return
' a divide-by-zero error and
' bail out.
For i = 0 To digits
memcpy xo + 4 * i, lxo, 4
Next
fac1.exponent = 99999 + BIAS + 1
er = DIVZ_ERR
result = fac1
Exit Sub
ElseIf fac1.exponent = 0 Then 'fact1=0, just return
er = 0
result = fac1
Exit Sub
Else
'check to see if fac2 is a power of ten
is_power_of_ten = 0
memcpy lyo, yo, 4
If ly = 10000000 Then
is_power_of_ten = 1
For i = 1 To digits
memcpy lyo, yo + 4 * i, 4
If ly <> 0 Then
is_power_of_ten = 0
Exit For
End If
Next
End If
'if fac2 is a power of ten then all we need to do is to adjust the sign and exponent and we are finished
If is_power_of_ten = 1 Then
fac1.sign = fac1.sign Xor fac2.sign
fac1.exponent = fac1.exponent - fac2.exponent + BIAS + 1
result = fac1
Exit Sub
End If
Dim As Double result(1 To 2 * digits + 3), n(1 To 2 * digits + 3), d(1 To 2 * digits + 3)
Const b = 10000
Dim As Long j, last, laststep, q, t
Dim As Long stp
Dim As Double xd, xn, rund
Dim As Double w(1 To UBound(n) + 4)
For j = 0 To digits
memcpy lxo, xo + 4 * j, 4
n(2 * j + 2) = lx \ 10000
n(2 * j + 3) = lx Mod 10000
memcpy lyo, yo + 4 * j, 4
d(2 * j + 2) = ly \ 10000
d(2 * j + 3) = ly Mod 10000
Next
n(1) = (fac1.exponent And &H7FFFFFFF) - BIAS - 1
d(1) = (fac2.exponent And &H7FFFFFFF) - BIAS - 1
For j = UBound(n) To UBound(w)
w(j) = 0
Next
t = UBound(n) - 1
w(1) = n(1) - d(1) + 1
w(2) = 0
For j = 2 To UBound(n)
w(j + 1) = n(j)
Next
xd = (d(2) * b + d(3)) * b + d(4) + d(5) / b
laststep = t + 2
For stp = 1 To laststep
xn = RealW(w(), (stp + 2))
q = Int(xn / xd)
last = min(stp + t + 1, UBound(w))
subtract w(), q, d(), (stp + 2), last
normalize w(), (stp + 2), q
Next
finalnorm w(), (laststep + 1)
If w(2) <> 0 Then laststep = laststep - 1
rund = w(laststep + 1) / b
If rund >= 0.5 Then w(laststep) = w(laststep) + 1
If w(2) = 0 Then
For j = 1 To t + 1
result(j) = w(j + 1)
Next
Else
For j = 1 To t + 1
result(j) = w(j)
Next
End If
If w(2) = 0 Then result(1) = w(1) - 1 Else result(1) = w(1)
For j = 0 To digits
lx = result(2 * j + 2) * 10000 + result(2 * j + 3)
memcpy xo + 4 * j, lxo, 4
Next
NORM_FAC1 fac1, digits
fac1.exponent = (result(1) + BIAS)
End If
fac1.sign = fac1.sign Xor fac2.sign
result = fac1
End Sub
Sub fpdiv_si (result As decfloat, num As decfloat, den As Long, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat fac1
Dim As _Unsigned _Integer64 carry, remder
Dim As _Integer64 i, divisor
Dim As _Integer64 quotient
remder = 0
divisor = Abs(den)
fac1 = num
If divisor = 0 Then
Print "error: divisor = 0"
result = fac1: Exit Sub
End If
If divisor > 99999999 Then
Dim As decfloat fac2
si2fp fac2, divisor, digits
fpdiv result, fac1, fac2, digits
Exit Sub
End If
Dim As Long lx
Dim As _Offset xo, lxo
xo = _Offset(fac1.mantissa)
lxo = _Offset(lx)
For i = 0 To digits
memcpy lxo, xo + 4 * i, 4
quotient = lx + remder * 100000000
remder = quotient Mod divisor
lx = quotient \ divisor
memcpy xo + 4 * i, lxo, 4
Next
quotient = remder * 100000000
quotient = quotient \ divisor
memcpy lxo, xo, 4
carry = lx
If carry = 0 Then
LSHIFT_8 fac1, digits
fac1.exponent = fac1.exponent - 8
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient
memcpy xo + 4 * digits, lxo, 4
ElseIf carry < 10 Then
LSHIFT_7 fac1, digits
fac1.exponent = fac1.exponent - 7
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient \ 10
memcpy xo + 4 * digits, lxo, 4
ElseIf carry < 100 Then
Call LSHIFT_6(fac1, digits)
fac1.exponent = fac1.exponent - 6
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient \ 100
memcpy xo + 4 * digits, lxo, 4
ElseIf carry < 1000 Then
Call LSHIFT_5(fac1, digits)
fac1.exponent = fac1.exponent - 5
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient \ 1000
memcpy xo + 4 * digits, lxo, 4
ElseIf carry < 10000 Then
Call LSHIFT_4(fac1, digits)
fac1.exponent = fac1.exponent - 4
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient \ 10000
memcpy xo + 4 * digits, lxo, 4
ElseIf carry < 100000 Then
Call LSHIFT_3(fac1, digits)
fac1.exponent = fac1.exponent - 3
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient \ 100000
memcpy xo + 4 * digits, lxo, 4
ElseIf carry < 1000000 Then
Call LSHIFT_2(fac1, digits)
fac1.exponent = fac1.exponent - 2
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient \ 1000000
memcpy xo + 4 * digits, lxo, 4
ElseIf carry < 10000000 Then
Call LSHIFT_1(fac1, digits)
fac1.exponent = fac1.exponent - 1
memcpy lxo, xo + 4 * digits, 4
lx = lx + quotient \ 10000000
memcpy xo + 4 * digits, lxo, 4
End If
'NORM_FAC1(fac1)
If den < 0 Then
fac1.sign = fac1.sign Xor &H8000
End If
result = fac1
End Sub
' sqrt(num)
Sub fpsqr (result As decfloat, num As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat r, r2, tmp, n, half
Dim As Long ex, k, l, prec
Dim As String ts, v
Dim As Double x
l = Log((NUM_DIGITS + 8) * 0.0625) * 1.5
'l=estimated number of iterations needed
'first estimate is accurate to about 16 digits
'l is approximatly = to log2((NUM_DIGITS+9)/16)
'NUM_DIGITS+9 because decfloat has an extra 9 guard digits
n = num
si2fp tmp, 0, digits
If fpcmp(n, tmp, digits) = 0 Then
si2fp r, 0, digits
result = r
Exit Sub
End If
si2fp tmp, 1, digits
If fpcmp(n, tmp, digits) = 0 Then
si2fp r, 1, digits
result = r
Exit Sub
End If
si2fp tmp, 0, digits
If fpcmp(n, tmp, digits) < 0 Then
si2fp r, 0, digits
result = r
Exit Sub
End If
Dim As Long lx
Dim As _Offset xo, lxo
xo = _Offset(n.mantissa)
lxo = _Offset(lx)
'=====================================================================
'hack to bypass the limitation of double exponent range
'in case the number is larger than what a double can handle
'for example, if the number is 2e500
'we separate the exponent and mantissa in this case 2
'if the exponent is odd then multiply the mantissa by 10
'take the square root and assign it to decfloat
'divide the exponent in half for square root
'in this case 1.414213562373095e250
If n.exponent > 0 Then
ex = (n.exponent And &H7FFFFFFF) - BIAS - 1
Else
ex = 0
End If
memcpy lxo, xo, 4
ts = _Trim$(Str$(lx))
If Len(ts) < 8 Then
ts = ts + String$(8 - Len(ts), "0")
End If
v = v + Left$(ts, 1) + "." + Mid$(ts, 2)
memcpy lxo, xo + 4, 4
ts = _Trim$(Str$(lx))
If Len(ts) < 8 Then
ts = String$(8 - Len(ts), "0") + ts
End If
v = v + ts
x = Val(v)
If x = 0 Then Print "Div 0": result = r: Exit Sub
If x = 1 And ex = 0 Then
si2fp r, 1, digits
result = r
Exit Sub
End If
If Abs(ex) And 1 Then
x = x * 10
ex = ex - 1
End If
x = Sqr(x) 'approximation
v = _Trim$(Str$(x))
k = InStr(v, ".")
str2fp r, v
r.exponent = ex \ 2 + BIAS + 1
If Len(v) > 1 And k = 0 Then r.exponent = r.exponent + 1
str2fp half, "0.5"
'=====================================================================
'Newton-Raphson method
prec = 3
For k = 1 To l + 1
prec = 2 * prec - 1
fpdiv tmp, n, r, prec
fpadd r2, r, tmp, prec
fpmul r, r2, half, prec
Next
result = r
End Sub
Sub fpinv (result As decfloat, m As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As Double x
Dim As Long k, l, ex
Dim As Long prec
Dim As decfloat r, r2, one, n
Dim As Long lx
Dim As _Offset xo, lxo
xo = _Offset(n.mantissa)
lxo = _Offset(lx)
n = m
l = Log((NUM_DIGITS + 8) * 0.0625) * 1.5
Dim As String v, ts
If n.exponent > 0 Then
ex = (n.exponent And &H7FFFFFFF) - BIAS - 1
Else
ex = 0
End If
If n.sign Then v = "-" Else v = " "
memcpy lxo, xo, 4
ts = Str$(lx)
If Len(ts) < 8 Then
ts = ts + String$(8 - Len(ts), "0")
End If
v = v + Left$(ts, 1) + "." + Mid$(ts, 2)
memcpy lxo, xo + 4, 4
ts = Str$(lx)
If Len(ts) < 8 Then
ts = String$(8 - Len(ts), "0") + ts
End If
v = v + ts
x = Val(v)
If x = 0 Then Print "Div 0": result = r: Exit Sub
If x = 1 And ex = 0 Then
str2fp r, "1"
result = r: Exit Sub
ElseIf x = 1 Then
x = 10
ex = ex - 1
End If
ex = (-1) - ex
x = 1 / x
str2fp r, Str$(x)
r.exponent = ex + BIAS + 1
si2fp one, 1, digits
r2 = r
prec = 3
For k = 1 To l
prec = 2 * prec - 1
fpmul r2, n, r, prec
fpsub r2, one, r2, prec
fpmul r2, r, r2, prec
fpadd r, r, r2, prec
Next
result = r
End Sub
'fractional part of num
Sub fpfrac (result As decfloat, num As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat n
fpfix n, num
fpsub n, num, n, digits
result = n
End Sub
'returns the positive of n
Sub fpabs (result As decfloat, n As decfloat)
Dim As decfloat x
x = n
x.sign = 0
result = x
End Sub
'changes the sign of n, if n is positive then n will be negative & vice versa
Sub fpneg (result As decfloat, n As decfloat)
Dim As decfloat x
x = n
x.sign = x.sign Xor &H8000
result = x
End Sub
'returns the negative of n regardless of the sign of n
Sub fpnegative (result As decfloat, n As decfloat)
Dim As decfloat x
x = n
x.sign = &H8000
result = x
End Sub
Sub fpfmod (quotient As decfloat, f_mod As decfloat, num As decfloat, denom As decfloat, digits As Long)
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat q, fm 'make copy in case the _destination and source are the same
fpdiv fm, num, denom, digits
fpfix q, fm
fpsub fm, fm, q, digits
fpmul fm, fm, denom, digits
quotient = q
f_mod = fm
End Sub
Sub fpeps (result As decfloat, digits As Long)
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat ep
si2fp ep, 1, digits
ep.exponent = (-(NUM_DIGITS) + BIAS + 1)
result = ep
End Sub
Sub fpipow (result As decfloat, x As decfloat, e As _Integer64, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
'take x to an Long power
Dim As decfloat one, y, z
Dim As _Integer64 n, c
c = 0
y = x
n = Abs(e)
si2fp z, 1, digits
one = z
While n > 0
While (n And 1) = 0
n = n \ 2
fpmul y, y, y, digits
c = c + 1
Wend
n = n - 1
fpmul z, y, z, digits
c = c + 1
Wend
If e < 0 Then
fpdiv z, one, z, digits
End If
result = z
End Sub
Sub fpfactorial (result As decfloat, n As Long, digits_in As Long)
Dim As Long digits
digits = digits_in
Dim As Long i
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat f
If n < 0 Then Print "inf": result = f: Exit Sub
If n = 0 Or n = 1 Then
si2fp f, 1, digits
result = f: Exit Sub
End If
si2fp f, 2, digits
If n = 2 Then result = f: Exit Sub
For i = 3 To n
fpmul_si f, f, i, digits
Next
result = f
End Sub
Sub fplogTaylor (result As decfloat, x As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
'taylor series
'====================Log Guard==================
Dim As decfloat g, zero
fpabs g, x
si2fp zero, 0, digits
If fpcmp(g, x, digits) <> 0 Then result = zero: Exit Sub
If fpcmp(x, zero, digits) = 0 Then result = zero: Exit Sub
'=============================================
Dim As Long invflag
Dim As decfloat XX, Term, Accum, x9, tmp, tmp2
Dim As decfloat T, B, one, Q, two
si2fp one, 1, digits
si2fp two, 2, digits
x9 = x
If fpcmp(x, one, digits) < 0 Then
invflag = 1
fpdiv x9, one, x9, digits
End If
fpsub T, x9, one, digits
fpadd B, x9, one, digits
fpdiv Accum, T, B, digits
fpdiv Q, T, B, digits
tmp = Q
fpmul XX, Q, Q, digits
Dim As Long c
c = 1
Do
c = c + 2
tmp2 = tmp
fpmul Q, Q, XX, digits
fpdiv_si Term, Q, c, digits
fpadd Accum, tmp, Term, digits
Swap tmp, Accum
Loop Until fpcmp(tmp, tmp2, digits) = 0
fpmul_si Accum, Accum, 2, digits
If invflag Then
fpneg Accum, Accum
result = Accum: Exit Sub
End If
result = Accum
End Sub
Sub fplog (result As decfloat, x As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
'====================Log Guard==================
Dim As decfloat g, one, zero
Dim As Long factor
si2fp zero, 0, digits
si2fp one, 1, digits
fpabs g, x
If fpcmp(g, x, digits) <> 0 Then result = zero: Exit Sub
If fpcmp(x, zero, digits) = 0 Then result = zero: Exit Sub
If fpcmp(x, one, digits) = 0 Then result = zero: Exit Sub
'=============================================
Dim As decfloat approx, ans, logx
approx = x
factor = 4096
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fpsqr approx, approx, digits
fplogTaylor logx, approx, digits
fpmul_si ans, logx, factor, digits
result = ans
End Sub
Sub fpexp (result As decfloat, x As decfloat, digits_in As Long)
Dim As Long digits
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
'taylor series
Dim As decfloat fac, x9, temp, accum, p, term
Dim As Long i, c
si2fp temp, 0, digits
si2fp fac, 1, digits
If fpcmp(x, temp, digits) = 0 Then result = fac: Exit Sub
c = 1
fpdiv_si x9, x, 8192, digits 'fpdiv_si(x, 67108864) '
p = x9
fpadd accum, fac, x9, digits '1 + x
Do
c = c + 1
temp = accum
fpdiv_si fac, fac, c, digits
fpmul p, p, x9, digits
fpmul term, p, fac, digits
fpadd accum, temp, term, digits
Loop Until fpcmp(accum, temp, digits) = 0
For i = 1 To 13
fpmul accum, accum, accum, digits
Next
result = accum
End Sub
Sub fppow (result As decfloat, lhs As decfloat, rhs As decfloat)
Dim As decfloat lhs2
fplog lhs2, lhs, NUM_DWORDS
fpmul lhs2, lhs2, rhs, NUM_DWORDS
fpexp lhs2, lhs2, NUM_DWORDS
result = lhs2
End Sub
Sub fpnroot (result As decfloat, x As decfloat, p_in As Long, digits_in As Long)
Dim As Long digits, p, psign
digits = digits_in
If digits > NUM_DWORDS Then digits = NUM_DWORDS
Dim As decfloat ry, tmp, tmp2
Dim As Double t, t2
Dim As Long i, ex, l, prec, lx
Dim As _Offset lxo, xo
xo = _Offset(x.mantissa)
lxo = _Offset(lx)
x.sign = 0
psign = Sgn(p_in)
p = Abs(p_in)
l = Log((NUM_DIGITS + 8) * 0.0625) * 1.5 'calculate the number of iterations needed
ex = (x.exponent And &H7FFFFFFF) - BIAS - 1 'extract the exponent
memcpy lxo, xo, 4
t = lx
memcpy lxo, xo + 4, 4
t = t + lx / 100000000
'get 16 digits from x.mantissa
'for example, if x = 3.1415926535897932384626433832795028842 then the above would give
't = 31415926.53589793 because the mantissa doesn't have a decimal point, it's an integer
'each element of the mantissa holds 8 digits
'in this example ex = 0
t = t / 10000000 'now t = 3.141592653589793
t2 = Log(t) / p '+ Log(10) * ex / p 'log(t ^ (1/p)) = log(t)/p + Log(10) * ex / p
'in this example since ex = 0, it becomes: log(t ^ (1/p)) = log(t)/p
t2 = Exp(t2) 't2=t ^ (1/p)
str2fp ry, Str$(t2) 'convert the double t2 to decfloat in ry
t = Log(10) * ex / p
t2 = Exp(t - Fix(t))
str2fp tmp, Str$(t2) 'convert the double t2 to decfloat in tmp
fpmul ry, ry, tmp, prec 'ry = ry * Log(10) * ex / p
str2fp tmp, "2.7182818284590452353602874713527"
fpipow tmp, tmp, Fix(t), 24
fpmul ry, ry, tmp, 24
prec = 3 '3 * 8 = 24 digits, prec here means number of 8 digit elements
fpipow tmp, ry, p - 1, prec 'tmp = ry ^ (p-1)
fpdiv tmp, x, tmp, prec 'tmp = x * tmp
fpmul_si tmp2, ry, p - 1, prec 'tmp2 = ry * (p-1)
fpadd tmp2, tmp2, tmp, prec 'tmp2 = tmp2 + tmp
fpdiv_si ry, tmp2, p, prec 'ry = tmp2 / p
For i = 1 To l + 1
prec = 2 * prec - 1
fpipow tmp, ry, p - 1, prec 'tmp = ry^(p-1)
fpdiv tmp, x, tmp, prec 'tmp = x/tmp
fpmul_si tmp2, ry, p - 1, prec 'tmp2 = ry*(p-1)
fpadd tmp2, tmp2, tmp, prec 'tmp2 = tmp2+tmp
fpdiv_si ry, tmp2, p, prec 'ry = tmp2/p
Next
If psign < 0 Then
si2fp tmp, 1, digits
fpdiv ry, tmp, ry, digits
End If
result = ry
End Sub
Sub fpsin (result As decfloat, x As decfloat, digits_in As _Unsigned Long)
Dim As decfloat XX, Term, Accum, p, temp2, fac, x_2
Dim As decfloat pi2, circ, Ab
Dim As Long precision
precision = digits_in
x_2 = x
pi2 = pi_dec
fpmul_si circ, pi2, 2, precision
fpabs Ab, x
If fpcmp(Ab, circ, precision) > 0 Then
'======== CENTRALIZE ==============
'floor/ceil to centralize
Dim As decfloat tmp, tmp2
If precision > 20 Then
pi2 = pi_dec
End If
fpmul_si pi2, pi2, 2, precision 'got 2*pi
fpdiv tmp, x_2, pi2, precision
tmp2 = tmp
fpfix tmp, tmp 'int part
fpsub tmp, tmp2, tmp, precision 'frac part
fpmul tmp, tmp, pi2, precision
x_2 = tmp
End If
Dim As Long lm, limit2, i
Dim As decfloat factor
lm = precision
limit2 = Int(-0.45344993886092585968 + 0.022333002852398072433 * lm + 5.0461814408333079844E-7 * lm * lm - 4.2338453039804235772E-11 * lm * lm * lm)
si2fp factor, 5, precision
fpipow factor, factor, limit2, precision
fpdiv x_2, x_2, factor, precision 'x_=x_/5^limit2
'==================================
Dim As Long sign(3): sign(3) = 1
Dim As Long c: c = 1
Accum = x_2
si2fp fac, 1, precision
p = x_2
fpmul XX, x_2, x_2, precision
Do
c = c + 2
temp2 = Accum
fpmul_si fac, fac, c * (c - 1), precision
fpmul p, p, XX, precision
fpdiv Term, p, fac, precision
If sign(c And 3) Then
fpsub Accum, temp2, Term, precision
Else
fpadd Accum, temp2, Term, precision
End If
Loop Until fpcmp(Accum, temp2, precision) = 0
'multiply the result by 5^limit2
For i = 1 To limit2
fpmul p, Accum, Accum, precision
fpmul temp2, Accum, p, precision
'*** sin(5*x) = 5 * sin(x) - 20 * sin(x)^3 + 16 * sin(x)^5
fpmul_si Accum, Accum, 5, precision
fpmul_si Term, temp2, 20, precision
fpmul_si XX, temp2, 16, precision
fpmul XX, XX, p, precision
fpsub Accum, Accum, Term, precision
fpadd Accum, Accum, XX, precision
Next i
result = Accum
End Sub
Sub fpcos (result As decfloat, z As decfloat, digits_in As _Unsigned Long)
Dim As decfloat x_2, pi2
Dim As Long precision
precision = digits_in
fpdiv_si pi2, pi_dec, 2, precision
fpsub x_2, pi2, z, precision
fpsin result, x_2, precision
End Sub
Sub fptan (result As decfloat, z As decfloat, digits_in As _Unsigned Long)
Dim As decfloat x_2, s, c
Dim As Long precision
precision = digits_in
x_2 = z
fpsin s, x_2, precision
x_2 = z
fpcos c, x_2, precision
fpdiv result, s, c, precision
End Sub
Sub fpatn (result As decfloat, x As decfloat, digits_in As _Unsigned Long)
Dim As Long precision, z
precision = digits_in
Dim As Long sign(3): sign(3) = 1
Dim As _Unsigned Long c: c = 1
Dim As decfloat XX, Term, Accum, strC, x_2, mt, mt2, p
Dim As decfloat decnum, one, decnum2, factor
decnum2 = x
decnum2.sign = 0
si2fp one, 1, precision
If fpcmp(decnum2, one, precision) = 0 Then
fpdiv_si result, pi_dec, 4, precision
result.sign = x.sign
Exit Sub
End If
decnum2.sign = x.sign
Dim As Long limit2: limit2 = 16
si2fp factor, _ShL(2, limit2 - 1), precision
For z = 1 To limit2
fpmul decnum, decnum2, decnum2, precision
fpadd decnum, decnum, one, precision
fpsqr decnum, decnum, precision
fpadd decnum, decnum, one, precision
fpdiv decnum, decnum2, decnum, precision
decnum2 = decnum
Next z
mt = decnum
x_2 = decnum
p = decnum
fpmul XX, x_2, x_2, precision
Do
c = c + 2
mt2 = mt
si2fp strC, c, precision
fpmul p, p, XX, precision
fpdiv Term, p, strC, precision
If sign(c And 3) Then
fpsub Accum, mt, Term, precision
Else
fpadd Accum, mt, Term, precision
End If
Swap mt, Accum
Loop Until fpcmp(mt, mt2, precision) = 0
fpmul result, factor, mt, precision
End Sub
Sub fpasin (result As decfloat, x As decfloat, digits_in As _Unsigned Long)
Dim As Long precision
precision = digits_in
Dim As Double num
' ARCSIN = ATN(x / SQR(-x * x + 1))
'============= ARCSIN GUARD =========
num = fp2dbl(x)
If num > 1 Then Exit Sub
If num < -1 Then Exit Sub
'========================
Dim As decfloat one, T, B, term1, minusone
si2fp one, 1, precision
si2fp minusone, -1, precision
T = x
fpmul B, x, x, precision 'x*x
'for 1 and -1
If fpcmp(B, one, precision) = 0 Then
Dim As decfloat two, atn1
si2fp two, 2, precision
fpatn atn1, one, precision
If fpcmp(x, minusone, precision) = 0 Then
fpmul two, two, atn1, precision
fpmul result, two, minusone, precision
Exit Sub
Else
fpmul result, two, atn1, precision
Exit Sub
End If
End If
fpsub B, one, B, precision '1-x*x
fpsqr B, B, precision 'sqr(1-x*x)
fpdiv term1, T, B, precision
fpatn result, term1, precision
End Sub
Sub fpacos (result As decfloat, x As decfloat, digits_in As _Unsigned Long)
Dim As Long precision
precision = digits_in
Dim As decfloat one, minusone, two, atn1, tail, T, B, term1, atnterm1 ',_x,temp
Dim As Double num
'ARCCOS = ATN(-x / SQR(-x * x + 1)) + 2 * ATN(1)
'============= ARCCOS GUARD =========
num = fp2dbl(x)
If num > 1 Then Exit Sub
If num < -1 Then Exit Sub
'========================
si2fp one, 1, precision
si2fp minusone, -1, precision
si2fp two, 2, precision
fpatn atn1, one, precision
fpmul tail, two, atn1, precision '2*atn(1)
fpmul T, minusone, x, precision '-x
fpmul B, x, x, precision 'x*x
If fpcmp(B, one, precision) = 0 Then
'for 1 and -1
If fpcmp(x, minusone, precision) = 0 Then
Dim As decfloat four
si2fp four, 4, precision
fpmul result, four, atn1, precision
Exit Sub
Else
si2fp result, 0, precision
Exit Sub
End If
End If
fpsub B, one, B, precision '1-x*x
fpsqr B, B, precision 'sqr(1-x*x)
fpdiv term1, T, B, precision
fpatn atnterm1, term1, precision
fpadd result, atnterm1, tail, precision
End Sub
Sub initialize_fp
Print "initializing constants: please wait"
'pi_brent_salamin pi_dec, NUM_DIGITS
pi_chudnovsky_bs pi_dec, NUM_DIGITS
si2fp tan_half_num(0), 992, NUM_DIGITS
str2fp tan_half_num(1), "161388480"
str2fp tan_half_num(2), "7686610525440"
str2fp tan_half_num(3), "-167256984742848000"
str2fp tan_half_num(4), "2000393537524462080000"
str2fp tan_half_num(5), "-14467646220791919547392000"
str2fp tan_half_num(6), "66677300813465118447390720000"
str2fp tan_half_num(7), "-201117789910786072985458237440000"
str2fp tan_half_num(8), "400342706504764747636935691468800000"
str2fp tan_half_num(9), "-521967288977995909272835160309760000000"
str2fp tan_half_num(10), "435052278687602761865918494187323392000000"
str2fp tan_half_num(11), "-221463964316902607512694240578598338560000000"
str2fp tan_half_num(12), "63663507608965602906315837691661069058048000000"
str2fp tan_half_num(13), "-8994510946805140308046160658488525397688320000000"
str2fp tan_half_num(14), "470550277118574335327341015729793791741132800000000"
str2fp tan_half_num(15), "-3827142253897737927329040261268989506161213440000000"
si2fp tan_half_den(0), 491040, NUM_DIGITS
str2fp tan_half_den(1), "39540177600"
str2fp tan_half_den(2), "-1232419887578880"
str2fp tan_half_den(3), "19569067214913216000"
str2fp tan_half_den(4), "-180435497084706479616000"
str2fp tan_half_den(5), "1036847979156754234229760000"
str2fp tan_half_den(6), "-3857758118493338995884748800000"
str2fp tan_half_den(7), "9452536125806945430316537159680000"
str2fp tan_half_den(8), "-15257505370126034271052104685977600000"
str2fp tan_half_den(9), "15972199042726674823748755905478656000000"
str2fp tan_half_den(10), "-10480804895655884717678945541785518080000000"
str2fp tan_half_den(11), "4060172679143214471066061077274302873600000000"
str2fp tan_half_den(12), "-837419984702547545921539095790310985302016000000"
str2fp tan_half_den(13), "75810877980214754024960496978688999780515840000000"
str2fp tan_half_den(14), "-1913571126948868963664520130634494753080606720000000"
Cls
End Sub
Sub bs (a As _Unsigned _Integer64, b As _Unsigned _Integer64, pab As decfloat, qab As decfloat, tab1 As decfloat, digits As Long)
'computes the terms for binary splitting the chudnovsky infinite series
'a(a) = +/- (13591409 + 545140134*a)
'p(a) = (6*a-5)*(2*a-1)*(6*a-1)
'b(a) = 1
'q(a) = a*a*a*c3_over_24
'returns p(a,b), q(a,b) and t(a,b)
Static As decfloat c545140134
Static As decfloat c13591409
Static As decfloat c640320
Static As decfloat temp, c3_over_24
Dim As _Unsigned _Integer64 m, t
Dim As Long dwords
dwords = digits / 8 + 1
si2fp c545140134, 545140134, dwords
si2fp c13591409, 13591409, dwords
si2fp c640320, 640320, dwords
c3_over_24 = c640320
fpmul temp, c3_over_24, c3_over_24, dwords
fpmul c3_over_24, temp, c3_over_24, dwords
fpdiv_si c3_over_24, c3_over_24, 24, dwords
If b - a = 1 Then
' directly compute p(a,a+1), q(a,a+1) and t(a,a+1)
If a = 0 Then
si2fp pab, 1, dwords
si2fp qab, 1, dwords
Else
t = 6 * a
si2fp pab, t - 1, dwords
fpmul_si pab, pab, a + a - 1, dwords
fpmul_si pab, pab, t - 5, dwords
si2fp temp, a, dwords
fpmul qab, temp, temp, dwords
fpmul qab, qab, temp, dwords
fpmul qab, qab, c3_over_24, dwords
End If
tab1 = c545140134
fpmul_si tab1, tab1, a, dwords
fpadd tab1, tab1, c13591409, dwords
fpmul tab1, tab1, pab, dwords ' a(a) * p(a)
If a And 1 Then
tab1.sign = tab1.sign Xor &H8000 ' = -tab
End If
Else
Dim As decfloat pam, qam, tam, pmb, qmb, tmb
' recursively compute p(a,b), q(a,b) and t(a,b)
' m is the midpoint of a and b
m = (a + b) / 2
' recursively calculate p(a,m), q(a,m) and t(a,m)
bs a, m, pam, qam, tam, digits
' recursively calculate p(m,b), q(m,b) and t(m,b)
bs m, b, pmb, qmb, tmb, digits
' now combine
fpmul pab, pam, pmb, dwords
fpmul qab, qam, qmb, dwords
fpmul temp, qmb, tam, dwords
fpmul tab1, pam, tmb, dwords
fpadd tab1, tab1, temp, dwords
End If
End Sub
Sub pi_chudnovsky_bs (pi1 As decfloat, digits As Long)
'compute pi
'this is done using chudnovsky's series with binary splitting
Dim As decfloat p, q, sqrtc, t ', one_squared
Static As decfloat c640320
Static As decfloat temp, c3_over_24
Dim As _Unsigned _Integer64 n
Dim As Double digits_per_term
Dim As Long dwords
dwords = digits / 8 + 1
si2fp c640320, 640320, dwords
c3_over_24 = c640320
fpmul temp, c3_over_24, c3_over_24, dwords
fpmul c3_over_24, temp, c3_over_24, dwords
fpdiv_si c3_over_24, c3_over_24, 24, dwords
' how many terms to compute
digits_per_term = Log(fp2dbl(c3_over_24) / 6 / 2 / 6) * 0.4342944819032518
n = Int(digits / digits_per_term + 1)
Rem ?"n=";n
' calclate p(0,n) and q(0,n)
bs 0, n, p, q, t, digits
si2fp sqrtc, 10005, dwords
fpsqr sqrtc, sqrtc, dwords
fpmul_si pi1, sqrtc, 426880, dwords
fpmul pi1, pi1, q, dwords
fpdiv pi1, pi1, t, dwords
End Sub
Sub binarysplittingRamanujanPI (a As _Unsigned _Integer64, b As _Unsigned _Integer64, p As decfloat, q As decfloat, r As decfloat)
Dim As decfloat pp, qq, rr, one, three, bb
Dim As _Unsigned _Integer64 n1, n2, n3, md
si2fp one, 1, NUM_DIGITS
si2fp three, 3, NUM_DIGITS
If (b - a) = 1 Then
If b <= 832256 Then
n1 = (2 * b) - 1
n2 = (4 * b) - 3
n3 = (4 * b) - 1
si2fp r, n1, NUM_DIGITS
fpmul_si r, r, n2, NUM_DIGITS
fpmul_si r, r, n3, NUM_DIGITS
Else
si2fp bb, b, NUM_DIGITS
fpmul_si r, bb, 4, NUM_DIGITS
fpsub r, r, three, NUM_DIGITS
fpmul_si p, bb, 4, NUM_DIGITS
fpsub p, p, one, NUM_DIGITS
fpmul r, r, p, NUM_DIGITS
fpmul_si p, bb, 2, NUM_DIGITS
fpsub p, p, one, NUM_DIGITS
fpmul r, r, p, NUM_DIGITS
End If
si2fp p, b, NUM_DIGITS
fpmul_si p, p, 26390, NUM_DIGITS
si2fp one, 1103, NUM_DIGITS
fpadd p, p, one, NUM_DIGITS
fpmul p, p, r, NUM_DIGITS
si2fp q, b, NUM_DIGITS
fpmul one, q, q, NUM_DIGITS
fpmul q, q, one, NUM_DIGITS
si2fp one, 3073907232, NUM_DIGITS
fpmul q, q, one, NUM_DIGITS
Exit Sub
End If
md = (a + b) / 2
binarysplittingRamanujanPI a, md, p, q, r
binarysplittingRamanujanPI md, b, pp, qq, rr
fpmul pp, pp, r, NUM_DIGITS
fpmul p, p, qq, NUM_DIGITS
fpadd p, p, pp, NUM_DIGITS
fpmul q, q, qq, NUM_DIGITS
fpmul r, r, rr, NUM_DIGITS
End Sub
Sub Pi_Ramanujan (pi1 As decfloat, digits As Long)
Dim As Long prec
prec = digits
If prec > NUM_DIGITS Then prec = NUM_DIGITS
Dim As _Unsigned _Integer64 k
Dim As decfloat p, q, r
k = -Int(-(prec * Log(10) / Log(96059301)))
binarysplittingRamanujanPI 0, k, p, q, r
si2fp r, 8, prec
fpsqr r, r, prec
fpmul_si pi1, q, 1103, prec
fpadd pi1, pi1, p, prec
fpmul pi1, pi1, r, prec
fpmul_si q, q, 9801, prec
fpdiv pi1, q, pi1, prec
End Sub
Sub pi_brent_salamin (pi_bs As decfloat, digits_in As _Unsigned Long)
Dim As _Unsigned Long digits
digits = digits_in
If digits > NUM_DIGITS Then digits = NUM_DIGITS
Dim As Long limit2
Dim As decfloat c0, c1, c2, c05
Dim As decfloat a, b, sum
Dim As decfloat ak, bk, ck
Dim As decfloat ab, asq
Dim As decfloat pow2, tmp
limit2 = -digits + BIAS + 1
si2fp c0, 0, NUM_DIGITS: ak = c0: bk = c0: ab = c0: asq = c0
si2fp c1, 1, NUM_DIGITS: a = c1: ck = c1: pow2 = c1
si2fp c2, 2, NUM_DIGITS: b = c2
str2fp c05, ".5": sum = c05
si2fp pi_bs, 3, NUM_DIGITS
fpsqr b, b, NUM_DIGITS
fpdiv b, c1, b, NUM_DIGITS
While fpcmp(ck, c0, NUM_DIGITS) <> 0 And ck.exponent > limit2
fpadd ak, a, b, NUM_DIGITS
fpmul ak, c05, ak, NUM_DIGITS
fpmul ab, a, b, NUM_DIGITS
fpsqr bk, ab, NUM_DIGITS
fpmul asq, ak, ak, NUM_DIGITS
fpsub ck, asq, ab, NUM_DIGITS
fpmul pow2, pow2, c2, NUM_DIGITS
fpmul tmp, pow2, ck, NUM_DIGITS
fpsub sum, sum, tmp, NUM_DIGITS
a = ak: b = bk
Wend
fpdiv tmp, asq, sum, NUM_DIGITS
fpmul pi_bs, c2, tmp, NUM_DIGITS
End Sub
|
|
|
|
| Cool Line Input feature |
|
Posted by: bert22306 - 09-13-2022, 02:18 AM - Forum: General Discussion
- Replies (2)
|
|
Well, okay, this might also be one of those situations where I'm the only guy who didn't get the memo.
If we create a text file with multiple lines, each line ending with a <return>, and we use Line Input to read each line as one long string, the Line Input command only reads the top line in the file.
Okay, I thought, I can deal with that. I can always copy-paste the other lines to the top, to input each line.
No need!
All you have to do is go back to that Line Input statement, and it will automatically read the next line down, in the text file. How cool is that?
Code: (Select All) Dim Shared a$
Open "..\Textfile_with_many_lines_each_ending_with_carriage_return.ini" For Input As #1
1 Line Input #1, a$
Call sub_to_do_whatever
Print
Input "More sentences (y/n)"; cont$
If cont$ = "y" Then
Print
GoTo 1
End If
Close
End
Sub sub_to_do_whatever
Print a$
End Sub
I add one line at the bottom of the text file, which says "stop," to end the process. For this demo program, the subroutine only prints the line input from the text file.
|
|
|
|
|
