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
I put this together in just 1 1/2 hours tonight without knowing any equations, just some knowledge about the Circle command's radians that I've used before. This doesn't make circles, except for the line it makes using circles. What it does is make a graph of the degrees you punch in. For example, if you punch in 90, it will make a thick line going straight up. If you punch in 180 it will make a thick line going to the left, and so on. It also writes out the degrees next to the line. Plus I added printer support so you can print out the picture if you wish to on your printer. When it uses the printer, I made it so the background is white and the graphics are black and the thick line is blue. I've wanted to make this since I started programming in BASIC in the 1980's. Amazing I figured it out all by myself this time. Feel free to use any of this in your own code of course. I might try some artwork with it sometime. Everything in the app is self-explanatory. Enjoy.
'Degrees Graph Plotter by SierraKen
'Made on July 11, 2022
Screen _NewImage(800, 800, 32)
Dim img As Long
start:
_Title "Degrees Graph Plotter by SierraKen"
Cls
Print "Degrees Graph Plotter"
Print: Print
Print "By SierraKen"
Print: Print: Print
Print "This app will plot a graph from the degrees you give it."
Print "It can also print it on a printer by pressing P."
Print "To do another one, just press the Space Bar."
Print "To quit, press the Esc key."
Print: Print: Print: Print
Input "Type Degrees Here: ", deg
start2:
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Cls
'Vertical and Horizontal dashes.
For vert = 0 To 780 Step 20
Line (400, vert)-(400, vert + 10), _RGB32(255, 255, 255)
Next vert
For horiz = 0 To 800 Step 20
Line (horiz, 400)-(horiz + 10, 400), _RGB32(255, 255, 255)
Next horiz
'Add 90 degrees to your amount for degrees to radians below.
deg = 90 + deg
'Plot 300 points with equations.
For t = 0 To 300
x = (Sin(_D2R(deg)) * t) + 400
y = (Cos(_D2R(deg)) * t) + 400
Circle (x, y), 2, _RGB32(0, 255, 0)
Next t
deg$ = Str$(deg - 90) + " Degrees"
_PrintString (x + 10, y + 20), deg$
'Wait to see if you want more.
_Title "Press P to Print on Paper, Space Bar for another Degree, or Esc to Quit,"
Do
a$ = InKey$
If a$ = Chr$(27) Then End
If a$ = " " Then GoTo start:
'Printing on the Printer
If a$ = "p" Or a$ = "P" Then
If img& <> 0 Then _FreeImage (img&)
Cls
Paint (0, 0), _RGB32(255, 255, 255)
'Vertical and Horizontal dashes.
For vert = 0 To 780 Step 20
Line (400, vert)-(400, vert + 10), _RGB32(0, 0, 0)
Next vert
For horiz = 0 To 800 Step 20
Line (horiz, 400)-(horiz + 10, 400), _RGB32(0, 0, 0)
Next horiz
'Plot 300 points with equations.
For t = 0 To 300
x = (Sin(_D2R(deg)) * t) + 400
y = (Cos(_D2R(deg)) * t) + 400
Circle (x, y), 2, _RGB32(0, 0, 255)
Next t
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
deg$ = Str$(deg - 90) + " Degrees"
_PrintString (x + 10, y + 20), deg$
img& = _CopyImage(0)
_PrintImage img&
_Delay 5
deg = deg - 90
GoTo start2:
End If
Loop
GoTo start:
![[Image: Ackermann-Absturz2022-07-15.jpg]](https://i.ibb.co/Pzx0DfG/Ackermann-Absturz2022-07-15.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)
![[Image: Degrees-Plotter-by-Sierra-Ken.jpg]](https://i.ibb.co/vjsdJnJ/Degrees-Plotter-by-Sierra-Ken.jpg)
