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
Here is a modification (mod) of B+'s "Basic Polygon and Multiplier Mod" of snowflakes falling down. He probably has made this before but I thought I would try it myself.
Thanks B+!
Code: (Select All)
'Snowflakes - mod from B+'s Basic Polygon and Multiplier Mod
'b+ 2022-07-13, SierraKen 2022-07-13
Dim xc(500), yc(500), r(500), n(500), x(500), y(500)
' a circle is 360 degree
' a polyon of n side has central angles 360 / n > think of a pie the central angle are the angle of slices in center
Screen _NewImage(800, 600, 32)
_ScreenMove 350, 100
Randomize Timer
Do
_Limit 30
If Rnd > .25 Then
t = t + 1
If t > 495 Then t = 0
xc(t) = Rnd * _Width
yc(t) = 1
r(t) = Rnd * 20
n(t) = Int(Rnd * 10) + 3
End If
For tt = 1 To t
yc(tt) = yc(tt) + 1
For m = 1 To n(tt) - 1
For angle = 0 To 720 Step 360 / n(tt) ' step the size of pie angles
' let xC, yC be the coordinates at the center of the pie circle
' let r be the radius of the pie
' then the n outside points are
x(tt) = xc(tt) + r(tt) * Cos(m * _D2R(angle) - _Pi / 2) ' x coordinate of outter edge point
y(tt) = yc(tt) + r(tt) * Sin(m * _D2R(angle) - _Pi / 2) ' y coordinate of outter edge point
If angle = 0 Then PSet (x(tt), y(tt)) Else Line -(x(tt), y(tt)) ' outter edge edge
Line (xc(tt), yc(tt))-(x(tt), y(tt)) ' slice from center of pie
Next
Next m
Next tt
_Display
Cls
Loop Until InKey$ = Chr$(27)
B+ mentioned prime numbers in my "Make Shapes" thread so I decided to see how I could make a long list of them. I tried a few times on my own but I couldn't figure it out so I found code on a QBasic page on Google. I added the URL in the code. Their page only lets people type a number to see if it's a Prime Number or not so I just listed them with the same code pretty much and added a bit of my own. When it almost fills up a page, it asks if you want to see more which you can do so by pressing the Space Bar, or Esc to quit. It ends at 50,021. I noticed my computer slows down a little bit in the 40,000 range. Am not sure why it does that since I dimmed the number as a double and put the _LIMIT at 3000. Anyway, enjoy the numbers.
Code: (Select All)
'Prime Numbers up to 50,021.
'Thank you to: https://seeqbasicomputer.blogspot.com/2016/10/check-prime-or-composite-number-qbasic.html
Dim n As Double
Screen _NewImage(800, 600, 32)
_Title "Prime Numbers from 2 to 50,021."
Do
_Limit 3000
n = n + 1
c = 0
For I = 1 To n
If n Mod I = 0 Then c = c + 1 'If there's no remainder from n / I, c = c + 1.
Next I
If c = 2 Then Print n; " "; 'If there's no more than n / 1 and n / n then it's a prime number.
If n > 50021 Then
Print
Print "Limit Finished."
End
End If
If n / 3000 = Int(n / 3000) Then
Print
Print "Press Space Bar for more or Esc to finish."
Do
a$ = InKey$
If a$ = " " Then Cls: GoTo more:
If a$ = Chr$(27) Then End
Loop
End If
more:
Loop
Really 2 utilities a CMYK palette builder for 256 color modes (easily adapted to other indexed modes)
and a number of print commands for default text using _PRINTSTRING but using text sized columns and rows for coordinates.
Code: (Select All)
' build a 256 color CMYK palette
' a variety of print subroutines using default text with coordinates as text row and column
Screen _NewImage(800, 500, 256)
Dim Shared klr
'build a CMYK palette
loadCMYK ' this routine builds a cmyk pallette
Color 20, 0
Cls
'demonstartion of text command within program
pat 1, 2, "Hello"
cpat 1, 4, "Color text", 0, 20
pato 1, 6, "Over text", "_"
cpato 1, 8, "Over Color Text", 0, 15, "-", 78
Vpat 2, 10, "Vertical"
CVpat 4, 10, "Color Vertical", 0, 10
CVpato 6, 10, "Over Color Vertical", 0, 15, "ð", 66
Vpato 8, 10, "Hello", 0, 10, "_"
boxtext 10, 10, "Box", "*", 1
cboxtext 20, 10, "Color BOX", "+", 2, 0, 100
cboxtexto 20, 20, "Color OVER BOX", "+", 2, 0, 100, "°", 18
fillboxt 50, 20, " Fill Box ", "+", 1, 0, 100, "°", 18, 8
Locate 25, 60
Input a$
Cls
fillboxt 1, 1, " Sample CMYK Palette", "*", 1, 0, 18, "°", 18, 8
Locate 4, 1
For klr = 0 To 255
Color 20, klr
If klr > 13 And klr < 21 Then Color 0, klr
Print " "; klr; " ";
Next
Color 20, 0
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 pat (c, r, txt$)
'print txt$ at colooum c and row r
cc = (c - 1) * 8
rr = (r - 1) * 16
_PrintString (cc, rr), txt$
End Sub
Sub cpat (c, r, txt$, fk, bk)
obk = _BackgroundColor
ofk = _DefaultColor
Color fk, bk
cc = (c - 1) * 8
rr = (r - 1) * 16
_PrintString (cc, rr), txt$
Color ofk, obk
End Sub
Sub Vpat (c, r, txt$)
'Vertical print at
cc = (c - 1) * 8
rr = (r - 1) * 16
n = Len(txt$)
For p = 1 To n
r2 = rr + ((p - 1) * 16)
_PrintString (cc, r2), Mid$(txt$, p, 1)
Next
End Sub
Sub CVpat (c, r, txt$, fk, bk)
'Vertical print at
obk = _BackgroundColor
ofk = _DefaultColor
Color fk, bk
cc = (c - 1) * 8
rr = (r - 1) * 16
n = Len(txt$)
For p = 1 To n
r2 = rr + ((p - 1) * 16)
_PrintString (cc, r2), Mid$(txt$, p, 1)
Next
Color ofk, obk
End Sub
Sub pato (c, r, txt$, ch$)
'print txt$ at colooum c and row r of charcter ch$
' this saves and restores the program default printomode so the user does not have to redefine it"
pm = _PrintMode
cc = (c - 1) * 8
rr = (r - 1) * 16
ll = Len(txt$)
_PrintMode _FillBackground
For c2 = cc To (cc + (ll - 1) * 8)
_PrintString (c2, rr), ch$
Next c2
_PrintMode _KeepBackground
_PrintString (cc, rr), txt$
Select Case pm
Case 1
_PrintMode _KeepBackground
Case 2
_PrintMode _OnlyBackground
Case 3
_PrintMode _FillBackground
End Select
End Sub
Sub cpato (c, r, txt$, fk, bk, ch$, ck)
'princt colored text over character ch$ which is in color ck
pm = _PrintMode
obk = _BackgroundColor
ofk = _DefaultColor
cc = (c - 1) * 8
rr = (r - 1) * 16
ll = Len(txt$)
Color ck, bk
_PrintMode _FillBackground
For c2 = cc To (cc + (ll - 1) * 8)
_PrintString (c2, rr), ch$
Next c2
_PrintMode _KeepBackground
Color fk, bk
_PrintString (cc, rr), txt$
Select Case pm
Case 1
_PrintMode _KeepBackground
Case 2
_PrintMode _OnlyBackground
Case 3
_PrintMode _FillBackground
End Select
Color ofk, obk
End Sub
Sub CVpato (c, r, txt$, fk, bk, ch$, ck)
'Vertical print at
pm = _PrintMode
obk = _BackgroundColor
ofk = _DefaultColor
Color ck, bk
_PrintMode _FillBackground
cc = (c - 1) * 8
rr = (r - 1) * 16
n = Len(txt$)
For p = 1 To n
r2 = rr + ((p - 1) * 16)
_PrintString (cc, r2), ch$
Next
_PrintMode _KeepBackground
Color fk, bk
For p = 1 To n
r2 = rr + ((p - 1) * 16)
_PrintString (cc, r2), Mid$(txt$, p, 1)
Next
Select Case pm
Case 1
_PrintMode _KeepBackground
Case 2
_PrintMode _OnlyBackground
Case 3
_PrintMode _FillBackground
End Select
Color ofk, obk
End Sub
Sub Vpato (c, r, txt$, fk, bk, ch$)
'Vertical print at
pm = _PrintMode
_PrintMode _FillBackground
cc = (c - 1) * 8
rr = (r - 1) * 16
n = Len(txt$)
For p = 1 To n
r2 = rr + ((p - 1) * 16)
_PrintString (cc, r2), ch$
Next
_PrintMode _KeepBackground
For p = 1 To n
r2 = rr + ((p - 1) * 16)
_PrintString (cc, r2), Mid$(txt$, p, 1)
Next
Select Case pm
Case 1
_PrintMode _KeepBackground
Case 2
_PrintMode _OnlyBackground
Case 3
_PrintMode _FillBackground
End Select
End Sub
Sub boxtext (c, r, txt$, b$, bb)
'printboxed text at column,row, b$ is hte border character,bb is the border buffer in character size
n = Len(txt$)
bw = n + (bb * 2)
bh = 1 + (bb * 2)
rr = (r - 1) * 16
For cc = c To c + bw
_PrintString ((cc - 1) * 8, rr), b$
_PrintString ((cc - 1) * 8, rr + (bh - 1) * 16), b$
Next
c1 = (c - 1) * 8
c2 = (c + bw) * 8
For rr = r To (r + bh - 1)
_PrintString (c1, (rr - 1) * 16), b$
_PrintString (c2, (rr - 1) * 16), b$
Next rr
cc = (c + bb) * 8
rr = (r + bb - 1) * 16
_PrintString (cc, rr), txt$
End Sub
Sub cboxtext (c, r, txt$, b$, bb, fk, bk)
'printboxed text at column,row, b$ is hte border character,bb is the border buffer in character size
obk = _BackgroundColor
ofk = _DefaultColor
Color fk, bk
n = Len(txt$)
bw = n + (bb * 2)
bh = 1 + (bb * 2)
For cc = c To c + bw
For rr = r To (r + bh - 1)
_PrintString ((cc - 1) * 8, (rr - 1) * 16), " "
Next
Next
rr = (r - 1) * 16
For cc = c To c + bw
_PrintString ((cc - 1) * 8, rr), b$
_PrintString ((cc - 1) * 8, rr + (bh - 1) * 16), b$
Next
c1 = (c - 1) * 8
c2 = (c + bw) * 8
For rr = r To (r + bh - 1)
_PrintString (c1, (rr - 1) * 16), b$
_PrintString (c2, (rr - 1) * 16), b$
Next rr
cc = (c + bb) * 8
rr = (r + bb - 1) * 16
_PrintString (cc, rr), txt$
Color ofk, obk
End Sub
Sub cboxtexto (c, r, txt$, b$, bb, fk, bk, o$, ock)
'printboxed text at column,row, b$ is hte border character,bb is the border buffer in character size
obk = _BackgroundColor
ofk = _DefaultColor
pm = _PrintMode
_PrintMode _FillBackground
n = Len(txt$)
bw = n + (bb * 2)
bh = 1 + (bb * 2)
Color ock, bk
For cc = c To c + bw
For rr = r To (r + bh - 1)
_PrintString ((cc - 1) * 8, (rr - 1) * 16), o$
Next
Next
Color fk, bk
rr = (r - 1) * 16
For cc = c To c + bw
_PrintString ((cc - 1) * 8, rr), b$
_PrintString ((cc - 1) * 8, rr + (bh - 1) * 16), b$
Next
c1 = (c - 1) * 8
c2 = (c + bw) * 8
For rr = r To (r + bh - 1)
_PrintString (c1, (rr - 1) * 16), b$
_PrintString (c2, (rr - 1) * 16), b$
Next rr
cc = (c + bb) * 8
rr = (r + bb - 1) * 16
_PrintMode _KeepBackground
_PrintString (cc, rr), txt$
Color ofk, obk
Select Case pm
Case 1
_PrintMode _KeepBackground
Case 2
_PrintMode _OnlyBackground
Case 3
_PrintMode _FillBackground
End Select
End Sub
Sub fillboxt (c, r, txt$, b$, bb, fk, bk, o$, ock, rate)
'box text with a marque fill style that runs once
obk = _BackgroundColor
ofk = _DefaultColor
pm = _PrintMode
n = Len(txt$)
bw = n + (bb * 2)
bh = 1 + (bb * 2)
For x = 1 To n
_Limit rate
_PrintMode _FillBackground
Color ock, bk
For cc = c To c + bw
For rr = r To (r + bh - 1)
_PrintString ((cc - 1) * 8, (rr - 1) * 16), o$
Next
Next
Color fk, bk
rr = (r - 1) * 16
For cc = c To c + bw
_PrintString ((cc - 1) * 8, rr), b$
_PrintString ((cc - 1) * 8, rr + (bh - 1) * 16), b$
Next
c1 = (c - 1) * 8
c2 = (c + bw) * 8
For rr = r To (r + bh - 1)
_PrintString (c1, (rr - 1) * 16), b$
_PrintString (c2, (rr - 1) * 16), b$
Next rr
cc = (c + bb) * 8 + (n - x) * 8
rr = (r + bb - 1) * 16
_PrintMode _KeepBackground
_PrintString (cc, rr), Mid$(txt$, 1, x)
Next x
Color ofk, obk
Select Case pm
Case 1
_PrintMode _KeepBackground
Case 2
_PrintMode _OnlyBackground
Case 3
_PrintMode _FillBackground
End Select
End Sub
Sub loadCMYK
'builing a cmyk palete
'this paletteuses set of colors in 20 incremental
klr = 0
c = 0
m = 0
y = 0
k = 0
For klr = 0 To 255
Select Case klr
Case 1 TO 20 'lightest grey to black in 5% increments
k = k + 5
c = 0
m = 0
y = 0
Case 21 TO 40 'cyan on white in 5% increments
k = 0
c = c + 5
m = 0
y = 0
Case 41 TO 60 'magenta on white in 5% increments
k = 0
c = 0
m = m + 5
y = 0
Case 61 TO 80 'yellow on white in 5% increments
k = 0
c = 0
m = 0
y = y + 5
Case 81 TO 100 'cyan and magenta on white in 5% increments
k = 0
c = c + 5
m = m + 5
y = 0
Case 101 TO 120 'cyan and yellow on white in 5% increments
k = 0
c = c + 5
m = 0
y = y + 5
Case 121 TO 140 'magenta and yellow on white in 5% increments
k = 0
c = 0
m = m + 5
y = y + 5
Case 121 TO 140 'cyan and magenta in 5% increments with 20% black
k = 20
c = c + 5
m = m + 5
y = 0
Case 141 TO 160 'cyan and yellow in 5% increments with 20% black
k = 20
c = c + 5
m = 0
y = y + 5
Case 161 TO 180 'magenta and yellow in 5% increments with 20% black
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
Print " "; klr; " ";
Next klr
End Sub
I finally got around to fixing the AI to make it unbeatable in Tic Tac Toe. Hear that ARB? UNBEATABLE ;-))
Here is a screen shot:
Simply 9 buttons on the screen with message box comments thrown in as needed so as to not spoil the board setup.
In the snap you see the listing of the zip file which includes the fixed Tic Tac Toe with AI code I updated today before converting it to GUI.
Here is what the code looks like for GUI (without the BI/BM).
Code: (Select All)
Option _Explicit
' _Title "GUI Tic Tac Toe with AI" ' b+ 2022-07-12 try GUI version with fixed AI and a Btn Array!
' Needs fixing https://www.youtube.com/watch?v=5n2aQ3UQu9Y
' you start at corner
' they AI play middle to at least tie
' you play opposite corner
' they or AI plays corner will loose!!! I am saying in AI always play corner is not always right!!!
' they have to play side to just tie
'
' 2022-07-12 finally got around to fixing this program
' 2022-07-12 Now try it out with vsGUI, can I use an array of control handles? Yes.
'$include:'vs GUI.BI'
' Set Globals from BI your Title here VVV
Xmax = 502: Ymax = 502: GuiTitle$ = "GUI Tic-Tac-Toe with AI"
OpenWindow Xmax, Ymax, GuiTitle$, "ARLRDBD.TTF"
Dim Shared As Long Btn(0 To 8) ' our 9 buttons for the game
Dim As Long x, y, i
For y = 0 To 2 ' yes in, vs GUI, we Can have arrays of controls!!!
For x = 0 To 2
Btn(i) = NewControl(1, x * 175 + 1, y * 175 + 1, 150, 150, 120, 600, 668, "")
i = i + 1
Next
Next ' that's all for the GUI
' one time sets
Dim Shared Player$, AI$, Turn$, Winner$
Dim Shared As Long PlayerStarts, Count, Done
Dim Shared board$(2, 2) 'store X and O here 3x3
Player$ = "X": AI$ = "O": PlayerStarts = 0
ResetGame
MainRouter
Sub ResetGame
Dim As Long i, rc, bx, by
Winner$ = "": Count = 0: Done = 0: Erase board$ 'reset
For i = 0 To 8
con(Btn(i)).Text = ""
drwBtn i + 1, 0
Next
PlayerStarts = 1 - PlayerStarts
If PlayerStarts Then Turn$ = Player$ Else Turn$ = AI$
If Turn$ = AI$ Then
rc = AIchoice
con(rc + 1).Text = AI$
bx = rc Mod 3: by = Int(rc / 3)
board$(bx, by) = AI$
_Delay 3 'let player think AI is thinking
drwBtn rc + 1, 0
Count = Count + 1
'If checkwin Then Winner$ = AI$
Turn$ = Player$
mBox "The AI has started the next game.", "It's your turn."
'now wait for MainRouter to detect a Button click
End If
End Sub
Function checkwin
Dim As Long i
For i = 0 To 2
If (board$(0, i) = board$(1, i) And board$(1, i) = board$(2, i)) And (board$(2, i) <> "") Then checkwin = 1: Exit Function
Next
For i = 0 To 2
If (board$(i, 0) = board$(i, 1) And board$(i, 1) = board$(i, 2)) And board$(i, 2) <> "" Then checkwin = 1: Exit Function
Next
If (board$(0, 0) = board$(1, 1) And board$(1, 1) = board$(2, 2)) And board$(2, 2) <> "" Then checkwin = 1: Exit Function
If (board$(0, 2) = board$(1, 1) And board$(1, 1) = board$(2, 0)) And board$(2, 0) <> "" Then checkwin = 1
End Function
Function AIchoice
Dim As Long r, c
'test all moves to win
For r = 0 To 2
For c = 0 To 2
If board$(c, r) = "" Then
board$(c, r) = AI$
If checkwin Then
board$(c, r) = ""
AIchoice = 3 * r + c
Exit Function
Else
board$(c, r) = ""
End If
End If
Next
Next
'still here? then no winning moves for AI, how about for player$
For r = 0 To 2
For c = 0 To 2
If board$(c, r) = "" Then
board$(c, r) = Player$
If checkwin Then
board$(c, r) = ""
AIchoice = 3 * r + c 'spoiler move!
Exit Function
Else
board$(c, r) = ""
End If
End If
Next
Next
'still here? no winning moves, no spoilers then is middle sq available
If board$(1, 1) = "" Then AIchoice = 4: Exit Function
' one time you dont want a corner when 3 moves made human has opposite corners, then defense is any side!
If (board$(0, 0) = Player$ And board$(2, 2) = Player$) Or (board$(2, 0) = Player$ And board$(0, 2) = Player$) Then
' try a side order?
If board$(1, 0) = "" Then AIchoice = 1: Exit Function
If board$(0, 1) = "" Then AIchoice = 3: Exit Function
If board$(2, 1) = "" Then AIchoice = 5: Exit Function
If board$(1, 2) = "" Then AIchoice = 7: Exit Function
'still here still? how about a corner office?
If board$(0, 0) = "" Then AIchoice = 0: Exit Function
If board$(2, 0) = "" Then AIchoice = 2: Exit Function
If board$(0, 2) = "" Then AIchoice = 6: Exit Function
If board$(2, 2) = "" Then AIchoice = 8: Exit Function
Else
'still here still? how about a corner office?
If board$(0, 0) = "" Then AIchoice = 0: Exit Function
If board$(2, 0) = "" Then AIchoice = 2: Exit Function
If board$(0, 2) = "" Then AIchoice = 6: Exit Function
If board$(2, 2) = "" Then AIchoice = 8: Exit Function
'still here??? a side order then!
If board$(1, 0) = "" Then AIchoice = 1: Exit Function
If board$(0, 1) = "" Then AIchoice = 3: Exit Function
If board$(2, 1) = "" Then AIchoice = 5: Exit Function
If board$(1, 2) = "" Then AIchoice = 7: Exit Function
End If
End Function
Sub BtnClickEvent (i As Long) ' Basically the game is played here with player's button clicks
Dim As Long rc, bx, by
' note Btn(0) = 1, Btn(1) = 2...
rc = i - 1 ' from control number to button number
bx = rc Mod 3: by = Int(rc / 3) ' from button number to board$ x, y location
If board$(bx, by) = "" Then ' update board, check win, call AI for it's turn, update board, check win
con(i).Text = Player$
drwBtn i, 0
board$(bx, by) = Player$
If checkwin Then
mBox "And the Winner is", "You! Congratulations AI was supposed to be unbeatable."
ResetGame
Else
Count = Count + 1
If Count >= 9 Then
mBox "Out of Spaces:", "The Game is a draw."
ResetGame
Else ' run the ai
rc = AIchoice
con(rc + 1).Text = AI$
bx = rc Mod 3: by = Int(rc / 3)
board$(bx, by) = AI$
_Delay 1 'let player think AI is thinking
drwBtn rc + 1, 0
If checkwin Then
mBox "And the Winner is", "AI, the AI is supposed to be unbeatable."
ResetGame
Else
Count = Count + 1
If Count >= 9 Then
mBox "Out of Spaces:", "The Game is a draw."
ResetGame
Else
Turn$ = Player$
End If
End If
End If
End If
Else
Beep: mBox "Player Error:", "That button has already been played."
End If
End Sub
' this is to keep MainRouter in, vs GUI.BM, happy =========================================
Sub LstSelectEvent (control As Long)
Select Case control
End Select
End Sub
Sub PicClickEvent (i As Long, Pmx As Long, Pmy As Long)
Select Case i
End Select
End Sub
Sub PicFrameUpdate (i As Long)
Select Case i
End Select
End Sub
Hi, I have just recently found my program needs to print out some of the results on paper. I much prefer to print to the screen however now find I can compare present results better if I had a printed copy of the past results. I was sure I'd be able to search our site for hints on this topic but wasn't able to find a clue as to what I'm missing in the code I have picked up from the WIKI.
If you can see where I may be going wrong, thanks in advance for your help. This code I'm using is printing a BLACK page on my printer and I can't tell if it is printing the test phrase or not.
Code: (Select All)
'NOTE: THIS ROUTINE DOESN'T WORK ... SUPPOSTED HAVE A WHITE BACKGROUND BUT GETTING AN ALL BLACK INK PAGE
'Printing on the Printer - an example using "_PrintImage" command
'Assumes a menu where an option to print to printer is the letter "p" or "P"
a$ = "P"
Text$ = "The Rain in Spain falls mainly in the Plain."
PRINT
PRINT
PRINT Text$ 'This text is printing to the screen ok
IF a$ = "p" OR a$ = "P" THEN
IF img& <> 0 THEN _FREEIMAGE (img&)
_DEST Page& ' This is meant to capture the PRINTER data, making the size of the print the same size as the typical paper found in the printer and set the focus to the printer
CLS , _RGB32(255, 255, 255) ' Insterestingly, this CLS does not Clear the computer screen but setting the RGB color to white seems to NEED Cls plus the comma, _RGB(255,255,255) on it's own generates an error
' according to the _PRINTIMAGE wiki , this line sets a white background
'.....I think things go wrong from here on down. .....
_DEST 0 ' This is supposed to set the focus on the computer screen
_PRINTSTRING (1, 1), Text$ 'This re-writes the phrase to the computer screen, so the phrase is written once at line 22 and again here
img& = _COPYIMAGE(0) ' This is supposed to capture the computer screen where the phrase is written twice
_PRINTIMAGE img& ' this command is supposed to send the img just captured to the printer
_DELAY 5
I made this as an inspiration to B+'s a few years ago. It shows 17 different polygons in order, in random color, layered in giant circles. It changes every 2 seconds and loops back to 3 sides after 20 sides. Thanks B+ for helping me get this far.
Code: (Select All)
'Polygon Artwork
'Thanks to B+ for the inspiration to make this.
Dim cl As Long
Screen _NewImage(800, 600, 32)
sides = 3
Do
Locate 1, 1: Print "Sides: "; sides
st = Int(360 / sides)
cl = _RGB32(255 * Rnd, 255 * Rnd, 255 * Rnd)
x = 250
y = 300
For tt = 0 To 360 Step 10
For deg = 0 + tt To 360 + tt Step st
oldx = x
oldy = y
For t = 1 To 40 Step .25
x = (Sin(_D2R(deg)) * t) + oldx
y = (Cos(_D2R(deg)) * t) + oldy
Circle (x, y), 1, cl
Next t
Next deg
Next tt
sides = sides + 1
If sides > 20 Then sides = 3
_Delay 2
_Display
Cls
Loop Until InKey$ = Chr$(27)
Now that I'm learning degrees, I decided to make a shape maker today. You type in how many sides you want, from 3 to 100 and what basic color (15 to choose from) you want and if you want it filled-in or not. Then it makes the shape. It makes it with a white background so you can press C to copy it to the clipboard and paste it to your favorite graphics program.
Code: (Select All)
Dim img As Long
Dim cl As Long
Screen _NewImage(800, 600, 32)
start:
_Title "Shape Maker by SierraKen"
x = 400
y = 300
fill = 0
Cls
again:
Print: Print: Print
Input "Number Of Sides (3-100): ", sides
If sides > 100 Then Print "Too many, type between 3 to 100.": GoTo again:
If sides < 3 Then Print "Too few, type between 3 to 100.": GoTo again:
again2:
Print
Print "(1) Red"
Print "(2) Green"
Print "(3) Blue"
Print "(4) Purple"
Print "(5) Pink"
Print "(6) Orange"
Print "(7) Brown"
Print "(8) Gray"
Print "(9) Black"
Print "(10) Yellow"
Print "(11) Sky Blue"
Print "(12) Tan"
Print "(13) Light Green"
Print "(14) Light Red"
Print "(15) Dark Yellow"
Print
Input "Type color here (1-15): ", c
If c < 1 Or c > 15 Or Int(c) <> c Then Print "Type 1-15 only, without decimals.": GoTo again2:
If c = 1 Then cl = _RGB32(255, 0, 0)
If c = 2 Then cl = _RGB32(0, 255, 0)
If c = 3 Then cl = _RGB32(0, 0, 255)
If c = 4 Then cl = _RGB32(188, 0, 255)
If c = 5 Then cl = _RGB32(255, 0, 255)
If c = 6 Then cl = _RGB32(255, 122, 0)
If c = 7 Then cl = _RGB32(183, 83, 0)
If c = 8 Then cl = _RGB32(127, 127, 127)
If c = 9 Then cl = _RGB32(0, 0, 0)
If c = 10 Then cl = _RGB32(255, 255, 0)
If c = 11 Then cl = _RGB32(0, 255, 255)
If c = 12 Then cl = _RGB32(222, 150, 127)
If c = 13 Then cl = _RGB32(89, 255, 0)
If c = 14 Then cl = _RGB32(255, 0, 83)
If c = 15 Then cl = _RGB32(255, 188, 67)
Print
Input "Do you wish to have the shape filled in (Y/N)"; yn$
If Left$(yn$, 1) = "y" Or Left$(yn$, 1) = "Y" Then fill = 1
Cls
_Title "Shape Maker - C copies to clipboard, Space Bar starts over, Esc quits"
Paint (0, 0), _RGB32(255, 255, 255)
st = 360 / sides
For deg = 0 To 360 Step st
deg2 = 90 + deg
'Plot 300 points with equations.
oldx = x
oldy = y
For t = 1 To 800 / sides Step .25
x = (Sin(_D2R(deg2)) * t) + oldx
y = (Cos(_D2R(deg2)) * t) + oldy
Circle (x - 400 / sides, y), 1, cl
Next t
Next deg
If fill = 1 Then Paint (400, 250), cl
Do
a$ = InKey$
If a$ = Chr$(27) Then End
If a$ = " " Then GoTo start:
If a$ = "c" Or a$ = "C" Then
If img <> 0 Then _FreeImage (img&)
img& = _CopyImage(0)
_ClipboardImage = img&
Locate 1, 1: Print "Image Copied To Clipboard."
End If
Loop
![[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)
![[Image: Snowflakes.png]](https://i.ibb.co/SBG5rNg/Snowflakes.png)
![[Image: Shape-Maker-by-Sierra-Ken.jpg]](https://i.ibb.co/PMh91Hc/Shape-Maker-by-Sierra-Ken.jpg)
