Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 512
» Latest member: zaidativanovoz1699
» Forum threads: 2,909
» Forum posts: 27,042

Full Statistics

Latest Threads
Hardware Acceleration and...
Forum: General Discussion
Last Post: Pete
Less than 1 minute ago
» Replies: 3
» Views: 37
Roll The Dice InputBox$ a...
Forum: Programs
Last Post: bplus
47 minutes ago
» Replies: 14
» Views: 169
Memory Usage Monitor
Forum: Utilities
Last Post: Steffan-68
5 hours ago
» Replies: 4
» Views: 93
'BandInte' - Bandwidth & ...
Forum: Utilities
Last Post: Sanmayce
Today, 08:59 AM
» Replies: 5
» Views: 506
Dialog Tools
Forum: bplus
Last Post: bplus
Today, 12:18 AM
» Replies: 4
» Views: 246
PCX file format
Forum: Petr
Last Post: a740g
Yesterday, 10:05 PM
» Replies: 9
» Views: 113
BMP File format
Forum: Petr
Last Post: Petr
Yesterday, 09:39 PM
» Replies: 0
» Views: 29
QB64 and QB64PE together?
Forum: General Discussion
Last Post: Mad Axeman
Yesterday, 08:48 PM
» Replies: 7
» Views: 127
Updating my mouse and key...
Forum: Works in Progress
Last Post: Pete
Yesterday, 08:39 PM
» Replies: 28
» Views: 719
Word-list creator
Forum: Utilities
Last Post: PhilOfPerth
Yesterday, 07:18 AM
» Replies: 2
» Views: 83

 
  Any better way around Duplicate Definition problems?
Posted by: Pete - 01-23-2025, 09:12 PM - Forum: Help Me! - Replies (16)

So while making some routines into libraries we have this common problem when arrays are involved, which is...

How to use an array in the main or calling routine without having to stick a REDIM a$(0) in that routine.

In other words say we need a$() in the calling routine and the library we are going to add for that routine like a mouse routine.

Main:
mouse x, y, a$()

Sub mouse (x, y, a$())
    Static initiate
    If initiate = 0 Then
        initiate = 1
        ReDim a$(_Height)
    End If
End Sub

Now this will fail with a Duplicate Definition error, because a$() is being introduced as an array to be passed into the mouse sub, and therefore it must be initially defined in that calling routine, before it is passed.

So we have this, which will work...

Main:
ReDim a$(0)
mouse x, y, a$()

Sub mouse (x, y, a$())
    Static initiate
    If initiate = 0 Then
        initiate = 1
        ReDim a$(_Height)
    End If
End Sub

...but we have to remember when we make the mouse routine part into a library, and use INCLUDE to add it to the main program, we also must remember it manually add the Redim() code in the calling procedure or make a companion library bi file that needs to also be included to add the needed Redim() statement in the main.

So am I missing any other library making alternatives here? If not, I feel a bit more compelled to just work with Shared arrays in a bi file, instead of passing them at all.

Pete

Print this item

Information New Wiki Page - Change Logs - By released Versions
Posted by: grymmjack - 01-23-2025, 12:40 PM - Forum: Wiki Discussion - Replies (9)

To help us all keep up with the changes in QB64PE we have created this page:
https://qb64phoenix.com/qb64wiki/index.p...d_Versions
(page also accessible from the Wiki Main page -> Keyword References -> Other section)

For every released version in GitHub, there is a release page which explains what is new. You may have seen this information before. But what you might not know is that @RhoSigma and the rest of the team maintain the wiki each time new things are added, changed, etc. and it can be hard to keep track of everything.

This new page centralizes the change logs in one spot, allowing you to do a full text search in the wiki for the version number vX.y.z which the wiki mentions explicitly when versions are relevant to a change/addition/fix, as well as the GitHub release itself through the version tag, which contains the developers journal of what happened for that release.

Now there is one spot to check for new things.

It might be fun for everyone to go through the list just to see what's new, improved, etc.

For example, @SierraKen didn't realize the SOUND keyword had more waveforms now, and now that he does know he integrated that feature into his new MouseTank game.

Huge thanks to @RhoSigma for maintaining this wiki the way he has which has made this possible - thank you for your service!

Print this item

  Pointlessly Walk or Run forever! (update 0002)
Posted by: Cobalt - 01-22-2025, 11:01 PM - Forum: Programs - Replies (14)

no literally thats all you can do in this code! for now anyway.

Now with interactions. (well a few at the moment)
Now with collisions!
Using a NEW MFI file!


Arrow keys - to move. Only the four main directions, as that's all the character sprites I have(might make diagonal ones... )
Shift keys - to run! Holding down shift goes from walking to running.
Spacebar - exit popup window
ESC -  to quit(outside of popup window)
Enter key - to interact with some objects.

and the world STILL just goes on and on and on and on...................

Code: (Select All)

TYPE World_data
ID AS _BYTE
END TYPE

TYPE Character_data
X AS _UNSIGNED _BYTE
Y AS _UNSIGNED _BYTE
Direction AS _BYTE
Act AS _BYTE
END TYPE

TYPE Game
Event AS _BYTE
END TYPE

DIM SHARED World_Map(255, 255) AS World_data, P AS Character_data
DIM SHARED World_Sprite(255, 255) AS World_data, G AS Game, M$(64)
DIM SHARED Layer(16) AS LONG
CONST Default_Key_Right = 19712, Default_Key_Left = 19200, Default_Key_Up = 18432, Default_Key_Down = 20480
CONST Default_Key_RShift = 100303, Default_Key_LShift = 100304
CONST MOVING = -1: IDLE = 0
CONST TRUE = -1, FALSE = NOT TRUE
'Events
CONST Fire_Event = 1, InterAct_Event = 2, Action_Fail = 3, Treasure_Event = 4, NPC_Event = 5, Gross_Event = 6

SCREEN _NEWIMAGE(800, 600, 32)
Layer(0) = _DISPLAY
Layer(1) = _COPYIMAGE(_DISPLAY)
Layer(2) = _NEWIMAGE(32 * 24, 32 * 24, 32)
'Layer(3) = _LOADIMAGE("testtileset3.bmp", 32)
'Layer(4) = _LOADIMAGE("character_greenhair.bmp", 32)
Layer(5) = _COPYIMAGE(Layer(2))
'Layer(6) = _LOADIMAGE("popupwindow.bmp", 32)
'Layer(7) = _LOADIMAGE("cruknight_dead.bmp", 32)

MFI_Loader "InfWorld.MFI"

_CLEARCOLOR _RGB32(0), Layer(4)
_CLEARCOLOR _RGB32(225, 0, 126), Layer(3)
_CLEARCOLOR _RGB32(34, 34, 35), Layer(3)
_SETALPHA 128, , Layer(6)
_CLEARCOLOR _RGB32(0), Layer(6)
_CLEARCOLOR _RGB32(255), Layer(7)

_PRINTMODE _KEEPBACKGROUND

World_Map(2, 2).ID = 63
World_Sprite(255, 255).ID = 1 'fire(anim)
World_Sprite(5, 25).ID = 2 'Treasure
World_Sprite(25, 10).ID = 3 'Corpse

M$(0) = "OUCH!"
M$(1) = "I'm not ready to be cremated yet!"
M$(2) = "Press SpaceBar"
M$(3) = "HMMMMM...."
M$(4) = "There is nothing I can do with that."
M$(5) = "OOOooo SHINY!"
M$(6) = "I have found some treasure on the Ground!"
M$(7) = "EXCUSE ME!?"
M$(8) = "DISTGUSTING!"
M$(9) = "This guy has been here a while. Nothing"
M$(10) = "to do but get away from the smell!"
UpDate_MapLayer
ClearLayerT Layer(5)

DO
IF _KEYDOWN(Default_Key_Down) AND (Player_Screen_X%% = 0) THEN P.Direction = 0
IF _KEYDOWN(Default_Key_Left) AND (Player_Screen_Y%% = 0) THEN P.Direction = 1
IF _KEYDOWN(Default_Key_Right) AND (Player_Screen_Y%% = 0) THEN P.Direction = 2
IF _KEYDOWN(Default_Key_Up) AND (Player_Screen_X%% = 0) THEN P.Direction = 3

IF _KEYDOWN(Default_Key_Down) OR _KEYDOWN(Default_Key_Left) OR _KEYDOWN(Default_Key_Right) OR _KEYDOWN(Default_Key_Up) THEN P.Act = MOVING ELSE P.Act = IDLE
IF _KEYDOWN(Default_Key_RShift) OR _KEYDOWN(Default_Key_LShift) THEN Speed%% = 2 ELSE Speed%% = 1

IF P.Act = MOVING THEN IF Collision THEN P.Act = IDLE
IF _KEYDOWN(13) THEN G.Event = InterAct_Event: P.Act = IDLE

IF P.Act = MOVING OR Player_Screen_Y%% <> 0 OR Player_Screen_X%% <> 0 THEN
  SELECT CASE P.Direction
  CASE 0
    Player_Screen_Y%% = Player_Screen_Y%% + Speed%%
  CASE 1
    Player_Screen_X%% = Player_Screen_X%% - Speed%%
  CASE 2
    Player_Screen_X%% = Player_Screen_X%% + Speed%%
  CASE 3
    Player_Screen_Y%% = Player_Screen_Y%% - Speed%%
  END SELECT
END IF
IF Player_Screen_Y%% >= (32 + Speed%%) THEN P.Y = P.Y + 1: Player_Screen_Y%% = 0: UpDate_MapLayer
IF Player_Screen_Y%% <= (-32 - Speed%%) THEN P.Y = P.Y - 1: Player_Screen_Y%% = 0: UpDate_MapLayer
IF Player_Screen_X%% <= (-32 - Speed%%) THEN P.X = P.X - 1: Player_Screen_X%% = 0: UpDate_MapLayer
IF Player_Screen_X%% >= (32 + Speed%%) THEN P.X = P.X + 1: Player_Screen_X%% = 0: UpDate_MapLayer

Run_Sprite_Layer

_PUTIMAGE (7, 7)-STEP(567, 567), Layer(2), Layer(1), (64 + Player_Screen_X%%, 64 + Player_Screen_Y%%)-STEP(567, 567)
_PUTIMAGE (7, 7)-STEP(567, 567), Layer(5), Layer(1), (64 + Player_Screen_X%%, 64 + Player_Screen_Y%%)-STEP(567, 567)

_PUTIMAGE (289, 264)-STEP(39, 51), Layer(4), Layer(1), (0 + 21 * frame%%, 0 + 27 * P.Direction)-STEP(19, 25)

_PRINTSTRING (600, 0), STR$(Player_Screen_Y%%), Layer(1)
_PRINTSTRING (600, 18), STR$(Player_Screen_X%%), Layer(1)
_PRINTSTRING (600, 36), STR$(P.X), Layer(1)
_PRINTSTRING (600, 54), STR$(P.Y), Layer(1)
_PRINTSTRING (600, 72), STR$(G.Event), Layer(1)

_PUTIMAGE , Layer(1), Layer(0)
IF G.Event THEN Run_Event_Handler: P.Act = IDLE
ClearLayer Layer(1)
ClearLayerT Layer(5)
IF P.Act = MOVING OR Player_Screen_Y%% <> 0 OR Player_Screen_X%% <> 0 THEN Fc%% = Fc%% + Speed%% ELSE frame%% = 0
IF Fc%% >= 16 THEN frame%% = frame%% + 1: Fc%% = 0
IF frame%% = 8 THEN frame%% = 0

_LIMIT 60
LOOP UNTIL INKEY$ = CHR$(27)

'SCREEN Layer(2)
'LINE (64 + Player_Screen_X%%, 64 + Player_Screen_Y%%)-STEP(567, 567), _RGB32(255, 0, 0), B

SUB Place_Tile (ID_tag AS _BYTE, X AS INTEGER, Y AS INTEGER)
SELECT CASE ID_tag
  CASE 0 'grass default
  _PUTIMAGE (X, Y)-STEP(31, 31), Layer(3), Layer(2), (114, 66)-STEP(15, 15)
  CASE 63 'small crystal
  _PUTIMAGE (X, Y)-STEP(31, 31), Layer(3), Layer(2), (114, 66)-STEP(15, 15)
  _PUTIMAGE (X, Y)-STEP(31, 31), Layer(3), Layer(2), (788, 146)-STEP(15, 15)
END SELECT
END SUB

SUB Place_Sprites (ID_tag AS _BYTE, X AS INTEGER, Y AS INTEGER)
STATIC Fire AS _BYTE, Fire_Frame AS _BYTE
SELECT CASE ID_tag
  CASE 1 'Fire Sprite
  _PUTIMAGE (X, Y - 16)-STEP(31, 31), Layer(3), Layer(5), (66, 66 + 16 * Fire)-STEP(15, 15)
  CASE 2 'treasure
  _PUTIMAGE (X, Y - 16)-STEP(31, 31), Layer(3), Layer(5), (338, 162)-STEP(15, 15)
  CASE 3 'corpse (need to fix layer when finished
  _PUTIMAGE (X, Y - 16)-STEP(39, 43), Layer(7), Layer(5), (0, 0)-STEP(19, 21)

END SELECT
Fire_Frame = Fire_Frame + 1
IF Fire_Frame = 8 THEN Fire = Fire + 1: Fire_Frame = 0
IF Fire = 4 THEN Fire = 0
END SUB

SUB UpDate_MapLayer
ClearLayer Layer(2)
FOR x%% = 0 TO 21
  FOR y%% = 0 TO 21
  PX~%% = x%% + P.X - 11
  py~%% = y%% + P.Y - 11
  Place_Tile World_Map(PX~%%, py~%%).ID, x%% * 32, y%% * 32
  '_PRINTSTRING (x%% * 32, y%% * 32), HEX$(PX~%%) + HEX$(py~%%), Layer(2)
  NEXT
NEXT
END SUB

SUB Run_Sprite_Layer
FOR x%% = 0 TO 21
  FOR y%% = 0 TO 21
  PX~%% = x%% + P.X - 11
  py~%% = y%% + P.Y - 11
  IF World_Sprite(PX~%%, py~%%).ID THEN Place_Sprites World_Sprite(PX~%%, py~%%).ID, x%% * 32, y%% * 32
  NEXT
NEXT
END SUB



FUNCTION Collision%% ()
Result%% = FALSE 'no collision
SELECT CASE P.Direction
  CASE 0
  PY~%% = P.Y + 1
  IF World_Map(P.X, PY~%%).ID <> 0 THEN Result%% = TRUE 'collision detected with world object
  IF World_Sprite(P.X, PY~%%).ID <> 0 THEN Result%% = TRUE: G.Event = TRUE 'collision detected with sprite object
  CASE 1
  PX~%% = P.X - 1
  IF World_Map(PX~%%, P.Y).ID <> 0 THEN Result%% = TRUE 'collision detected with world object
  IF World_Sprite(PX~%%, P.Y).ID <> 0 THEN Result%% = TRUE: G.Event = TRUE 'collision detected with sprite object
  CASE 2
  PX~%% = P.X + 1
  IF World_Map(PX~%%, P.Y).ID <> 0 THEN Result%% = TRUE 'collision detected with world object
  IF World_Sprite(PX~%%, P.Y).ID <> 0 THEN Result%% = TRUE: G.Event = TRUE 'collision detected with sprite object
  CASE 3
  PY~%% = P.Y - 1
  IF World_Map(P.X, PY~%%).ID <> 0 THEN Result%% = TRUE 'collision detected with world object
  IF World_Sprite(P.X, PY~%%).ID <> 0 THEN Result%% = TRUE: G.Event = TRUE 'collision detected with sprite object
END SELECT
Collision = Result%%
END FUNCTION

SUB ClearLayer (L&)
old& = _DEST
_DEST L&
CLS ' ,0
_DEST old&
END SUB

SUB ClearLayerT (L&)
old& = _DEST
_DEST L&
CLS , 0
_DEST old&
END SUB

SUB Run_Event_Handler
SELECT CASE P.Direction 'get the sprite id that player touched
  CASE 0
  PY~%% = P.Y + 1
  PX~%% = P.X
  Id%% = World_Sprite(P.X, PY~%%).ID
  Id2%% = World_Map(P.X, PY~%%).ID
  CASE 1
  PX~%% = P.X - 1
  PY~%% = P.Y
  Id%% = World_Sprite(PX~%%, P.Y).ID
  Id2%% = World_Map(PX~%%, P.Y).ID
  CASE 2
  PX~%% = P.X + 1
  PY~%% = P.Y
  Id%% = World_Sprite(PX~%%, P.Y).ID
  Id2%% = World_Map(PX~%%, P.Y).ID
  CASE 3
  PY~%% = P.Y - 1
  PX~%% = P.X
  Id%% = World_Sprite(P.X, PY~%%).ID
  Id2%% = World_Map(P.X, PY~%%).ID
END SELECT
IF G.Event = TRUE THEN
  SELECT CASE Id%%
  CASE Fire_Event 'Fire HOT!
    Popup_Message_Window Fire_Event
  CASE 2 ' treasure
    Popup_Message_Window Treasure_Event
    World_Sprite(PX~%%, PY~%%).ID = 0 'remove treasure
  CASE 3 'corpse
    Popup_Message_Window Gross_Event
  END SELECT
ELSEIF G.Event = InterAct_Event THEN
  SELECT CASE Id2%%
  CASE 63 'crystal
    Popup_Message_Window Action_Fail
  END SELECT
END IF

END SUB

SUB Popup_Message_Window (Message%%)
_PUTIMAGE (300 - (376 / 2), 32), Layer(6), Layer(0)

_PRINTSTRING (600, 90), STR$(Message%%), Layer(0)

SELECT CASE Message%%
  CASE Fire_Event
  COLOR _RGB32(0)
  _PRINTSTRING (300 - 8 * LEN(M$(0)) \ 2, 54), M$(0)
  COLOR _RGB32(255)
  _PRINTSTRING (300 - 8 * LEN(M$(1)) \ 2, 96), M$(1)
  COLOR _RGB32(212)
  _PRINTSTRING (300 - 8 * LEN(M$(2)) \ 2, 192), M$(2)
  CASE Action_Fail
  COLOR _RGB32(0)
  _PRINTSTRING (300 - 8 * LEN(M$(3)) \ 2, 54), M$(3)
  COLOR _RGB32(255)
  _PRINTSTRING (300 - 8 * LEN(M$(4)) \ 2, 96), M$(4)
  COLOR _RGB32(212)
  _PRINTSTRING (300 - 8 * LEN(M$(2)) \ 2, 192), M$(2)
  CASE Treasure_Event
  COLOR _RGB32(0)
  _PRINTSTRING (300 - 8 * LEN(M$(5)) \ 2, 54), M$(5)
  COLOR _RGB32(255)
  _PRINTSTRING (300 - 8 * LEN(M$(6)) \ 2, 96), M$(6)
  COLOR _RGB32(212)
  _PRINTSTRING (300 - 8 * LEN(M$(2)) \ 2, 192), M$(2)
  CASE Gross_Event
  COLOR _RGB32(0)
  _PRINTSTRING (300 - 8 * LEN(M$(8)) \ 2, 54), M$(8)
  COLOR _RGB32(255)
  _PRINTSTRING (300 - 8 * LEN(M$(9)) \ 2, 96), M$(9)
  _PRINTSTRING (300 - 8 * LEN(M$(10)) \ 2, 112), M$(10)
  COLOR _RGB32(212)
  _PRINTSTRING (300 - 8 * LEN(M$(2)) \ 2, 192), M$(2)

END SELECT
DO: LOOP UNTIL _KEYDOWN(32)
_KEYCLEAR
G.Event = FALSE
END SUB

SUB MFI_Loader (FN$)
DIM Size(128) AS LONG, FOffset(128) AS LONG
OPEN FN$ FOR BINARY AS #1
GET #1, , c~%% 'retrieve number of files
FOR I~%% = 1 TO c~%%
  GET #1, , FOffset(I~%%)
  GET #1, , Size(I~%%)
  FOffset&(I~%%) = FOffset&(I~%%) + 1
NEXT I~%%
'Adjust window,add title, and show music volume warning while finishing loading
_SCREENMOVE 10, 10
_TITLE "'Infinate World' UniKorn ProDucKions 2025"
_KEYCLEAR
Layer(4) = LoadGFX(FOffset(1), Size(1)) '
Layer(3) = LoadGFX(FOffset(2), Size(2)) '
Layer(6) = LoadGFX(FOffset(3), Size(3)) '
Layer(7) = LoadGFX(FOffset(4), Size(4)) '
CLOSE #1
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
END SUB


FUNCTION LoadGFX& (Foff&, Size&)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
LoadGFX& = _LOADIMAGE("temp.dat", 32)
END FUNCTION



Attached Files
.mfi   InfWorld.MFI (Size: 386.67 KB / Downloads: 37)
Print this item

  Color Picker
Posted by: SMcNeill - 01-22-2025, 03:53 PM - Forum: SMcNeill - Replies (11)

One of my most useful little ten minute programs that I've came up with for a while, though this is for Windows Only:

Code: (Select All)
Dim WinMse As POINTAPI
Type POINTAPI: As Long X_Pos, Y_Pos: End Type

Declare Dynamic Library "User32"
Function GetWindowLongA& (ByVal hwnd As Long, ByVal nIndex As Long)
Function SetWindowLongA& (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)
Function GetAsyncKeyState% (ByVal vkey As Long)
Function GetCursorPos (lpPoint As POINTAPI)
End Declare
Width 12, 1 'large enough to hold our color value in hex
GWL_STYLE = -16
ws_border = &H800000
WS_VISIBLE = &H10000000
_Title "Color Picker"
hwnd& = _WindowHandle
winstyle& = GetWindowLongA&(hwnd&, GWL_STYLE)
_Delay .2
a& = SetWindowLongA&(hwnd&, GWL_STYLE, winstyle& And WS_VISIBLE)

Color 15
Do
_Limit 30
z = GetCursorPos(WinMse)
_ScreenMove WinMse.X_Pos + 1, WinMse.Y_Pos + 1
tempimage = _ScreenImage
Cls , 0
_Source tempimage: Print Hex$(Point(WinMse.X_Pos, WinMse.Y_Pos));: _Source 0
_FreeImage tempimage
_Display
Loop Until GetAsyncKeyState(1) Or GetAsyncKeyState(2) Or GetAsyncKeyState(27)
System

Run it. Move the mouse around your screen. I think you can tell fairly quickly and easily what it does for you.

Print this item

  eRATication: Return of the Cheese Chewers
Posted by: bplus - 01-22-2025, 12:35 AM - Forum: bplus - Replies (3)

No shooting please!

Code: (Select All)

_Title "Return of the Cheese Chewer(s) by bplus 2018-08-06"
' QB64 X 64 version 1.2 20180228/86 from git b301f92

' 2018-07-13 eRATication - modified from Asteroids game
' 2018-07-15 eRATication 2
' color rats, eliminate jerks when kill rat,
' decrease rat size as life progresses
' 2018-07-15 some minor changes since post of e #2
' 2018-07-20 eRATication 3
' Shooter: location controlled by mouse
' mouse left and right button works like left and right arrow keys.
' Code: use type for objects, simplify math where possible
' complete makeover of code.
' Fixed problem of running into burning rat.
' Display: Life # and Points on screen as Fellippe suggested.
' Points: should be directly proportional to rat's speed and indirectly
' proportional to size, so speed\size!
' but compare that to number of shots taken!

'2018-08-06 Return of the Cheese Chewer(s)
' All that cheese going to waste?
' nope! redesigned shooter to chucky cheese rat eater


'================================ Instructions ==========================
'
' Move cheese, eat rats, get a-round(er)
'
' Eat or be eaten!
'
'========================================================================

'screen dimensions
Const ww = 1280
Const wh = 740
Const cx0 = 400
Const cy0 = 300
Const ratPack = 5
Const maxLife = 3

Type cheeseType
x As Integer
y As Integer
r As Integer
a As Double 'curr angle
ma As Double 'mouth angle
dma As Integer 'mouth angle growing 1 or shrinking -1
End Type

Type rat
x As Integer
y As Integer
r As Integer
dx As Integer
dy As Integer
c As _Unsigned Long
dead As Integer
End Type

Screen _NewImage(ww, wh, 32)
_FullScreen
Randomize Timer

Dim Shared life, nRats, points, GameOn, newRound, cheese&
Dim Shared r(maxLife * ratPack + maxLife) As rat
Dim Shared chucky As cheeseType

restart:

chucky.x = ww / 2
chucky.y = wh / 2
chucky.r = 50
chucky.a = 0 'mouth direction
chucky.ma = _Pi(1 / 3) 'mouth angle
chucky.dma = 1 'mouth angle direction up or down
lastx = ww / 2: lasty = wh / 2
life = 1
nRats = life * ratPack
points = 0
GameOn = 1
newRound = 0
For i = 0 To nRats
newRat i
Next
growCheese

_MouseHide
While GameOn
Cls
newRound = 0

'KISS control!!!
While _MouseInput: Wend
chucky.x = _MouseX: chucky.y = _MouseY
If chucky.x <> lastx Or chucky.y <> lasty Then
chucky.a = _Atan2(chucky.y - lasty, chucky.x - lastx)
lastx = chucky.x: lasty = chucky.y
End If
If _MouseButton(1) Then chucky.a = chucky.a - _Pi(10 / 360)
If _MouseButton(2) Then chucky.a = chucky.a + _Pi(10 / 360)
While chucky.a < 0
chucky.a = chucky.a + _Pi(2)
Wend
While chucky.a >= _Pi(2)
chucky.a = chuck.a - _Pi(2)
Wend
If _KeyDown(27) Then _MouseShow: End
drawChucky
stats
handleRats
If newRound Then
'chucky goes, round over show last frame to see rat overlap
For ra = 0 To _Pi(2) Step _Pi(1 / 24)
xx = chucky.x + (chucky.r + 20) * Cos(ra)
yy = chucky.y + (chucky.r + 20) * Sin(ra)
xx2 = chucky.x + 5 * chucky.r * Cos(ra)
yy2 = chucky.y + 5 * chucky.r * Sin(ra)
ln xx, yy, xx2, yy2, _RGB32(200, 0, 0)
Next
_Display
_Delay 1.5
If life + 1 <= maxLife Then
life = life + 1
nRats = life * ratPack
'new set o rats
For i = 0 To nRats
newRat i
Next
Else
GameOn = 0
End If
Else
chucky.r = 50 + Int(points / 5)
If chucky.r > 150 Then chucky.r = 150
_Display
_Limit 30
End If
Wend
_Delay 4 ' pause to examine score,
' no play again prompt necessary, of course you want to play again!
GoTo restart

Sub newRat (iRat)
side = rand(1, 4)
Select Case life
Case Is = 1: m = 1
Case Is = 2: m = 1.125
Case Is = 3: m = 1.5
End Select
Select Case side
Case 1
r(iRat).x = 0: r(iRat).y = rand(0, wh)
r(iRat).dx = rand(1, 6) * m: r(iRat).dy = rand(-4, 4) * m
Case 2
r(iRat).x = ww: r(iRat).y = rand(0, wh)
r(iRat).dx = rand(-6, -1) * m: r(iRat).dy = rand(-4, 4) * m
Case 3
r(iRat).x = rand(0, ww): r(iRat).y = 0
r(iRat).dx = rand(-6, 6) * m: r(iRat).dy = rand(1, 4) * m
Case 4
r(iRat).x = rand(0, ww): r(iRat).y = wh:
r(iRat).dx = rand(-6, 6) * m: r(iRat).dy = rand(-4, -1) * m
End Select
r(iRat).r = rand(10, 60 / m)
r(iRat).dead = 0
r = rand(60, 255): g = r \ 2 + rand(0, 10): b = g \ 2
r(iRat).c = _RGB32(r, g, b)
End Sub

Sub handleRats ()
For i = 0 To nRats
If r(i).dead = 0 Then 'if rat not dead move it
r(i).x = r(i).x + r(i).dx
r(i).y = r(i).y + r(i).dy
End If

' rat collides with chucky:
If ((r(i).x - chucky.x) ^ 2 + (r(i).y - chucky.y) ^ 2) ^ .5 < .85 * chucky.r And r(i).dead = 0 Then
'Who gets who ??
'if rat (abdomen) in chucky's mouth chucky lives, rat dies... otherwise vice versa
'we can determine this from the angle between two centers and the direction = direction of chucky's mouth
mx = chucky.x + .5 * chucky.r * Cos(chucky.a)
my = chucky.y + .5 * chucky.r * Sin(chucky.a)
If ((r(i).x - mx) ^ 2 + (r(i).y - my) ^ 2) ^ .5 < .65 * chucky.r Then 'very near center of mouth
'rat dies
If r(i).dead = 0 Then
r(i).dead = 1
points = points + life
End If
Else
newRound = 1 'draw rest of rats to show collisions
End If
End If
'is the rat on screen
If r(i).x > 0 And r(i).x < ww And r(i).y > 0 And r(i).y < wh Then 'inbounds
If r(i).dead Then 'show the burn out until reaches rat radius
r(i).dead = r(i).dead + 2
If r(i).dead < r(i).r Then
For d = 1 To 2 * r(i).r
r1 = rand(-r(i).r, r(i).r): ra1 = Rnd * _Pi(2): r2 = Rnd
dx1 = chucky.x + .5 * chucky.r * Cos(chucky.a) + r2 * r1 * Cos(ra1)
dy1 = chucky.y + .5 * chucky.r * Sin(chucky.a) + r2 * r1 * Sin(ra1)
fcirc dx1, dy1, 2, _RGB32(255 - r(i).dead, 128 - r(i).dead, 0)
Next
Else
newRat i
End If
Else
'draw it
Dim heading As Single
heading = _Atan2(r(i).dy, r(i).dx)
noseX = r(i).x + 2 * r(i).r * Cos(heading)
noseY = r(i).y + 2 * r(i).r * Sin(heading)
neckX = r(i).x + .75 * r(i).r * Cos(heading)
neckY = r(i).y + .75 * r(i).r * Sin(heading)
tailX = r(i).x + 2 * r(i).r * Cos(heading + _Pi)
tailY = r(i).y + 2 * r(i).r * Sin(heading + _Pi)
earLX = r(i).x + r(i).r * Cos(heading - _Pi(1 / 12))
earLY = r(i).y + r(i).r * Sin(heading - _Pi(1 / 12))
earRX = r(i).x + r(i).r * Cos(heading + _Pi(1 / 12))
earRY = r(i).y + r(i).r * Sin(heading + _Pi(1 / 12))
fcirc r(i).x, r(i).y, .65 * r(i).r, r(i).c
fcirc neckX, neckY, r(i).r * .3, r(i).c
fTri noseX, noseY, earLX, earLY, earRX, earRY, r(i).c
fcirc earLX, earLY, r(i).r * .3, r(i).c
fcirc earRX, earRY, r(i).r * .3, r(i).c
wX = .5 * r(i).r * Cos(heading - _Pi(11 / 18))
wY = .5 * r(i).r * Sin(heading - _Pi(11 / 18))
ln noseX + wX, noseY + wY, noseX - wX, noseY - wY, r(i).c
wX = .5 * r(i).r * Cos(heading - _Pi(7 / 18))
wY = .5 * r(i).r * Sin(heading - _Pi(7 / 18))
ln noseX + wX, noseY + wY, noseX - wX, noseY - wY, r(i).c
ln r(i).x, r(i).y, tailX, tailY, r(i).c
End If
Else 'out of bounds
newRat i
End If
Next
End Sub

Sub drawChucky ()
'first makeCheese and use cheese& image to build chucky image
'dim shared chucky as cheeseType

'first chucky's mouth angle
chucky.ma = chucky.ma + _Pi(1 / 5) * chucky.dma
If chucky.ma > _Pi(5 / 6) Then chucky.ma = _Pi(5 / 6): chucky.dma = -1 * chucky.dma
If chucky.ma < _Pi(1 / 12) Then chucky.ma = _Pi(1 / 12): chucky.dma = -1 * chucky.dma
ma2 = .5 * chucky.ma

'next first leg of chucky
x1 = chucky.x + chucky.r * Cos(chucky.a + ma2)
y1 = chucky.y + chucky.r * Sin(chucky.a + ma2)
'first leg of cheese
cx1 = cx0 + chucky.r * Cos(ma2)
cy1 = cy0 + chucky.r * Sin(ma2)

'take small traingles off cheese& image and map them onto main screen at chucky's and mouth angle position
stepper = _Pi(1 / 20)
starter = ma2 + stepper
stopper = _Pi(2) - ma2
For a = starter To stopper Step stepper
'one to one ratio of mapping
x2 = chucky.x + chucky.r * Cos(chucky.a + a)
y2 = chucky.y + chucky.r * Sin(chucky.a + a)
cx2 = cx0 + chucky.r * Cos(a)
cy2 = cy0 + chucky.r * Sin(a)
_MapTriangle (cx0, cy0)-(cx1, cy1)-(cx2, cy2), cheese& To(chucky.x, chucky.y)-(x1, y1)-(x2, y2), 0
x1 = x2: y1 = y2: cx1 = cx2: cy1 = cy2
Next
End Sub


Sub growCheese () 'make this more self contained than first version, all hole stuff just in here
curr& = _Dest
If cheese& Then _FreeImage cheese&
cheese& = _NewImage(ww, wh, 32)
_Dest cheese&
nHoles = 300: maxHoleLife = 20: maxHoleRadius = 7: tfStart = 1
Dim hx(nHoles), hy(nHoles), hLife(nHoles)
For i = 1 To nHoles
GoSub newHole
Next
tfStart = 0
For layr = 1 To 30
Line (0, 0)-(ww, wh), _RGBA32(255, 255, 0, 50), BF 'layer of cheese
For i = 1 To nHoles 'holes in layer
If hLife(i) + 1 > maxHoleLife Then GoSub newHole Else hLife(i) = hLife(i) + 1
hx(i) = hx(i) + Rnd * 2 - 1
hy(i) = hy(i) + Rnd * 2 - 1
If hLife(i) < maxHoleRadius Then
radius = hLife(i)
ElseIf maxHoleLife - hLife(i) < maxHoleRadius Then
radius = maxHoleLife - hLife(i)
Else
radius = maxHoleRadius
End If
fcirc hx(i), hy(i), radius, _RGBA32(0, 0, 0, 50)
Next
Next
_Dest curr&
Exit Sub

newHole:
hx(i) = ww * Rnd
hy(i) = wh * Rnd
If tfStart Then hLife(i) = Int(Rnd * maxHoleLife) Else hLife(i) = 1
Return

End Sub

Sub stats ()
Color _RGB(200, 225, 255)
_PrintString (5, 5), "Life #" + LTrim$(Str$(life)) + " Points:" + Str$(points)
End Sub

Function rand% (lo%, hi%)
rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function

' found at QB64.net: http://www.qb64.net/forum/index.php?topic=14425.0
Sub fTri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest 0
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub

Sub ln (x1, y1, x2, y2, K As _Unsigned Long)
Line (x1, y1)-(x2, y2), K
End Sub

'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long, c As _Unsigned Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long

subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0

If subRadius = 0 Then PSet (CX, CY), c: Exit Sub

' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
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

Print this item

  Mouse Tank
Posted by: SierraKen - 01-21-2025, 10:04 PM - Forum: Games - Replies (31)

Here is a game I've been working on for a few days called Mouse Tank.
You use your mouse to move your little tank anywhere on the screen while dodging the monsters and shooting them 
with your left mouse button. Also you can turn the turret cannon using your mouse wheel. 
I know B+ made something similar to this years ago but I realized that half-way into making it. 
I hope you all enjoy it. I had a blast making it. Smile

@bplus

-Ken
[Image: Ken-s-Mouse-Tank.jpg]


Code: (Select All)

'Mouse Tank by SierraKen
'January 21, 2025

'Thank you to the QB64 Phoenix Forum, including B+ for the help over the years.

_Title "Mouse Tank - by SierraKen"

Screen _NewImage(800, 600, 32)

Randomize Timer

num = 40

Dim oldx(100), oldy(100)
Dim d1(100), d2(100), s(100), d(100), t(100)
Dim x(100), y(100), xx(100), yy(100), si(100), red(100), green(100), blue(100)
Dim nox(100), llx(100), lly(100)

start:

level = 1
score = 0
health = 50
healthp = 100

Cls
_AutoDisplay

Locate 3, 25: Print "M O U S E  T A N K"
Locate 5, 25: Print "By SierraKen"
Locate 10, 25: Print "Move your tank around with your mouse."
Locate 11, 25: Print "Turn your cannon turret with your mouse wheel."
Locate 12, 25: Print "Press left mouse button to fire at monsters."
Locate 13, 25: Print "To pause and unpause, press Space Bar."
Locate 14, 25: Print "Press Esc anytime to quit."
Locate 18, 25: Print "Center Mouse on screen and click left mouse Button to begin."
Do
    If _MouseInput Then mi = 1
Loop Until mi = 1 And _MouseButton(1)

start2:
Cls

_Title "Score: " + Str$(score) + "    Health: " + Str$(healthp) + "%    Level: " + Str$(level)

oldx = 400
oldy = 300

hits = 0

bx = 1
bx2 = 1

mw = -90
r1 = 4
r2 = 30
r3 = 25
loops = 0
For size = 1 To num
    si(size) = (Rnd * 10) + 10
Next size

For colors = 1 To num
    red(colors) = Int(Rnd * 100) + 155
    green(colors) = Int(Rnd * 100) + 155
    blue(colors) = Int(Rnd * 100) + 155
Next colors

Do
    _Limit 400
    For n = 1 To num
        If nox(n) = 1 Then GoTo skip:
        If d1(n) > d2(n) Then s(n) = s(n) + .1
        If d2(n) > d1(n) Then s(n) = s(n) - .1
        d(n) = d(n) + 1
        If d(n) > t(n) Then
            oldx(n) = oldx(n) + x(n)
            oldy(n) = oldy(n) + y(n)
            bugchange d1(n), d2(n), d(n), t(n)
        End If
        x(n) = Cos(s(n) * _Pi / 180) * d(n)
        y(n) = Sin(s(n) * _Pi / 180) * d(n)
        xx(n) = x(n) + oldx(n)
        yy(n) = y(n) + oldy(n)
        If xx(n) > 750 Then oldx(n) = 50: Cls: bugchange d1(n), d2(n), d(n), t(n)
        If xx(n) < 50 Then oldx(n) = 750: Cls: bugchange d1(n), d2(n), d(n), t(n)
        If yy(n) > 550 Then oldy(n) = 50: Cls: bugchange d1(n), d2(n), d(n), t(n)
        If yy(n) < 50 Then oldy(n) = 550: Cls: bugchange d1(n), d2(n), d(n), t(n)
        fillCircle xx(n), yy(n), si(n), _RGB32(red(n), green(n), blue(n))
        fillCircle xx(n) - (si(n) * .3), yy(n) - (si(n) * .3), si(n) * .2, _RGB32(255, 0, 0)
        fillCircle xx(n) + (si(n) * .3), yy(n) - (si(n) * .3), si(n) * .2, _RGB32(255, 0, 0)
        fillCircle xx(n), yy(n), 3, _RGB32(255, 0, 0)
        For sz = .1 To si(n) * .4 Step .1
            Circle (xx(n), yy(n) + (si(n) * .4)), sz, _RGB32(255, 0, 0), , , .35
        Next sz
        skip:
        If _MouseInput Then
            mx = _MouseX
            my = _MouseY
            If _MouseButton(1) Then
                laser = 1
                lx = mx
                ly = my + 25
            End If
            If _MouseWheel Then
                mw = mw + _MouseWheel * 5
            End If
        End If

        If laser = 1 Then
            lx2 = Cos(mw * _Pi / 180)
            ly2 = Sin(mw * _Pi / 180)
            lx = lx2 / 2 + lx
            ly = ly2 / 2 + ly
            fillCircle lx, ly, r1, _RGB32(255, 0, 5)
            For chk = 1 To num

                distance = Sqr((lx - xx(chk)) ^ 2 + (ly - yy(chk)) ^ 2)
                If distance <= r1 + r2 Then
                    DetectCollision = -1 ' True (collision detected)
                Else
                    DetectCollision = 0 ' False (no collision)
                End If

                If DetectCollision And nox(chk) <> 1 Then
                    For explosion = 1 To 100
                        Circle (lx, ly), explosion, _RGB32(255, 0, 0)
                        llx(explosion) = lx
                        lly(explosion) = ly
                    Next explosion
                    Sound 75, .1 '
                    oldx(chk) = -100: nox(chk) = 1
                    score = score + 10
                    _Title "Score: " + Str$(score) + "    Health: " + Str$(healthp) + "%    Level: " + Str$(level)
                    hits = hits + 1
                    laser = 0
                    ly = -3
                    GoTo skip2:
                End If
            Next chk
        End If

        skip2:
        If ly < -2 Then
            laser = 0
            ly = 0
        End If
        If hits > num - 1 Then
            Cls
            ly = 0
            laser = 0
            For nn = 1 To num
                nox(nn) = 0
            Next nn
            level = level + 1
            num = num + 2
            If num > 75 Then num = 75
            GoTo start2
        End If

        'Draw your tank.
        For mxx = -25 To 25 Step .25
            Line (mx, my - 5)-(mx - mxx, my + 25), _RGB32(127, 255, 127)
        Next mxx
        For mxx2 = 1 To 25 Step .25
            Line (mx, my - 5)-(mx + mxx2, my + 25), _RGB32(127, 255, 127)
        Next mxx2

        For mxx = -25 To 25 Step .25
            Line (mx, my + 50)-(mx + mxx, my + 25), _RGB32(127, 255, 127)
        Next mxx
        For mxx2 = 1 To 25 Step .25
            Line (mx, my + 50)-(mx - mxx2, my + 25), _RGB32(127, 255, 127)
        Next mxx2
        fillCircle mx, my + 25, 15, _RGB32(0, 0, 255)
        fillCircle mx, my + 25, 7, _RGB32(127, 255, 127)

        'Draw your tank turret cannon.
        s1 = 90 - mw
        x = Int(Sin(s1 / 180 * _Pi) * 30) + mx
        y = Int(Cos(s1 / 180 * _Pi) * 30) + my
        Line (mx, my + 25)-(x, y + 25), _RGB32(255, 0, 0)
        If loops < 1000 Then GoTo skip3
        'Detect collision with monsters.
        For chk = 1 To num

            distance = Sqr((mx - xx(chk)) ^ 2 + (my - yy(chk)) ^ 2)
            If distance <= r3 + r2 Then
                DetectCollision = -1 ' True (collision detected)
            Else
                DetectCollision = 0 ' False (no collision)
            End If
            If DetectCollision And nox(chk) <> 1 Then
                health = health - .005
                healthp = Int((health / 50) * 100)
                _Title "Score: " + Str$(score) + "    Health: " + Str$(healthp) + "%    Level: " + Str$(level)
                If health < .01 Then
                    For explosion = 1 To 200
                        Circle (mx, my + 25), explosion, _RGB32(255, 0, 0)
                    Next explosion
                    For snd = 100 To 150 Step 5
                        Sound snd, .1
                    Next snd
                    Locate 20, 30: Print "G A M E    O V E R"
                    Locate 25, 30: Input "Again (Y/N)"; ag$
                    If Left$(ag$, 1) = "y" Or Left$(ag$, 1) = "Y" Then GoTo start
                    End
                End If
            End If
        Next chk
        skip3:

        If loops < 1000 Then
            loops = loops + 1
        End If

    Next n
    b$ = InKey$
    If b$ = " " Then
        Do: c$ = InKey$:
            If c$ = Chr$(27) Then End
        Loop Until c$ = " "
    End If
    _Display
    Cls
Loop Until b$ = Chr$(27)
End


Sub bugchange (d1, d2, d, t)
    d1 = Rnd * 360
    d2 = Rnd * 360
    d = 0
    t = Int(Rnd * 360) + 1
End Sub

'from Steve Gold standard
Sub fillCircle (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

Print this item

  Updating my mouse and keyboard routine.
Posted by: Pete - 01-21-2025, 05:05 PM - Forum: Works in Progress - Replies (28)

I thought I'd put this in a demo for @bplus to have a look at the mouse function. I want to add my other mapping routine as an option. This one uses arrays. Basically my goal is to pack as many methods and actions as I use in many of my apps into this one subroutine, if possible.

Demo: Press keys, hold keys like ctrl, click mouse, use wheel, hover/click buttons, drag, etc.

Code: (Select All)
ReDim Shared y_btl(2), y_bbr(2), x_btl(2), x_bbr(2), button$(2)
nob = 2
Color 15, 1
If mapping = 0 Then
Locate 10, 50: y_btl(1) = CsrLin: x_btl(1) = Pos(0): Print Chr$(218) + String$(10, 196) + Chr$(191)
Locate 11, 50: Print Chr$(179);: Locate , Pos(0) + 10: Print Chr$(179);
Locate 12, 50: Print Chr$(192) + String$(10, 196) + Chr$(217);: y_bbr(1) = CsrLin: x_bbr(1) = Pos(0) - 1
button$(1) = " Button 1 "
Locate 11, 51: Print " Button 1 ";

Locate 10, 65: y_btl(2) = CsrLin: x_btl(2) = Pos(0): Print Chr$(218) + String$(10, 196) + Chr$(191)
Locate 11, 65: Print Chr$(179);: Locate , Pos(0) + 10: Print Chr$(179);
Locate 12, 65: Print Chr$(192) + String$(10, 196) + Chr$(217);: y_bbr(2) = CsrLin: x_bbr(2) = Pos(0) - 1
button$(2) = " Button 2 "
Locate 11, 66: Print " Button 2 ";
Else
Locate 10, 50: Print Chr$(218) + String$(10, 196) + Chr$(191)
Locate 11, 50: Print Chr$(179);: Locate , Pos(0) + 10: Print Chr$(179);
button$(1) = " Button 1 "
Locate 12, 50: Print Chr$(192) + String$(10, 196) + Chr$(217)
Locate 11, 51: Print " Button 1 ";

Locate 10, 65: Print Chr$(218) + String$(10, 196) + Chr$(191)
Locate 11, 65: Print Chr$(179);: Locate , Pos(0) + 10: Print Chr$(179);
Locate 12, 65: Print Chr$(192) + String$(10, 196) + Chr$(217)
button$(2) = " Button 2 "
Locate 11, 66: Print " Button 2 ";
End If
PCopy 0, 1
Color 7, 0
Locate 1, 1
Do
MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, alt, AltToggle, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$, nob, button$()

If drag Then
If olddrag <> drag Then
If drag > 0 Then Print "Drag Right. Status ="; Else Print "Drag Left. Status = ";
Print drag
olddrag = drag
End If
Else
olddrag = 0
End If
If oldlb <> lb Then
Select Case lb
Case 0: Print "Left Button Up - Button Status ="; lb
Case -1: Print "Left Button Down - Button Status = "; lb
Case 1: Print "Left Button Pressed - Button Status ="; lb
Case 2: Print "Left Button Released - Button Status ="; lb
End Select
If lb = 0 Then Print "Number of clicks ="; clkcnt
End If
If oldmb <> mb Then
Select Case mb
Case 0: Print "Middle Button Up - Button Status ="; mb
Case -1: Print "Middle Button Down - Button Status = "; mb
Case 1: Print "Middle Button Pressed - Button Status ="; mb
Case 2: Print "Middle Button Released - Button Status ="; mb
End Select
End If
If oldrb <> rb Then
Select Case rb
Case 0: Print "Right Button Up - Button Status ="; rb
Case -1: Print "Right Button Down - Button Status = "; rb
Case 1: Print "Right Button Pressed - Button Status ="; rb
Case 2: Print "Right Button Released - Button Status ="; rb
End Select
End If
If oldmw <> mw Then
If mw < 0 Then Print "Mouse Wheel Up - Wheel Status ="; mw
If mw > 0 Then Print "Mouse Wheel Down - Wheel Status ="; mw
End If
If oldalt% <> alt% Then
If alt% < 0 Then Print "Alt Button Down" Else Print "Alt Button Released"
End If
If oldctrl% <> ctrl% Then
If ctrl% < 0 Then Print "Ctrl Button Down" Else Print "Ctrl Button Released"
End If
If oldshift% <> shift% Then
If shift% < 0 Then Print "Shift Button Down" Else Print "Shift Button Released"
End If
If oldalt <> alt And alt < 0 Then
Print "Alt Key Pressed";
If AltToggle Then Print " / Alt Toggle Status: On" Else Print " / Alt Toggle Status: Off"
End If
If k& < 0 Then oldb$ = ""
Select Case Len(b$)
Case 1
If oldb$ <> b$ Then Print "You Pressed: ";: x = CVI(MKI$(Asc(b$))): Print Chr$(x); " Chr$(" + LTrim$(Str$(x)) + ")"
oldb$ = b$
Case 2
If oldb$ <> b$ Then Print "You Pressed: "; "nul + " + LTrim$(Str$(Asc(Mid$(b$, 2, 1)))) + " Chr$(0) + " + Chr$(34) + Mid$(b$, 2, 1) + Chr$(34)
oldb$ = b$
End Select

oldlb = lb: oldrb = rb: oldmb = mb: oldmw = mw: oldalt% = alt%: oldctrl% = ctrl%: oldshift% = shift%: oldalt = alt
If CsrLin > _Height - 2 Then Cls: PCopy 1, 0
Loop

Sub MyMouse_and_Keyboard (lb, mb, rb, my, mx, mw, shift%, alt, AltToggle, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$, nob, button$())
Dim As Integer b_hover, i, oldmw
Static As Integer oldmy, oldmx, hover, mwy, oldmwy, b_active
Static z1 As Single
_Limit 60
If alt Then alt = 0
If Len(autokey$) Then
b$ = Mid$(autokey$, 1, InStr(autokey$ + ",", ",") - 1)
autokey$ = Mid$(autokey$, InStr(autokey$ + ",", ",") + 1)
Exit Sub
Else
k& = _KeyHit
If k& = 100307 Or k& = 100308 Then
alt = -1
AltToggle = 1 - AltToggle
Exit Sub
End If
If k& > 0 Then
b$ = MKI$(k&)
If Mid$(b$, 2, 1) = Chr$(135) Then b$ = "" ' Keys like like Shift, Ctrl, and alt.
If Right$(b$, 1) = Chr$(0) Then b$ = Left$(b$, 1)
Else
b$ = ""
End If
End If
If z1 Then If Abs(Timer - z1) > .25 Then z1 = 0: clkcnt = 0
If lb > 0 Then
If lb = 1 Then
lb = -1
Else
lb = 0
End If
End If
If rb > 0 Then If rb = 1 Then rb = -1 Else rb = 0
If mb > 0 Then If mb = 1 Then mb = -1 Else mb = 0
While _MouseInput
mwy = mwy + _MouseWheel
Wend
my = _MouseY
mx = _MouseX
b_hover = 0
For i = 1 To nob ' number of buttons.
If my >= y_btl(i) And my <= y_bbr(i) And mx >= x_btl(i) And mx <= x_bbr(i) Then
b_hover = i
Exit For
End If
Next
If lb = -1 Then
If oldmy And oldmx <> mx Or oldmy And oldmy <> my Then
If mx <> oldmx Then drag = Sgn(mx - oldmx) ' Prevent zero which can occur if mouse moves off row when being dragged horizontally.
End If
End If
If drag = 0 Then
If mwy <> oldmw Then
mw = Sgn(mwy - oldmwy): mwy = 0
Else
mw = 0
End If
oldmwy = mwy
If _KeyDown(100303) Or _KeyDown(100304) Then shift% = -1 Else If shift% Then shift% = 0
If _KeyDown(100305) Or _KeyDown(100306) Then ctrl% = -1 Else If ctrl% Then ctrl% = 0
If _KeyDown(100307) Or _KeyDown(100308) Then alt% = -1 Else If alt% Then alt% = 0
End If
If lb = -1 And _MouseButton(1) = 0 Then
lb = 2: drag = 0: hover = 0
ElseIf rb = -1 And _MouseButton(2) = 0 Then
rb = 2
ElseIf mb = -1 And _MouseButton(3) = 0 Then
mb = 2
End If
If _MouseButton(1) Then
If lb = 0 Then
lb = 1: z1 = Timer
clkcnt = clkcnt + 1
End If
ElseIf _MouseButton(2) And rb = 0 Then
rb = 1
ElseIf _MouseButton(3) And mb = 0 Then
mb = 1
End If
If b_active Then
If b_hover Then
If lb = 1 Or lb = 0 Then ' Button clicked. Flash effect.
s1 = CsrLin: s2 = Pos(0)
c1 = _DefaultColor: c2 = _BackgroundColor
If lb = 1 Then Color 15, 3 Else Color 1, 3
Locate y_btl(b_active), x_btl(b_active): Print Chr$(218) + String$(10, 196) + Chr$(191)
Locate , x_btl(b_active): Print Chr$(179);: Locate , Pos(0) + 10: Print Chr$(179)
Locate , x_btl(b_active): Print Chr$(192) + String$(10, 196) + Chr$(217);
Locate y_btl(b_active) + 1, x_btl(b_active) + 1: Print button$(b_active);
Color c1, c2
Locate s1, s2
End If
Else
s1 = CsrLin: s2 = Pos(0)
c1 = _DefaultColor: c2 = _BackgroundColor
Color 15, 1
Locate y_btl(b_active), x_btl(b_active): Print Chr$(218) + String$(10, 196) + Chr$(191)
Locate , x_btl(b_active): Print Chr$(179);: Locate , Pos(0) + 10: Print Chr$(179)
Locate , x_btl(b_active): Print Chr$(192) + String$(10, 196) + Chr$(217);
Locate y_btl(b_active) + 1, x_btl(b_active) + 1: Print button$(b_active);
Color c1, c2
Locate s1, s2
b_active = 0
End If
Else
If b_hover And oldmy <> 0 Then
If b_active = 0 Then
s1 = CsrLin: s2 = Pos(0)
c1 = _DefaultColor: c2 = _BackgroundColor
Color 1, 3
Locate y_btl(b_hover), x_btl(b_hover): Print Chr$(218) + String$(10, 196) + Chr$(191)
Locate , x_btl(b_hover): Print Chr$(179);: Locate , Pos(0) + 10: Print Chr$(179)
Locate , x_btl(b_hover): Print Chr$(192) + String$(10, 196) + Chr$(217);
Locate y_btl(b_hover) + 1, x_btl(b_hover) + 1: Print button$(b_hover);
Color c1, c2
Locate s1, s2
b_active = b_hover
End If
End If
End If
oldmy = my: oldmx = mx
End Sub

I'll probably switch to type variables before going any further.

Oh, since INKEY$ is very familiar to me, but I get a bit PISSED OFF now and then by its inability to detect press and release without adding a slightly imperfect coding workaround, I decided to migrate to _KEYHIT by using a _KEYHIT to INKEY$ conversion method. Lucky for me I migrated just before Inauguration day, or I might have HIT A WALL on that one!

Pete

Print this item

  [split] Lines of Code
Posted by: bplus - 01-20-2025, 05:13 PM - Forum: General Discussion - Replies (20)

"Less lines does not = more readable code"

agreed! 100% but this does not mean less readable either. Fact is readable is an opinion and that is based on ones personal experiences.
(BTW "Less lines <> readable code" less words but don't use it in an English paperBig Grin )

I think there is a legitimate positive challenge to reduce the lines of code. I think of it as boiling down a code's essence. It is NOT some useless exercise even if it gets silly except silly with colons of course Smile

In reducing lines of code here, what step had I taken that wasn't instructive to a beginner?
Never did I say well you can put it all one one line by using colons because that is not helpful in learning; thats what a bot would do, nothing to learn there. Seems the use _IIF was a popular outcome of this thread. I think _InputBox$ dialog has some great advantages over the simpler Input. How many newbies know about multiple assignments from one Input prompt?

The final one-liner here is less than appealing because it exceeds a certain tolerable line width. line extensions? eeeeh only if you must! better than having to use a horizontal scroller. Thats when I consider shortening variable names or strings.

Tell me, you look at a text book that is 1000 pages and you look at a summary statement one line long, which are you more inclined to read?
Maybe the one-liner will help motivate you to read the text book.

Print this item

  Qix line monster
Posted by: Abazek - 01-20-2025, 07:35 AM - Forum: Programs - Replies (2)

Anyone remember the 1980's arcade game (and later home computer / console game) Qix ?

I was thinking about how to re-create the "line monster" (the Qix) from this game.  Basically it is an array of lines (ie:  (x1,y1) and (x2,y2) coordinates).  A line is drawn, then the color is dimmed a little, and the next line is drawn.  This produces a fade out effect.  The coordinates of the first line are changed each time the monster moves.  Each remaining line is a copy of the one before it in the array.  The code would be something like this:

for q = last_line to 2 step -1
    line(q) = line(q-1)
next q
update_coords line(1)

In the 1980's game, the array contained only a handful of lines, maybe a dozen or so at most.  This was likely done because of hardware limitations (both CPU speeds, and screen resolution).  Today, with our high-res screens and faster CPUs, we can make the array much longer...

Below is my first attempt at doing this.  It is not the most elegant code, but it works.  The array is 135 lines long (const cnqlen, ie: Qix Length).  It doesn't look exactly like the arcade.  It sort of reminds me of the old "Mystify" screen saver for Windows...  The line will change colors every few seconds, or you can press 1-7 to change colors.

Code: (Select All)

'' Qix line experiment 1 (first attempt at reproducing the "line monster" from the 1980's game Qix)
'' by Abazek    2025-Jan-19
''
'' Future plans:
'' 1. Optimize the code (there are parts of this I could do differently/better)
'' 2. Greater variety of movement (perhaps RND, or SIN and COS, so cx/cy can be more than just 1, 0, or -1)
'' 3. Qix size limits (ie: if qixA and qixB get too far apart, change cx/cy to bring them closer together)

Const cnqlen = 135
Const cnfade = 2
Const cnSPD = 0.05
Const cnResX = 1280
Const cnResY = 960
Const cnMinChg = 25
Const cnMaxChg = 100
Const defx1 = 620
Const defy1 = 460
Const defx2 = 660
Const defy2 = 500

Type coord
    x As Integer
    y As Integer
    c As Integer
End Type

Dim qixA(cnqlen) As coord
Dim qixB(cnqlen) As coord
Dim scn&, pixcolr&
Dim a$, qq, d1, d2, colr, fw, flag, cl, clrchg, whenclr
Dim showc
Dim Shared cx, cy, chgdirA, chgdirB, whenChgA, whenChgB

Randomize Timer
scn& = _NewImage(cnResX, cnResY, 32)
Screen scn&
Cls 0, _RGB(0, 0, 0)
_Title "Qix Experiment 1"

For qq = 1 To cnqlen
    qixA(qq).x = defx1
    qixA(qq).y = defy1
    qixA(qq).c = 7
    qixB(qq).x = defx2
    qixB(qq).y = defy2
    qixB(qq).c = 7
Next qq
GoSub changedirA
GoSub changedirB

chgdirA = 0
chgdirB = 0
clrchg = 0
whenclr = cnMaxChg
showc = 0
flag = 0
While flag = 0
    GoSub MoveQix
    If showc = 1 Then GoSub ShowCoords
    GoSub DrawQix
    Color _RGB32(128, 128, 128)
    Locate 1, 1
    Print "ESC or SPACE to exit.  S to show coordintates.  D to hide coordintates.  1-7 manually change color."
    ''GoSub framewait
    _Delay cnSPD
    ''GoSub WaitKey
    a$ = InKey$
    If a$ = Chr$(27) Then flag = 1
    If a$ = Chr$(32) Then flag = 1
    If a$ = "S" Or a$ = "s" Then showc = 1: Cls
    If a$ = "D" Or a$ = "d" Then showc = 0: Cls
    If a$ = "1" Then cl = 1: GoSub ManualClr
    If a$ = "2" Then cl = 2: GoSub ManualClr
    If a$ = "3" Then cl = 3: GoSub ManualClr
    If a$ = "4" Then cl = 4: GoSub ManualClr
    If a$ = "5" Then cl = 5: GoSub ManualClr
    If a$ = "6" Then cl = 6: GoSub ManualClr
    If a$ = "7" Then cl = 7: GoSub ManualClr
Wend
End

WaitKey:
a$ = InKey$
If a$ = "" Then GoTo WaitKey
If a$ = Chr$(27) Then flag = 1
Return

framewait:
fw = Timer
While (Abs(Timer - fw) < cnSPD)
Wend
Return

ShowCoords:
For qq = 1 To cnqlen
    If qq < 51 Then
        Locate (qq + 1), 1
    ElseIf qq < 101 Then
        Locate (qq - 49), 50
    ElseIf qq < 151 Then
        Locate (qq - 99), 100
    Else
        Locate 51, 100
    End If
    Color _RGB32(128, 128, 128)
    Print "Coords "; qq; " = ("; qixA(qq).x; ","; qixA(qq).y; ") - ("; qixB(qq).x; ","; qixB(qq).y; ")"
Next qq
Locate 52, 1
Print "Timer = "; Timer; "  Delay="; cnSPD; "  ChgdirA="; chgdirA; "/"; whenChgA; "  ChgdirB="; chgdirB; "/"; whenChgB;
colr = 128
GoSub setColor
Color pixcolr&
Print "  Color "; clrchg; "/"; whenclr; "  "
Return

DrawQix:
colr = 1
For qq = cnqlen To 1 Step -1
    cl = qixA(qq).c
    GoSub setColor
    Color pixcolr&
    Line (qixA(qq).x, qixA(qq).y)-(qixB(qq).x, qixB(qq).y), pixcolr&
    colr = colr + cnfade
    If colr > 255 Then colr = 255
Next qq
Color _RGB32(1, 1, 1)
Return

MoveQix:
For qq = cnqlen To 2 Step -1
    qixA(qq).x = qixA(qq - 1).x
    qixA(qq).y = qixA(qq - 1).y
    qixA(qq).c = qixA(qq - 1).c
    qixB(qq).x = qixB(qq - 1).x
    qixB(qq).y = qixB(qq - 1).y
    qixB(qq).c = qixB(qq - 1).c
Next qq
qq = 1
chgdirA = chgdirA + 1
chgdirB = chgdirB + 1
clrchg = clrchg + 1
If chgdirA > whenChgA Then
    GoSub changedirA
End If
If chgdirB > whenChgB Then
    GoSub changedirB
End If
If clrchg > whenclr Then
    GoSub changeClr
    qixA(qq).c = cl
    qixB(qq).c = cl
End If
SetMoveDir d1
cx = cx * 2
cy = cy * 2
qixA(qq).x = qixA(qq).x + cx
qixA(qq).y = qixA(qq).y + cy
If qixA(qq).x < 1 Then qixA(qq).x = 1: GoSub changedirA
If qixA(qq).x > cnResX Then qixA(qq).x = cnResX: GoSub changedirA
If qixA(qq).y < 1 Then qixA(qq).y = 1: GoSub changedirA
If qixA(qq).y > cnResY Then qixA(qq).y = cnResY: GoSub changedirA
SetMoveDir d2
cx = cx * 2
cy = cy * 2
qixB(qq).x = qixB(qq).x + cx
qixB(qq).y = qixB(qq).y + cy
If qixB(qq).x < 1 Then qixB(qq).x = 1: GoSub changedirB
If qixB(qq).x > cnResX Then qixB(qq).x = cnResX: GoSub changedirB
If qixB(qq).y < 1 Then qixB(qq).y = 1: GoSub changedirB
If qixB(qq).y > cnResY Then qixB(qq).y = cnResY: GoSub changedirB
Return

changedirA:
d1 = Int(Rnd * 8) + 1
cl = cnMaxChg - cnMinChg
whenChgA = Int(Rnd * cl) + cnMinChg
chgdirA = 0
Return

changedirB:
d2 = Int(Rnd * 8) + 1
cl = cnMaxChg - cnMinChg
whenChgB = Int(Rnd * cl) + cnMinChg
chgdirB = 0
Return

changeClr:
cl = Int(Rnd * 7) + 1
clrchg = 0
Return

ManualClr:
qixA(1).c = cl
qixB(1).c = cl
clrchg = 0
Return

setColor:
Select Case cl
    Case 1
        pixcolr& = _RGB32(colr, 0, 0)
    Case 2
        pixcolr& = _RGB32(0, colr, 0)
    Case 3
        pixcolr& = _RGB32(colr, colr, 0)
    Case 4
        pixcolr& = _RGB32(0, 0, colr)
    Case 5
        pixcolr& = _RGB32(colr, 0, colr)
    Case 6
        pixcolr& = _RGB32(0, colr, colr)
    Case Else
        pixcolr& = _RGB32(colr, colr, colr)
End Select
Return

Sub SetMoveDir (dir)
    Select Case dir
        Case 1
            cx = 1: cy = 0
        Case 2
            cx = 0: cy = 1
        Case 3
            cx = -1: cy = 0
        Case 4
            cx = 0: cy = -1
        Case 5
            cx = 1: cy = -1
        Case 6
            cx = -1: cy = 1
        Case 7
            cx = -1: cy = -1
        Case Else
            cx = 1: cy = 1
    End Select
End Sub

Print this item

  [split] BAM and _IIF with INPUT
Posted by: bplus - 01-19-2025, 08:20 PM - Forum: QBJS, BAM, and Other BASICs - Replies (8)

"Oh you speed demon" ah, Charlie I had so much less typing to do Smile

That is freak'n interesting code you had back there @CharlieJV
https://qb64phoenix.com/forum/showthread...6#pid31416

I see your Input can take variable string for/in the prompt And something funny about IF THEN Structure there too.
I must warn newbies that this BAM code is NOT QB64pe code but a very close cousin.

Print this item