A looong time ago, on the old qb64.org forums, we discussed rounding numbers, and out of it came some functions:
For rounding type _FLOAT:
FUNCTION Round## (num##, digits%)
FUNCTION RoundUp## (num##, digits%)
FUNCTION RoundDown## (num##, digits%)
FUNCTION RoundScientific## (num##, digits%)
For rounding up (DOUBLE, SINGLE):
FUNCTION RoundUpDouble# (num#, digits%)
FUNCTION RoundUpSingle! (num!, digits%)
Convert to string, getting rid of scientific notation (DOUBLE, SINGLE):
FUNCTION DblToStr$ (n#)
FUNCTION SngToStr$ (n!)
From what I recall, they were all working.
This weekend I dug up the code to use in a new program,
and added the equivalent rounding and convert-to-string for all 3 types (_FLOAT, DOUBLE, SINGLE):
FUNCTION Round## (num##, digits%)
FUNCTION RoundUp## (num##, digits%)
FUNCTION RoundDown## (num##, digits%)
FUNCTION RoundScientific## (num##, digits%)
FUNCTION RoundDouble# (num#, digits%)
FUNCTION RoundUpDouble# (num#, digits%)
FUNCTION RoundDownDouble# (num#, digits%)
FUNCTION RoundScientificDouble# (num#, digits%)
FUNCTION RoundSingle! (num!, digits%) <- not sure this one works: when digits%=3, it rounds .31 to .32
FUNCTION RoundUpSingle! (num!, digits%)
FUNCTION RoundDownSingle! (num!, digits%)
FUNCTION RoundScientificSingle! (num!, digits%)
FUNCTION DblToStr$ (n#)
FUNCTION SngToStr$ (n!)
FUNCTION FloatToStr$ (n##)
Everything seems to work as expected, except for the function RoundUpSingle!, which for some reason rounds 0.31 to 0.32.
I've been comparing code and checking everything and am not seeing what is causing this, or whether the problem is in RoundUpSingle! or SngToStr$.
Maybe a second set of eyes would help...
If someone could spare a couple minutes to look at this and find what's the wrong, it would be most appreciated!
These functions might come in handy for someone.
Code: (Select All)
' ################################################################################################################################################################
' Rounding test
' ################################################################################################################################################################
' GLOBAL VARIABLES a$=string, i%=integer, L&=long, s!=single, d#=double
DIM ProgramPath$: ProgramPath$ = LEFT$(COMMAND$(0), _INSTRREV(COMMAND$(0), "\"))
DIM ProgramName$: ProgramName$ = MID$(COMMAND$(0), _INSTRREV(COMMAND$(0), "\") + 1)
' START THE MAIN PROGRAM
main ProgramName$
' FINISH UP
SYSTEM ' return control to the operating system
PRINT ProgramName$ + " finished."
END
' /////////////////////////////////////////////////////////////////////////////
' Rounding and math.
' http://www.qb64.net/forum/index_PHPSESSID_gulg2aoa966472fnfhjkgp4i35_topic_14266-0/
'
' Rounding up to n decimal places?
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on May 16, 2017, 06:57:17 pm
' Can also try:
' INT(number * 100)/100
' Now that worked.
' STR$(INT(myprice * 100) / 100)
' Perfectly drops all the numbers to 2 decimal places.
' What a relief. Thank you so much and everyone else who gave advice. :)
' Quote from: bplus on Today at 02:13:29 PM
' There is round Keyword check Wiki, might be _round
' you have to add 1/2 of 10 ^ DP to x
' EDIT: crap it's .5 * (1/10^DP)
SUB main (ProgName$)
DIM RoutineName AS STRING:: RoutineName = "main"
DIM in$
DIM arrOutput(100, 4) AS STRING
DIM s1!
DIM s2!
DIM d1#
DIM d2#
DIM f1##
DIM f2##
DIM iLine1 AS INTEGER
DIM iLine2 AS INTEGER
DIM iLine3 AS INTEGER
DIM iLine4 AS INTEGER
DIM iColumn AS INTEGER
DIM iMaxLines AS INTEGER
DIM dp% ' # decimal places
Screen _NewImage(1280, 1024, 32)
CLS
iTotal = 0
PRINT "Rounding numbers of type _FLOAT."
PRINT "Thanks to SMcNeill, bplus, and Pete for your help."
PRINT
' /////////////////////////////////////////////////////////////////////////////
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
FUNCTION Round## (num##, digits%)
Round## = INT(num## * 10 ^ digits% + .5) / 10 ^ digits%
END FUNCTION
FUNCTION RoundUp## (num##, digits%)
RoundUp## = _CEIL(num## * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
FUNCTION RoundDown## (num##, digits%)
RoundDown## = INT(num## * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
FUNCTION RoundScientific## (num##, digits%)
RoundScientific## = _ROUND(num## * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
FUNCTION RoundDouble# (num#, digits%)
RoundDouble# = INT(num# * 10 ^ digits% + .5) / 10 ^ digits%
END FUNCTION
FUNCTION RoundUpDouble# (num#, digits%)
RoundUpDouble# = _CEIL(num# * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
FUNCTION RoundDownDouble# (num#, digits%)
RoundDownDouble# = INT(num# * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
FUNCTION RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _ROUND(num# * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE SINGLE
FUNCTION RoundSingle! (num!, digits%)
RoundSingle! = INT(num! * 10 ^ digits% + .5) / 10 ^ digits%
END FUNCTION
' NOTE: not sure this one works: when digits%=3, it rounds .31 to .32
FUNCTION RoundUpSingle! (num!, digits%)
RoundUpSingle! = _CEIL(num! * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
FUNCTION RoundDownSingle! (num!, digits%)
RoundDownSingle! = INT(num! * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
FUNCTION RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _ROUND(num! * 10 ^ digits%) / 10 ^ digits%
END FUNCTION
' /////////////////////////////////////////////////////////////////////////////
' Integer to string
FUNCTION cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _TRIM$(STR$(myValue))
END FUNCTION ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
FUNCTION DblToStr$ (n#)
value$ = UCASE$(LTRIM$(STR$(n#)))
Xpos% = INSTR(value$, "D") + INSTR(value$, "E") 'only D or E can be present
IF Xpos% THEN
expo% = VAL(MID$(value$, Xpos% + 1))
IF VAL(value$) < 0 THEN
sign$ = "-"
valu$ = MID$(value$, 2, Xpos% - 2)
ELSE
valu$ = MID$(value$, 1, Xpos% - 1)
END IF
dot% = INSTR(valu$, ".")
L% = LEN(valu$)
IF expo% > 0 THEN
add$ = STRING$(expo% - (L% - dot%), "0")
END IF
IF expo% < 0 THEN
min$ = STRING$(ABS(expo%) - (dot% - 1), "0")
DP$ = "."
END IF
FOR n = 1 TO L%
IF MID$(valu$, n, 1) <> "." THEN
num$ = num$ + MID$(valu$, n, 1)
END IF
NEXT n
ELSE
DblToStr$ = value$
EXIT FUNCTION
END IF
DblToStr$ = _TRIM$(sign$ + DP$ + min$ + num$ + add$)
END FUNCTION ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
FUNCTION FloatToStr$ (n##)
value$ = UCASE$(LTRIM$(STR$(n##)))
Xpos% = INSTR(value$, "D") + INSTR(value$, "E") 'only D or E can be present
IF Xpos% THEN
expo% = VAL(MID$(value$, Xpos% + 1))
IF VAL(value$) < 0 THEN
sign$ = "-"
valu$ = MID$(value$, 2, Xpos% - 2)
ELSE
valu$ = MID$(value$, 1, Xpos% - 1)
END IF
dot% = INSTR(valu$, ".")
L% = LEN(valu$)
IF expo% > 0 THEN
add$ = STRING$(expo% - (L% - dot%), "0")
END IF
IF expo% < 0 THEN
min$ = STRING$(ABS(expo%) - (dot% - 1), "0")
DP$ = "."
END IF
FOR n = 1 TO L%
IF MID$(valu$, n, 1) <> "." THEN
num$ = num$ + MID$(valu$, n, 1)
END IF
NEXT n
ELSE
FloatToStr$ = value$
EXIT FUNCTION
END IF
FloatToStr$ = _TRIM$(sign$ + DP$ + min$ + num$ + add$)
END FUNCTION ' FloatToStr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
FUNCTION SngToStr$ (n!)
value$ = UCASE$(LTRIM$(STR$(n!)))
Xpos% = INSTR(value$, "D") + INSTR(value$, "E") 'only D or E can be present
IF Xpos% THEN
expo% = VAL(MID$(value$, Xpos% + 1))
IF VAL(value$) < 0 THEN
sign$ = "-"
valu$ = MID$(value$, 2, Xpos% - 2)
ELSE
valu$ = MID$(value$, 1, Xpos% - 1)
END IF
dot% = INSTR(valu$, ".")
L% = LEN(valu$)
IF expo% > 0 THEN
add$ = STRING$(expo% - (L% - dot%), "0")
END IF
IF expo% < 0 THEN
min$ = STRING$(ABS(expo%) - (dot% - 1), "0")
DP$ = "."
END IF
FOR n = 1 TO L%
IF MID$(valu$, n, 1) <> "." THEN
num$ = num$ + MID$(valu$, n, 1)
END IF
NEXT n
ELSE
SngToStr$ = value$
EXIT FUNCTION
END IF
SngToStr$ = _TRIM$(sign$ + DP$ + min$ + num$ + add$)
END FUNCTION ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
FUNCTION IsNum% (text$)
DIM a$
DIM b$
a$ = _TRIM$(text$)
b$ = _TRIM$(STR$(VAL(text$)))
IF a$ = b$ THEN
IsNum% = TRUE
ELSE
IsNum% = FALSE
END IF
END FUNCTION ' IsNum%
1. As I mentioned in another thread, I wrote extensive QB programs Back in the 80s & 90s when RAM and HD space was at a premium. I used MKI$, MKS$ and MKD$ extensively in my databases.
Converting the programs using QB64 I noticed they, MKS$ etc., were not converting back properly with CVI, CVS, and CVD.
I found and tested CVSMBF and that seemed to work. Does that mean to continue accessing/using my existing databases with QB64 EXEs I must modify the syntax by adding MBF to all of the above, e.g. MDS$ becomes MDSMBF$, etc.?
2. Is there a way to position the window of the running program so it always opens to the same spot on the desktop?
3. When the program exits, I sometimes get the message "press any key to continue" when all I want is the window to close.
i'm Has anyone done batch resizing of images in QB64?
I'm looking to make a simple drag and drop exe that you drag one or more pictures onto (or maybe send it a command line parameter with a path, or a path + a pattern) and it will auto-convert all the images in the folder to some predetermined target resolution at a high quality (or maybe be able to choose the quality vs processing time?) and write the converted images to target folder (or the same folder but with some prefix or change to the file name so you can easily separate them). It would support JPEG / PNG maybe also BMP / GIF, maybe specify the output format + quality?
Bonus if the created file retains the modified date of the original.
If anyone has done or seen this kind of thing, I would be interested in any samples or advice...!
UPDATE: I think ImageMagick is what I was thinking of.
It would still be interesting to do this in QB64, but ImageMagick with a batch file should work for now...
Print Using "Eingabe vor Funktionsaufruf: ###"; zahlref
Print Using "Eingabe nach Funktionsaufruf (Eingabe x 3): ###"; AlsReferenz(zahlref)
Print
Print "Wertbeispiel - Eingabe wird nicht veraendert"
Input "Eingabe: ", zahlwert
Print Using "Eingabe vor Funktionsaufruf: ###"; zahlwert
'Aufruf mit Wert in Klammern um sie zu einem Ausdruck zu machen
'QBasic Referenz S. 2.31
Call AlsWert((zahlwert))
Print Using "Eingabe nach Funktionsaufruf (Als Ausdruck): ###"; zahlwert
Print
Print "Uebergabe nicht als Ausdruck - keine Klammern (Eingabe + 3)."
'Jetzt nicht als Ausdruck: Ohne extra Klammern
'um die Variable wird die Eingabe veraendert, da
'sie jetzt wieder als Referenz (Standard) uebergeben wird.
Call AlsWert(zahlwert)
Print Using "Eingabe nach Funktionsaufruf: ###"; zahlwert
Function AlsReferenz (eingabe As Integer)
AlsReferenz = eingabe * 3
End Function
Sub AlsWert (eingabe As Integer)
'Hat nur Auswirkung, wenn Argument nicht als Ausdruck
'uebergeben wird
eingabe = eingabe + 3
End Sub
And now with a function: Passing by value doesn't work.
Code: (Select All)
'Beispiel fuer Uebergabe an Funktionen als Referenz und als Wert
'17. Juli 2022
Option _Explicit
Declare Function AlsReferenz(eingabe as Integer) as Integer
Declare Function AlsWert(eingabe as Integer) as Integer
I made this a year ago. It uses the mouse and it randomly picks who goes first.
Code: (Select All)
'I've wanted to make this game for decades and finally am able to!
'This game was made on August 14, 2019 by SierraKen.
'This is Freeware.
'Jan. 28, 2021 update: Choose at random who goes first.
'Jan. 29, 2021 update: Random colored grid, better looking X's, faster welcome screen, centered welcome screen better, made the ability to click to play a new game and another game,
'and added text colors.
'Jan. 30, 2021 update: Added background blue shades. Also added a score in the Title Bar. Turned the game into 3D - Thanks to B+ for the idea!
Dim a(10), b(10)
_Limit 60
_Title "Tic-Tac-Toe by SierraKen"
Screen _NewImage(600, 480, 32)
Cls
Print: Print: Print
Locate 10, 34: Print "-"
Locate 10, 40: Print "-"
For tic = 1 To 10
Locate tic, 30: Print "TIC"
_Delay .1
Locate tic, 30: Print " "
Next tic
Locate 10, 30: Print "TIC"
For tac = 20 To 10 Step -1
Locate tac, 36: Print "TAC"
_Delay .1
Locate tac, 36: Print " "
Next tac
Locate 10, 36: Print "TAC"
For toe = 1 To 10
Locate toe, 42: Print "TOE"
_Delay .1
Locate toe, 42: Print " "
Next toe
Locate 10, 42: Print "TOE"
computer = 0
you = 0
Print: Print: Print
Print " By SierraKen"
Print: Print: Print
Print " Play against the computer in this classic game of Tic-Tac-Toe."
Print " Whoever gets 3 in a row wins."
Print
Print " Choose a sqace by using your mouse."
Print " Computer chooses who goes first."
Color _RGB32(255, 255, 255), _ClearColor
_PrintString (220, 430), "Click Here To Start"
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Do
_Limit 60
mouseWheel = 0
Do While _MouseInput
mouseX = _MouseX
mouseY = _MouseY
mouseLeftButton = _MouseButton(1)
mouseRightButton = _MouseButton(2)
mouseMiddleButton = _MouseButton(3)
mouseWheel = mouseWheel + _MouseWheel
Loop
ag$ = InKey$
If ag$ = Chr$(27) Then End
If ag$ = " " Then Cls: GoTo start:
If mouseLeftButton = -1 And mouseX > 220 And mouseX < 370 And mouseY > 430 And mouseY < 446 Then Cls: GoTo start:
Loop
start:
ag$ = ""
t = 0
turn = 0
comp = 0
For cc = 0 To 480
cl = cl + .5
Line (0, cc)-(640, cc), _RGB32(0, 0, cl)
Next cc
cl = 0
Randomize Timer
c1 = Int(Rnd * 155) + 100
c2 = Int(Rnd * 155) + 100
c3 = Int(Rnd * 155) + 100
GoSub grid:
whosfirst:
Randomize Timer
first = Int(Rnd * 2) + 1
If first = 1 Then GoTo computerchoice:
Go:
_Limit 60
a$ = InKey$
If a$ = Chr$(27) Then End
mouseWheel = 0
Do While _MouseInput
mouseX = _MouseX
mouseY = _MouseY
mouseLeftButton = _MouseButton(1)
mouseRightButton = _MouseButton(2)
mouseMiddleButton = _MouseButton(3)
mouseWheel = mouseWheel + _MouseWheel
Loop
If mouseLeftButton = -1 Then
If mouseX > 88 And mouseX < 218 And mouseY > 93 And mouseY < 182 And b(1) = 0 And a(1) = 0 And t = 0 Then GoSub space1:
If mouseX > 241 And mouseX < 357 And mouseY > 93 And mouseY < 182 And b(2) = 0 And a(2) = 0 And t = 0 Then GoSub space2:
If mouseX > 381 And mouseX < 509 And mouseY > 93 And mouseY < 182 And b(3) = 0 And a(3) = 0 And t = 0 Then GoSub space3:
If mouseX > 88 And mouseX < 218 And mouseY > 205 And mouseY < 302 And b(4) = 0 And a(4) = 0 And t = 0 Then GoSub space4:
If mouseX > 241 And mouseX < 357 And mouseY > 205 And mouseY < 302 And b(5) = 0 And a(5) = 0 And t = 0 Then GoSub space5:
If mouseX > 381 And mouseX < 509 And mouseY > 205 And mouseY < 302 And b(6) = 0 And a(6) = 0 And t = 0 Then GoSub space6:
If mouseX > 88 And mouseX < 218 And mouseY > 326 And mouseY < 410 And b(7) = 0 And a(7) = 0 And t = 0 Then GoSub space7:
If mouseX > 241 And mouseX < 357 And mouseY > 326 And mouseY < 410 And b(8) = 0 And a(8) = 0 And t = 0 Then GoSub space8:
If mouseX > 381 And mouseX < 509 And mouseY > 326 And mouseY < 410 And b(9) = 0 And a(9) = 0 And t = 0 Then GoSub space9:
End If
If mouseLeftButton = -1 And ending = 1 Then GoTo start:
If mouseRightButton = -1 And ending = 1 Then End
If t = 1 Then GoSub computer:
GoTo Go:
checkwin:
'Check to see if you won.
If a(1) = 1 And a(2) = 1 And a(3) = 1 Then GoTo won:
If a(4) = 1 And a(5) = 1 And a(6) = 1 Then GoTo won:
If a(7) = 1 And a(8) = 1 And a(9) = 1 Then GoTo won
If a(1) = 1 And a(4) = 1 And a(7) = 1 Then GoTo won:
If a(2) = 1 And a(5) = 1 And a(8) = 1 Then GoTo won:
If a(3) = 1 And a(6) = 1 And a(9) = 1 Then GoTo won:
If a(1) = 1 And a(5) = 1 And a(9) = 1 Then GoTo won:
If a(3) = 1 And a(5) = 1 And a(7) = 1 Then GoTo won:
turn = turn + 1
Sound 100, .25
If turn = 9 Then GoTo catsgame:
GoTo Go:
won:
For snd = 300 To 900 Step 50
Sound snd, .5
Next snd
For tt = 1 To 9
a(tt) = 0
b(tt) = 0
Next tt
you = you + 1
you$ = Str$(you)
computer$ = Str$(computer)
_Title "You: " + you$ + " Computer: " + comp$
t = 0
Color _RGB32(255, 0, 0), _ClearColor
Locate 2, 32: Print "Y O U W I N ! !"
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
GoTo playagain:
computer:
'Check to win.
'Last space gone.
If b(1) = 1 And b(2) = 1 And a(3) = 0 And b(3) = 0 Then GoTo compspace3:
If b(4) = 1 And b(5) = 1 And a(6) = 0 And b(6) = 0 Then GoTo compspace6:
If b(7) = 1 And b(8) = 1 And a(9) = 0 And b(9) = 0 Then GoTo compspace9:
If b(1) = 1 And b(4) = 1 And a(7) = 0 And b(7) = 0 Then GoTo compspace7:
If b(2) = 1 And b(5) = 1 And a(8) = 0 And b(8) = 0 Then GoTo compspace8:
If b(3) = 1 And b(6) = 1 And a(9) = 0 And b(9) = 0 Then GoTo compspace9:
If b(1) = 1 And b(5) = 1 And a(9) = 0 And b(9) = 0 Then GoTo compspace9:
If b(3) = 1 And b(5) = 1 And a(7) = 0 And b(7) = 0 Then GoTo compspace7:
'First space gone.
If b(2) = 1 And b(3) = 1 And a(1) = 0 And b(1) = 0 Then GoTo compspace1:
If b(5) = 1 And b(6) = 1 And a(4) = 0 And b(4) = 0 Then GoTo compspace4:
If b(8) = 1 And b(9) = 1 And a(7) = 0 And b(7) = 0 Then GoTo compspace7:
If b(4) = 1 And b(7) = 1 And a(1) = 0 And b(1) = 0 Then GoTo compspace1:
If b(5) = 1 And b(8) = 1 And a(2) = 0 And b(2) = 0 Then GoTo compspace2:
If b(6) = 1 And b(9) = 1 And a(3) = 0 And b(3) = 0 Then GoTo compspace3:
If b(5) = 1 And b(9) = 1 And a(1) = 0 And b(1) = 0 Then GoTo compspace1:
If b(7) = 1 And b(5) = 1 And a(3) = 0 And b(3) = 0 Then GoTo compspace3:
'Middle space gone.
If b(1) = 1 And b(3) = 1 And a(2) = 0 And b(2) = 0 Then GoTo compspace2:
If b(4) = 1 And b(6) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
If b(7) = 1 And b(9) = 1 And a(8) = 0 And b(8) = 0 Then GoTo compspace8:
If b(1) = 1 And b(7) = 1 And a(4) = 0 And b(4) = 0 Then GoTo compspace4:
If b(2) = 1 And b(8) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
If b(3) = 1 And b(9) = 1 And a(6) = 0 And b(6) = 0 Then GoTo compspace6:
If b(1) = 1 And b(9) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
If b(3) = 1 And b(7) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
'Check to block.
'Last space gone.
If a(1) = 1 And a(2) = 1 And a(3) = 0 And b(3) = 0 Then GoTo compspace3:
If a(4) = 1 And a(5) = 1 And a(6) = 0 And b(6) = 0 Then GoTo compspace6:
If a(7) = 1 And a(8) = 1 And a(9) = 0 And b(9) = 0 Then GoTo compspace9:
If a(1) = 1 And a(4) = 1 And a(7) = 0 And b(7) = 0 Then GoTo compspace7:
If a(2) = 1 And a(5) = 1 And a(8) = 0 And b(8) = 0 Then GoTo compspace8:
If a(3) = 1 And a(6) = 1 And a(9) = 0 And b(9) = 0 Then GoTo compspace9:
If a(1) = 1 And a(5) = 1 And a(9) = 0 And b(9) = 0 Then GoTo compspace9:
If a(3) = 1 And a(5) = 1 And a(7) = 0 And b(7) = 0 Then GoTo compspace7:
'First space gone.
If a(2) = 1 And a(3) = 1 And a(1) = 0 And b(1) = 0 Then GoTo compspace1:
If a(5) = 1 And a(6) = 1 And a(4) = 0 And b(4) = 0 Then GoTo compspace4:
If a(8) = 1 And a(9) = 1 And a(7) = 0 And b(7) = 0 Then GoTo compspace7:
If a(4) = 1 And a(7) = 1 And a(1) = 0 And b(1) = 0 Then GoTo compspace1:
If a(5) = 1 And a(8) = 1 And a(2) = 0 And b(2) = 0 Then GoTo compspace2:
If a(6) = 1 And a(9) = 1 And a(3) = 0 And b(3) = 0 Then GoTo compspace3:
If a(5) = 1 And a(9) = 1 And a(1) = 0 And b(1) = 0 Then GoTo compspace1:
If a(7) = 1 And a(5) = 1 And a(3) = 0 And b(3) = 0 Then GoTo compspace3:
'Middle space gone.
If a(1) = 1 And a(3) = 1 And a(2) = 0 And b(2) = 0 Then GoTo compspace2:
If a(4) = 1 And a(6) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
If a(7) = 1 And a(9) = 1 And a(8) = 0 And b(8) = 0 Then GoTo compspace8:
If a(1) = 1 And a(7) = 1 And a(4) = 0 And b(4) = 0 Then GoTo compspace4:
If a(2) = 1 And a(8) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
If a(3) = 1 And a(9) = 1 And a(6) = 0 And b(6) = 0 Then GoTo compspace6:
If a(1) = 1 And a(9) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
If a(3) = 1 And a(7) = 1 And a(5) = 0 And b(5) = 0 Then GoTo compspace5:
'Computer decides a random space.
computerchoice:
Randomize Timer
comp = Int(Rnd * 9) + 1
If b(comp) = 1 Then GoTo computerchoice:
If a(comp) = 1 Then GoTo computerchoice:
If comp = 1 Then GoTo compspace1:
If comp = 2 Then GoTo compspace2:
If comp = 3 Then GoTo compspace3:
If comp = 4 Then GoTo compspace4:
If comp = 5 Then GoTo compspace5:
If comp = 6 Then GoTo compspace6:
If comp = 7 Then GoTo compspace7:
If comp = 8 Then GoTo compspace8:
If comp = 9 Then GoTo compspace9:
'Cat's Game
catsgame:
For snd = 400 To 300 Step -25
Sound snd, .5
Next snd
For tt = 1 To 9
a(tt) = 0
b(tt) = 0
Next tt
t = 0
Color _RGB32(255, 0, 255), _ClearColor
Locate 2, 29: Print "Cat's Game - No Winners"
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
GoTo playagain:
'Check to see if the computer won.
check:
If b(1) = 1 And b(2) = 1 And b(3) = 1 Then GoTo compwon:
If b(4) = 1 And b(5) = 1 And b(6) = 1 Then GoTo compwon:
If b(7) = 1 And b(8) = 1 And b(9) = 1 Then GoTo compwon
If b(1) = 1 And b(4) = 1 And b(7) = 1 Then GoTo compwon:
If b(2) = 1 And b(5) = 1 And b(8) = 1 Then GoTo compwon:
If b(3) = 1 And b(6) = 1 And b(9) = 1 Then GoTo compwon:
If b(1) = 1 And b(5) = 1 And b(9) = 1 Then GoTo compwon:
If b(3) = 1 And b(5) = 1 And b(7) = 1 Then GoTo compwon:
turn = turn + 1
If turn = 9 Then GoTo catsgame:
t = 0
GoTo Go:
compwon:
For snd = 900 To 300 Step -50
Sound snd, .5
Next snd
For tt = 1 To 9
a(tt) = 0
b(tt) = 0
Next tt
t = 0
computer = computer + 1
you$ = Str$(you)
comp$ = Str$(computer)
_Title "You: " + you$ + " Computer: " + comp$
Color _RGB32(128, 255, 255), _ClearColor
Locate 2, 33: Print "Computer Wins"
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
GoTo playagain:
'This part draws the computer's circle.
compspace1:
t = 0
b(1) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (160 - xx, 140 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoSub grid:
GoTo check:
compspace2:
t = 0
b(2) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (300 - xx, 140 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoSub grid:
GoTo check:
compspace3:
t = 0
b(3) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (440 - xx, 140 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoSub grid:
GoTo check:
compspace4:
t = 0
b(4) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (160 - xx, 260 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoSub grid:
GoTo check:
compspace5:
t = 0
b(5) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (300 - xx, 260 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoSub grid:
GoTo check:
compspace6:
t = 0
b(6) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (440 - xx, 260 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoSub grid:
GoTo check:
compspace7:
t = 0
b(7) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (160 - xx, 375 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoTo check:
compspace8:
t = 0
b(8) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (300 - xx, 375 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoTo check:
compspace9:
t = 0
b(9) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Circle (440 - xx, 375 - xx), 40 - s, _RGB32(255 - (xx * 10), 0, 0)
Next s
Next xx
GoTo check:
'This last part draws your X.
space1:
a(1) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (115 + s - xx, 104 - xx)-(195 + s - xx, 169 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (195 + s - xx, 104 - xx)-(115 + s - xx, 169 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space2:
a(2) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (255 + s - xx, 104 - xx)-(335 + s - xx, 169 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (335 + s - xx, 104 - xx)-(255 + s - xx, 169 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space3:
a(3) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (395 + s - xx, 104 - xx)-(475 + s - xx, 169 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (475 + s - xx, 104 - xx)-(395 + s - xx, 169 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space4:
a(4) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (110 + s - xx, 224 - xx)-(190 + s - xx, 289 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (190 + s - xx, 224 - xx)-(110 + s - xx, 289 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space5:
a(5) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (255 + s - xx, 224 - xx)-(335 + s - xx, 289 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (335 + s - xx, 224 - xx)-(255 + s - xx, 289 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space6:
a(6) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (395 + s - xx, 224 - xx)-(475 + s - xx, 289 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (475 + s - xx, 224 - xx)-(395 + s - xx, 289 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space7:
a(7) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (110 + s - xx, 339 - xx)-(190 + s - xx, 404 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (190 + s - xx, 339 - xx)-(110 + s - xx, 404 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space8:
a(8) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (255 + s - xx, 339 - xx)-(335 + s - xx, 404 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (335 + s - xx, 339 - xx)-(255 + s - xx, 404 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
space9:
a(9) = 1
For xx = .1 To 10 Step .1
For s = .25 To 10 Step .25
Line (395 + s - xx, 339 - xx)-(475 + s - xx, 404 - xx), _RGB32(0, 255 - (xx * 10), 0)
Line (475 + s - xx, 339 - xx)-(395 + s - xx, 404 - xx), _RGB32(0, 255 - (xx * 10), 0)
Next s
Next xx
t = 1
GoTo checkwin:
playagain:
Color _RGB32(255, 0, 0), _ClearColor
_PrintString (220, 55), "Click Here To Play Again"
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Do
_Limit 60
mouseWheel = 0
Do While _MouseInput
mouseX = _MouseX
mouseY = _MouseY
mouseLeftButton = _MouseButton(1)
mouseRightButton = _MouseButton(2)
mouseMiddleButton = _MouseButton(3)
mouseWheel = mouseWheel + _MouseWheel
Loop
ag$ = InKey$
If ag$ = Chr$(27) Then End
If ag$ = " " Then Cls: GoTo start:
If mouseLeftButton = -1 And mouseX > 220 And mouseX < 412 And mouseY > 55 And mouseY < 69 Then Cls: GoTo start:
Loop
grid:
'Draw Grid
'Vertical Lines
For xx = .1 To 15 Step .1
Line (220 - xx, 100 - xx)-(240 - xx, 410 - xx), _RGB32(c1 - (xx * 10), c2 - (xx * 10), c3 - (xx * 10)), BF
Line (360 - xx, 100 - xx)-(380 - xx, 410 - xx), _RGB32(c1 - (xx * 10), c2 - (xx * 10), c3 - (xx * 10)), BF
Next xx
For xx = .1 To 15 Step .1
'Horizontal Lines
Line (90 - xx, 185 - xx)-(510 - xx, 205 - xx), _RGB32(c1 - (xx * 10), c2 - (xx * 10), c3 - (xx * 10)), BF
Line (90 - xx, 305 - xx)-(510 - xx, 325 - xx), _RGB32(c1 - (xx * 10), c2 - (xx * 10), c3 - (xx * 10)), BF
Next xx
Return
I tried to install Inform, but when I run the setup file, it tries to download files and the server is unreachable. I downloaded the source files on Github and extracted them to my QB64 folder. Although the inform design program works, nothing else works in QB64. I get error message after error message. Who knows how to solve this? Is there an installer that contains all the files?
'ants!!!
' a program by James D. Jarvis
'just some ants made with the draw command running about
'press any key to quit
_Title "ANTS!!!"
Screen _NewImage(800, 500, 256)
'_FullScreen
Dim Shared ant$, ax(100), ay(100), am(100), aa(100), ascl(100), aklr(100)
loadCMYK
Color 20, 145
Cls
ant$ = "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2bm-3,+0e5g5f5h5u5d10u6dg5e5h5"
For a = 1 To 100
ax(a) = 100 - Int(Rnd * 100)
ay(a) = Int(Rnd * 300) + 100
am(a) = Int(Rnd * 3) + 2
aa(a) = Int(Rnd * 10) - Int(Rnd * 10)
ascl(a) = Int(Rnd * 6) + 3
aklr(a) = 20 - Int(Rnd * 4)
Next a
ro = _Pi / 180
Do
_Limit 30
Cls
For a = 1 To 100
If Rnd * 6 > 4 Then
ax(a) = ax(a) + ascl(a) * Sin((aa(a) + 90) * ro)
ay(a) = ay(a) + ascl(a) * Cos((aa(a) + 90) * ro)
If ax(a) < -20 Or ax(a) > 850 Then
ax(a) = 0 - (Int(Rnd * 10) + 5)
ay(a) = Int(Rnd * 300) + 100
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
If ay(a) < -10 Or ay(a) > 650 Then
ay(a) = Int(Rnd * 300) + 100
ax(a) = 0 - (Int(Rnd * 10) + 5)
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
End If
dant aa(a), aklr(a), ascl(a), ax(a), ay(a)
dc = Int(Rnd * 20) + 1
Select Case dc
Case 1 TO 3
aa(a) = aa(a) - (Int(Rnd * 6) + 2)
Case 4 TO 17
Case 18 TO 20
aa(a) = aa(a) + (Int(Rnd * 6) + 2)
End Select
Next a
aa$ = InKey$
_Display
Loop Until aa$ <> ""
System
Sub dant (ang, klr, scl, x, y)
Draw "s" + Str$(scl)
PSet (x, y)
Draw "c" + Str$(klr) + "ta" + Str$(ang) + ant$
End Sub
Sub pal_cmyk (pk, c, m, y, k)
' create a 256 color palette entry using CMYK
' CMYK process color Cyan, Magenta, Yellow, Black each expressed as a percent from 0 to 100
r = 255 * (100 - c)
r = (r / 100) * ((100 - k) / 100)
g = 255 * (100 - m)
g = (g / 100) * ((100 - k) / 100)
b = 255 * (100 - y)
b = (b / 100) * ((100 - k) / 100)
_PaletteColor pk, _RGB32(r, g, b)
End Sub
Sub loadCMYK
'builing a cmyk pallete
klr = 0
c = 0
m = 0
y = 0
k = 0
For klr = 0 To 255
Select Case klr
Case 1 TO 20
k = k + 5
c = 0
m = 0
y = 0
Case 21 TO 40
k = 0
c = c + 5
m = 0
y = 0
Case 41 TO 60
k = 0
c = 0
m = m + 5
y = 0
Case 61 TO 80
k = 0
c = 0
m = 0
y = y + 5
Case 81 TO 100
k = 0
c = c + 5
m = m + 5
y = 0
Case 101 TO 120
k = 0
c = c + 5
m = 0
y = y + 5
Case 121 TO 140
k = 0
c = 0
m = m + 5
y = y + 5
Case 121 TO 140
k = 20
c = c + 5
m = m + 5
y = 0
Case 141 TO 160
k = 20
c = c + 5
m = 0
y = y + 5
Case 161 TO 180
k = 20
c = 0
m = m + 5
y = y + 5
Case 181 TO 200
k = 40
c = c + 5
m = m + 5
y = 0
Case 201 TO 220
k = 40
c = c + 5
m = 0
y = y + 5
Case 221 TO 240
k = 40
c = 0
m = m + 5
y = y + 5
Case 241 TO 255
k = 10 + (klr - 240) * 4
c = 0
m = 100
y = y + 5
End Select
pal_cmyk klr, c, m, y, k
Color 0, klr
Next klr
End Sub
The Mandelbrot set is another example of mathematical chaos and there is much enjoyment to be had by examining it. From wikipedia:
"The Mandelbrot set is the set of complex numbers c for which the function z=z^2+c does not diverge to infinity when iterated from z=0."
There are many programs which show the set and zoom into the set and there is an infinity of patterns and much similarity.
This program shows the orbit (iterations) of the function for one mouse-selected number c. For a number in the set, the function can slowly or rapidly converge to one number, or it can oscillate/rotate among many numbers. For numbers not in the set, the function can slowly or rapidly go off to infinity. The numbers near the edge of the set make the most complex patterns.
Const xlo = -2.4, xhi = .8, ylo = -1.2, yhi = 1.2
Dim Shared imx, imy, imDn, imClk, imEnd, iImgSave
Dim mx, my
doCreate ' create the image
iImgSave = _CopyImage(0) ' save
Do ' wait for mouse input
_Limit 30
MouseCk
uv2xy imx, imy, mx, my
Color 15, 8
Locate 2, 3: Print "mx,my: ";: Print Using "##.##,##.##"; mx; my
Locate , 3: Print "Black: Mandelbrot set (remains local)"
Locate , 3: Print "Gray: Not Mandelbrot (goes to infinity)"
Locate , 3: Print "Yellow: Not Mandelbrot (almost remains local)"
Locate , 3: Print "Press left button to get orbit"
Locate , 3: Print "ESC to exit"
If imClk Then doOrbit ' upon Click, show orbit
If InKey$ = Chr$(27) Then System
Loop
Sub doCreate () ' draw mandelbrot set
Dim i, iu, iv, x0, y0, x, y, xx, yy, ic
For iv = 0 To 766 ' screen horiz
For iu = 0 To 1023 ' screen vert
uv2xy iu, iv, x0, y0 ' get x0,y0
x = 0: y = 0 ' start at 0, 0
For i = 0 To 1000 ' 1000 max iterations
xx = x * x - y * y + x0 ' (x, y) squared + (x0, y0)
yy = 2 * x * y + y0
If xx * xx + yy * yy > 4 Then Exit For ' not in set
x = xx: y = yy ' for next iteration
Next i
ic = 8 ' not in set
If i > 20 Then ic = 14 ' yellow, almost in set
If i = 1001 Then ic = 0 ' black, in set
PSet (iu, iv), ic
Next iu
Next iv
End Sub
Sub doOrbit () ' show orbit
Dim i, x0, y0, x, y, xx, yy, iu, iv
PSet (imx, imy), 15 ' orbit start
uv2xy imx, imy, x0, y0 ' get x0,y0
x = 0: y = 0 ' start at 0, 0
For i = 0 To 1000 ' 1000 max iterations
_Limit 30
MouseCk
If imEnd Then GoTo zreset
xx = x * x - y * y + x0 ' (x, y) squared + (x0, y0)
yy = 2 * x * y + y0
xy2uv xx, yy, iu, iv
Line -(iu, iv), 15
If xx * xx + yy * yy > 50 Then Exit For ' not in set
x = xx: y = yy ' for next iteration
Next i
Do: _Limit 30: MouseCk: Loop Until imEnd
zreset:
_PutImage , iImgSave, 0 ' reset
End Sub
Sub uv2xy (iu, iv, x, y) ' screen u, v to world x, y
x = lerplh(xlo, xhi, iu, 0, 1023)
y = lerplh(ylo, yhi, iv, 766, 0)
End Sub
Sub xy2uv (x, y, iu, iv) ' world x, y to screen u, v
iu = lerplh(0, 1023, x, xlo, xhi)
iv = lerplh(766, 0, y, ylo, yhi)
End Sub
Function lerplh (xlo, xhi, y, ylo, yhi) ' linear interpolation
Dim k01: k01 = (y - ylo) / (yhi - ylo) ' get k01
lerplh = xlo * (1 - k01) + xhi * k01
End Function
Sub MouseCk () ' Mouse routine
Static imPrev ' previous time Down?
imClk = 0: imEnd = 0 ' down, up edges
Do While _MouseInput: Loop ' clear
imx = _MouseX: imy = _MouseY: imDn = _MouseButton(1) ' now
If imDn Then
If Not imPrev Then imClk = -1 ' down edge
Else
If imPrev Then imEnd = -1 ' up edge
End If
imPrev = imDn ' for next time
End Sub
But with a procedure (Sub) it worked.
It uses the mouse and it randomly picks who goes first. ![[Image: Win-error-2.jpg]](https://i.ibb.co/H7yvMQC/Win-error-2.jpg)
![[Image: Ackermann-Absturz2022-07-15.jpg]](https://i.ibb.co/Pzx0DfG/Ackermann-Absturz2022-07-15.jpg)
![[Image: jpg1.jpg]](https://i.ibb.co/gmBhjb2/jpg1.jpg)
