| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| mem arrays |
|
Posted by: James D Jarvis - 08-23-2022, 04:45 AM - Forum: Works in Progress
- Replies (6)
|
 |
Other folks using mem and posting about it got me reading the documentation on the _mem commands and I realized it
was a possible solution to a limitation in QB.
I've always wanted to use arrays inside a programmer defined record type. The functions and subs here are an attempt to do so. Currently only supports one dimensional arrays of 2 byte integers.
Code: (Select All) 'mem array functions and subs
Type rectype
array As _MEM 'this could of course be just one of many entries inside a larger record but this demo code is cleaner with the array alone here
End Type
Dim rec As rectype
Dim r2 As rectype
rec.array = _MemNew(20) 'make a 20 byte mem block to hold an intger array with 10 elements
r2.array = _MemNew(20)
Print "I've always wanted to uses arrays inside record types but that isn't a standard option"
Print "the functions and subs this program uses are made to handle arrays inside such records"
'I chose to do this without creating seperate reference arrays to establish the arrays as all the routines...
' required to access the arrays don't have to ever look at a seperately defined array
Print
Print "Made 2 integer arays"
Print "Offset", "Size"
Print rec.array.OFFSET, rec.array.SIZE, "Rec"
Print r2.array.OFFSET, r2.array.SIZE, "R2"
Print
'build 2 integer arrays
For x = 1 To 10
xx% = Int(x * 2)
x2% = Int(x)
miput_array xx%, rec.array, x
miput_array x2%, r2.array, x
Next x
Print "Here are their values"
'manually read the arrays rec.array and r2.array and print the values
For x = 1 To 10
n = Int(miget(rec.array, x))
m = Int(miget(r2.array, x))
Print n, m
Next
Input "press enter to continue", kk$
'directly setting the first elelemnt in array in r2 to the vale 123
Print "Changed the 1st vlaue of the array r2"
xx% = 123
_MemPut r2.array, r2.array.OFFSET, xx%
'trying out iget function
Print iget(r2, 1)
'trying out miget function
Print miget(r2.array, 1)
Print
print_iarray r2.array, 1, 10
Input "press enter to continue", kk$
Print
Print "Appending the array at r2 to have 2 more elements"
mem_iappend r2.array, 2
s = iarray_len(r2.array)
For x = 1 To s
Print miget(r2.array, x);
Next x
Print "array length "; iarray_len(r2.array)
Print "let's fill elements 11 and 12..."
x2% = 11
miput_array x2%, r2.array, 11
x2% = 12
miput_array x2%, r2.array, 12
print_iarray r2.array, 1, s
Print: Print
Print "taking these values"
print_iarray rec.array, 1, 6
Print "and replacing elements 4 to 9 in the last array."
quick_iacopy rec.array, r2.array, 1, 6, 4
print_iarray r2.array, 1, 12
'cleaning up
_MemFree rec.array
_MemFree r2.array
'================================================================================================
'functions and subs to handle arrays inside a memory block
'
'currently only supports 2 byte intgers
'================================================================================================
Sub quick_iacopy (ra As _MEM, rb As _MEM, a1 As Integer, a2 As Integer, b As Integer)
'take elements a1 to a2 form integer arrai ra and repalce in integer array rb starting at element b
_MemCopy ra, ra.OFFSET + (a1 - 1) * 2, (a2 + 1 - a1) * 2 To rb, rb.OFFSET + (b - 1) * 2
End Sub
Sub print_iarray (r As _MEM, x1, x2)
'print elements x1 to x2 in an integer array
If x1 < x2 Then 'print order is lower element # to higher element #
For n = x1 To x2
x = _MemGet(r, r.OFFSET + (n - 1) * 2, Integer)
Print x;
Next
Print
End If
If x1 > x2 Then 'print order is higher elelemnt # to lower element #
For n = x1 To x2 Step -1
x = _MemGet(r, r.OFFSET + (n - 1) * 2, Integer)
Print x;
Next
Print
End If
End Sub
Sub miput_array (n As Integer, r As _MEM, e)
'this puts a 2 byte integer into the array r at element e
If e > 0 And e <= r.SIZE / 2 Then 'if element is outside array size program will not check incorrect offset but will still return a 0
_MemPut r, r.OFFSET + ((e - 1) * 2), n
End If
End Sub
Function iget (r As rectype, e)
'get elelent e out of the array in the record ... probably retirng this function as it isn't as robust as miget
iget = _MemGet(r.array, r.array.OFFSET + (e - 1) * 2, Integer)
End Function
Function miget (r As _MEM, e)
'mem integer get, grab element out of the array at r
miget = _MemGet(r, r.OFFSET + (e - 1) * 2, Integer)
End Function
Sub mem_iappend (r As _MEM, n)
'add n elements to an integer array
SA$ = Str$(r.SIZE)
s = Val(_Trim$(SA$))
Dim temp As _MEM
temp = _MemNew(s)
_MemCopy r, r.OFFSET, r.SIZE To temp, temp.OFFSET
_MemFree r 'now ths is strange, if you don't do this the address of the offset will change after the next command, not a big deal but a curisotiy
r = _MemNew(s + n * 2)
_MemCopy temp, temp.OFFSET, temp.SIZE To r, r.OFFSET
_MemFree temp
End Sub
Function iarray_len (r As _MEM)
ll% = Int(Val(_Trim$(Str$(r.SIZE))) / 2)
iarray_len = ll%
End Function
|
|
|
| Questions about _MEMs and UDT's |
|
Posted by: justsomeguy - 08-22-2022, 09:04 PM - Forum: General Discussion
- Replies (1)
|
|
Is it possible to pass _MEM handles to Functions/Subs without having to make it global?
Is there a way to normalize the behavior of strings in UDT's? Uninitialized strings in UDT's are filled with CHR$(0), and initialized strings are padded with spaces at the end. Trying to determine the actual string length is difficult, because I can't tell if the spaces are intentional or not.
Are variable length strings in UDT allowed? I though that they weren't. But it seems if you use the right syntax they are allowed, but I found that I can get some strange behaviors if I use them. (Not demonstrated in code.)
I've demonstrated my questions in the following code.
Code: (Select All) TYPE tTEST
st AS STRING * 12
END TYPE
TYPE tTESTBUG
AS STRING st
END TYPE
DIM AS tTEST test
DIM AS tTESTBUG testbug
PRINT "Uninitialized String."
prntSTR test
PRINT "Initialized String."
test.st = "Hello"
prntSTR test
PRINT "Variable length String in UDT? "
PRINT "Uninitiated String."
prntSTRBug testbug
PRINT "Initialized String."
testbug.st = "Hello"
prntSTRBug testbug
SUB prntSTR (test AS tTEST)
DIM i AS LONG
FOR i = 1 TO LEN(test.st)
PRINT ASC(MID$(test.st, i, 1)); " ";
NEXT
PRINT
END SUB
SUB prntSTRBug (test AS tTESTBUG)
DIM i AS LONG
FOR i = 1 TO LEN(test.st)
PRINT ASC(MID$(test.st, i, 1)); " ";
NEXT
PRINT
END SUB
|
|
|
|
| Processing huge files |
|
Posted by: mdijkens - 08-22-2022, 05:08 PM - Forum: Utilities
- Replies (3)
|
|
I saw the discussion in MemFile System about fast fileread
That all works fine up to 2GB files
I sometimes have to process huge (100GB+) csv files.
Therefore I created this reader (2x slower but unlimited size):
Code: (Select All) t! = Timer
recs~&& = processBigFile("20.csv", Chr$(10))
Print "Done"; " in"; (Timer - t!); "seconds"
End
Function processBigFile~&& (ifile$, eol$)
Const BLOCKSIZE = 4 * 1024 * 1024 'on average 4MB blocks seems fastest
Dim block As String * BLOCKSIZE
filenum% = FreeFile
Open ifile$ For Random Access Read As filenum% Len = Len(block)
blocks~& = .5 + LOF(filenum%) / Len(block)
buf$ = "": recs~&& = 0: bufpos~& = 0
$Checking:Off
For blck~& = 1 To blocks~&
Get filenum%, blck~&, block: buf$ = Mid$(buf$, bufpos~&) + block
bufpos~& = 1: endline~& = InStr(bufpos~&, buf$, eol$)
Do While endline~& >= bufpos~&
recs~&& = recs~&& + 1
lin$ = Mid$(buf$, bufpos~&, endline~& - bufpos~&)
processLine lin$
bufpos~& = endline~& + Len(eol$): endline~& = InStr(bufpos~&, buf$, eol$)
Loop
Locate , 1, 0: Print recs~&&;
Next blck~&
Print
$Checking:On
buf$ = "": Close
processBigFile~&& = recs~&&
End Function
Sub processLine (lin$)
' do something with lin$
'f3$ = CSV.field$(lin$, 3)
End Sub
Function CSV.field$ (lin$, n%)
Const MAXFIELDS = 100
Static rec$, fld$(1 To MAXFIELDS)
If rec$ <> lin$ Then
rec$ = lin$
cf% = 0: q% = 0: i0% = 0: ll% = Len(rec$)
For i% = 1 To ll%
cc% = Asc(Mid$(rec$, i%, 1))
If cc% = 13 Or cc% = 10 Then
Exit For
ElseIf cc% = 34 Then '34 = "
q% = 1 - q%
ElseIf cc% = 44 And q% = 0 Then '44 = ,
cf% = cf% + 1: fld$(cf%) = Mid$(rec$, i0%, i% - i0%)
i0% = i% + 1
End If
Next i%
cf% = cf% + 1: fld$(cf%) = Mid$(rec$, i0%, i% - i0%)
End If
CSV.field$ = fld$(n%)
End Function
|
|
|
|
| MemFile System |
|
Posted by: SMcNeill - 08-22-2022, 03:08 PM - Forum: SMcNeill
- Replies (14)
|
 |
Can you open files to the drive and PRINT and LINE INPUT data to them?
If so, then you can now use _MEM, with these little routines which let you work with mem blocks the same way you'd read and write to the disk with PRINT and LINE INPUT!
Code: (Select All) Type Mem_File_Type
inUse As Integer
EOF_Marker As _Offset
Current_Pos As _Offset
Content As _MEM
End Type
Dim Shared MemFile(1 To 100) As Mem_File_Type
'BI HEADER INFO BEFORE THIS
'first, let's showcase how to print and input some information to and from memory
handle = MemFileOpen ' This is a combination FREEFILE + OPEN statement
MemPrint handle, "Hello World", 1 ' PRINT #filehandle, whatever$ + CRLF
MemPrint handle, "My name is Steve", 1 ' PRINT #filehandle, whatever$ + CRLF
For i = 1 To 10
MemPrint handle, Str$(i) + ") Record #" + _Trim$(Str$(i)), 1
Next
MemSeek handle, 0 ' SEEK #filehandle, byte
Do Until MemEOF(handle) ' DO UNTIL EOF(filehandle)
MemLineInput handle, temp$ ' LINE INPUT #filehandle, temp$
Print temp$ ' PRINT temp$
Loop ' LOOP
'I hope the above with the comments help to highlight how exactly similar the two syntaxes are here.
'With these mem routines, we're basically just using mem *exactly* as we'd do basic file access with PRINT and LINE INPUT
'And here I'll showcase how to save and load your memblock to disk -- both in compressed and uncompressed form
MemFileSave handle, "temp.txt", 0 ' 0 says save it in uncompressed format. You can read the data in any old text editor!
MemFileSave handle, "temp_compressed.txt", -1 ' Anything else says to compress the data before saving it. Not readable untl uncompressed.
Print
Print "Mem saved to disk in both compressed and uncompressed form."
Open "temp.txt" For Input As #1: LOF1 = LOF(1): Close
Open "temp_compressed.txt" For Input As #1: LOF2 = LOF(1): Close
Print "unCompressed file is "; LOF1; "bytes in size."
Print "Compressed file is "; LOF2; "bytes in size."
MemFileClose handle ' CLOSE filehandle
_KeyClear
Print "Now to load back the file with the uncompressed data. Press <ANY KEY>"
Sleep
newhandle = MemFileLoad("temp.txt", 0) 'load the uncompressed data file
Do Until MemEOF(newhandle) ' DO UNTIL EOF(filehandle)
MemLineInput newhandle, temp$ ' LINE INPUT #filehandle, temp$
Print temp$ ' PRINT temp$
Loop ' LOOP
MemFileClose newhandle
_KeyClear
Print "Now to load back the file with the compressed data. Press <ANY KEY>"
Sleep
newhandle = MemFileLoad("temp_compressed.txt", -1) 'load the compressed data file
Do Until MemEOF(newhandle) ' DO UNTIL EOF(filehandle)
MemLineInput newhandle, temp$ ' LINE INPUT #filehandle, temp$
Print temp$ ' PRINT temp$
Loop ' LOOP
MemFileClose newhandle
Print
Print "And remember, the difference of the sizes of the files on disk were:"
Print " compressed:"; LOF2
Print "uncompressed:"; LOF1
Print
Print "Press <ANY KEY> to compare speeds in loading an large file into an array in memory."
_KeyClear
Sleep
'And let's showcase a bit more of how this works, why don't we.
Dim As String wordlist(466544), wordlist2(466544), wordlist3(466544) 'arrays to hold the data
'MEM FILE INPUT
handle = MemFileLoad("466544 Word List.txt", 0) 'load a file directly into memory, and it's not compressed
t## = Timer ' timer to see how long we take loading this data
Do Until MemEOF(handle) ' Hopefully these lines will be intuitive enough.
count = count + 1 ' Especially when compared to the notes above
MemLineInput handle, wordlist(count) ' and the preceeding lines after
Loop
Print count; Using " words loaded into memory from file, in ##.#### seconds."; Timer - t##
MemFileClose handle
'OPEN FILE FOR INPUT
Open "466544 Word List.txt" For Input As #1
t## = Timer
Do Until EOF(1)
count2 = count2 + 1
Line Input #1, wordlist2(count2)
Loop
Print count2; Using " words loaded from file OPEN FOR INPUT, in ##.#### seconds."; Timer - t##
Close handle
'OPEN FILE FOR BINARY
Open "466544 Word List.txt" For Binary As #1
t## = Timer
Do Until EOF(1)
count3 = count3 + 1
Line Input #1, wordlist3(count3)
Loop
Print count3; Using " words loaded from file OPEN FOR BINARY, in ##.#### seconds."; Timer - t##
Close handle
'and let's compare contents to be safe
For i = 1 To count
If wordlist(i) <> wordlist2(i) Then Print "Wordlist does not match Wordlist2": failed = -1
If wordlist(i) <> wordlist3(i) Then Print "Wordlist does not match Wordlist3": failed = -1
Next
If failed Then
Print "Lists do not match"
Else
Print "Lists match each other perfectly"
End If
'BM FOOTER AFTER THIS
Sub MemFileDump (memfile, file$, compressed) 'just one quick call to save to disk and free the memory all at once.
MemFileSave memfile, file$, compressed
MemFileClose memfile
End Sub
Sub MemFileSave (memfile, file$, compressed)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Sub 'File Not Found Error message
temphandle = FreeFile
Dim As _Offset length
length = MemFile(memfile).EOF_Marker + 1
temp$ = Space$(length)
$Checking:Off
_MemGet MemFile(memfile).Content, MemFile(memfile).Content.OFFSET, temp$
$Checking:On
If compressed Then temp1$ = _Deflate$(temp$) Else temp1$ = temp$
Open file$ For Output As temphandle: Close temphandle 'erase any existing file with the same name
Open file$ For Binary As temphandle
Put #temphandle, 1, temp1$
Close
End Sub
Function MemFileLoad (file$, compressed)
'Error codes for MemFileLoad
'1: No mem files available. (All 100 are in use! Free some to use more!)
For i = 1 To 100
If MemFile(i).inUse = 0 Then Exit For
Next
If i > 100 Then MemFileLoad = 0: Exit Function 'can't open any more memfiles!
If _FileExists(file$) = 0 Then Error 53: Exit Function 'file not found
MemFileLoad = i
temphandle = FreeFile
Open file$ For Binary As #temphandle
temp$ = Space$(LOF(temphandle))
Get temphandle, 1, temp$
Close temphandle
If compressed Then temp$ = _Inflate$(temp$)
length = Len(temp$)
MemFile(i).Content = _MemNew(length)
$Checking:Off
_MemPut MemFile(i).Content, MemFile(i).Content.OFFSET, temp$
$Checking:On
MemFile(i).inUse = -1 'TRUE
MemFile(i).EOF_Marker = length - 1 'the end of the file is the length of the file to begin with
MemFile(i).Current_Pos = 0 'and we're at the start of our nothing in the file
End Function
Sub MemFileClose (memfile)
If memfile < 1 Or memfile > 100 Then Error 5: Exit Sub 'ILLEGAL FUNCTION CALL
MemFile(memfile).inUse = 0 'no longer in sue
MemFile(memfile).EOF_Marker = 0 'nothing is written in the file to begin with
MemFile(memfile).Current_Pos = 0 'and we're at the start of our nothing in the file
_MemFree MemFile(memfile).Content 'free the memory we were using
End Sub
Function MemFileOpen
'Error codes for MemFileOpen
'1: No mem files available. (All 100 are in use! Free some to use more!)
For i = 1 To 100
If MemFile(i).inUse = 0 Then Exit For
Next
If i > 100 Then MemFileOpen = 0: Exit Function 'can't open any more memfiles!
MemFileOpen = i
MemFile(i).inUse = -1 'TRUE
MemFile(i).EOF_Marker = 0 'nothing is written in the file to begin with
MemFile(i).Current_Pos = 0 'and we're at the start of our nothing in the file
MemFile(i).Content = _MemNew(1000000) '1mb memfile by default
$Checking:Off
_MemFill MemFile(i).Content, MemFile(i).Content.OFFSET, MemFile(i).Content.SIZE, 0 As _UNSIGNED _BYTE
'make certain to blank the file when opening it for the first time so we don't have unwanted characters in it.
$Checking:On
End Function
Function MemEOF (memfile)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Function 'File Not Found Error message
If MemFile(memfile).Current_Pos >= MemFile(memfile).EOF_Marker Then MemEOF = -1
End Function
Sub MemSeek (memfile, position As _Offset)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Sub 'File Not Found Error message
If position < 0 Then Error 5: Exit Sub 'Invalid Function Call
If position > MemFile(memfile).EOF_Marker Then Error 5: Exit Sub 'Invalid Function Call
MemFile(memfile).Current_Pos = position
End Sub
Sub MemLineInput (memfile, what$)
'only valid line endings here are CHR$(10), chr$(13), and chr$(13) + chr$(10)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Sub 'File Not Found Error message
Dim As _Offset CP, EP, Size, L
Dim tempM As _MEM, a1 As _Unsigned _Byte
tempM = MemFile(memfile).Content 'it's just much shorter to type!
CP = MemFile(memfile).Current_Pos
EP = MemFile(memfile).EOF_Marker
If CP >= EP Then Error 62: Exit Sub 'INPUT PAST END OF FILE error
Size = tempM.SIZE
$Checking:Off
Do
a$ = _MemGet(tempM, tempM.OFFSET + CP, String * 1)
Select Case a$
Case Chr$(13)
_MemGet tempM, tempM.OFFSET + CP + 1, a1
If a1 = 10 Then CP = CP + 1 'move the Current Pointer past the 2nd character in a windows CRLF ending
finished = -1
Case Chr$(10)
finished = -1
Case Else
temp$ = temp$ + a$
End Select
CP = CP + 1
If CP >= EP Then finished = -1
Loop Until finished
$Checking:On
MemFile(memfile).Current_Pos = CP
what$ = temp$
End Sub
Sub MemPrint (memfile, what$, EOL_Type As Integer)
'memfile is the memfile handle to print to
'what$ is what we want to print
'EOL_Type is the type of line ending we want after this print statement
'1: This is a CHR$(10) line ending (Linux style line ending)
'2: This is a CHR$(13) line ending (Old Mac style line ending)
'3: This is a CHR$(13) + CHR$(10) line ending (Old Windows style line ending)
'4: This is a COMMA line ending. Use this if writing continous CSV fields.
' (Think PRINT #1, stuff$, <-- see the comma there at the end of the print statement??)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Sub 'File Not Found Error message
Dim CRLF As String
Dim As _Offset CP, EP, Size, L
Select Case EOL_Type
Case 1: CRLF = Chr$(10)
Case 2: CRLF = Chr$(13)
Case 3: CRLF = Chr$(13) + Chr$(10)
Case 4: CRLF = ","
End Select
CP = MemFile(memfile).Current_Pos
EP = MemFile(memfile).EOF_Marker
Size = MemFile(memfile).Content.SIZE
L = Len(what$) + Len(CRLF)
If CP + L > Size Then 'we're writing beyond the bounds of our reserved memory!
Dim tempM As _MEM
recheck:
If Size <= 100000000 Then 'resize our memblock (to the limit) to save our data
tempM = _MemNew(Size * 10)
_MemCopy MemFile(memfile).Content, MemFile(memfile).Content.OFFSET, Size To tempM, tempM.OFFSET
_MemFree MemFile(memfile).Content
MemFile(memfile).Content = tempM
Size = Size * 10
GoTo recheck 'just to make certain that our reserved memory is now large enough to hold our data
Else
Error 61 'DISK FULL ERROR MESSAGE
Exit Sub 'I'm coding a hard size limit of 1GB for each memfile opened!
' Anything larger than that, and I'm tossing a Disk Full Error
End If
End If
_MemPut MemFile(memfile).Content, MemFile(memfile).Content.OFFSET + CP, what$ + CRLF
MemFile(memfile).Current_Pos = CP + L
If CP + L > EP Then MemFile(memfile).EOF_Marker = CP + L
End Sub
Grab the necessary dictionary file from here: https://staging.qb64phoenix.com/attachment.php?aid=760
(I didn't see any reason why the same file needed to be uploaded and attached to multiple posts when it was already here once.  )
|
|
|
|
Cartesian axes automatically scaled and finding Y on a graph, given the X. |
|
Posted by: bartok - 08-22-2022, 12:26 PM - Forum: Utilities
- No Replies
|
 |
![[Image: Immagine.png]](https://i.ibb.co/M18ZfH5/Immagine.png)
Code: (Select All) 'this utility:
'1. given X! and Y! values (the maximum values in abscissa and ordinate of a graph that generally is an output of a
' part of the code that makes calculations), it automatically scales the Cartesian plane so that (0,0) is at 40
' pixels in abscissa and ordinate directions from the bottom left corner and the axes end 40 pixels beyond X! and Y!,
' maintaining 40 pixels from the border;
'2. it draws on the graph the point (X1!,Y!) (where X1! is the X value corresponding to Y! on the graph), it prints
' its values and it draws 2 dashed lines up to the axes;
'3. it asks an X value on which calculate the corresponding Y value;
'4. it draws on the graph the point (X,Y), it prints its values and it draws 2 dashed lines up to the axes.
OPTION BASE 1
CONST R& = _RGB32(255, 0, 0)
CONST G& = _RGB32(0, 255, 0)
CONST B& = _RGB32(0, 0, 255)
CONST white& = _RGB32(255, 255, 255)
CONST yellow& = _RGB32(255, 255, 0)
CONST grey& = _RGB32(127, 127, 127)
CONST azure& = _RGB32(0, 255, 255)
DIM SHARED DESKTOPWIDTH%, DESKTOPHEIGHT%
DIM schermo&, grafico&
DIM X! 'maximum value in abscissa of a graph. generally they are both an output of a part of the code that makes calculations.
DIM Y! 'maximum value in ordinate of a graph. generally they are both an output of a part of the code that makes calculations.
DIM X1! 'X value corresponding to Y! on the graph. generally they are both an output of a part of the code that makes calculations.
DIM L%, H%
DESKTOPWIDTH% = _DESKTOPWIDTH \ 2
DESKTOPHEIGHT% = _DESKTOPHEIGHT \ 2
L% = DESKTOPWIDTH%: H% = L% \ 1.62 'L e H are defined to create a golden rectangle.
schermo& = _NEWIMAGE(DESKTOPWIDTH%, DESKTOPHEIGHT%, 32)
grafico& = _NEWIMAGE(L%, H%, 32)
SCREEN schermo&
'START OF THE EXAMPLE++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
VIEW PRINT 1 TO 2
X! = 44.66777 '----------------------------------------------------------------> it is generally an output of a part of the code.
Y! = 100.434667 '--------------------------------------------------------------> it is generally an output of a part of the code.
X1! = 3 '----------------------------------------------------------------------> it is the X value corresponding to Y! on the graph and it is generally an output of a part of the code.
CALL DisegnaAssi("X", "Y", X!, Y!, grafico&, R&, white&, white&, yellow&) '----> point 1 of the description.
CALL DisegnaValore(X1!, Y!, azure&, azure&, white&) '--------------------------> point 2 of the description.
LINE (dx!, dy!)-(dx! + X1!, dy! + Y!), yellow& '-------------------------------> it can be any kind of graph generated by a part of the code.
LINE -(dx! + X!, dy!), yellow& '-----------------------------------------------> it can be any kind of graph generated by a part of the code.
_PUTIMAGE (0, (DESKTOPHEIGHT% - _HEIGHT(grafico&) - 16)), grafico&, schermo&
CALL DisegnaPortata(X!, grafico&, schermo&) '----------------------------------> points 3 and 4 of the description.
VIEW PRINT
'END OF THE EXAMPLE++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SLEEP
_FREEIMAGE grafico&
SYSTEM
'--------------------------------------------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------
SUB ScalaOrigine (scala~%, origine~%, X!, Y!, immagine&)
'scala~%: if 1, it activates the routine "scala", if 0, it does not activate it;
'origine~%: if 1, it activates the routine "origine", if 0, it does not activate it;
'X!: maximum value on the abscissa. it could be the last value of a vector or the last value of a vector that is greater than a given theshold;
'Y!: maximum value in ordinate.
'So, generally they aren't both directly given as in this example.
'immagine&: is the image on which the point (0,0) is set by the routine "origine".
'this subroutine scales the image via WINDOW in an iterative way, so that the point "1" of the description could be reached.
'generally this SUB is CALLed by the SUB "DisegnaAssi", as we can see in the main code. In that case, both routines "scala" and "origine"
'are executed, as to say whenever a new graph is made.
'However, in some cases, it could be necessary to make further graphs on an image already existing without changing the scale. In this
'case "ScalaOrigine" 'is CALLed alone with parameters (0,1,0,0,immagine&).
'In other cases, in which we already have a graph properly scaled, it could be necessary to add a further graph not in scale compared to
'the first. In that case "ScalaOrigine" is CALLed alone with parameters (1,1,Kx*X!,Ky*Y!, immagine&) where Kx and Ky are appropriate
'coefficient in order to have the wanted result.
SHARED dx%, dy%
SHARED dx!, dy!
DIM fattoreX!, fattoreY!
fattoreX! = 1
fattoreY! = 1
IF scala~% = 0 AND origine~% = 1 THEN GOSUB origine
IF scala~% = 1 AND origine~% = 1 THEN
DO
GOSUB scala
GOSUB origine
IF Y! * fattoreY! >= dy! + Y! + dy! + dy! THEN
IF X! * fattoreX! >= dx! + X! + dx! + dx! THEN
EXIT DO
ELSE
fattoreX! = fattoreX! + 0.01
END IF
ELSE
fattoreY! = fattoreY! + 0.01
END IF
LOOP
END IF
EXIT SUB
'--------------------------------------------------------------------------------------------------------------------------------------------------
scala:
WINDOW 'it closes other WINDOWs already opened with this routine.
WINDOW (0, 0)-(X! * fattoreX!, Y! * fattoreY!)
RETURN
'--------------------------------------------------------------------------------------------------------------------------------------------------
origine:
dx% = 39
dx! = PMAP(dx%, 2)
dy% = _HEIGHT(immagine&) - 1 - dx%
dy! = PMAP(dy%, 3)
RETURN
END SUB
'--------------------------------------------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------
SUB DisegnaAssi (X$, Y$, X!, Y!, immagine&, ColoreCartiglio&, ColoreAssi&, ColoreTacca&, ColoreNumeri&)
SHARED dx%, dy%
SHARED dx!, dy!
DIM x%, y% 'for marks positioning on the axes.
DIM taccaX!, taccaY! 'they define the range with which to draw the marks.
_DEST immagine&: CLS
SELECT CASE X!
CASE IS >= 12
taccaX! = X! \ 6
CASE IS <= 1
taccaX! = 0.25
CASE ELSE
taccaX! = 0.5
END SELECT
SELECT CASE Y!
CASE IS >= 12
taccaY! = Y! \ 6
CASE IS <= 1
taccaY! = 0.25
CASE ELSE
taccaY! = 0.5
END SELECT
WINDOW
LINE (0, 0)-(_WIDTH(immagine&) - 1, _HEIGHT(immagine&) - 1), ColoreCartiglio&, B
CALL ScalaOrigine(1, 1, X!, Y!, immagine&)
LINE (dx!, dy! + Y! + dy!)-(dx!, dy!), ColoreAssi&: LINE -(dx! + X! + dx!, dy!), ColoreAssi& 'it draws the axis.
PSET (dx!, dy! + Y! + dy!), ColoreAssi&: DRAW "F20": PSET (dx!, dy! + Y! + dy!), ColoreAssi&: DRAW "G20" 'it draws the arrow of the ordinate axis.
PSET (dx! + X! + dx!, dy!), ColoreAssi&: DRAW "G20": PSET (dx! + X! + dx!, dy!), ColoreAssi&: DRAW "H20" 'it draws the arrow of the abscissa axis.
COLOR ColoreNumeri&
_PRINTSTRING (PMAP(dx! + X! + dx!, 0), dy%), X$
_PRINTSTRING (dx%, PMAP(dy! + Y! + dy!, 1) - dx% \ 2), Y$
_PRINTSTRING (dx% \ 4, dy% - 7), "0"
i% = 1
WHILE i% * taccaX! <= X! 'it draws and prints the marks and the corresponding values on the abscissa axis.
LINE (dx! + i% * taccaX!, PMAP(dy% + 5, 3))-(dx! + i% * taccaX!, PMAP(dy% - 5, 3)), ColoreTacca& 'it draws the marks in abscissa direction of 11 pixels lenght.
x% = PMAP(dx! + i% * taccaX!, 0)
_PRINTSTRING (x% - 3 * LEN(_TRIM$(STR$(i% * taccaX!))), _HEIGHT(immagine&) - 1 - dx% + 5), _TRIM$(STR$(i% * taccaX!)) 'it prints the value corresponding
'to the mark, considering that the single character is 8 bits large.
i% = i% + 1
WEND
i% = 1
WHILE i% * taccaY! <= Y! 'it draws and prints the marks and the corresponding values on the ordinate axis.
LINE (PMAP(dx% - 5, 2), dy! + i% * taccaY!)-(PMAP(dx% + 5, 2), dy! + i% * taccaY!), ColoreTacca& 'it draws the marks in ordinate direction of 11 pixels lenght.
y% = PMAP(dy! + i% * taccaY!, 1)
_PRINTSTRING (dx% \ 4, y% - 7), _TRIM$(STR$(i% * taccaY!)) 'it spaces the value of the mark of 10 pixels from the border and it centrates it on the mark, considering that the chararacter in 16 pixels hight.
i% = i% + 1
WEND
END SUB
'--------------------------------------------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------
SUB DisegnaValore (X!, Y!, ColoreLinea&, ColorePunto&, ColoreTesto&)
'subroutine which draws on the graph the point (X!,Y!), it prints its values and it draws 2 dashed lines up to the axes.
'In this case:
'X!: it is X value corresponding to Y!
'Y!: it is the maximum.
'Even in this case X! and Y! generally are not given, but they are the result of a part of the code that search them.
SHARED dx%, dy%
SHARED dx!, dy!
DIM x%, y% 'for the positioning on the graph of the point (X!,Y!)
CIRCLE (dx! + X!, dy! + Y!), PMAP(3, 2), ColorePunto&
PAINT (dx! + X! + PMAP(0.5, 2), dy! + Y! + PMAP(0.5, 2)), ColorePunto&
LINE (dx!, dy! + Y!)-(dx! + X!, dy! + Y!), ColoreLinea&, , 65520 '=1111111111110000 where each character is a pixel. 1: the pixel is drawn, 0: the pixel is empty. so we have a dashed line with 12 pixels drawn
'every 4 empty pixels.
LINE -(dx! + X!, dy!), ColoreLinea&, , 65520
x% = PMAP(dx! + X!, 0)
y% = PMAP(dy! + Y!, 1)
COLOR ColoreTesto&
_PRINTSTRING (x% - 4, y% - 16), "(" + _TRIM$(STR$(Arrotonda!(X!))) + ";" + _TRIM$(STR$(Arrotonda!(Y!))) + ")"
END SUB
'--------------------------------------------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------
SUB DisegnaPortata (X!, immagine&, destinazione&)
'subroutine that uses the subroutine "DisegnaValore" in order to draw and print on the graph the point (X,Y) and its value. the dashed lines are animated.
'in order to find the Y value, it asks the X value. Then, starting from the pixel corresponding to Y=0 (y%), it proceeds pixel by pixel decreasing the
'value of y%, until a yellow pixel of the graph is found. While the DO-LOOP cycle goes on searching the yellow pixel, a dashed line is drawn and displayed.
'similarly a dashed line is drawn towards the ordinate axis, while searching a white pixel.
SHARED dx%, dy%
SHARED dx!, dy!
DIM ore!
DIM x%, y% 'for the drawn of the dashed lines in real time.
_DEST schermo&
DO
CLS 2
INPUT "- Type an X value: ", ore!
LOOP WHILE ore! > X! 'it doesn't axcept values greater than the maximum abscissa value of the graph.
IF ore! = 0 THEN EXIT SUB
_DEST immagine&
_SOURCE immagine&
CALL ScalaOrigine(0, 1, 0, 0, immagine&)
x% = PMAP(dx! + ore!, 0)
y% = PMAP(dy!, 1)
DO
y% = y% - 1
IF POINT(dx! + ore!, PMAP(y%, 3)) = azure& THEN 'in this case the user has chosen an X value corresponding to X!, which is already displayed.
_DEST schermo&
EXIT SUB
END IF
IF POINT(dx! + ore!, PMAP(y%, 3)) = yellow& THEN EXIT DO 'the yellow pixel corresponds to the value of searched value.
LINE (dx! + ore!, dy!)-(dx! + ore!, PMAP(y%, 3)), grey&, , 65520 'it draws the dashed line from the abscissa to the yello pixel. The animation is provided by the following _PUTIMAGE.
_PUTIMAGE (0, (DESKTOPHEIGHT% - _HEIGHT(immagine&) - 16)), immagine&, destinazione&
LOOP
portata! = PMAP(y%, 3) - dy!
CALL DisegnaValore(ore!, portata!, 0, 0, white&) 'via subroutine "DisegnaValore", the valune of (X,Y) is displayed.
i% = 2
DO
x% = x% - 1
IF POINT(PMAP(x%, 2), PMAP(y%, 3)) = white& THEN EXIT DO 'the condition in order to exit the LOOP is the identification of a white pixel which belongs to the ordinate axis.
LINE (dx! + ore!, PMAP(y%, 3))-(PMAP(x%, 2), PMAP(y%, 3)), grey&, , 65520 'an animated dashed line is drawn towards the ordinate axis, as before.
_PUTIMAGE (0, (DESKTOPHEIGHT% - _HEIGHT(immagine&) - 16)), immagine&, destinazione&
LOOP
_DEST schermo&
END SUB
'--------------------------------------------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------
FUNCTION Arrotonda! (num!)
Arrotonda! = _ROUND(num! * 100) / 100
END FUNCTION
|
|
|
|
| KISS MY ASCII GOOD PI! |
|
Posted by: Pete - 08-22-2022, 09:43 AM - Forum: General Discussion
- Replies (32)
|
 |
So I updated my pi approximation routine with my faster string math addition/subtraction/multiplication routine and got...
3.14149 and change in about 15-minutes. Now my system is Mem/CPU challenged, so I suspect your systems might be able to turn and burn the 10,000 iterations it took to achieve that in under 5-minutes. Anyway pi by Liebniz's method (1 - (1/3) + (1/5)... = pi /4) appears valid, but to get anything close to accurate would take maybe what, 50,000 iterations? Also, I cheated a bit by not increasing the digit limit to over 1,000 and I used the betatest% variable to direct the routine to cut the final division calculation to 32 digits. I did that because I have not addressed a faster way to do long division by chunks or some other method in my new improved string math routines. If I left that last cheat out, the difference would not be all that great and the calculation time would probably be a few hours and burn up the CPU.
Anyway, if you are impatient, just play around with lowering the loops. It will do 500 very fast.
Code: (Select All) DIM SHARED betatest%: betatest% = -2
WIDTH 160, 43
_SCREENMOVE 0, 0
limit&& = 128
j = -1
FOR i = 1 TO 10000
IF betatest% <> -1 THEN IF i MOD 100 = 0 THEN PRINT "Loop"; i
j = j + 2
IF oldd$ = "" THEN
d$ = "1": oldd$ = "1": oldn$ = "1": n$ = "1"
ELSE
d$ = LTRIM$(STR$(j))
' 2nd denominator * 1st numerator.
a$ = d$: b$ = oldn$: op$ = "*"
CALL string_math(a$, op$, b$, x$, limit&&)
m1$ = x$
' 1st denominator * 2nd numerator.
a$ = oldd$: b$ = n$
CALL string_math(a$, op$, b$, x$, limit&&)
m2$ = x$
' Get common denominator
a$ = d$: b$ = oldd$
CALL string_math(a$, op$, b$, x$, limit&&)
d$ = x$
a$ = m1$: b$ = m2$: IF i / 2 = i \ 2 THEN op$ = "-" ELSE op$ = "+"
CALL string_math(a$, op$, b$, x$, limit&&)
REM PRINT "oldn$ = "; oldn$; " oldd$ = "; oldd$, "n$ = "; x$; " d$ = "; d$
IF betatest% = -1 THEN PRINT "n$ = "; x$; " d$ = "; d$;: COLOR 14, 0: PRINT " "; op$; " 1/"; LTRIM$(STR$(j)): COLOR 7, 0
oldn$ = x$: oldd$ = d$
END IF
NEXT
n$ = x$
a$ = x$: b$ = d$: op$ = "/"
IF betatest% = -1 THEN ' Reduce for speed increase
limit&& = 32
j&& = LEN(b$) - LEN(a$)
a$ = MID$(a$, 1, 32)
b$ = MID$(b$, 1, j&& + 32)
PRINT: PRINT "Numerator = "; a$; " "; "Denominator = "; b$
ELSE
IF betatest% = -2 THEN
limit&& = 32
j&& = LEN(b$) - LEN(a$)
a$ = MID$(a$, 1, 32)
b$ = MID$(b$, 1, j&& + 32)
PRINT: PRINT "Numerator = "; a$; " "; "Denominator = "; b$
ELSE
PRINT "Begin long division...": PRINT
END IF
END IF
CALL string_math(a$, op$, b$, x$, limit&&)
a$ = x$: b$ = "4": op$ = "*"
CALL string_math(a$, op$, b$, x$, limit&&)
PRINT: PRINT "pi = "; x$
END
SUB string_math (stringmatha$, operator$, stringmathb$, runningtotal$, limit&&)
DIM AS _INTEGER64 a, c, aa, cc, s, ss
SELECT CASE operator$
CASE "+", "-"
GOTO string_add_subtract_new
CASE "*"
GOTO string_multiply_new
CASE "/"
GOTO string_divide
CASE ELSE
PRINT "Error, no operator selected. operator$ = "; operator$
END SELECT
string_divide:
terminating_decimal% = 0: divsign% = 0: divremainder& = 0: divremainder$ = "": divplace& = 0: divplace2& = 0: quotient$ = "": divcarry& = 0
operationdivision% = -1
divbuffer& = LEN(stringmathb$) - LEN(stringmatha$)
IF divbuffer& < 0 THEN divbuffer& = 0
d2dividend$ = stringmatha$
d1divisor$ = stringmathb$
IF LEFT$(d1divisor$, 1) = "0" AND LEN(d1divisor$) = 1 THEN PRINT "Division by zero not allowed.": divsign% = 0: operationdivision% = 0: EXIT SUB
IF LEFT$(d1divisor$, 1) = "-" THEN divsign% = -1: d1divisor$ = MID$(d1divisor$, 2)
IF LEFT$(d2dividend$, 1) = "-" THEN
IF divsign% THEN
divsign% = 0
ELSE
divsign% = -1
END IF
d2dividend$ = MID$(d2dividend$, 2)
END IF
IF INSTR(d1divisor$, ".") <> 0 THEN
DO UNTIL RIGHT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 1, LEN(d1divisor$) - 1) ' Strip off trailing zeros
LOOP
divplace& = LEN(d1divisor$) - INSTR(d1divisor$, ".")
d1divisor$ = MID$(d1divisor$, 1, INSTR(d1divisor$, ".") - 1) + MID$(d1divisor$, INSTR(d1divisor$, ".") + 1) ' Strip off decimal point.
DO UNTIL LEFT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 2) ' Strip off leading zeros for divisors smaller than .1
LOOP
END IF
IF INSTR(d2dividend$, ".") <> 0 THEN
d2dividend$ = d2dividend$ + STRING$(divplace& - LEN(d2dividend$) - INSTR(d2dividend$, "."), "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace2& = INSTR(d2dividend$, ".")
DO UNTIL RIGHT$(d2dividend$, 1) <> "0"
d2dividend$ = MID$(d2dividend$, 1, LEN(d2dividend$) - 1) ' Strip off trailing zeros
LOOP
d2dividend$ = MID$(d2dividend$, 1, INSTR(d2dividend$, ".") - 1) + MID$(d2dividend$, INSTR(d2dividend$, ".") + 1) ' Strip off decimal point.
ELSE
d2dividend$ = d2dividend$ + STRING$(divplace&, "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace& = 0
END IF
DO
DO
divremainder& = divremainder& + 1: divremainder$ = divremainder$ + MID$(d2dividend$, divremainder&, 1)
IF MID$(d2dividend$, divremainder&, 1) = "" THEN
IF divremainder$ = STRING$(LEN(divremainder$), "0") AND LEN(quotient$) > LEN(d2dividend$) THEN
divflag% = -1
terminating_decimal% = -1
EXIT DO
END IF
divcarry& = divcarry& + 1
IF divcarry& = 1 THEN divplace3& = divremainder& - 1
IF divcarry& > limit&& + 1 + divbuffer& THEN
divflag% = -2: EXIT DO
END IF
divremainder$ = divremainder$ + "0" ' No more digits to bring down.
END IF
IF LEN(divremainder$) > LEN(d1divisor$) OR LEN(divremainder$) = LEN(d1divisor$) AND divremainder$ >= d1divisor$ THEN EXIT DO
quotient$ = quotient$ + "0"
LOOP
IF divflag% THEN divflag% = 0: EXIT DO
FOR div_i% = 9 TO 1 STEP -1
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply_new: m_product$ = runningtotal$
tempcutd$ = divremainder$ ' divremainder$ can be 00 or other leading zero values.
DO
IF LEN(tempcutd$) = 1 THEN EXIT DO
IF LEFT$(tempcutd$, 1) = "0" THEN
tempcutd$ = MID$(tempcutd$, 2)
ELSE
EXIT DO
END IF
LOOP
IF LEN(tempcutd$) > LEN(m_product$) OR LEN(tempcutd$) = LEN(m_product$) AND m_product$ <= tempcutd$ THEN EXIT FOR
NEXT
quotient$ = quotient$ + LTRIM$(STR$(div_i%))
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply: m_product$ = runningtotal$
operator$ = "-"
stringmatha$ = divremainder$
stringmathb$ = m_product$
GOSUB string_add_subtract_new
stringmatha$ = runningtotal$ '*'
divremainder$ = stringmatha$
operator$ = "/"
LOOP
IF divplace& = 0 AND divplace2& = 0 THEN divplace& = divplace3&
IF divplace2& THEN divplace& = divplace& + divplace2& - 1
IF quotient$ = "" THEN divplace& = 0 ' dividend is zero.
IF divplace& OR divplace2& THEN
quotient$ = MID$(quotient$, 1, divplace&) + "." + MID$(quotient$, divplace& + 1)
DO UNTIL RIGHT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off trailing zeros
LOOP
IF RIGHT$(quotient$, 1) = "." THEN quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off abandoned decimal.
END IF
DO UNTIL LEFT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 2) ' Strip off leading zeros
LOOP
IF quotient$ = "" THEN quotient$ = "0": divsign% = 0
operationdivision% = 0
stringmathb$ = quotient$: quotient$ = ""
IF stringmathb$ = "overflow" THEN divsign% = 0: operationdivision% = 0: EXIT SUB
runningtotal$ = stringmathb$: stringmathb$ = ""
IF divsign% THEN runningtotal$ = "-" + runningtotal$
IF stringmathround$ <> "" THEN runningtotal$ = runningtotal$ + stringmathround$
operationdivision% = 0
EXIT SUB
'------------------------------------------------------------------------
string_multiply:
m_decimal_places& = 0: m_product$ = ""
fac1$ = stringmatha$: fac2$ = stringmathb$ ' Make numbers whole numbers and remove any - sign.
IF LEFT$(fac1$, 1) = "-" THEN fac1$ = MID$(fac1$, 2): m_sign% = -1
IF LEFT$(fac2$, 1) = "-" THEN fac2$ = MID$(fac2$, 2): IF m_sign% THEN m_sign% = 0 ELSE m_sign% = -1
IF INSTR(fac1$, ".") <> 0 THEN m_decimal_places& = LEN(fac1$) - INSTR(fac1$, "."): fac1$ = MID$(fac1$, 1, INSTR(fac1$, ".") - 1) + MID$(fac1$, INSTR(fac1$, ".") + 1)
IF INSTR(fac2$, ".") <> 0 THEN m_decimal_places& = m_decimal_places& + LEN(fac2$) - INSTR(fac2$, "."): fac2$ = MID$(fac2$, 1, INSTR(fac2$, ".") - 1) + MID$(fac2$, INSTR(fac2$, ".") + 1)
FOR m_i& = LEN(fac2$) TO 1 STEP -1 ' Multiply each charater top and bottom.
m_k& = m_l&
m_x2$ = MID$(fac2$, m_i&, 1)
FOR m_j& = LEN(fac1$) TO 1 STEP -1
m_x1$ = MID$(fac1$, m_j&, 1)
IF m_product$ <> "" THEN
m_add$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0")
m_t& = 0: m_xproduct$ = "": m_carry% = 0
DO ' Add multiplied characters together.
m_x3$ = MID$(m_add$, LEN(m_add$) - m_t&, 1)
m_x4$ = MID$(m_product$, LEN(m_product$) - m_t&, 1)
IF m_x3$ = "" AND m_x4$ = "" THEN
IF m_carry% THEN m_xproduct$ = "1" + m_xproduct$
EXIT DO
END IF
m_g% = VAL(m_x3$) + VAL(m_x4$) + m_carry%
IF m_g% >= 10 THEN m_g% = m_g% - 10: m_carry% = 1 ELSE m_carry% = 0
m_xproduct$ = LTRIM$(STR$(m_g%)) + m_xproduct$
m_t& = m_t& + 1
LOOP
m_product$ = m_xproduct$: m_xproduct$ = ""
ELSE
m_product$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0") ' First loop makes variable here.
END IF
m_k& = m_k& + 1 ' Adds trailing zeros multiplication
NEXT
m_l& = m_l& + 1 ' Used to reset value for m_k& adding one trailing zer for each loop.
NEXT
fac1$ = "": fac2$ = "": m_l& = 0: m_k& = 0: m_t& = 0
IF m_decimal_places& > LEN(m_product$) THEN m_product$ = STRING$(m_decimal_places& - LEN(m_product$), "0") + m_product$ ' Add any leading zeros to a decimal. Ex: .02 * .01 is factored as 002. It needs one leading zero before adding the decimal point, .0002.
IF m_decimal_places& AND m_product$ <> "0" THEN ' Replace any decimal point.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - m_decimal_places&) + "." + MID$(m_product$, LEN(m_product$) - m_decimal_places& + 1)
END IF
DO UNTIL LEFT$(m_product$, 1) <> "0" ' Remove leading zeros.
m_product$ = MID$(m_product$, 2)
LOOP
IF m_decimal_places& THEN
DO UNTIL RIGHT$(m_product$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1)
LOOP
END IF
IF m_product$ = "" THEN m_product$ = "0": m_sign% = 0
IF RIGHT$(m_product$, 1) = "." THEN m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1) ' Remove decimal from the end of an integer total.
IF operationdivision% THEN m_sign% = 0: RETURN
stringmathb$ = m_product$: m_product$ = ""
IF stringmathb$ = "overflow" THEN EXIT SUB
runningtotal$ = stringmathb$: stringmathb$ = ""
IF m_sign% THEN runningtotal$ = "-" + runningtotal$: m_sign% = 0
EXIT SUB
string_add_subtract:
IF INSTR(stringmatha$, ".") <> 0 THEN ' Evaluate sum for decimal fraction.
sumplace& = LEN(stringmatha$) - INSTR(stringmatha$, ".")
stringmatha$ = MID$(stringmatha$, 1, INSTR(stringmatha$, ".") - 1) + MID$(stringmatha$, INSTR(stringmatha$, ".") + 1) ' Strip out decimal
END IF
IF INSTR(stringmathb$, ".") <> 0 THEN ' Evaluate number for decimal fraction.
numplace& = LEN(stringmathb$) - INSTR(stringmathb$, ".")
stringmathb$ = MID$(stringmathb$, 1, INSTR(stringmathb$, ".") - 1) + MID$(stringmathb$, INSTR(stringmathb$, ".") + 1) ' Strip out decimal
END IF
IF sumplace& > numplace& THEN addsubplace& = sumplace& ELSE addsubplace& = numplace&
IF sumplace& > addsubplace& THEN
stringmatha$ = stringmatha$ + STRING$(sumplace& - addsubplace&, "0")
ELSEIF addsubplace& > sumplace& THEN
stringmatha$ = stringmatha$ + STRING$(addsubplace& - sumplace&, "0")
END IF
IF numplace& > addsubplace& THEN
stringmathb$ = stringmathb$ + STRING$(numplace& - addsubplace&, "0")
ELSEIF addsubplace& > numplace& THEN
stringmathb$ = stringmathb$ + STRING$(addsubplace& - numplace&, "0")
END IF ' END Decimal evaluations.
IF LEFT$(stringmatha$, 1) = "-" THEN sign_input$ = "-" ELSE sign_input$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN sign_total$ = "-" ELSE sign_total$ = "+"
addsubsign% = 0
SELECT CASE sign_input$ + operator$ + sign_total$
CASE "+++", "+--"
operator$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
CASE "++-", "+-+"
operator$ = "-"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
GOSUB string_comp
IF gl% < 0 THEN SWAP stringmatha$, stringmathb$: addsubsign% = -1
CASE "---", "-++"
operator$ = "-"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
GOSUB string_comp
IF gl% < 0 THEN SWAP stringmatha$, stringmathb$: addsubsign% = -1
CASE "--+", "-+-"
operator$ = "+"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
addsubsign% = -1
END SELECT
IF LEN(stringmatha$) > LEN(stringmathb$) THEN
stringmathb$ = STRING$(LEN(stringmatha$) - LEN(stringmathb$), "0") + stringmathb$
ELSEIF LEN(stringmatha$) < LEN(stringmathb$) THEN
stringmatha$ = STRING$(LEN(stringmathb$) - LEN(stringmatha$), "0") + stringmatha$
END IF
addsubx1$ = ""
SELECT CASE operator$
CASE "+", "="
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) + VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% > 9 THEN addsubx1% = addsubx1% - 10: addsubcarry% = 1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubcarry% THEN addsubx1$ = "1" + addsubx1$: addsubcarry% = 0
GOSUB replace_decimal
CASE "-"
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) - VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% < 0 THEN addsubx1% = addsubx1% + 10: addsubcarry% = -1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubx1$ <> "" AND addsubx1$ <> STRING$(LEN(addsubx1$), "0") THEN GOSUB replace_decimal
DO UNTIL LEFT$(addsubx1$, 1) <> "0" ' Remove leading zeros.
addsubx1$ = MID$(addsubx1$, 2)
LOOP
IF addsubx1$ = "" THEN
addsubx1$ = "0": addsubsign% = 0
ELSE
IF addsubcarry% THEN addsubx1$ = "-" + addsubx1$: addsubcarry% = 0
END IF
END SELECT
IF addsubsign% THEN
IF LEFT$(addsubx1$, 1) = "-" THEN addsubx1$ = MID$(addsubx1$, 2) ELSE addsubx1$ = "-" + addsubx1$
END IF
stringmatha$ = addsubx1$: addsubx1$ = ""
IF operationdivision% THEN RETURN
stringmathb$ = stringmatha$: stringmatha$ = ""
IF LEFT$(stringmathb$, 1) = "-" THEN
stringmathb$ = MID$(stringmathb$, 2)
n2sign$ = "-"
ELSE
n2sign$ = ""
END IF
IF stringmathb$ = "overflow" THEN n2sign$ = "": EXIT SUB
runningtotal$ = n2sign$ + stringmathb$: n2sign$ = ""
EXIT SUB
'------------------------------------------------------------------------
string_add_subtract_new:
a1$ = stringmatha$: b1$ = stringmathb$
s = 18: i&& = 0: c = 0
a$ = stringmatha$: b$ = stringmathb$: op$ = operator$
IF op$ = "-" THEN
IF LEFT$(b$, 1) = "-" THEN b$ = MID$(b$, 2) ELSE b$ = "-" + b$
END IF
IF INSTR(a$, ".") <> 0 OR INSTR(b$, ".") <> 0 THEN
decimal% = -1
IF INSTR(a$, ".") <> 0 THEN
dec_a&& = LEN(MID$(a$, INSTR(a$, ".") + 1))
a$ = MID$(a$, 1, INSTR(a$, ".") - 1) + MID$(a$, INSTR(a$, ".") + 1)
END IF
IF INSTR(b$, ".") <> 0 THEN
dec_b&& = LEN(MID$(b$, INSTR(b$, ".") + 1))
b$ = MID$(b$, 1, INSTR(b$, ".") - 1) + MID$(b$, INSTR(b$, ".") + 1)
END IF
' Line up decimal places by inserting trailing zeros.
IF dec_b&& > dec_a&& THEN
j&& = dec_b&&
a$ = a$ + STRING$(dec_b&& - dec_a&&, "0")
ELSE
j&& = dec_a&&
b$ = b$ + STRING$(dec_a&& - dec_b&&, "0")
END IF
END IF
IF LEFT$(a$, 1) = "-" OR LEFT$(b$, 1) = "-" THEN
IF LEFT$(a$, 1) = "-" AND LEFT$(b$, 1) = "-" THEN
sign$ = "--": a$ = MID$(a$, 2): b$ = MID$(b$, 2)
ELSE
IF LEFT$(a$, 1) = "-" THEN a$ = MID$(a$, 2): sign_a$ = "-"
IF LEFT$(b$, 1) = "-" THEN b$ = MID$(b$, 2): sign_b$ = "-"
IF LEFT$(a1$, 1) = "-" THEN a1_x$ = MID$(a1$, 2) ELSE a1_x$ = a1$
IF LEFT$(b1$, 1) = "-" THEN b1_x$ = MID$(b1$, 2) ELSE b1_x$ = b1$
string_compare a1_x$, b1_x$, gl%
IF gl% < 0 THEN
IF LEN(sign_b$) THEN sign$ = "-": SWAP a$, b$
ELSE
IF LEN(sign_a$) THEN sign$ = "-": SWAP sign_a$, sign_b$
END IF
END IF
END IF
z$ = ""
DO
i&& = i&& + s
x1$ = MID$(a$, LEN(a$) - i&& + 1, s)
x2$ = MID$(b$, LEN(b$) - i&& + 1, s)
a = VAL(sign_a$ + x1$) + VAL(sign_b$ + x2$) + c
IF x1$ + x2$ = "" AND c = 0 THEN EXIT DO
c = 0
IF a > VAL(STRING$(s, "9")) THEN a = a - 10 ^ s: c = 1
IF a < 0 THEN a = a + 10 ^ s: c = -1
tmp$ = LTRIM$(STR$(a))
z$ = STRING$(LEN(x1$) - LEN(tmp$), "0") + tmp$ + z$
LOOP
IF decimal% THEN
z$ = MID$(z$, 1, LEN(z$) - j&&) + "." + MID$(z$, LEN(z$) - j&& + 1)
END IF
' Remove any leading zeros.
DO
IF LEFT$(z$, 1) = "0" THEN z$ = MID$(z$, 2) ELSE EXIT DO
LOOP
IF z$ = "" OR z$ = "0" THEN z$ = "0" ELSE z$ = LEFT$(sign$, 1) + z$
runningtotal$ = z$ '*'
sign$ = "": sign_a$ = "": sign_b$ = "": i&& = 0: j&& = 0: decimal% = 0: c = 0
IF operationdivision% THEN RETURN
EXIT SUB
'------------------------------------------------------------------------
string_multiply_new:
z$ = "": sign$ = "": mult&& = 0: h&& = 0: i&& = 0: j&& = 0: c = 0: decimal% = 0
zz$ = "": ii&& = 0: jj&& = 0
s = 8: ss = 18
a$ = stringmatha$: b$ = stringmathb$
IF INSTR(a$, "-") <> 0 OR INSTR(b$, "-") <> 0 THEN
IF INSTR(a$, "-") <> 0 AND INSTR(b$, "-") <> 0 THEN
a$ = MID$(a$, 2): b$ = MID$(b$, 2)
ELSE
IF INSTR(a$, "-") <> 0 THEN a$ = MID$(a$, 2) ELSE b$ = MID$(b$, 2)
sign$ = "-"
END IF
END IF
IF INSTR(a$, ".") <> 0 OR INSTR(b$, ".") <> 0 THEN
decimal% = -1
IF INSTR(a$, ".") <> 0 THEN
dec_a&& = LEN(MID$(a$, INSTR(a$, ".") + 1))
a$ = MID$(a$, 1, INSTR(a$, ".") - 1) + MID$(a$, INSTR(a$, ".") + 1)
END IF
IF INSTR(b$, ".") <> 0 THEN
dec_b&& = LEN(MID$(b$, INSTR(b$, ".") + 1))
b$ = MID$(b$, 1, INSTR(b$, ".") - 1) + MID$(b$, INSTR(b$, ".") + 1)
END IF
END IF
IF LEN(a$) < LEN(b$) THEN SWAP a$, b$
DO
h&& = h&& + s: i&& = 0
x2$ = MID$(b$, LEN(b$) - h&& + 1, s)
WHILE -1
i&& = i&& + s
x1$ = MID$(a$, LEN(a$) - i&& + 1, s)
a = VAL(sign_a$ + x1$) * VAL(sign_b$ + x2$) + c
c = 0
tmp$ = LTRIM$(STR$(a))
IF LEN(tmp$) > s THEN c = VAL(MID$(tmp$, 1, LEN(tmp$) - s)): tmp$ = MID$(tmp$, LEN(tmp$) - s + 1)
z$ = STRING$(LEN(x1$) - LEN(tmp$), "0") + tmp$ + z$
IF i&& >= LEN(a$) AND c = 0 THEN EXIT WHILE
WEND
jj&& = jj&& + 1
IF jj&& > 1 THEN
ii&& = 0: cc = 0
aa$ = holdaa$
bb$ = z$ + STRING$((jj&& - 1) * s, "0")
DO
ii&& = ii&& + ss
xx1$ = MID$(aa$, LEN(aa$) - ii&& + 1, ss)
xx2$ = MID$(bb$, LEN(bb$) - ii&& + 1, ss)
aa = VAL(xx1$) + VAL(xx2$) + cc
IF xx1$ + xx2$ = "" AND cc = 0 THEN EXIT DO ' Prevents leading zeros.
cc = 0
IF aa > VAL(STRING$(ss, "9")) THEN aa = aa - 10 ^ ss: cc = 1
tmp$ = LTRIM$(STR$(aa))
zz$ = STRING$(LEN(xx1$) - LEN(tmp$), "0") + tmp$ + zz$
LOOP
DO WHILE LEFT$(zz$, 1) = "0"
IF LEFT$(zz$, 1) = "0" THEN zz$ = MID$(zz$, 2)
LOOP
IF zz$ = "" THEN zz$ = "0"
holdaa$ = zz$
ELSE
holdaa$ = z$ + STRING$(jj&& - 1, "0")
END IF
z$ = "": zz$ = ""
LOOP UNTIL h&& >= LEN(b$)
z$ = holdaa$
IF decimal% THEN
DO UNTIL LEN(z$) >= dec_a&& + dec_b&&
z$ = "0" + z$
LOOP
z$ = MID$(z$, 0, LEN(z$) - (dec_a&& + dec_b&& - 1)) + "." + MID$(z$, LEN(z$) - (dec_a&& + dec_b&&) + 1)
DO UNTIL RIGHT$(z$, 1) <> "0" AND RIGHT$(z$, 1) <> "."
z$ = MID$(z$, 1, LEN(z$) - 1)
LOOP
END IF
IF z$ = "" OR z$ = "0" THEN z$ = "0": ELSE z$ = sign$ + z$
decimal% = 0: sign$ = ""
runningtotal$ = z$
IF operationdivision% THEN RETURN
EXIT SUB
replace_decimal:
IF addsubplace& THEN
addsubx1$ = STRING$(addsubplace& - LEN(addsubx1$), "0") + addsubx1$
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - addsubplace&) + "." + MID$(addsubx1$, LEN(addsubx1$) - addsubplace& + 1)
DO UNTIL RIGHT$(addsubx1$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1)
addsubplace& = addsubplace& - 1
LOOP
IF RIGHT$(addsubx1$, 1) = "." THEN addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1) ' Number is now an integer.
END IF
RETURN
string_comp:
DO
' Remove trailing zeros after a decimal point.
IF INSTR(acomp$, ".") THEN
DO UNTIL RIGHT$(acomp$, 1) <> "0" AND RIGHT$(acomp$, 1) <> "." AND RIGHT$(acomp$, 1) <> "-"
acomp$ = MID$(acomp$, 1, LEN(acomp$) - 1)
LOOP
END IF
IF INSTR(bcomp$, ".") THEN
DO UNTIL RIGHT$(bcomp$, 1) <> "0" AND RIGHT$(bcomp$, 1) <> "." AND RIGHT$(bcomp$, 1) <> "-"
bcomp$ = MID$(bcomp$, 1, LEN(bcomp$) - 1)
LOOP
END IF
IF MID$(acomp$, 1, 2) = "-0" OR acomp$ = "" OR acomp$ = "-" THEN acomp$ = "0"
IF MID$(bcomp$, 1, 2) = "-0" OR bcomp$ = "" OR bcomp$ = "-" THEN bcomp$ = "0"
' A - and +
IF LEFT$(acomp$, 1) = "-" THEN j% = -1
IF LEFT$(bcomp$, 1) = "-" THEN k% = -1
IF k% = 0 AND j% THEN gl% = -1: EXIT DO
IF j% = 0 AND k% THEN gl% = 1: EXIT DO
' A decimal and non-decimal.
j% = INSTR(acomp$, ".")
k% = INSTR(bcomp$, ".")
IF j% = 0 AND k% THEN
IF acomp$ = "0" THEN gl% = -1 ELSE gl% = 1
EXIT DO
END IF
IF k% = 0 AND j% THEN
IF bcomp$ = "0" THEN gl% = 1 ELSE gl% = -1
EXIT DO
END IF
' Both decimals.
IF j% THEN
IF acomp$ > bcomp$ THEN
gl% = 1
ELSEIF acomp$ = bcomp$ THEN gl% = 0
ELSEIF acomp$ < bcomp$ THEN gl% = -1
END IF
EXIT DO
END IF
' Both positive or both negative whole numbers.
SELECT CASE LEN(acomp$)
CASE IS < LEN(bcomp$)
gl% = -1
CASE IS = LEN(bcomp$)
IF acomp$ = bcomp$ THEN
gl% = 0
ELSEIF acomp$ > bcomp$ THEN gl% = 1
ELSEIF acomp$ < bcomp$ THEN gl% = -1
END IF
CASE IS > LEN(bcomp$)
gl% = 1
END SELECT
EXIT DO
LOOP
RETURN
END SUB
SUB string_compare (compa$, compb$, gl%)
DO
' Remove trailing zeros after a decimal point.
IF INSTR(compa$, ".") THEN
DO UNTIL RIGHT$(compa$, 1) <> "0" AND RIGHT$(compa$, 1) <> "." AND RIGHT$(compa$, 1) <> "-"
compa$ = MID$(compa$, 1, LEN(compa$) - 1)
LOOP
END IF
IF INSTR(compb$, ".") THEN
DO UNTIL RIGHT$(compb$, 1) <> "0" AND RIGHT$(compb$, 1) <> "." AND RIGHT$(compb$, 1) <> "-"
compb$ = MID$(compb$, 1, LEN(compb$) - 1)
LOOP
END IF
IF MID$(compa$, 1, 2) = "-0" OR compa$ = "" OR compa$ = "-" THEN compa$ = "0"
IF MID$(compb$, 1, 2) = "-0" OR compb$ = "" OR compb$ = "-" THEN compb$ = "0"
' A - and +
IF LEFT$(compa$, 1) = "-" THEN j% = -1
IF LEFT$(compb$, 1) = "-" THEN k% = -1
IF k% = 0 AND j% THEN gl% = -1: PRINT "1*": EXIT DO
IF j% = 0 AND k% THEN gl% = 1: PRINT "2*": EXIT DO
' A decimal and non-decimal.
j% = INSTR(compa$, ".")
k% = INSTR(compb$, ".")
IF j% = 0 AND k% THEN
IF compa$ = "0" THEN gl% = -1: PRINT "4*" ELSE gl% = 1: PRINT "5*"
EXIT DO
END IF
IF k% = 0 AND j% THEN
IF compb$ = "0" THEN gl% = 1: PRINT "6*" ELSE gl% = -1: PRINT "7*"
EXIT DO
END IF
' Both decimals.
IF j% THEN
IF compa$ > compb$ THEN
gl% = 1: PRINT "8*"
ELSEIF compa$ = compb$ THEN gl% = 0: PRINT "9*"
ELSEIF compa$ < compb$ THEN gl% = -1: PRINT "10*"
END IF
EXIT DO
END IF
' Both positive or both negative whole numbers.
SELECT CASE LEN(compa$)
CASE IS < LEN(compb$)
gl% = -1
CASE IS = LEN(compb$)
IF compa$ = compb$ THEN
gl% = 0
ELSEIF compa$ > compb$ THEN gl% = 1
ELSEIF compa$ < compb$ THEN gl% = -1
END IF
CASE IS > LEN(compb$)
gl% = 1
END SELECT
EXIT DO
LOOP
END SUB
Pete
PS Sorry about the title, Steve. (I might have got his hopes up it meant I was de-partying!) 
|
|
|
|
| Rookie Rainfall |
|
Posted by: james2464 - 08-22-2022, 01:11 AM - Forum: Programs
- Replies (7)
|
 |
You can use 'w' and 's' to adjust the display speed
Code: (Select All) 'Rookie Rainfall
'james2464
Dim scx As Integer
Dim scy As Integer
Dim res As Integer
scx = 500
scy = 400
res = 1
Screen _NewImage(scx, scy, 32)
$Resize:Smooth
Dim c0(100) As Long
'cyan
c0(0) = _RGB(0, 0, 0) 'black
c0(2) = _RGB(0, 127, 255) 'cyan
c0(3) = _RGB(0, 45, 90) 'cyan
c0(4) = _RGB(0, 30, 60) 'cyan
c0(5) = _RGB(0, 20, 40) 'cyan
c0(6) = _RGB(0, 10, 20) 'cyan
c0(7) = _RGB(0, 5, 10) 'cyan
Randomize Timer
'starting speed delay value
Dim dv As Long
dv = 20
'screen sized array
Dim a(scx, scy) As Integer
'set to zero
For f = 0 To scx
For s = 0 To scy
a(f, s) = 0
Next s
Next f
'fill screen with colour c0(0) pixels
For s = 0 To scx
For f = 0 To scy
PSet (s, f), c0(a(s, f))
Next
Next
'smaller array size for higher value of "res"
scx2 = scx / res
scy2 = scy / res
Dim dtx(2000) As Integer 'stores droplet position along x axis
Dim dty(2000) As Integer 'stores droplet postion along y axis
Dim dx, ct As Integer 'used in loops when "drying"
Dim dice1 As Long 'used to randomize things
Dim p1~& 'used to interpret pixel colours when "drying"
flag = 0
ct = 0
ctmax = 150 'max number of active droplets
rain = 488 'starting value for rainflow
dry1 = 0
dryrate = 0
'dtx array -1 value makes the position inactive...higher than -1 is active
'initialize by setting to -1
For j = 1 To scx
dtx(j) = -1
Next j
'used to separate pixel colours from _Point to _Red32 _Blue32 etc
Dim a99, b99, c99, d99 As Integer
Do
t = Int(Rnd * 500)
If t > 480 Then 'sometimes allow for changes in the amount of rainfall
flowchange = Int(Rnd * 3) - 1 'randomize the change in amount of rain. Even overall with minor ups and downs
rain = rain + flowchange 'go up or down slightly depending on the previous line
End If
If rain < 470 Then 'if too much rain (lower is more chance of additional rain drops) the bump flow back up next line
rain = rain + 5
End If
'dry if rainfall rate is slow enough - 495 is not much rainfall. Below that it's too wet to expect any drying to happen
If rain > 495 Then
dry1 = dry1 + 1
If dry1 > 35 Then
dry1 = 0
For jx = 0 To scx
p1~& = Point(jx, scy - 1)
a99 = _Red32(p1~&)
b99 = _Green32(p1~&)
c99 = _Blue32(p1~&)
d99 = a99 + b99 + c99
If d99 > 0 Then
If a99 > 0 Then a99 = a99 - 1
If b99 > 0 Then b99 = b99 - 1
If c99 > 0 Then c99 = c99 - 1
c0(40) = _RGB(a99, b99, c99)
Line (jx, scy - 1)-(jx, scy), c0(40), BF
End If
Next jx
End If
End If
'no rain when over 500, bump flow value towards some rainfall
If rain > 510 Then
rain = rain - 7
End If
'generate rain droplets
dice1 = Int(Rnd * 500)
If dice1 > rain Then 'sometimes introduce a new droplet
flag2 = 0
'count up active droplets
ct = 0
For j = 1 To scx2
If dtx(j) > -1 Then
ct = ct + 1
End If
Next j
If ct < ctmax Then 'if not maxxed out, a new droplet is born
dx = Int(Rnd * scx2)
If dtx(dx) = -1 Then 'only in an available position
dtx(dx) = dx * res
dty(dx) = 0
End If
End If
End If
'droplets moving down until splash
For j = 1 To scx2
If dtx(j) > -1 Then
dty(j) = dty(j) + 1
If dty(j) < scy Then
Line (dtx(j), dty(j) - 4 * res)-(dtx(j) + res, dty(j) - 4 * res + res), c0(0), BF
Line (dtx(j), dty(j) - 0)-(dtx(j) + res, dty(j) - 0 + res), c0(7), BF
Line (dtx(j), dty(j) + 10 * res)-(dtx(j) + res, dty(j) + 10 * res + res), c0(6), BF
Line (dtx(j), dty(j) + 16 * res)-(dtx(j) + res, dty(j) + 16 * res + res), c0(5), BF
Line (dtx(j), dty(j) + 22 * res)-(dtx(j) + res, dty(j) + 22 * res + res), c0(4), BF
Line (dtx(j), dty(j) + 28 * res)-(dtx(j) + res, dty(j) + 28 * res + res), c0(3), BF
Line (dtx(j), dty(j) + 30 * res)-(dtx(j) + res, dty(j) + 30 * res + res), c0(2), BF
End If
If dty(j) = scy - 9 Then
Circle (dtx(j), scy + 2), 2, c0(3)
Circle (dtx(j) - 3, scy - 5), 1, c0(3)
Circle (dtx(j) + 3, scy - 5), 1, c0(3)
End If
If dty(j) = scy - 8 Then
Circle (dtx(j), scy + 2), 3, c0(4)
End If
If dty(j) = scy - 6 Then
Circle (dtx(j) - 5, scy - 8), 1, c0(3)
Circle (dtx(j) + 5, scy - 8), 1, c0(3)
End If
If dty(j) = scy - 2 Then
Circle (dtx(j), scy + 2), 4, c0(5)
End If
If dty(j) = scy - 1 Then
Circle (dtx(j), scy + 2), 5, c0(6)
End If
If dty(j) >= scy + 10 Then
Circle (dtx(j) - 3, scy - 5), 1, c0(0)
Circle (dtx(j) + 3, scy - 5), 1, c0(0)
End If
If dty(j) >= scy + 20 Then
Line (dtx(j) - 2, scy - 5)-(dtx(j) + 2, scy), c0(2), BF
End If
If dty(j) >= scy + 30 Then
Line (dtx(j) - 4, scy - 3)-(dtx(j) + 4, scy), c0(2), BF
End If
If dty(j) >= scy + 45 Then
Line (dtx(j) - 7, scy - 2)-(dtx(j) + 7, scy), c0(2), BF
End If
If dty(j) >= scy + 60 Then
Circle (dtx(j) - 5, scy - 8), 1, c0(0)
Circle (dtx(j) + 5, scy - 8), 1, c0(0)
Line (dtx(j) - 12, scy - 8)-(dtx(j) + 12, scy - 1), c0(0), BF
Line (dtx(j) - 12, scy - 1)-(dtx(j) + 12, scy), c0(2), BF
dtx(j) = -1 'expired
End If
End If
Next j
'======================================================
'adjust display speed using "w" and "s" keys
keypress$ = InKey$
If keypress$ = Chr$(115) Then dv = dv + 2
If keypress$ = Chr$(119) Then dv = dv - 2
If dv > 200 Then dv = 200
If dv < 2 Then dv = 2
'fancy indicator for display speed
'======================================================
'Locate 1, 1
'Print Using "#######"; dv
'Print "Speed"
'Line (69, 1)-(270, 10), c0(2), BF
'Line (70, 2)-(269, 9), c0(0), BF
'Line (69, 1)-(271 - dv, 10), c0(2), BF
'======================================================
For del1 = 1 To dv * 10000
Next del1
Loop Until flag > 0
End
|
|
|
|
| MemPrint and MemInput |
|
Posted by: SMcNeill - 08-22-2022, 12:59 AM - Forum: Works in Progress
- Replies (7)
|
|
So, if there's a few absolute things that I've learned about what folks say about QB64 from over the years, two of the most prevalent have to be:
1) MEM IS HARD!! IT'S NOT FOR BEGINNERS!!
2) Opening files for INPUT and OUTPUT is the most basic of BASIC. *EVERYONE* knows how to do this -- if not, then they'll learn it by the second lesson on learning QB64...
Now, I'm not saying I agree with point 1 -- I truly don't think that mem is all that hard to learn and use, which is why I've made videos and written a bazillion words on how to help folks understand it. BUT, even after all that, the general consensus is "Mem is hard and not for beginners!"
But... What if I told you guys that I was working on a way to bring those two concepts together?? That I was making a means so that one could use _MEM just as easily as they can use LINE INPUT and PRINT??
Don't believe it??
Then let me present.... Dum Dum De Dummmm:
Code: (Select All) Type Mem_File_Type
inUse As Integer
EOF_Marker As _Offset
Current_Pos As _Offset
Content As _MEM
End Type
Dim Shared MemFile(1 To 100) As Mem_File_Type
'BI HEADER INFO BEFORE THIS
handle = MemFileOpen
MemPrint handle, "Hello World", 1
MemPrint handle, "My name is Steve", 1
MemSeek handle, 0
Do Until MemEOF(handle)
MemLineInput handle, temp$
Print temp$
Loop
'BM FOOTER INFO AFTER THIS
Function MemFileOpen
'Error codes for MemFileOpen
'1: No mem files available. (All 100 are in use! Free some to use more!)
For i = 1 To 100
If MemFile(i).inUse = 0 Then Exit For
Next
If i > 100 Then MemFileOpen = 0 'can't open any more memfiles!
MemFileOpen = i
MemFile(i).inUse = -1 'TRUE
MemFile(i).EOF_Marker = 0 'nothing is written in the file to begin with
MemFile(i).Current_Pos = 0 'and we're at the start of our nothing in the file
MemFile(i).Content = _MemNew(1000000) '1mb memfile by default
$Checking:Off
_MemFill MemFile(i).Content, MemFile(i).Content.OFFSET, MemFile(i).Content.SIZE, 0 As _UNSIGNED _BYTE
'make certain to blank the file when opening it for the first time so we don't have unwanted characters in it.
$Checking:On
End Function
Function MemEOF (memfile)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Function 'File Not Found Error message
If MemFile(memfile).Current_Pos >= MemFile(memfile).EOF_Marker Then MemEOF = -1
End Function
Sub MemSeek (memfile, position As _Offset)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Sub 'File Not Found Error message
If position < 0 Then Error 5: Exit Sub 'Invalid Function Call
If position > MemFile(memfile).EOF_Marker Then Error 5: Exit Sub 'Invalid Function Call
MemFile(memfile).Current_Pos = position
End Sub
Sub MemLineInput (memfile, what$)
'only valid line endings here are CHR$(10), chr$(13), and chr$(13) + chr$(10)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Sub 'File Not Found Error message
Dim As _Offset CP, EP, Size, L
Dim tempM As _MEM
tempM = MemFile(memfile).Content 'it's just much shorter to type!
CP = MemFile(memfile).Current_Pos
EP = MemFile(memfile).EOF_Marker
If CP >= EP Then Error 62: Exit Sub 'INPUT PAST END OF FILE error
Size = tempM.SIZE
Do
a$ = _MemGet(tempM, tempM.OFFSET + CP, String * 1)
Select Case a$
Case Chr$(13)
a1$ = _MemGet(tempM, tempM.OFFSET + CP + 1, String * 1)
If al$ = Chr$(10) Then CP = CP + 1 'move the Current Pointer past the 2nd character in a windows CRLF ending
finished = -1
Case Chr$(10)
finished = -1
Case Else
temp$ = temp$ + a$
End Select
CP = CP + 1
If CP >= EP Then finished = -1
Loop Until finished
MemFile(memfile).Current_Pos = CP
what$ = temp$
End Sub
Sub MemPrint (memfile, what$, EOL_Type As Integer)
'memfile is the memfile handle to print to
'what$ is what we want to print
'EOL_Type is the type of line ending we want after this print statement
'1: This is a CHR$(10) line ending (Linux style line ending)
'2: This is a CHR$(13) line ending (Old Mac style line ending)
'3: This is a CHR$(13) + CHR$(10) line ending (Old Windows style line ending)
'4: This is a COMMA line ending. Use this if writing continous CSV fields.
' (Think PRINT #1, stuff$, <-- see the comma there at the end of the print statement??)
If MemFile(memfile).inUse = 0 Then Error 53: Exit Sub 'File Not Found Error message
Dim CRLF As String
Dim As _Offset CP, EP, Size, L
Select Case EOL_Type
Case 1: CRLF = Chr$(10)
Case 2: CRLF = Chr$(13)
Case 3: CRLF = Chr$(13) + Chr$(10)
Case 4: CRLF = ","
End Select
CP = MemFile(memfile).Current_Pos
EP = MemFile(memfile).EOF_Marker
Size = MemFile(memfile).Content.SIZE
L = Len(what$) + Len(CRLF)
If CP + L > Size Then 'we're writing beyond the bounds of our reserved memory!
Dim tempM As _MEM
recheck:
If Size <= 100000000 Then 'resize our memblock (to the limit) to save our data
tempM = _MemNew(Size * 10)
_MemCopy MemFile(memfile).Content, MemFile(memfile).Content.OFFSET, Size To tempM, tempM.OFFSET
_MemFree MemFile(memfile).Content
MemFile(memfile).Content = tempM
Size = Size * 10
GoTo recheck 'just to make certain that our reserved memory is now large enough to hold our data
Else
Error 61 'DISK FULL ERROR MESSAGE
Exit Sub 'I'm coding a hard size limit of 1GB for each memfile opened!
' Anything larger than that, and I'm tossing a Disk Full Error
End If
End If
_MemPut MemFile(memfile).Content, MemFile(memfile).Content.OFFSET + CP, what$ + CRLF
MemFile(memfile).Current_Pos = CP + L
If CP + L > EP Then MemFile(memfile).EOF_Marker = CP + L
End Sub
Here's the main code of relevance for the end user -- see how it'd compare to a normal file being opened in QB64:
Code: (Select All) handle = MemFileOpen
MemPrint handle, "Hello World", 1
MemPrint handle, "My name is Steve", 1
MemSeek handle, 0
Do Until MemEOF(handle)
MemLineInput handle, temp$
Print temp$
Loop
The very first line here is a wee bit odd, but think of it as: handle = FREEFILE It basically gives you a free handle and readies a block of memory for you to make use of.
PRINT #1, "Hello World"
PRINT #1, "My name is Steve"
Hopefully you can see where the next lines would match up to a simple file PRINT statement? That , 1 at the end there is basically the way of telling the program what file ending we want, or if we want to toss a comma at the end of this data, for CSVs. (Think of it as being PRINT #1, "Hello World", <-- do we put that comma there at the end, or not??) ,1 says we're going with a normal CHR$(10) file ending at the end of the data.
The MemSeek is basically the same as the SEEK statement, with the exception that we start at position 0 rather than position 1. (I may adjust this later, if folks feel its necessary.)
DO UNTIL EOF(1)
LINE INPUT #1, temp$
PRINT temp$
LOOP
And the next few lines should definitely be noticeably comparable to the file LINE INPUT method. Right?
It's all in mem... but it's simple PRINT and LINE INPUT style commands...
Is your mind blown yet??
Yet to do:
There needs to be a CLOSE statement to close the files and free the memory for good.
I also want to add 2 quick commands : MemFileSave -- to save the mem block to disk. MemFileLoad -- to load the file back into memory.
And what's the purpose to such a system?? Besides trying to make use of the speed of using mem?
To reduce disk reads and writes as much as possible and save wear and usage of SSDs. Load the whole file at once. Save the whole file at once. Otherwise, just read and write to a mem block exactly as you normally would a file! No need to track offsets. No _memget or _memput.... Just simple PRINT and INPUT file access like folks are used to doing already.
Any and all comments and feedback is appreciated. Post questions and suggestions galore! Honestly, I'd say this is already 90% finished. If anyone has any specific user requests, get them in *now*, before I wrap this up in the next day or so, and move on to something else.
|
|
|
|
| Primitive Radial Flagellum Cells |
|
Posted by: James D Jarvis - 08-22-2022, 12:46 AM - Forum: Programs
- Replies (2)
|
|
More fun with the DRAW command. Pretty simple Radial Flagellum Cells moving about, sometimes bumping each other about. It'll keep on running until you hit the escape key.
Code: (Select All) ' radial flagellum cells animation
' By James D. Jarvis
' a simple simulation of animated cells
'they will bounce off the sides and wrestle with shove and pull each other now and again
' press esc to quit
xmax = 1100
ymax = 600
Screen _NewImage(xmax, ymax, 32)
_Title "Radial Flagellum"
Randomize Timer
ncells = 16+(rnd*16) 'you could also make this a fixed number, don't go too high this seems to bog down with too many cells
Dim Shared X(ncells), Y(ncells), r(ncells), xv(ncells), yv(ncells), kkr(ncells), kkg(ncells), kkb(ncells), a(ncells)
Dim Shared rt(ncells)
'build the cells
For c = 1 To ncells
X(c) = Int(2 + Rnd * (xmax - 60) / 28) * 30
Y(c) = Int(2 + Rnd * (ymax - 60) / 28) * 30
r(c) = 20 + Int(Rnd * 60)
xv(c) = Int(2 - Rnd * 4)
yv(c) = Int(2 - Rnd * 4)
kkr(c) = 150 + Int(Rnd * 100)
kkg(c) = 150 + Int(Rnd * 100)
kkb(c) = 150 + Int(Rnd * 100)
a(c) = 8 + Int(Rnd * 16)
rt(c) = Int(Rnd * 4) - Int(Rnd * 4)
Next c
'animate the cells
Do
_Limit 60
Cls
For c = 1 To ncells
For n = r(c) To Int(r(c) * .4) Step -2
draw_microbe X(c) + Sin(n / 4), Y(c) + Cos(n / 4), n + Int(Rnd * 4), kkr(c) - n * 2, kkg(c) - n * 2, kkb(c) - n * 2, a(c), c
Next
X(c) = X(c) + xv(c)
Y(c) = Y(c) + yv(c)
If X(c) < r(c) Then xv(c) = xv(c) * -1
If Y(c) < r(c) Then yv(c) = yv(c) * -1
If X(c) > xmax - r(c) Then xv(c) = xv(c) * -1
If Y(c) > ymax - r(c) Then yv(c) = yv(c) * -1
For c2 = 1 To ncells
If c2 <> c Then
If Int((X(c) + r(c)) / 40) = Int((X(c2) + r(c2)) / 40) And Int((Y(c) + r(c)) / 40) = Int((Y(c2) + r(c2)) / 40) Then
xv(c) = xv(c) * -1
yv(c) = yv(c) * -1
xv(c2) = xv(c2) * -1 + Rnd * .2 - Rnd * .2
yv(c2) = yv(c2) * -1 + Rnd * .2 - Rnd * .2
End If
End If
Next c2
rt(c) = rt(c) - (Rnd * 3) + (Rnd * 3)
Next
_Display
k$ = InKey$
Loop Until k$ = Chr$(27)
Sub draw_microbe (x, y, r, kR, kG, kB, arm, c)
'draw a crude radial microbe with flagellum
Draw "C" + Str$(_RGB32(kR, kG, kB))
Draw "bm" + Str$(x) + "," + Str$(y)
rv = Rnd * .2
For ang = 0 + rt(c) To 360 + rt(c) Step Int(360 / arm) + rv
wiggle$ = " r" + Str$((r + Int(Rnd * 3)) * .33) + " e" + Str$(1 + Int(Rnd * r(c) / 6))
wiggle$ = wiggle$ + " r" + Str$((r + Int(Rnd * 3)) * .33) + " e" + Str$(1 + Int(Rnd * r(c) / 6))
wiggle$ = wiggle$ + " r" + Str$((r + Int(Rnd * 3)) * .33)
Draw "ta" + Str$(ang) + wiggle$ + "bm" + Str$(x) + "," + Str$(y)
' Draw "ta" + Str$(ang) + " r" + Str$(r + Int(Rnd * 3)) + " u" + Str$(1 + Int(Rnd * 3)) + "m" + Str$(x) + "," + Str$(y)
Next ang
End Sub
|
|
|
|
| My Best Globe So Far |
|
Posted by: SierraKen - 08-21-2022, 12:15 AM - Forum: Programs
- Replies (6)
|
 |
This isn't animated, but by trial and error and a bit of experience, I made this PSET globe.
![[Image: Globe-by-Sierra-Ken.jpg]](https://i.ibb.co/HFztf1Y/Globe-by-Sierra-Ken.jpg)
Code: (Select All) _Title "Globe by SierraKen"
Screen _NewImage(800, 600, 32)
start:
t = 100 * (2 * _Pi)
cc = 50
w = 10
cc3 = 50
_Limit 20
While _MouseInput: Wend
If t < 0 Then GoTo start:
For l = -100 To 100 Step .025
cc3 = cc3 + .1
If cc3 > 255 Then cc3 = 50
x = (Sin(t) * 100) * (_Pi / 2) + 400
y = (Cos(t) * l) * (_Pi / 2) + 200
t = t - (.25 + w / 10)
PSet (x, y), _RGB32(cc3, cc3, 100 + cc3)
Next l
For l = -100 To 100 Step .025
cc = cc + .1
If cc > 255 Then cc = 50
x = (Sin(t) * l) * (_Pi / 2) + 400
y = (Cos(t) * 100) * (_Pi / 2) + 200
t = t - (.25 + w / 10)
PSet (x, y), _RGB32(cc, cc, 100 + cc)
Next l
t = t - .025
cc2 = 100
For sz = .1 To 100 Step .25
cc2 = cc2 - .25
Circle (400, 450), sz, _RGB32(100 + cc2, 100 + cc2, cc2), , , .5
Next sz
Line (400, 200)-(400, 450), _RGB32(255, 255, 255)
Do: Loop Until InKey$ = Chr$(27)
|
|
|
|
|
