| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
astuce pour survivre fina...
Forum: Utilities
Last Post: coletteleger
05-14-2025, 04:47 AM
» Replies: 0
» Views: 9
|
trouver permis de conduir...
Forum: Utilities
Last Post: nicolasrene
05-05-2025, 05:24 AM
» Replies: 0
» Views: 14
|
LIGHTBAR Menu
Forum: Programs
Last Post: nicolasrene
05-05-2025, 05:08 AM
» Replies: 15
» Views: 945
|
Learning Pallet Rack Safe...
Forum: Utilities
Last Post: Sandrapew
04-03-2025, 09:36 AM
» Replies: 0
» Views: 38
|
Choosing New Versus or Pr...
Forum: Utilities
Last Post: Sandrapew
03-18-2025, 01:11 AM
» Replies: 0
» Views: 33
|
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 1,058
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 71
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 68
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 3,438
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 2,169
|
|
|
| Scrabble Word Maker |
|
Posted by: SMcNeill - 04-20-2022, 02:32 AM - Forum: SMcNeill
- No Replies
|
 |
A word making routine for use in scrabble. Give it the letters you have, it'll show you the possible words you can make with it.
2006 Scrabble Word List is attached as a link at the bottom of the post; don't forget to grab it. 
Code: (Select All) DEFLNG A-Z
REDIM SHARED WordList(0) AS STRING
REDIM SHARED Match(0) AS STRING
Init
DO
GetLetters text$
CheckMatchs text$
DisplayMatches
LOOP
SUB DisplayMatches
PRINT
PRINT "MATCHES :"
IF UBOUND(match) = 0 THEN PRINT "NONE": EXIT SUB
FOR i = 1 TO UBOUND(match)
PRINT Match(i),
NEXT
PRINT
END SUB
SUB CheckMatchs (text$)
text$ = LTRIM$(RTRIM$(text$))
DIM userletters(26), wordletters(26)
REDIM Match(0)
alpha$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
l = LEN(text$)
work$ = UCASE$(text$)
wordcount = 1 'the number of letters in the word we're looking for
FOR i = 1 TO l
a = ASC(work$, i)
IF a > 64 AND a < 91 THEN 'it's all good
userletters(a - 64) = userletters(a - 64) + 1
ELSE
PRINT "Invalid letters entered. Only use A-Z."
EXIT SUB
END IF
NEXT
FOR i = 1 TO UBOUND(wordlist)
FOR l = 1 TO 26: wordletters(l) = 0: NEXT 'reset wordletters back to 0
FOR l = 1 TO LEN(WordList(i)) 'count the letters in the word
a = ASC(WordList(i), l)
wordletters(a - 64) = wordletters(a - 64) + 1
NEXT
valid = -1 'assume it's a match
FOR l = 1 TO 26 'compare for matches
IF wordletters(l) > userletters(l) THEN valid = 0: EXIT FOR
NEXT
IF valid THEN
REDIM _PRESERVE Match(UBOUND(match) + 1)
Match(UBOUND(match)) = WordList(i)
END IF
NEXT
PRINT
END SUB
SUB GetLetters (text$)
PRINT
DO
PRINT "Give me the letters you want to check for word matches. (From 2-15 letters) => ";
INPUT text$
IF text$ = "" THEN SYSTEM
l = LEN(text$)
IF l < 2 OR l > 15 THEN PRINT "Invalid Letters. Try Again."
LOOP UNTIL l > 1 AND l < 16
END SUB
SUB Init
PRINT "Loading Dictionary..."
file$ = "Scrabble WordList 2006.txt"
OPEN file$ FOR BINARY AS #1
l = LOF(1)
WholeList$ = SPACE$(l)
GET #1, 1, WholeList$
PRINT "Parsing Dictionary..."
c = 0: i = 0
DO
c = INSTR(c1, WholeList$, CHR$(13))
IF c > 0 THEN
u = UBOUND(wordlist) + 1
REDIM _PRESERVE WordList(u)
WordList(u) = MID$(WholeList$, c1, c - c1)
c1 = c + 2 'our start pointer is now after the finish pointer
ELSE
EXIT DO
END IF
LOOP
PRINT u; " words are now loaded and ready for use."
CLOSE
END SUB
Scrabble Offical Word List for 2006
|
|
|
| A Simple Center Routine |
|
Posted by: SMcNeill - 04-20-2022, 02:30 AM - Forum: SMcNeill
- No Replies
|
|
The title really says it all...
Code: (Select All) SCREEN _NEWIMAGE(640, 480, 32)
Center 10, "A centered title", -1
'The 10 above is the line that we want to center our text on.
'"A centered title" is the text that we want centered.
'The -1 above says that we want to move the print positon to the next line down -- line 11 in this case.
Center 0, "by Steve", 0
'The 0 above says to print on the CURRENT LINE
'"by Steve" is simply the text we want centered.
'The 0 here says that we DON'T move the print position to the next line down.
'NOTE: In this case, our print cursor is going to be at line 11, position 1 (like LOCATE 11,1) for our next PRINT statement.
COLOR _RGB32(255, 255, 0)
PRINT "<<<<<<<<<<<<<<<<"
'Notice where the yellow arrows above printed on the screen -- it's the SAME line as "by Steve".
'If we wanted to move the cursor down to the next line automatically, we'd set that last parameter to anything other than 0.
'Because QB64 counts 0 as FALSE, all else as TRUE.
COLOR -1
Center 20, "Press <ANY KEY> to see this in SCREEN 0", 0
a$ = INPUT$(1)
SCREEN 0
Center 10, "A centered title", -1
Center 0, "by Steve", 0
Center 20, "Notice that the center command works fine in ALL screen modes?", 0
SUB Center (PrintLine AS INTEGER, text AS STRING, NewLine AS INTEGER)
IF PrintLine = 0 THEN
y = CSRLIN
ELSE
y = PrintLine
END IF
IF _PIXELSIZE <> 0 THEN Py = (y - 1) * _FONTHEIGHT ELSE Py = y
pw = _PRINTWIDTH(text)
w = _WIDTH
C = (w - pw) \ 2
_PRINTSTRING (C, Py), text
IF NewLine THEN LOCATE y + 1
END SUB
Note that we have a 3rd parameter for our Center routine, which is for the NEWLINE option. Basically this is used to toggle between two modes of behavior:
0 -- don't move the print position location from what it previously existed. (This allows us to center text wherever we want, without losing where we were printing before.)
Anything Else -- move the print position to the line directly below what we just centered, and to the left side of the screen, just as PRINT "something" would.
The rest should be easy enough to figure out. 
|
|
|
|
| Basic WordWrap |
|
Posted by: SMcNeill - 04-20-2022, 02:29 AM - Forum: SMcNeill
- No Replies
|
|
A simple little routine which can be plugged in to break text and word wrap it nice and neat for us.
Code: (Select All) 'SCREEN _NEWIMAGE(640, 480, 32)
LOCATE 1, 21 'to test a line with an offset
test$ = "This is a very long sentence which runs on and on and one and even contains tipos and errors and goofs and mistakes and all sorts of junk, but it is good for testing if we have word breaks working properly for us!"
WordWrap test$, -1
PRINT 'to test a line from the starting point
WordWrap test$, -1
PRINT
PRINT "=============="
PRINT
WordWrap test$, 0 'And this shows that we can wordwrap text without automatically moving to a new line
WordWrap test$, -1 'As this line picks up right where the last one left off.
SUB WordWrap (text AS STRING, newline)
DIM BreakPoint AS STRING
BreakPoint = ",./- ;:!" 'I consider all these to be valid breakpoints. If you want something else, change them.
w = _WIDTH
pw = _PRINTWIDTH(text)
x = POS(0): y = CSRLIN
IF _PIXELSIZE <> 0 THEN x = x * _FONTWIDTH
firstlinewidth = w - x + 1
IF pw <= firstlinewidth THEN
PRINT text;
IF newline THEN PRINT
ELSE
'first find the natural length of the line
FOR i = 1 TO LEN(text)
p = _PRINTWIDTH(LEFT$(text, i))
IF p > firstlinewidth THEN EXIT FOR
NEXT
lineend = i - 1
t$ = RTRIM$(LEFT$(text, lineend)) 'at most, our line can't be any longer than what fits the screen.
FOR i = lineend TO 1 STEP -1
IF INSTR(BreakPoint, MID$(text, i, 1)) THEN lineend = i: EXIT FOR
NEXT
PRINT LEFT$(text, lineend)
WordWrap LTRIM$(MID$(text, lineend + 1)), newline
END IF
END SUB
|
|
|
|
| Steve's Config File System |
|
Posted by: SMcNeill - 04-20-2022, 02:28 AM - Forum: SMcNeill
- No Replies
|
|
Two little routines which can be used to read and write to a config file. (If you guys want to see an example of what an actual config file would look like using this, look at the config.txt in your QB64/internal folder. This is the exact same config routines which we imported into QB64. :-X)
Code: (Select All) ConfigFile$ = "config.txt"
ConfigBak$ = "config.bak"
WriteConfigSetting "'[COLOR SETTING]", "Background", "_RGB32(255,0,255)"
DisplayConfigFile
WriteConfigSetting "'[COLOR SETTING]", "TextColor", "_RGB32(255,0,0)"
DisplayConfigFile
WriteConfigSetting "'[COLOR SETTING]", "Background", "_RGB32(255,0,0) 'REDONE"
DisplayConfigFile
WriteConfigSetting "'[COLOR SETTING]", "TextColor", "_RGB32(255,0,255) 'REDONE ALSO"
DisplayConfigFile
PRINT
PRINT "============================================="
PRINT
work = ReadConfigSetting("TextColor", value$)
IF work THEN
PRINT "Textcolor value found. It's: "; value$
ELSE
PRINT "No textcolor found"
END IF
SUB DisplayConfigFile
SHARED ConfigFile$
InFile = FREEFILE: OPEN ConfigFile$ FOR BINARY AS #InFile
IF LOF(InFile) THEN
DO UNTIL EOF(InFile)
LINE INPUT #InFile, junk$
PRINT junk$
LOOP
ELSE
KILL "config.txt" 'remove the blank file from the drive
PRINT "No config file found."
END IF
CLOSE InFile
END SUB
SUB WriteConfigSetting (heading$, item$, value$)
SHARED ConfigFile$, ConfigBak$
DIM CRLF AS STRING
IF INSTR(_OS$, "WIN") THEN CRLF = CHR$(13) + CHR$(10) ELSE CRLF = CHR$(10)
_TITLE STR$(LEN(CRLF))
InFile = FREEFILE: OPEN ConfigFile$ FOR BINARY AS #InFile
OutFile = FREEFILE: OPEN ConfigBak$ FOR OUTPUT AS #OutFile
placed = 0
IF LOF(InFile) THEN
DO UNTIL EOF(InFile)
LINE INPUT #InFile, junk$
'we really don't care about heading$ here; it's only used to make things easier for the user to locate in the config file
junk$ = LTRIM$(RTRIM$(junk$))
IF _STRICMP(LEFT$(junk$, LEN(item$)), item$) = 0 THEN
PRINT #OutFile, item$; " = "; value$
placed = -1
ELSE
PRINT #OutFile, junk$
END IF
LOOP
END IF
CLOSE #InFile, #OutFile
IF NOT placed THEN 'we didn't find the proper setting already in the file somewhere.
'Either the file was corrupted, or the user deleted this particulat setting sometime in the past.
'Now we look to see if the heading exists in the file or not.
'If it does, then we place the new setting under that heading.
'If not then we write that heading to the end of the file to make it easier for the user to locate in the future
'and then we write it below there.
OPEN ConfigBak$ FOR BINARY AS #InFile
l = LOF(InFile)
out$ = item$ + " = " + value$ + CRLF
temp$ = SPACE$(l)
GET #InFile, 1, temp$
l1 = INSTR(temp$, heading$)
IF l1 THEN
l1 = l1 + LEN(heading$) + LEN(CRLF)
PUT #InFile, l1, out$
r$ = MID$(temp$, l1)
PUT #InFile, , r$
placed = -1
END IF
IF NOT placed THEN
PUT #InFile, l + 1, CRLF
PUT #InFile, , heading$
PUT #InFile, , CRLF
PUT #InFile, , out$
PUT #InFile, , CRLF
END IF
CLOSE InFile
END IF
KILL ConfigFile$
NAME ConfigBak$ AS ConfigFile$
END SUB
FUNCTION ReadConfigSetting (item$, value$)
SHARED ConfigFile$
value$ = "" 'We start by blanking the value$ as a default return state
InFile = FREEFILE: OPEN ConfigFile$ FOR BINARY AS #InFile
IF LOF(InFile) THEN
found = 0
DO UNTIL EOF(InFile)
LINE INPUT #InFile, temp$
temp$ = LTRIM$(RTRIM$(temp$))
IF LEFT$(UCASE$(temp$), LEN(item$)) = UCASE$(item$) THEN found = -1: EXIT DO
LOOP
CLOSE InFile
IF found THEN 'we found what we're looking for
l = INSTR(temp$, "=") 'return the value after the = sign
IF l THEN
value$ = MID$(temp$, l + 1)
l = INSTR(value$, CHR$(13)) 'we only want what's before a CR
IF l THEN value$ = LEFT$(value$, l)
l = INSTR(value$, CHR$(10)) 'or a LineFeed
'These are basic text files; they shouldn't have stray CHR$(10) or CHR$(13) characters in them!
IF l THEN value$ = LEFT$(value$, l)
value$ = LTRIM$(RTRIM$(value$))
ReadConfigSetting = -1
EXIT FUNCTION
END IF
END IF
END IF
ReadConfigSetting = 0 'failed to find the setting
END FUNCTION
The concept behind the routines here is rather simple:
First, most config files have headings to help make finding and organizing things easier for the user to find if they ever open the file in a simple text editor. This supports those as a purely organizational type object, but they actually don't hold any value except to make things easier for the user in they alter things manually.
For example, a config file might look like the following:
'[COLORS]
RED = 1
BLUE = 2
'[JOYSTICK]
EnableJoystick = FALSE
Now that's easy enough to read and alter in a text editor, but what if the user edits it so that it looks something more like the following:
'[COLORS]
RED = 1
'[JOYSTICK]
EnableJoystick = FALSE
BLUE = 2
That BLUE isn't in the right heading!
So the choice here is: Do we ignore it since it's not in the expected place? Or read it as long as it's anywhere in the file?? I chose to read it no matter where it appears in the config file.
The only drawback to this is that we can't have two different settings called BLUE under different headings, but that I don't see that as being an issue for us so much just for the simple fact that QB64 really isn't going to have that many settings to use that we can't give them all an unique name.
So honestly, all we're really dealing with here is the item$ which is the setting we're looking for, and the value$ that we want to assign to it, with the heading$ only being there to help with making it all look pretty...
Other point to note:
ReadConfigSetting is a FUNCTION.
It returns a 0 to us if it fails to find a setting, and a -1 if it found it successfully.
the value$ is passed back to us via the 2nd parameter in the FUNCTION.
work = ReadConfigSetting("TextColor", value$)
Now if we have a setting for TextColor, work will be -1 and value$ will be whatever that setting is
If there's no TextColor in the config file, work will be 0 and value$ might be anything....
I'd suggest to ALWAYS check to see if the return value of that function is true or not, before I'd accept the value that it gave us.
work = ReadConfigSetting("TextColor", value$)
IF work THEN
PRINT "Textcolor value found. It's: "; value$
ELSE
PRINT "No textcolor found"
END IF
All in all, I find it easier to use than I do to explain the use. LOL - try out the demo and you'll see how it works for yourself easily enough.
WriteConfigSetting (heading$, item$, value$) writes the headings (just for prettification), item, and value to the proper place in your config file. It searches to see if the setting is already in the file, and if not it adds it to the proper area automatically for you.
ReadConfigSetting (item$, value$) returns a 0 or -1 through the function to tell us if things worked as we expected, and returns our value to use through the second parameter if it can.
It really is basically that simple to use. [/quote]
|
|
|
|
| File Listing To Arrays |
|
Posted by: SMcNeill - 04-20-2022, 02:22 AM - Forum: SMcNeill
- Replies (7)
|
|
direntry.h -- Grab this file. It's a C header which QB64 will need to make use of. Without it, the following won't run.
Copied, more or less verbatim, from my post over at QB64.net:
Random1 asked elsewhere:
Quote:Is there a way to save the output of FILES to a string or text file?
FILES "C:\MyFile\*.TXT" to a string or .txt file
So, I worked up this quick little routine to do just that...
Basic usage is rather simple: Copy the header and put it up top in your program. Copy the routine, put it at the end of your program. Make certain "direntry.h" is in your QB64 directory when compiling...
Call the routine with:
GetFileList _CWD$, Dir(), File()
In this case, I'm just getting the file and subdirectory listings for the Current Working Directory (_CWD$), but you can get them for any directory that exists on your system...
Here's a way you can do what you want to, which is compatible for both Linux and Windows users (whereas SHELL may not always work across various platforms).
Code: (Select All) DECLARE CUSTOMTYPE LIBRARY ".\direntry"
FUNCTION load_dir& (s AS STRING)
FUNCTION has_next_entry& ()
SUB close_dir ()
SUB get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
END DECLARE
REDIM Dir(0) AS STRING, File(0) AS STRING
GetFileList _CWD$, Dir(), File()
PRINT "SUBDIRECTORIES"
FOR i = 1 TO UBOUND(dir)
PRINT Dir(i),
NEXT
PRINT
SLEEP
PRINT "FILES": PRINT: PRINT
FOR i = 1 TO UBOUND(file)
PRINT File(i),
NEXT
PRINT
SUB GetFileList (SearchDirectory AS STRING, DirList() AS STRING, FileList() AS STRING)
CONST IS_DIR = 1
CONST IS_FILE = 2
DIM flags AS LONG, file_size AS LONG
REDIM _PRESERVE DirList(100), FileList(100)
DirCount = 0: FileCount = 0
IF load_dir(SearchDirectory) THEN
DO
length = has_next_entry
IF length > -1 THEN
nam$ = SPACE$(length)
get_next_entry nam$, flags, file_size
IF flags AND IS_DIR THEN
DirCount = DirCount + 1
IF DirCount > UBOUND(DirList) THEN REDIM _PRESERVE DirList(UBOUND(DirList) + 100)
DirList(DirCount) = nam$
ELSEIF flags AND IS_FILE THEN
FileCount = FileCount + 1
IF FileCount > UBOUND(filelist) THEN REDIM _PRESERVE FileList(UBOUND(filelist) + 100)
FileList(FileCount) = nam$
END IF
END IF
LOOP UNTIL length = -1
close_dir
ELSE
END IF
REDIM _PRESERVE DirList(DirCount)
REDIM _PRESERVE FileList(FileCount)
END SUB
Note, I set this up to separate the search results into files and subdirectories separately.
Note 2. You'll need to download "direntry.h" from the attachment below and copy it into your QB64 folder for this to work. It doesn't need to be with the EXE once you compile it, but it does need to be in the QB64 folder for compiling.
Useage is rather simple (even if it doesn't look it at first).
First, Copy the library declarations into the top of the program where you'd like to make use of this routine.
DECLARE CUSTOMTYPE LIBRARY ".\direntry"
FUNCTION load_dir& (s AS STRING)
FUNCTION has_next_entry& ()
SUB close_dir ()
SUB get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
END DECLARE
Then set two arrays to hold the directory and file information for you:
REDIM Dir(0) AS STRING, File(0) AS STRING
Then when you're ready, call the routine to get that directory's subdirectory list and file list updated:
GetFileList _CWD$, Dir(), File()
At this point, you now have the listing of whichever directory you wanted stored in those two arrays, which you can use for whatever purpose you needed.
In this case, I just cheesily printed them to the screen:
PRINT "SUBDIRECTORIES"
FOR i = 1 TO UBOUND(dir)
PRINT Dir(i),
NEXT
PRINT
SLEEP
PRINT "FILES": PRINT: PRINT
FOR i = 1 TO UBOUND(file)
PRINT File(i),
NEXT
PRINT
And, at the end of your code, don't forget to include the routine itself:
Code: (Select All) SUB GetFileList (SearchDirectory AS STRING, DirList() AS STRING, FileList() AS STRING)
CONST IS_DIR = 1
CONST IS_FILE = 2
DIM flags AS LONG, file_size AS LONG
REDIM _PRESERVE DirList(100), FileList(100)
DirCount = 0: FileCount = 0
IF load_dir(SearchDirectory) THEN
DO
length = has_next_entry
IF length > -1 THEN
nam$ = SPACE$(length)
get_next_entry nam$, flags, file_size
IF flags AND IS_DIR THEN
DirCount = DirCount + 1
IF DirCount > UBOUND(DirList) THEN REDIM _PRESERVE DirList(UBOUND(DirList) + 100)
DirList(DirCount) = nam$
ELSEIF flags AND IS_FILE THEN
FileCount = FileCount + 1
IF FileCount > UBOUND(filelist) THEN REDIM _PRESERVE FileList(UBOUND(filelist) + 100)
FileList(FileCount) = nam$
END IF
END IF
LOOP UNTIL length = -1
close_dir
ELSE
END IF
REDIM _PRESERVE DirList(DirCount)
REDIM _PRESERVE FileList(FileCount)
END SUB
direntry.h -- Remember, you need this file. It's a C header which QB64 will need to make use of. Without it, the following won't run.
|
|
|
|
| Change Floating Point Precision |
|
Posted by: SMcNeill - 04-20-2022, 02:20 AM - Forum: SMcNeill
- No Replies
|
|
A quick example of how to change floating point precision in QB64. This swaps between quick math (which uses hardware math processors) to extended precision math (which uses software processing). Note that the default qbfpu is quite a bit faster, and for most folks this should be more than sufficient for your needs, as it tracks precision down to about the 15th decimal point. IF, however, you absolutely have to have greater levels of precision, you can now swap over to extended precision and have about 20 decimal points worth of precision, at a significant reduction of speed.
And, if you need more than 20 decimal points of precision, you're just shit out of luck. Find a math library for that, or else write a string math handling routine -- your CPU isn't equipped to handle anything more than this, natively.
FPU_Precision.h
Code: (Select All) void set_dpfpu() { unsigned int mode = 0x37F; asm ("fldcw %0" : : "m" (*&mode));}
void set_qbfpu() { unsigned int mode = 0x27F; asm ("fldcw %0" : : "m" (*&mode));}
QB64 Code:
Code: (Select All) ' FPU_Precision.h needs to be in QB64 folder
$CONSOLE:ONLY
_DEST _CONSOLE
DECLARE CUSTOMTYPE LIBRARY ".\FPU_Precision"
SUB set_dpfpu 'to toggle to double precision floating point math
SUB set_qbfpu 'to toggle back to what most folks will see with QB64 64-bit default math
END DECLARE
DIM x AS _FLOAT, y AS _FLOAT
'Let's print our results without screwing with anything first.
x = 5##
y = x / 9##
PRINT USING "QB64 division #.####################"; y
'Set the double precision math
set_dpfpu
x = 5##
y = x / 9##
PRINT USING "QB64 division #.####################"; y
'Set the QB64 precision math
set_qbfpu
x = 5##
y = x / 9##
PRINT USING "QB64 division #.####################"; y
|
|
|
|
| ConvertOffset |
|
Posted by: SMcNeill - 04-20-2022, 02:18 AM - Forum: SMcNeill
- No Replies
|
|
Code: (Select All) DIM x AS INTEGER
DIM m AS _MEM
m = _MEM(x)
PRINT m.OFFSET
PRINT ConvertOffset(m.OFFSET)
FUNCTION ConvertOffset&& (value AS _OFFSET)
$CHECKING:OFF
DIM m AS _MEM 'Define a memblock
m = _MEM(value) 'Point it to use value
$IF 64BIT THEN
'On 64 bit OSes, an OFFSET is 8 bytes in size. We can put it directly into an Integer64
_MEMGET m, m.OFFSET, ConvertOffset&& 'Get the contents of the memblock and put the values there directly into ConvertOffset&&
$ELSE
'However, on 32 bit OSes, an OFFSET is only 4 bytes. We need to put it into a LONG variable first
_MEMGET m, m.OFFSET, temp& 'Like this
ConvertOffset&& = temp& 'And then assign that long value to ConvertOffset&&
$END IF
_MEMFREE m 'Free the memblock
$CHECKING:ON
END FUNCTION
|
|
|
|
| Extended Timer and TimeStamp |
|
Posted by: SMcNeill - 04-20-2022, 02:17 AM - Forum: SMcNeill
- Replies (3)
|
|
Code: (Select All) SHELL "https://www.epochconverter.com/"
PRINT "Compare to time stamps generated at the website which popped up in your browser.https://www.epochconverter.com/"
CONST MyTimeZone## = 4 * 3600
DO
_LIMIT 1
CLS
PRINT TimeStamp(DATE$, TIMER + MyTimeZone) 'Timezone difference with GMT, which is what the webpage sometimes points to.
' If the times seem off from the website, you'll want to change the timezone
' offset to match your current time zone.
PRINT ExtendedTimer 'Unix Epoch Timer based on local time.
_DISPLAY
LOOP
FUNCTION TimeStamp## (d$, t##) 'date and timer
'Based on Unix Epoch time, which starts at year 1970.
DIM l AS _INTEGER64, l1 AS _INTEGER64, m AS _INTEGER64
DIM d AS _INTEGER64, y AS _INTEGER64, i AS _INTEGER64
DIM s AS _FLOAT
l = INSTR(d$, "-")
l1 = INSTR(l + 1, d$, "-")
m = VAL(LEFT$(d$, l))
d = VAL(MID$(d$, l + 1))
y = VAL(MID$(d$, l1 + 1))
IF y < 1970 THEN 'calculate shit backwards
SELECT CASE m 'turn the day backwards for the month
CASE 1, 3, 5, 7, 8, 10, 12: d = 31 - d '31 days
CASE 2: d = 28 - d 'special 28 or 29.
CASE 4, 6, 9, 11: d = 30 - d '30 days
END SELECT
IF y MOD 4 = 0 AND m < 3 THEN 'check for normal leap year, and we're before it...
d = d + 1 'assume we had a leap year, subtract another day
IF y MOD 100 = 0 AND y MOD 400 <> 0 THEN d = d - 1 'not a leap year if year is divisible by 100 and not 400
END IF
'then count the months that passed after the current month
FOR i = m + 1 TO 12
SELECT CASE i
CASE 2: d = d + 28
CASE 3, 5, 7, 8, 10, 12: d = d + 31
CASE 4, 6, 9, 11: d = d + 30
END SELECT
NEXT
'we should now have the entered year calculated. Now lets add in for each year from this point to 1970
d = d + 365 * (1969 - y) '365 days per each standard year
FOR i = 1968 TO y + 1 STEP -4 'from 1968 onwards,backwards, skipping the current year (which we handled previously in the FOR loop)
d = d + 1 'subtract an extra day every leap year
IF (i MOD 100) = 0 AND (i MOD 400) <> 0 THEN d = d - 1 'but skipping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = -(s## + 24 * 60 * 60 - t##)
EXIT FUNCTION
ELSE
y = y - 1970
END IF
FOR i = 1 TO m 'for this year,
SELECT CASE i 'Add the number of days for each previous month passed
CASE 1: d = d 'January doestn't have any carry over days.
CASE 2, 4, 6, 8, 9, 11: d = d + 31
CASE 3 'Feb might be a leap year
IF (y MOD 4) = 2 THEN 'if this year is divisible by 4 (starting in 1972)
d = d + 29 'its a leap year
IF (y MOD 100) = 30 AND (y MOD 400) <> 30 THEN 'unless..
d = d - 1 'the year is divisible by 100, and not divisible by 400
END IF
ELSE 'year not divisible by 4, no worries
d = d + 28
END IF
CASE 5, 7, 10, 12: d = d + 30
END SELECT
NEXT
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
FOR i = 2 TO y - 1 STEP 4 'from 1972 onwards, skipping the current year (which we handled previously in the FOR loopp)
d = d + 1 'add an extra day every leap year
IF (i MOD 100) = 30 AND (i MOD 400) <> 30 THEN d = d - 1 'but skiping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = (s## + t##)
END FUNCTION
FUNCTION ExtendedTimer##
'Simplified version of the TimeStamp routine, streamlined to only give positive values based on the current timer.
'Note: Only good until the year 2100, as we don't do all the fancy calculations for leap years.
'A timer should work quickly and efficiently in the background; and the less we do, the less lag we might insert
'into a program.
DIM m AS INTEGER, d AS INTEGER, y AS INTEGER
DIM s AS _FLOAT, day AS STRING
day = DATE$
m = VAL(LEFT$(day, 2))
d = VAL(MID$(day, 4, 2))
y = VAL(RIGHT$(day, 4)) - 1970
SELECT CASE m 'Add the number of days for each previous month passed
CASE 2: d = d + 31
CASE 3: d = d + 59
CASE 4: d = d + 90
CASE 5: d = d + 120
CASE 6: d = d + 151
CASE 7: d = d + 181
CASE 8: d = d + 212
CASE 9: d = d + 243
CASE 10: d = d + 273
CASE 11: d = d + 304
CASE 12: d = d + 334
END SELECT
IF (y MOD 4) = 2 AND m > 2 THEN d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
ExtendedTimer## = (s + TIMER)
END FUNCTION
|
|
|
|
| EllipseFill |
|
Posted by: SMcNeill - 04-20-2022, 02:16 AM - Forum: SMcNeill
- Replies (2)
|
|
Code: (Select All) SUB EllipseFill (cx AS INTEGER, cy AS INTEGER, rx AS INTEGER, ry AS INTEGER, c AS LONG)
DIM a AS LONG, b AS LONG
DIM x AS LONG, y AS LONG
DIM xx AS LONG, yy AS LONG
DIM sx AS LONG, sy AS LONG
DIM e AS LONG
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
DO WHILE sx >= sy
LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
IF y <> 0 THEN LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
IF (e + e + xx) > 0 THEN
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
END IF
LOOP
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
DO WHILE sx <= sy
LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
DO
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
LOOP UNTIL (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
LOOP
END SUB
|
|
|
|
|
![[Image: Screenshot-2022-04-19-22-10-30.png]](https://i.ibb.co/nLhtRBJ/Screenshot-2022-04-19-22-10-30.png)
![[Image: Screenshot-2022-04-19-22-11-05.png]](https://i.ibb.co/1vngx09/Screenshot-2022-04-19-22-11-05.png)
![[Image: Screenshot-2022-04-19-22-11-25.png]](https://i.ibb.co/3W24Sqk/Screenshot-2022-04-19-22-11-25.png)
![[Image: Screenshot-2022-04-19-22-11-59.png]](https://i.ibb.co/1GrvLnh/Screenshot-2022-04-19-22-11-59.png)
![[Image: Screenshot-2022-04-19-22-24-17.png]](https://i.ibb.co/wB3rZnZ/Screenshot-2022-04-19-22-24-17.png)
![[Image: Screenshot-2022-04-19-22-12-48.png]](https://i.ibb.co/nmHyFn4/Screenshot-2022-04-19-22-12-48.png)
![[Image: Screenshot-2022-04-19-22-25-41.png]](https://i.ibb.co/y8tQzNQ/Screenshot-2022-04-19-22-25-41.png)
