This is a computer version of a very old wooden peg pyramid game. Everything is manual so please read the directions at the start page. If you have any questions, please ask. I would also like comments. I thought about making it non-manual with it detecting jumps, etc. but it would add a lot of programming time and I thought that it's good enough the way it is, just like the original. I think I saw someone make this, or something like this many months ago on the old forum, but I wanted to make my own version. I also know there's a lot of code here and better programmers could have made it a lot less, but I just kept it simple.
I hope you have fun with it!
Code: (Select All)
'Manual Pyramid Peg Game - by SierraKen"
'Made on August 7, 2022.
'This game only has the pegs and board, you have to use the mouse to control everything.
Screen _NewImage(600, 600, 32)
_Title "Manual Pyramid Peg Game - by SierraKen - Space Bar Resets - Esc Quits"
start:
_Limit 20
Cls
Print " Manual Pyramid Peg Game"
Print: Print
Print " By SierraKen"
Print: Print
Print "This game only has the pegs and board, you have to use the mouse to"
Print "control everything."
Print
Print "How To Play:"
Print "1. First remove one peg anywhere on the board."
Print "2. Then jump over an existing peg, using another existing peg,"
Print " onto an empty hole."
Print "3. First click the peg that you want to jump with to delete it"
Print " from that first hole."
Print "4. Then click the empty hole you are jumping into to add the peg."
Print "5. And then make sure and click the peg you jumped over to delete it."
Print "6. Keep doing this until you cannot jump over any others."
Print "7. To win the game you need to only have one peg left."
Print "8. You can only go in a straight line and cannot skip over other"
Print " holes or pegs."
Print "9. Space Bar resets the game."
Print "10. Esc ends the program."
Print: Print: Print
Print " Click This Screen With Your Mouse To Start."
Do
While _MouseInput: Wend
mouseLeftButton = _MouseButton(1)
If mouseLeftButton Then
Clear_MB 1
GoTo begin:
End If
Loop
Cls
For yy = 0 To 600
cc = cc + .2
Line (0, yy)-(600, yy), _RGB32(0, 0, cc)
Next yy
cc = 0
Line (300, 50)-(50, 550), _RGB32(200, 84, 0)
Line (300, 50)-(550, 550), _RGB32(200, 84, 0)
Line (50, 550)-(550, 550), _RGB32(200, 84, 0)
Paint (300, 52), _RGB32(200, 84, 0)
'Pegs
'Bottom Holes Left To Right.
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (150, 475), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (225, 475), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (300, 475), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (375, 475), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (450, 475), sz, _RGB32(cl, cl, cl)
Next sz
'Second Level Holes Left To Right
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (185, 400), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (260, 400), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (335, 400), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (410, 400), sz, _RGB32(cl, cl, cl)
Next sz
'Third Level Holes Left To Right
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (225, 325), sz, _RGB32(cl, cl, cl)
Next sz
cl = 244
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (300, 325), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (375, 325), sz, _RGB32(cl, cl, cl)
Next sz
'Fourth Level Holes Left To Right
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (265, 250), sz, _RGB32(cl, cl, cl)
Next sz
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (340, 250), sz, _RGB32(cl, cl, cl)
Next sz
'Top Level Hole
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (300, 175), sz, _RGB32(cl, cl, cl)
Next sz
Do
_Limit 20
a$ = InKey$
If a$ = Chr$(27) Then End
If a$ = " " Then GoTo start:
While _MouseInput: Wend
x = _MouseX
y = _MouseY
mouseLeftButton = _MouseButton(1)
If mouseLeftButton Then
Clear_MB 1
'First Bottom Level
If x > 135 And x < 165 And y > 460 And y < 490 And h1 = 0 Then
For sz = .25 To 15 Step .1
Circle (150, 475), sz, _RGB32(100, 50, 50)
Next sz
h1 = 1
x = -100
y = -100
cl = 255
End If
If x > 135 And x < 165 And y > 460 And y < 490 And h1 = 1 Then
cl = 255
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (150, 475), sz, _RGB32(cl, cl, cl)
Next sz
h1 = 0
x = -100
y = -100
cl = 255
End If
If x > 210 And x < 240 And y > 460 And y < 490 And h2 = 0 Then
For sz = .25 To 15 Step .1
Circle (225, 475), sz, _RGB32(105, 50, 50)
Next sz
h2 = 1
x = -100
y = -100
cl = 255
End If
If x > 210 And x < 240 And y > 460 And y < 490 And h2 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (225, 475), sz, _RGB32(cl, cl, cl)
Next sz
h2 = 0
x = -100
y = -100
cl = 255
End If
If x > 285 And x < 315 And y > 460 And y < 490 And h3 = 0 Then
For sz = .25 To 15 Step .1
Circle (300, 475), sz, _RGB32(105, 50, 50)
Next sz
h3 = 1
x = -100
y = -100
cl = 255
End If
If x > 285 And x < 315 And y > 460 And y < 490 And h3 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (300, 475), sz, _RGB32(cl, cl, cl)
Next sz
h3 = 0
x = -100
y = -100
cl = 255
End If
If x > 360 And x < 390 And y > 460 And y < 490 And h4 = 0 Then
For sz = .25 To 15 Step .1
Circle (375, 475), sz, _RGB32(105, 50, 50)
Next sz
h4 = 1
x = -100
y = -100
cl = 255
End If
If x > 260 And x < 390 And y > 460 And y < 490 And h4 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (375, 475), sz, _RGB32(cl, cl, cl)
Next sz
h4 = 0
x = -100
y = -100
cl = 255
End If
If x > 435 And x < 465 And y > 460 And y < 490 And h5 = 0 Then
For sz = .25 To 15 Step .1
Circle (450, 475), sz, _RGB32(105, 50, 50)
Next sz
h5 = 1
x = -100
y = -100
cl = 255
End If
If x > 435 And x < 465 And y > 460 And y < 490 And h5 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (450, 475), sz, _RGB32(cl, cl, cl)
Next sz
h5 = 0
x = -100
y = -100
cl = 255
End If
'Second Level
If x > 170 And x < 200 And y > 385 And y < 415 And h6 = 0 Then
For sz = .25 To 15 Step .1
Circle (185, 400), sz, _RGB32(105, 50, 50)
Next sz
h6 = 1
x = -100
y = -100
cl = 255
End If
If x > 170 And x < 200 And y > 385 And y < 415 And h6 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (185, 400), sz, _RGB32(cl, cl, cl)
Next sz
h6 = 0
x = -100
y = -100
cl = 255
End If
If x > 245 And x < 275 And y > 385 And y < 415 And h7 = 0 Then
For sz = .25 To 15 Step .1
Circle (260, 400), sz, _RGB32(105, 50, 50)
Next sz
h7 = 1
x = -100
y = -100
cl = 255
End If
If x > 245 And x < 275 And y > 385 And y < 415 And h7 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (260, 400), sz, _RGB32(cl, cl, cl)
Next sz
h7 = 0
x = -100
y = -100
cl = 255
End If
If x > 320 And x < 350 And y > 385 And y < 415 And h8 = 0 Then
For sz = .25 To 15 Step .1
Circle (335, 400), sz, _RGB32(105, 50, 50)
Next sz
h8 = 1
x = -100
y = -100
cl = 255
End If
If x > 320 And x < 350 And y > 385 And y < 415 And h8 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (335, 400), sz, _RGB32(cl, cl, cl)
Next sz
h8 = 0
x = -100
y = -100
cl = 255
End If
If x > 395 And x < 425 And y > 385 And y < 415 And h9 = 0 Then
For sz = .25 To 15 Step .1
Circle (410, 400), sz, _RGB32(105, 50, 50)
Next sz
h9 = 1
x = -100
y = -100
cl = 255
End If
If x > 395 And x < 425 And y > 385 And y < 415 And h9 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (410, 400), sz, _RGB32(cl, cl, cl)
Next sz
h9 = 0
x = -100
y = -100
cl = 255
End If
'Third Level
If x > 210 And x < 240 And y > 310 And y < 340 And h10 = 0 Then
For sz = .25 To 15 Step .1
Circle (225, 325), sz, _RGB32(105, 50, 50)
Next sz
h10 = 1
x = -100
y = -100
cl = 255
End If
If x > 210 And x < 240 And y > 310 And y < 340 And h10 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (225, 325), sz, _RGB32(cl, cl, cl)
Next sz
h10 = 0
x = -100
y = -100
cl = 255
End If
If x > 285 And x < 315 And y > 310 And y < 340 And h11 = 0 Then
For sz = .25 To 15 Step .1
Circle (300, 325), sz, _RGB32(105, 50, 50)
Next sz
h11 = 1
x = -100
y = -100
cl = 255
End If
If x > 285 And x < 315 And y > 310 And y < 340 And h11 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (300, 325), sz, _RGB32(cl, cl, cl)
Next sz
h11 = 0
x = -100
y = -100
cl = 255
End If
If x > 360 And x < 390 And y > 310 And y < 340 And h12 = 0 Then
For sz = .25 To 15 Step .1
Circle (375, 325), sz, _RGB32(105, 50, 50)
Next sz
h12 = 1
x = -100
y = -100
cl = 255
End If
If x > 360 And x < 390 And y > 310 And y < 340 And h12 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (375, 325), sz, _RGB32(cl, cl, cl)
Next sz
h12 = 0
x = -100
y = -100
cl = 255
End If
'Fourth Level
If x > 250 And x < 280 And y > 235 And y < 265 And h13 = 0 Then
For sz = .25 To 15 Step .1
Circle (265, 250), sz, _RGB32(105, 50, 50)
Next sz
h13 = 1
x = -100
y = -100
cl = 255
End If
If x > 250 And x < 280 And y > 235 And y < 280 And h13 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (265, 250), sz, _RGB32(cl, cl, cl)
Next sz
h13 = 0
x = -100
y = -100
cl = 255
End If
If x > 325 And x < 355 And y > 235 And y < 265 And h14 = 0 Then
For sz = .25 To 15 Step .1
Circle (340, 250), sz, _RGB32(105, 50, 50)
Next sz
h14 = 1
x = -100
y = -100
cl = 255
End If
If x > 325 And x < 355 And y > 235 And y < 280 And h14 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (340, 250), sz, _RGB32(cl, cl, cl)
Next sz
h14 = 0
x = -100
y = -100
cl = 255
End If
'Top Hole
If x > 285 And x < 315 And y > 160 And y < 190 And h15 = 0 Then
For sz = .25 To 15 Step .1
Circle (300, 175), sz, _RGB32(105, 50, 50)
Next sz
h15 = 1
x = -100
y = -100
cl = 255
End If
If x > 285 And x < 315 And y > 160 And y < 190 And h15 = 1 Then
For sz = .25 To 15 Step .1
cl = cl - 1
Circle (300, 175), sz, _RGB32(cl, cl, cl)
Next sz
h15 = 0
x = -100
y = -100
cl = 255
End If
End If
Loop
Sub Clear_MB (var As Integer)
Do Until Not _MouseButton(var)
While _MouseInput: Wend
Loop
I had someone contact me about using the CHAIN command and not being able to get it to work for them. They sent me their source code and after a few rewrites I can't get it to work either? QB64 continuously complains that it can't find QB64.bas two parent directories below the current working directory.
This also happens regardless if I'm using two .BAS programs from within the editor or using two compiled .EXE files outside the editor as pointed out by the CHAIN Wiki entry.
Has anyone been able to successfully use the CHAIN command? If so, please post some example code so I can see what I may be doing wrong.
For now I gave the user that contacted me other ways of achieving their goal without using CHAIN. I also explained to this user that CHAIN is really no longer needed as it's a relic from the golden age of BASIC, however I would still issue a possible bug report all the same.
On this forum and some others
i see tensions to move from Windows to Linux.
I am not sure why exactly such a "hate" for Windows when i know
that most of -them or us- ...use it before .
I like Windows and Windows is OS for me , i use Linux
just for testing purpose not on every day basis.
So now i am interested to know how many real Linux users use
QB64 for programming .
Is number of Linux users bigger than number of Windows users here on forum?
thanks!
My scatter-brained self, as I was studying QB64's SOUND and PLAY statements, and the "Web Audio API", got caught up in sound theory in general and then waveforms in particular.
Just in case anybody else feels like geeking out on this stuff while enjoying a hot/cold brew :
...could use a magnifier. I had done something similar on the old forum, but wanted something more portable. It mainly consists of two SUBs, one to create a color masking image and the other to acquire the portion to be magnified and apply the mask. Right mouse click magnifies the portion the mouse is hovering over, while the mousewheel controls the magnification factor. Hotkeys are "+" and "-" to increase or decrease magnifier size, and "s" to toggle a rifle scoop type reticle. Esc to quit.
It uses the screen image for navigation, but takes the magnified content from the original loaded image.
I also zipped it with several demo images, both big and small, or comment out the _LOADIMAGE code and use one of your own. It comes enabled to Bruegel's "Triumph of Death". Not so much to be macabre, but because Bruegel is the medieval periods answer to Richard Scarry. It's just chock full of details, perfect for magnification.
The '63 Chevy P/U image is a smaller image that is stretched to fit the screen so it will be noticed that Mag factor 1 will actually shrink it. The other images are larger and shrunk to fit.
SCREEN _NEWIMAGE(_DESKTOPWIDTH, _DESKTOPHEIGHT - 80, 32)
DO UNTIL _SCREENEXISTS: LOOP
_SCREENMOVE 0, 0
'VARIABLES
DIM SHARED msk& ' reticle mask handle
DIM hratio ' height ratio: screen / image
DIM wratio ' width ratio: screen / image
DIM ratio ' ratio to shrink image to screen
DIM magsiz%
DIM magfactor%
DIM scope%%
hratio = _HEIGHT(0) / _HEIGHT(img&)
wratio = _WIDTH(0) / _WIDTH(img&)
ratio = -hratio * (hratio < wratio) - wratio * (wratio <= hratio)
magsiz% = 250
magfactor% = 2
scope%% = 0
Make_Mask magsiz%, scope%%
DO
CLS
Image_Resize 0, 0, _WIDTH(0) - 1, _HEIGHT(0) - 1, img&, 0, "l", "u" 'placeimage to fit screen upper left corner
_PRINTSTRING (0, 0), "Original size " + STR$(_WIDTH(img&)) + " x " + STR$(_HEIGHT(img&))
_PRINTSTRING (0, 16), "Ratio= " + STR$(ratio) + " Mag. factor= " + STR$(magfactor%)
k$ = INKEY$
IF k$ <> "" THEN
IF k$ = CHR$(43) THEN ' "+" to increase magnifier size
magsiz% = magsiz% + 25: vin%% = -1
END IF
IF k$ = CHR$(45) THEN ' "-" to decrease magnifier size
magsiz% = magsiz% - 25: vin%% = -1
IF magsiz% < 25 THEN magsiz% = 25
END IF
IF k$ = "s" THEN ' "s" to toggle scope reticle
scope%% = NOT scope%%: vin%% = -1
END IF
IF vin%% THEN Make_Mask magsiz%, scope%% ' if valid input then redo mask overlay
k$ = "": vin%% = 0 ' clear input & and valid input flag
END IF
ms = MBS
IF ms AND 1 THEN ' left mouse button to show magnifier
_MOUSEHIDE
Magnify magfactor%, img&, magsiz%, ratio
ELSE
_MOUSESHOW "crosshair"
END IF
IF ms AND 512 THEN ' mousewheel to change magnification factor
magfactor% = magfactor% - 1
IF magfactor% < 1 THEN magfactor% = 1
END IF
IF ms AND 1024 THEN
magfactor% = magfactor% + 1
IF magfactor% > 30 THEN magfactor% = 30
END IF
_LIMIT 30
_DISPLAY
LOOP UNTIL _KEYDOWN(27)
END
SUB Make_Mask (s%, sc%)
cn% = _SHR(s%, 1) - 1 ' image center
IF msk& < -1 THEN _FREEIMAGE msk& ' remove old mask if any
IF sc% THEN ' if scope enabled, draw crosshairs
ret& = _NEWIMAGE(s%, s%, 32) ' define reticle image
_DEST ret& ' destination to reticle
CLS '
_CLEARCOLOR _RGB32(0, 0, 0) ' background transparent
CIRCLE (cn%, cn%), cn%, &HFFFF0000 ' circular border
CIRCLE (cn%, cn%), cn% - 1, &HFFFF0000
CIRCLE (cn%, cn%), cn% - 2, &HFFFF0000
LINE (0, cn%)-(s% - 1, cn%), &HFFFF0000 ' scope reticle
LINE (s% / 3, cn% + 1)-(s% * (2 / 3), cn% + 1), &HFFFF0000
LINE (cn% + 1, s% / 3)-(cn% + 1, s% * (2 / 3)), &HFFFF0000
LINE (cn%, 0)-(cn%, s% - 1), &HFFFF0000
END IF
msk& = _NEWIMAGE(s%, s%, 32) ' create mask image
_DEST msk&
COLOR , _RGB32(255, 0, 255) ' fill mask with purple to clear color in SUB Magnify
CLS
FCirc cn%, cn%, cn%, _RGB32(0, 0, 0) ' apply centered black circle to clearcolor in SUB Magnify
IF ret& < -1 THEN _PUTIMAGE , ret&: _FREEIMAGE ret& '
_DEST 0 '
END SUB 'Make_Mask
SUB Magnify (mf%, src&, s%, r!)
hs% = _SHR(s%, 1): hf% = hs% / mf% ' radius and mag at radius
x% = map!(_MOUSEX, 0, _WIDTH(src&) * r!, 0, _WIDTH(src&) - 1) 'map mouse position relative to image
y% = map!(_MOUSEY, 0, _HEIGHT(src&) * r!, 0, _HEIGHT(src&) - 1)
mag& = _NEWIMAGE(s%, s%, 32) ' Create magnifier lense
_PUTIMAGE , src&, mag&, (x% - hf%, y% - hf%)-(x% + hf%, y% + hf%) 'portion of src& to mag&
_DEST mag&
_CLEARCOLOR _RGB32(0, 0, 0), msk& ' set clearcolor to inner circle of mask
_PUTIMAGE , msk&, mag& ' overlay on magnifier
_CLEARCOLOR _RGB32(255, 0, 255), mag& ' clearcolor purple corners of mag& placed by mask
_PUTIMAGE (_MOUSEX - hs% - 1, _MOUSEY - hs% - 1), mag&, 0 ' place finished magnifier to screen, mouse centered
_FREEIMAGE mag&
END SUB 'Magnify
SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG) 'by Steve McNeill
DIM R AS INTEGER, RError AS INTEGER
DIM X AS INTEGER, Y AS INTEGER
R = ABS(RR)
RError = -R
X = R
Y = 0
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB
LINE (CX - X, CY)-(CX + X, CY), C, BF
WHILE X > Y
RError = RError + Y * 2 + 1
IF RError >= 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
RError = RError - 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 'FCirc
SUB Image_Resize (xpos AS INTEGER, ypos AS INTEGER, xlim AS INTEGER, ylim AS INTEGER, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
DIM AS INTEGER xs, ys, xp, yp, xl, yl ' ready for OPTION EXPLICIT programs
xp = xpos: yp = ypos: xl = xlim: yl = ylim ' isolate sent parameters from any changes
DIM AS SINGLE rt, xrt, yrt
xrt = (xl - xp) / _WIDTH(i) ' width of area divided by width of image
yrt = (yl - yp) / _HEIGHT(i) ' height of area divided by height of image
rt = -xrt * (xrt < yrt) - yrt * (yrt <= xrt) ' pick the smaller of the two ratios to fit area
xs = _WIDTH(i) * rt ' final image size ratio in x
ys = _HEIGHT(i) * rt ' final image size ratio in y
xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
xl = xp + xs
yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
yl = yp + ys
_PUTIMAGE (xp, yp)-(xl, yl), i, d
END SUB 'Image_Resize
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION 'map!
FUNCTION MBS% 'by Steve McNeill
STATIC StartTimer AS _FLOAT
STATIC ButtonDown AS INTEGER
'STATIC ClickCount AS INTEGER
CONST ClickLimit## = .4 'Less than 1/2 of a second to down, up a key to count as a CLICK.
' Down longer counts as a HOLD event.
SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
SELECT CASE SGN(_MOUSEWHEEL)
CASE 1: tempMBS = tempMBS OR 512
CASE -1: tempMBS = tempMBS OR 1024
END SELECT
WEND
IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1
IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2
IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4
IF StartTimer = 0 THEN
IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
ButtonDown = 1: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(2) THEN
ButtonDown = 2: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(3) THEN
ButtonDown = 3: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
END IF
ELSE
BD = ButtonDown MOD 3
IF BD = 0 THEN BD = 3
IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit. It's a click
IF _MOUSEBUTTON(BD) = 0 THEN tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
ELSE
IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
tempMBS = 0: ButtonDown = 0: StartTimer = 0
Mouse_EndX = _MOUSEX: Mouse_EndY = _MOUSEY
ELSE 'We've now started the hold event
tempMBS = tempMBS OR 32 * 2 ^ ButtonDown
END IF
END IF
END IF
MBS% = tempMBS
END FUNCTION 'MBS%
Posted by: CharlieJV - 08-06-2022, 02:56 AM - Forum: Programs
- No Replies
Nothing fancy, just a small bit of code I wanted to mindlessly play with. In case you want to put your own "spin" on it ...
A GW-BASIC program I modified in BASIC Anywhere Machine (view source code, run the program) before bringing it over to QB64.
Code: (Select All)
' Based on https://github.com/Zannick/qbasic-programs/blob/master/ROTATE.BAS by Benjamin Wolf (April 8, 2003)
SCREEN 12 : x = 0.5
DO
CLS
if x < 1 then
CIRCLE (320, 240), 230, 11
CIRCLE (320, 240), 75, 11
else
CIRCLE (320, 240), 230, 11, , , x
CIRCLE (320, 240), 75, 11, , , x
end if
if int(x*250000) < 1000000 then
FOR z = 1 TO 1000000 - int(x * 250000)
NEXT z
end if
_delay 0.0125
IF x = 75 THEN y = 2
IF x < 1 THEN y = 1
SELECT CASE y
CASE 1
x = x + 0.5
CASE 2
x = x - 0.5
END SELECT
LOOP
IF MID$(a$, 1, 1) = "-" THEN neg_a = -1
IF MID$(b$, 1, 1) = "-" THEN neg_b = -1
IF INSTR(a$, ".") THEN
dec_a1$ = MID$(a$, 1, INSTR(a$, ".") - 1): dec_a2$ = MID$(a$, INSTR(a$, ".") + 1)
ELSE
dec_a1$ = a$
END IF
IF INSTR(b$, ".") THEN
dec_b1$ = MID$(b$, 1, INSTR(b$, ".") - 1): dec_b2$ = MID$(b$, INSTR(b$, ".") + 1)
ELSE
dec_b1$ = b$
END IF
DO
' Test for sign.
SELECT CASE neg_a + neg_b
CASE 0, -2 ' Both positive or negative
IF dec_a1$ = dec_b1$ AND dec_a2$ = dec_b2$ THEN a_less_b = 0: EXIT DO ' Same number.
IF LEN(dec_a1$) AND dec_b1$ = "" THEN a_less_b = 1: EXIT DO ' a >=1 and b is a decimal.
IF LEN(dec_b1$) AND dec_a1$ = "" THEN a_less_b = -1: EXIT DO ' b >=1 and a is a decimal.
IF LEN(dec_a1$) AND dec_a1$ <> dec_b1$ OR LEN(dec_b1$) AND dec_a1$ <> dec_b1$ THEN ' One or both >=1 and non-decimal parts are not equal.
IF LEN(dec_a1$) > LEN(dec_b1$) THEN a_less_b = 1: EXIT DO
IF LEN(dec_a1$) < LEN(dec_b1$) THEN a_less_b = -1: EXIT DO
IF LEN(dec_a1$) = LEN(dec_b1$) THEN
FOR i = 1 TO LEN(dec_a1$)
IF MID$(dec_a1$, i, 1) <> MID$(dec_b1$, i, 1) THEN EXIT FOR
NEXT
IF MID$(dec_a1$, i, 1) < MID$(dec_b1$, i, 1) THEN a_less_b = -1: EXIT DO ELSE a_less_b = 1: EXIT DO
END IF
ELSE ' Both decimals or non-decimal digits are the same and cancel out.
j = LEN(dec_a2$)
IF LEN(dec_b2$) > j THEN j = LEN(dec_b2$)
FOR i = i TO j
IF MID$(dec_a2$, i, 1) <> MID$(dec_b2$, i, 1) THEN EXIT FOR
NEXT
IF MID$(dec_a2$, i, 1) < MID$(dec_b2$, i, 1) THEN a_less_b = -1: EXIT DO ELSE a_less_b = 1: EXIT DO
END IF
CASE -1 ' One is negative.
j = -999
IF neg_a THEN a_less_b = -1: EXIT DO ELSE a_less_b = 1: EXIT DO
END SELECT
EXIT DO
LOOP
IF neg_a OR neg_b THEN IF j <> -999 THEN a_less_b = a_less_b * -1
IF a_less_b < 0 THEN PRINT "a$ < b$" ELSE IF a_less_b = 0 THEN PRINT "a$ = b$" ELSE PRINT "a$ > b$"
REM PRINT dec_a1$, dec_a2$, dec_b1$, dec_b2$, neg_a, neg_b
PRINT
SLEEP
RUN
The point I'm at now, I can get away with using string comparison as long as I disallow -0 and flip the results for two negatives. A single negative is always the smaller number but as I came to realize in string comparisons from a different tread, when faced with two negatives, a string evaluation will not change the fact that the larger numeric value of string is all that is considered. You need a sub-routine to invert the results.
So, can anyone see anything I missed here in the shortcut routine, or is this cake all backed?
So testing out number comparison using STRING$() instead of the very limited VAL() function. What i discovered is string$() comparison does a great job, even on very large numbers, decimals included, until you get to comparing two negative string numbers. Note in the last comparison the string evaluation is true and should be false for [-11.2 > -11.1] as it is in the numeric variable comparison.
Ha! Just viewed all latest updates in Portal. Seems they don't get around to newest stuff in Prolific Programmers Board so here is a little message, GUI Waffle has just been posted here: https://qb64phoenix.com/forum/showthread...21#pid4921
![[Image: Manual-Pyramid-Peg-Game-by-Sierra-Ken.jpg]](https://i.ibb.co/MM21G8N/Manual-Pyramid-Peg-Game-by-Sierra-Ken.jpg)
