Is there a (simple) way to define a new single character in QB64, without changing to a different character-set?
I need a vertical line (like |) but in the right-hand column of the character-space. I know I can use graphics (Pset and Draw) to do this but this doesn't seem to render correctly on different screen resolutions.
Mastermind is a logic game (I believe it's still available). The object it to deduce a hidden code of six different color buttons using responses to one's guesses. A black button means a color is in the correct position, a whit button means a color is correct but in the wrong position.
Recently I decided to dust this off to experiment with QB64PE graphics and mouse ops. I originally wrote this as a text mode game for my TRS-80.
Enjoy, and feel free to offer constructive criticisms.
Code: (Select All)
' File: Mastermind.bas
' Purpose: An implementation of the classic board game Mastermind
' Create Date: 07/27/2022
' Revised: 01/23/2023
' Rev 1.0
OPTION _EXPLICIT
OPTION BASE 1
_TITLE "MASTERMIND"
TYPE Button
x AS INTEGER 'x coord
y AS INTEGER 'y coord
r AS INTEGER 'radius
c AS _UNSIGNED LONG 'color
END TYPE
CONST TRUE = -1
CONST FALSE = 0
DIM AS INTEGER ix, iz 'general purpose integer variables
DIM SHARED AS INTEGER NumGuesses, GameOver, GameWon
DIM SHARED AS Button Buttons(1 TO 8, 1 TO 13)
DIM AS INTEGER mx, my
DIM AS _UNSIGNED LONG ChosenColor
DIM AS STRING Message
'------------------------------------------------------------------------------
CLS
ix = _MESSAGEBOX("MASTERMIND", "Welcome to Mastermind. Do you need instructions?", "yesno", "question")
IF ix = 1 THEN ShowInstructions
'The game starts here
DO
InitButtons
DrawBoard
MakeCode
NumGuesses = 1: GameOver = FALSE: GameWon = FALSE: ChosenColor = 0
_LIMIT 30
'the loop for gathering and processing guesses starts here
DO
DO WHILE _MOUSEINPUT
IF _MOUSEBUTTON(1) THEN
mx = _MOUSEX: my = _MOUSEY
EXIT DO
END IF
LOOP
DO WHILE _MOUSEINPUT: LOOP 'clean the mouse buffer
SELECT CASE my
CASE 380 TO 400 'click is on the guess button row
IF ChosenColor <> 0 THEN 'a color is selected
SELECT CASE mx
CASE 30 TO 50
'first button
Buttons(1, 12).c = ChosenColor
ChosenColor = 0
ShowButton 1, 12
ClearHighlights
CASE 60 TO 80
'second button
Buttons(2, 12).c = ChosenColor
ChosenColor = 0
ShowButton 2, 12
ClearHighlights
CASE 90 TO 110
'third button
Buttons(3, 12).c = ChosenColor
ChosenColor = 0
ShowButton 3, 12
ClearHighlights
CASE 120 TO 140
Buttons(4, 12).c = ChosenColor
ChosenColor = 0
ShowButton 4, 12
ClearHighlights
END SELECT
END IF
CASE 445 TO 455
'on the color select row
IF ChosenColor = 0 THEN
SELECT CASE mx
CASE 75 TO 85
ChosenColor = RED
ClearHighlights
HighlightButton 1, 13
CASE 105 TO 115
ChosenColor = GREEN
ClearHighlights
HighlightButton 2, 13
CASE 135 TO 145
ChosenColor = BLUE
ClearHighlights
HighlightButton 3, 13
CASE 165 TO 175
ChosenColor = YELLOW
ClearHighlights
HighlightButton 4, 13
CASE 195 TO 205
ChosenColor = MAGENTA
ClearHighlights
HighlightButton 5, 13
CASE 225 TO 235
ChosenColor = CYAN
ClearHighlights
HighlightButton 6, 13
END SELECT
END IF
END SELECT
'test for keystrokes
iz = _KEYHIT
IF iz = 27 THEN END '<ESC> pressed, it's absolute.
IF iz = 71 OR iz = 103 THEN CheckGuess
IF GameWon = TRUE OR GameOver = TRUE THEN EXIT DO
LOOP
'check for end of game
FOR ix = 1 TO 4
ShowButton ix, 11
NEXT ix
IF GameWon = TRUE THEN Message = "You WIN! Play again?"
IF GameOver = TRUE THEN Message = "You lose. Try again?"
IF _MESSAGEBOX("MASTERMIND", Message, "yesno", "question") = 0 THEN END
LOOP
'end of game code
'------------------------------------------------------------------------------
SUB DrawBoard
DIM AS INTEGER ix, iy
'-- the previous guesses
COLOR WHITE, GRAY
CLS
PRINT " GUESSES RESPONSES": PRINT
FOR iy = 1 TO 10
PRINT iy: PRINT
FOR ix = 1 TO 8
ShowButton ix, iy
NEXT ix
NEXT iy
LINE (25, 343)-(145, 377), LIGHTGRAY, B
_PRINTSTRING (170, 352), "THE CODE"
FOR ix = 1 TO 4
ShowButton ix, 12
NEXT ix
_PRINTSTRING (170, 384), "YOUR GUESS"
FOR ix = 1 TO 6
ShowButton ix, 13
NEXT ix
LOCATE 31, 1: COLOR CYAN
PRINT "Click on a color and then click"
PRINT "on a guess button. You can click"
PRINT "as many times as you want.": PRINT
PRINT "Press <G> when you are ready"
PRINT "to enter your guess."
PRINT "Press <ESC> to quit."
END SUB
'------------------------------------------------------------------------------
SUB InitButtons
DIM AS INTEGER ix, iy
'guess and response buttons
FOR ix = 1 TO 4
FOR iy = 1 TO 12 'guess buttons
Buttons(ix, iy).x = 40 + (30 * (ix - 1))
Buttons(ix, iy).y = 40 + (32 * (iy - 1))
Buttons(ix, iy).r = 10
Buttons(ix, iy).c = GRAY
NEXT iy
NEXT ix
FOR ix = 5 TO 8 'response buttons
FOR iy = 1 TO 12
Buttons(ix, iy).x = 150 + (15 * (ix - 1))
Buttons(ix, iy).y = 40 + ((iy - 1) * 32)
Buttons(ix, iy).r = 5
Buttons(ix, iy).c = GRAY
NEXT iy
NEXT ix
END SUB
'------------------------------------------------------------------------------
SUB ShowButton (x AS LONG, y AS LONG)
'x and y are indexes into the Buttons array
'the desired color must already be set
CIRCLE (Buttons(x, y).x, Buttons(x, y).y), Buttons(x, y).r, BLACK
PAINT STEP(0, 0), Buttons(x, y).c, BLACK
END SUB
'------------------------------------------------------------------------------
SUB HighlightButton (x AS LONG, y AS LONG)
CIRCLE (Buttons(x, y).x, Buttons(x, y).y), Buttons(x, y).r + 1, WHITE
END SUB
'------------------------------------------------------------------------------
SUB ClearHighlights
DIM AS INTEGER ix
FOR ix = 1 TO 6
CIRCLE (Buttons(ix, 13).x, Buttons(ix, 13).y), Buttons(ix, 13).r + 1, GRAY
NEXT ix
END SUB
'------------------------------------------------------------------------------
SUB ShowInstructions
COLOR CYAN, GRAY
CLS
PRINT "The game is MASTERMIND. The object is"
PRINT "to guess a hidden code of colored"
PRINT "buttons. Choose any combination of"
PRINT "colors and submit a guess. You will"
PRINT "then see up to four responses. A black"
PRINT "response means you have a correct"
PRINT "color in the correct position. A white"
PRINT "response means you have a correct"
PRINT "color but in the wrong position. Use"
PRINT "your previous guesses and responses to"
PRINT "deduce the correct code.": PRINT
PRINT "Press any key to begin...": SLEEP
END SUB
'------------------------------------------------------------------------------
SUB MakeCode
DIM AS INTEGER ix, iy
RANDOMIZE TIMER
FOR ix = 1 TO 4
iy = INT(RND * 6) + 1
IF iy = 1 THEN Buttons(ix, 11).c = RED
IF iy = 2 THEN Buttons(ix, 11).c = GREEN
IF iy = 3 THEN Buttons(ix, 11).c = BLUE
IF iy = 4 THEN Buttons(ix, 11).c = YELLOW
IF iy = 5 THEN Buttons(ix, 11).c = MAGENTA
IF iy = 6 THEN Buttons(ix, 11).c = CYAN
NEXT ix
END SUB
'------------------------------------------------------------------------------
SUB CheckGuess
'look for matches and near misses
DIM AS _UNSIGNED LONG Code(1 TO 4)
DIM AS _UNSIGNED LONG Guess(1 TO 4)
DIM AS _UNSIGNED LONG Wipeout 'used to provide a unique number for each wipeout
DIM AS INTEGER ix, iy
DIM AS INTEGER Match, Almost
Match = 0: Almost = 0
GameWon = FALSE: GameOver = FALSE
'make temporary copies of the code and guess that we can wipe out
FOR ix = 1 TO 4
Code(ix) = Buttons(ix, 11).c
Guess(ix) = Buttons(ix, 12).c
NEXT ix
Wipeout = 0
'check exact matches first
FOR ix = 1 TO 4
IF Code(ix) = Guess(ix) THEN
Match = Match + 1
Code(ix) = Wipeout: Wipeout = Wipeout + 1
Guess(ix) = Wipeout: Wipeout = Wipeout + 1
END IF
NEXT ix
'now check right color, wrong position
FOR ix = 1 TO 4
FOR iy = 1 TO 4
IF Code(ix) = Guess(iy) THEN
Almost = Almost + 1
Code(ix) = Wipeout: Wipeout = Wipeout + 1
Guess(iy) = Wipeout: Wipeout = Wipeout + 1
END IF
NEXT iy
NEXT ix
'now set responses
IF Match > 0 THEN
FOR ix = 1 TO Match
Buttons(ix + 4, NumGuesses).c = BLACK
NEXT ix
END IF
IF Almost > 0 THEN
IF Match > 0 THEN iy = Match + 1 ELSE iy = 1
FOR ix = iy TO Match + Almost
Buttons(ix + 4, NumGuesses).c = WHITE
NEXT ix
END IF
'Show the guess and responses
FOR ix = 1 TO 4
Buttons(ix, NumGuesses).c = Buttons(ix, 12).c
NEXT ix
FOR ix = 1 TO 8
ShowButton ix, NumGuesses
NEXT ix
FOR ix = 1 TO 4
Buttons(ix, 12).c = GRAY
ShowButton ix, 12
NEXT ix
'final decisions and cleanup
IF Match = 4 THEN GameWon = TRUE
NumGuesses = NumGuesses + 1: IF NumGuesses = 11 THEN GameOver = TRUE
Pardon the ignorance of a newbie. I've been using QB64 off and on for years, I'm not really sure of it's relationship with QB64PE. I'm using what I think is the latest QB64 version 2.1, but I see the PE version is at 3.5.0?
Anyway, here is my issue:
Dragging and dropping into a BASIC program doesn't work on a Mac. So I have found it very useful to use the clipboard commands. I can easily find a file using Finder (the Mac equivalent of File Explorer) and copy it to the clipboard for my BASIC program to use. The problem I have is trying to extract the PATH information for the filename on the clipboard.
In Finder if you select files/folders, then right-click on them, you can copy them to the clipboard. But it doesn't copy the PATH information. But there is a way. Right-click on the files/folders. Instead of clicking on the "Copy" entry, hold down the [Option] key. "Copy" becomes "Copy as Pathnames". It copies the entire PATH and filename to the clipboard. If you are keyboard centric, use [Command]+[Option]+[C]. But there is a snag (bug?) with _CLIPBOARD$. It doesn't return all the data from the clipboard properly when there are file PATHs involved. Here is a simple program:
_CLIPBOARD$ = ""
PRINT "Copy the files to the clipboard."
DO UNTIL _CLIPBOARD$ <> ""
LOOP
CLS
PRINT _CLIPBOARD$
SLEEP
SYSTEM
If I select multiple files/folders in Finder, _CLIPBOARD$ returns all the titles (without the PATHs).
If I select multiple files/folders with their PATHs as described above, _CLIPBOARD$ only returns the first title. I know it contains all of them because I can paste to a blank document and they are all there with their PATHs.
For example, if I select the following files using “Copy Items”:
If I select them using “Copy Items As Pathnames”, _CLIPBOARD$ returns:
/Applications/QB64/Programs/File1.rtf
But if I paste the clipboard into a blank document I get:
/Applications/QB64/Programs/File1.rtf
/Applications/QB64/Programs/File2.txt
/Applications/QB64/Programs/File3.pdf
So I know the information is there, I just can't get to it. On a Mac the clipboard is loaded by either "Copy to clipboard" or "Copy path to clipboard", in either case QB64 should be able to read the contents of the clipboard.
Any help with this would be greatly appreciated...
' !!!!!!!!!!!!!!!!!!! Escape to Quit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Randomize Timer
Dim Shared xmax As Integer, ymax As Integer
xmax = _DesktopWidth
ymax = _DesktopHeight
Const nSpinners = 30
Type SpinnerType
x As Single
y As Single
dx As Single
dy As Single
a As Single
sz As Single
c As _Unsigned Long
End Type
Dim Shared s(1 To nSpinners) As SpinnerType
Type TypeSPRITE ' sprite definition ' for Terry's PixelCollide +++++++++++++++++++
image As Long ' sprite image
x1 As Integer ' upper left X
y1 As Integer ' upper left Y
x2 As Integer ' lower right X
y2 As Integer ' lower right Y
End Type
Type TypePOINT ' x,y point definition
x As Integer ' x coordinate
y As Integer ' y coordinate
End Type ' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dim power1, power2, power
Dim As Long i, imoved, j, iImg, jImg, lc, i2, sc
Dim As TypeSPRITE sIo, sJo
Dim intxy As TypePOINT
sc = _ScreenImage
Screen _NewImage(xmax, ymax, 32)
_FullScreen
For i = 1 To nSpinners
newSpinner i
Next
i2 = 1
While InKey$ <> Chr$(27)
_PutImage , sc, 0
lc = lc + 1
If lc Mod 100 = 99 Then
lc = 0
If i2 < nSpinners Then i2 = i2 + 1
End If
For i = 1 To i2
'PixelCollide (Obj1 As TypeSPRITE, Obj2 As TypeSPRITE, Intersect As TypePOINT)
If PixelCollide(sIo, sJo, intxy) Then '+++++++++++++++++++++++++++++++++++++++
'_SndPlay bump
Sound Rnd * 5000 + 1000, .1 * Rnd
If Rnd > .7 Then
imoved = 1
s(i).a = _Atan2(s(i).y - s(j).y, s(i).x - s(j).x)
s(j).a = _Atan2(s(j).y - s(i).y, s(j).x - s(i).x)
'update new dx, dy for i and j balls
power2 = (s(j).dy ^ 2 + s(j).dy ^ 2) ^ .5
power = (power1 + power2) / 2
s(i).dx = power * Cos(s(i).a)
s(i).dy = power * Sin(s(i).a)
s(j).dx = power * Cos(s(j).a)
s(j).dy = power * Sin(s(j).a)
s(i).x = s(i).x + s(i).dx
s(i).y = s(i).y + s(i).dy
s(j).x = s(j).x + s(j).dx
s(j).y = s(j).y + s(j).dy
Exit For
End If
End If
_FreeImage jImg
Next
If imoved = 0 Then
s(i).x = s(i).x + s(i).dx
s(i).y = s(i).y + s(i).dy
End If
If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i
'drawSpinner s(i).x, s(i).y, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c
_PutImage (s(i).x - 70, s(i).y - 70), iImg, 0
_FreeImage iImg
Next
_Display
_Limit 15
Wend
Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color?
Dim r
s(i).sz = Rnd * .25 + .5
If Rnd < .5 Then r = -1 Else r = 1
s(i).dx = (s(i).sz * Rnd * 8) * r * 2 + 2: s(i).dy = (s(i).sz * Rnd * 8) * r * 2 + 2
r = Int(Rnd * 4)
Select Case r
Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy
Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy
Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx
Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx
End Select
r = Rnd * 155 + 40
s(i).c = _RGB32(Rnd * .5 * r, r, Rnd * .25 * r)
End Sub
Sub drawSpinner (idest&, x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
Static switch As Integer
switch = switch + 2
switch = switch Mod 16 + 1
red = _Red32(c): green = _Green32(c): blue = _Blue32(c)
r = 10 * scale
x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
r = 2 * r 'lg lengths
For lg = 1 To 8
If lg < 5 Then
a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
Else
a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
End If
x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
drawLink idest&, x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
a1 = a + d * _Pi(1 / 12)
x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
drawLink idest&, x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
rd = Int(Rnd * 8) + 1
a2 = a1 + d * _Pi(1 / 8) * rd / 8
x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
drawLink idest&, x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
Next
r = r * .5
fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
fcirc x2, y2, r * .2, &HFF000000
x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
fcirc x2, y2, r * .2, &HFF000000
r = r * 2
x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
TiltedEllipseFill idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub
Sub drawLink (idest&, x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
a = _Atan2(y2 - y1, x2 - x1)
a1 = a + _Pi(1 / 2)
a2 = a - _Pi(1 / 2)
x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
fquad idest&, x3, y3, x4, y4, x5, y5, x6, y6, c
fcirc x1, y1, r1, c
fcirc x2, y2, r2, c
End Sub
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (idest&, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
ftri idest&, x1, y1, x2, y2, x4, y4, c
ftri idest&, x3, y3, x4, y4, x1, y1, c
End Sub
Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim a&
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest idest&
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
Dim prc As _Unsigned Long, tef As Long
prc = _RGB32(255, 255, 255, 255)
If a > b Then max = a + 1 Else max = b + 1
mx2 = max + max
tef = _NewImage(mx2, mx2)
_Dest tef
_Source tef 'point wont read without this!
For k = 0 To 6.2832 + .05 Step .1
i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
If k <> 0 Then
Line (lasti, lastj)-(i, j), prc
Else
PSet (i, j), prc
End If
lasti = i: lastj = j
Next
Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
For y = 0 To mx2
x = 0
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
xleft(y) = x
While Point(x, y) = prc And x < mx2
x = x + 1
Wend
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
Next
_Dest destHandle&
For y = 0 To mx2
If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
Next
_FreeImage tef
End Sub
Function PixelCollide (Obj1 As TypeSPRITE, Obj2 As TypeSPRITE, Intersect As TypePOINT)
'--------------------------------------------------------------------------------------------------------
'- Checks for pixel perfect collision between two rectangular areas. -
'- Returns -1 if in collision -
'- Returns 0 if no collision -
'- -
'- obj1 - rectangle 1 coordinates -
'- obj2 - rectangle 2 coordinates -
'---------------------------------------------------------------------
Dim x%, y%
Dim x1%, y1% ' upper left x,y coordinate of rectangular collision area
Dim x2%, y2% ' lower right x,y coordinate of rectangular collision area
Dim Test1& ' overlap image 1 to test for collision
Dim Test2& ' overlap image 2 to test for collision
Dim Hit% ' -1 (TRUE) if a collision occurs, 0 (FALSE) otherwise
Dim Osource& ' original source image handle
Dim p1~& ' alpha value of pixel on image 1
Dim p2~& ' alpha value of pixel on image 2
If Obj1.x2 >= Obj2.x1 Then ' rect 1 lower right X >= rect 2 upper left X ?
If Obj1.x1 <= Obj2.x2 Then ' rect 1 upper left X <= rect 2 lower right X ?
If Obj1.y2 >= Obj2.y1 Then ' rect 1 lower right Y >= rect 2 upper left Y ?
If Obj1.y1 <= Obj2.y2 Then ' rect 1 upper left Y <= rect 2 lower right Y ?
My computer's water cooler died so my computer can't function right now without major heat issues and throttling. No coding for me until I get it fixed, unfortunately. Also, no video until then. I actually had plans on doing it yesterday evening and that's when it broke.
Screen _NewImage(800, 600, 32)
Dim As Long block
block = _NewImage(80, 40, 32)
_Dest block
For y = 0 To 40
Line (0, y)-(100, y), midInk~&(80, 0, 0, 255, 100, 100, 1 - y / 40), BF
Next
_Dest 0
r = 230: a = 0
Do
x = 410 + r * 1.5 * Cos(a): y = 300 + r * Sin(a)
_PutImage (x - 50, y - 20), block, 0
a = a + .002
_Limit 1000
Loop Until a >= _Pi(2.47)
Well, yes, but this one has one or two features that I've never seen in other word-games, so at the risk of overloading this genre of Programs (and the mentalities of the non-lexophile group), here it is.
It's attached as a .zip file, with the dictionary folder Wordlists, which should be in the same folder as the .bas file.
Color 14: Locate 8, 38: Print "Worm": Print: Print Tab(22);: Color 15: Print " An original word-game by Phil Taylor"
Print
Color 14
Print Tab(17); "Would you like to read the instructions (Y/N) ?"
Instrs:
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
If k <> 78 And k <> 110 Then instructions
Cls
name$(1) = "PLAYER 1": name$(2) = "PLAYER 2": winscore = 200
Locate 10, 9
Print " Accept defaults PLAYER 1, PLAYER 2, Win-level 200 points (Y/N) ?"
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
If k = 89 Or k = 121 Then name$(1) = "PLAYER 1": name$(2) = "PLAYER 2": winscore = 200: GoTo SetUpGame
_KeyClear
wipe "10"
Locate 10, 10: Print "Name for first player (enter for default PLAYER 1): ";
Input n$
If Len(n$) > 1 Then name$(1) = UCase$(n$)
wipe "10"
Locate 10, 10: Print "Name for second player (enter for default PLAYER 2) ";
Input n$
If Len(n$) > 1 Then name$(2) = UCase$(n$)
wipe "10"
Locate 10, 13: Print "Winning score (1=100 to 9=900, enter for default 100):";
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
If k < 49 Or k > 57 Then winscore = 100 Else winscore = (k - 48) * 100
wipe "10"
NewWord:
If score(1) >= winscore Or score(2) >= winscore Then
Cls: Locate 10, 32: Print "We have a winner!"
Print: Print Tab(31); name$(1), score(1); Tab(31); name$(2), score(2)
Sleep
System
End If
wrd$ = Chr$(Int(Rnd * 26) + 65): csrh = 320 ' wrd$ is random letter at start
PlayerUp:
Color 14
Locate 1, 3: Print name$(1); Space$(4); score(1); Tab(30); name$(plr); " playing"; Tab(64); name$(2); Space$(4); score(2)
cut = Int((Len(wrd$) + 1) / 2): wrdpos = 40: picked = 0: flipped = 0 ' cut is number of letters at left of cursor, changes each time a letter is added
wipe "10"
Locate 10, wrdpos: Print wrd$
ShowChoices:
Color 14
Locate 1, 3: Print name$(1); Space$(4); score(1); Tab(34); name$(plr); " playing"; Tab(64); name$(2); Space$(4); score(2)
Locate 2, 33: Print "Winning Score:"; winscore
Color 15: Locate 14, 26: Print "A-Z to select a letter to add"
If picked = 0 Then Color 8
Locate 15, 6: Print "Use Left/Right arrows to change its position, then up-arrow to place it": Color 15
If Len(wrd$) < minsize Or flipped = 1 Then Color 8
Locate 16, 7: Print "1 to Claim a word 2 to Challenge a group": Color 15
If Len(wrd$) < minsize Or flipped = 1 Then Color 8
Locate 16, 53: Print "3 to Concede this round": Color 15
If Len(wrd$) < 2 Then Color 8
Locate 17, 27: Print "Down-arrow to flip the word": Color 15
Locate 18, 32: Print "Esc to close game"
Locate 19, 57: Print ""
Color 15: Locate 12, 40: Print "?"
Case 65 To 90, 97 To 122 ' letter
If picked = 0 Then ' as long as letter not already picked...
picked = 1
letr$ = UCase$(Chr$(choice))
Locate 12, 40: Print letr$
Locate 15, 6: Print "Use Left/Right arrows to change its position, then up-arrow to place it"
GoTo GetChoice
End If
Case Is = 19200 ' left
If picked = 0 Then GoTo GetChoice ' if no letter picked yet, ignore
If cut > 0 Then ' if csr not beyond left limit...
wipe "11" ' remove csr...
csrh = csrh - 8: cut = cut - 1 ' reposition cut position and csr
End If
GoTo GetChoice
Case Is = 19712 ' right
If picked = 0 Then GoTo GetChoice ' if no letter picked yet, ignore
If cut < Len(wrd$) Then ' if csr not beyond right limit...
wipe "11" ' remove csr...
csrh = csrh + 8: cut = cut + 1 ' reposition cut position and csr
End If
GoTo GetChoice
Case Is = 18432 ' up (place letter)
flipped = 0
If picked = 1 Then
wrd$ = Left$(wrd$, cut) + letr$ + Right$(wrd$, Len(wrd$) - cut)
cut = Int((Len(wrd$) + 1) / 2)
wrdpos = 41 - cut
Locate 10, wrdpos: Print wrd$
picked = 0: flipped = 0
wipe "111617 "
csrh = 320
Locate 12, 40: Print "?"
letr$ = ""
If plr = 1 Then plr = 2 Else plr = 1
wipe "14151719"
Color 15: Locate 12, 40: Print "?"
End If
GoTo ShowChoices
Case Is = 49 ' claim word
If Len(wrd$) >= minsize And flipped = 0 Then
wordval = 0
For a = 1 To Len(wrd$): wordval = wordval + a: Next
Locate 5, 35: Print "Points Value is"; wordval
DictionaryCheck:
If _DirExists("WordLists") Then
found = 0
srch$ = "WordLists/" + Left$(wrd$, 1) ' set up file to be searched for try$
Open srch$ For Input As #1
While Not EOF(1)
Input #1, dictword$
If UCase$(dictword$) = wrd$ Then
found = 1
Exit While
End If
Wend
Close #1
Else
Locate 6, 10: Print "Is this word accepted (y/n)"
_KeyClear: k = 0
While k < 1
k = _KeyHit
Wend
If k = 110 Then found = 0
End If
If found = 0 Then
wipe "0607"
Locate 7, 35: Color 12: Print wrd$; " not found!"
If plr = 1 Then plr = 2 Else plr = 1
score(plr) = score(plr) + wordval
Else score(plr) = score(plr) + wordval
End If
Locate 9, 30: Print name$(plr); " scores"; wordval; " points"
Sleep 2
wipe "050709"
Color 14
GoTo NewWord
Else
GoTo GetChoice
End If
Case Is = 50 ' challenge word
If Len(wrd$) >= minsize And flipped = 0 Then
found = 0
wordval = 0: tryval = 0
For a = 1 To Len(wrd$): wordval = wordval + a: Next
Locate 6, 30: Print name$(plr); " challenges this group!"
If plr = 1 Then plr = 2 Else plr = 1
Print Tab(15); name$(plr); " Please type a word that contains the group";
_KeyClear
Print Tab(35);: Color 15: Input try$
try$ = UCase$(try$)
If try$ < "A" Or try$ > "Z" Then GoTo BadTry
For a = 1 To Len(try$): tryval = tryval + a: Next
If tryval > wordval Then wordval = tryval
DictSearch:
If _DirExists("WordLists") Then
found = 0
srch$ = "WordLists/" + Left$(try$, 1) ' set up file to be searched for try$
Open srch$ For Input As #1
While Not EOF(1)
Input #1, dictword$
If UCase$(dictword$) = try$ Then
found = 1
Exit While
End If
Wend
Close #1
Else
Locate 6, 10: Print "Is this word accepted (y/n)"
_KeyClear: k = 0
While k < 1
k = _KeyHit
Wend
If k = 110 Then found = 0
End If
BadTry:
If found = 0 Then
wipe "07"
Locate 7, 35: Color 12: Print try$; " Not found!"
If plr = 1 Then plr = 2 Else plr = 1
score(plr) = score(plr) + wordval
Else score(plr) = score(plr) + wordval
End If
Locate 9, 30: Print name$(plr); " scores"; wordval; " points"
Sleep 2
wipe "060709"
Color 14
GoTo NewWord
Else
GoTo GetChoice
End If
Case Is = 51 ' concede word
If Len(wrd$) >= minsize And flipped = 0 Then
wipe "0607080914151719"
wordval = 0
For a = 1 To Len(wrd$): wordval = wordval + a: Next
Locate 6, 30: Print name$(plr); " concedes this round!"
If plr = 1 Then plr = 2 Else plr = 1
score(plr) = score(plr) + wordval
Locate 9, 30: Print name$(plr); " scores"; wordval; " points"
Sleep 2
wipe "0506070809"
Color 14
GoTo NewWord
Else
GoTo GetChoice
End If
GoTo NewWord
Case Is = 20480 ' flip word
If picked = 0 Then
If flipped = 1 Then GoTo GetChoice
Locate 17, 27: Color 8: Print "Down-arrow to flip the word": Color 15
reverse$ = ""
For a = Len(wrd$) To 1 Step -1
reverse$ = reverse$ + Mid$(wrd$, a, 1)
Next
wrd$ = reverse$
flipped = 1
cut = Int((Len(wrd$) + 1) / 2): wrdpos = 41 - cut
GoTo GetChoice
End If
Case Else
GoTo GetChoice
End Select
Sub instructions
Cls: Color 14
Print Tab(32); "Worm Instructions"
Color 15
Print " A random letter is presented, and the players take turns to add one letter to"
Print " it, building towards a word, but avoiding completing it. The letter may be"
Print " placed at either end, or anywhere inside the group, thus exending the "; Chr$(34); "Worm"; Chr$(34); "."
Print
Print " If a player recognizes a completed word they may claim it, and gain points."
Print " If successful, they gain points based on its length but if not, their opponent"
Print " gains the points."
Print " The group may also be Flipped (reversed) before adding the letter (the result"
Print " of the Flip can not be claimed as a word)."
Print
Print " If they suspect that the group is not part of a real word, they may challenge,"
Print " and their opponent must then type a complete word containing the group. If"
Print " they can"; Chr$(39); "t provide a real word, the challenger gains points based on either"
Print " the size of the group or the length of their attempt, whichever is greater."
Print
Print " If a player thinks that any word formed by continuing to expand the group will"
Print " cost points, they may concede, and their opponent gains points based on the"
Print " size of the group thus far. This can help to avoid losing even more points."
Print
Print " The game ends when one player reaches the pre-set winning score."
Color 14: Print Tab(28); "Press a key to continue."
Sleep
Cls
Print
End Sub
Sub wipe (ln$)
For a = 1 To Len(ln$) - 1 Step 2
Locate Val(Mid$(ln$, a, 2)): Print Space$(80)
Next
End Sub
Sub Keypress
End Sub
Sub DictSearch
wrd$ = try$
srch$ = "WordLists/" + Left$(wrd$, 1)
wipe "14151719"
Open srch$ For Input As #1
While Not EOF(1)
Input #1, dictword$
If UCase$(dictword$) = wrd$ Then
wipe "07"
Locate 7, 35: Color 14: Print wrd$; " found!"
found = 1
Exit While
End If
Wend
Close #1
End Sub
