Game here is another piece of ancient history, written more-or-less as a tutorial in days-gone-by to showcase how simple it is to write a poker program. Some folks think the logic for these things has to be complex as heck -- it doesn't.
Honestly, I can't think of too many games that are any simpler than this one was to make.
Waaaaayyyy back in 1902, before the US declared its independence from Japan, and right after the Great FreeBasic-64 War, The Amazing Steve found QB64 and showed up on the scene -- and this is the very first thing he ever posted at the ancient qb64 forums which are now lost to time. Nooo... not the forums which were lost to time recently... And not the forums before those forums which were lost to time.... and not the forums which were even before those forums.... This was posted in the forums from before THOSE forums!!
So we're talking ancient history here, and the code here shows that.
...and amazingly enough, it STILL works!!
So, for those of you who may have never seen it; and for those of you who want a blast from the past, here it is once again -- The Amazing Steve's very first QB64 program that he ever shared with the world wide web!!!
For folks that haven't bothered to read the various other topics on the forums here (especially one multiple pages deep), CONST is currently bugged. At the moment, it's suffering from a glitch that was made obvious via the latest set of fixes to CONST. (Fix one thing, break two more -- isn't that one of the core rules of programming? LOL!)
At the moment, there are instances where CONST will *negate* the resulting value for us. Const foo = 1 will assign a value of -1 to foo... This is a 100% glitch and is being patched even now by the dev team. (It's not something so obvious as to work with 1, but the previous was just an illustration. Where you can find the glitch is with CONST foo = &HFFFF which returns a value of - &HFFF.)
BUT, while working on this patch, we also noticed that there was a secondary issue with CONST which needed fixing. In the past, CONST has always returned UNSIGNED values to us with &H, &O, &B numbers. This is 100% on me, as I'd just always considered hex values and such to be unsigned.
THIS IS WRONG!!
Our guiding goal has always been QB45 compatibility, and I'd love for someone to show me where QB45 had an unsigned variable type...
In QB45, &HFFFF returns a value of -1, as it represents a SIGNED INTEGER value in hex.
In QB45, &HFFFFFFFF also returns a value of -1, as it represents an UNSIGNED LONG value in hex.
Due to Steve not realizing this, QB64 has been returning SIGNED values for those numbers in the past. &HFFFF would return 65635 and &HFFFFFFFF would return 4billion-something.
Where this makes a drastic change would be if someone ever did something such as:
CONST foo = &HFFFF + &HFFFFFFFF
In QB45, the answer to that would be -- as shocking as it seems to my poor brain -- MINUS TWO.
&HFFFF = -1 (as signed integer)
&HFFFFFFFF = -1 (as signed long)
-1 + -1 = -2 (add those together and get -2)
^That's just mind boggling to me personally, but it is what it is. For our goal of maintaining backward's compatibility, CONST needs to have this same behavior. Used outside of CONST, QB64 already does this type of bizarre type-casting. It's just that I never accounted for this behavior in CONST itself, and now that oversight is going to be fixed soon.
And this fix may affect your code.
If you relied on the same incorrect understanding that I did -- that unsuffixed values default to unsigned values, then you're going to be bit by these changes.
CONST foo = &HFF000000 + &HFFFF is no longer going to add up to be &HFF00FFFF. Instead, it's going to end up being &HFEFFFFFF. (It'll subtract that signed one instead of adding the unsigned 65535 for that integer.)
The fix here is rather simple: You need to manually assign the correct type to those hex values.
CONST foo = &HFF000000~& + &HFFFF~& <-- This makes both values unsigned longs, rather than default QB45 types of signed long and signed integer.
Be aware of this upcoming change and look over any existing code which you may be using. This might affect how QB64PE compiles and runs for you. We've had glitched behavior here with CONST giving signed values for &H, &O, and &B values, and that's being fixed. If your code *worked* under that glitch, it may *not* work now that the glitch is being fixed.
One particular place folks might want to double check their code is with color values.
CONST Blue = &HFF0000FF used to return unsigned long values to us. In the near future, once the patch is approved and added into the language, &HFF0000FF will instead give us a SIGNED long value.
As I mentioned above, the fix for this is to make certain you tell QB64 that you wanted it to be unsigned to begin with:
CONST Blue = &HFF0000FF~&
Unless you specify the type yourself, QB64 is going to try and follow the same logic that QB45 used in determining what variable type to return a value back to you. In the past, it failed at that determination and always returned unsigned values. That's being fixed, and if you relied on that glitch, then you'll need to go back and correct your code to keep up with the fix.
NOTE: This post is relevant only to QB64PE versions prior to 4.0.0, which use MinGW as their backend C++ compiler. Do not use this program on recent versions of QB64PE which use CLang+LLVM instead of MinGW.
In the QB64PE v3.10.0 announcement thread @RhoSigma mentioned 3 MinGW directories which add a lot of unnecessary weight to a QB64PE installation on Windows (something like 155 megabytes spread across 15000 files).
@Kernelpanic posted a VB Script file for removing those directories, and I posted a batch file to do the same.
Why did neither of us think to post a program in the language of the forum?
I dunno, but here's an attempt to set things right.
This is a useful, totally optional program which can double as a test of successful QB64PE installation.
'Verify that we're on Windoze.... 'Old joke: "A computer is like air conditioning - it becomes useless when you open Windows" --Linus Torvalds IfLeft$(_OS$, 9) <> "[WINDOWS]"Then Print: Print"Sorry, this program is only for Windows" End End If
'Verify that we're in the QB64PE directory.... IfNot (_FileExists(".\qb64pe.exe")) Then Print: Print"Sorry, this program must be run from the directory which contains 'qb64pe.exe'" End End If
Print"***********************************************************************" Print"* This program will delete three MinGW GCC directories which are *" Print"* not required for QB64PE operation. *" Print"* *" Print"* These directories contain about 15000 files and consume about 150 *" Print"* megabytes of disk space. *" Print"* *" Print"* These directories and the files they contain are required for legal *" Print"* distribution of GCC and QB64PE, but you may safely and legally *" Print"* delete them from your own personal installation. *" Print"***********************************************************************" Print Input"Enter 'Y' (uppercase only) to proceed: ", yupok$
If yupok$ = "Y"Then REMOVE_DIR (ccomp$ + "licenses") REMOVE_DIR (ccomp$ + "opt") REMOVE_DIR (ccomp$ + "share") Else Print"Operation aborted by user." End If
SubREMOVE_DIR (D$) Dim O$ 'QB64's "RMDIR" will not delete non-empty directories which means 'we would need to walk the tree of subdirectories deleting all files 'and subdirs contained within those directories before deleting the 'directories themselves... if we use QB64 commands only. 'Instead of doing that, we will let Windows handle all the gory details.... If_DirExists(D$) Then
O$ = "RD /Q /S " + Chr$(34) + D$ + Chr$(34) '("RD /Q /S" is silent, but deadly. Handle with care.) Print O$ Shell_Hide O$ Else Print"Directory not found "; Chr$(34); D$; Chr$(34) End If End Sub
Something I have been fiddling with for a while, not sure just what to do with it yet.
With it you can create a D&D style character with basic D&D attribute stats.
The HP,MP, NXP are all based on the 6 main stats or combinations there of.
Right now a player could re-roll the stats a total of 6 times( 1 initial roll then 5 more, unless you know the special names!) to try and get a stat grouping they want. This seems like a decent number otherwise somebody may sit there re-rolling to beat the band.
Save entering the name everything is done with the mouse, RE-Roll stats, change character portrait, look at pack.
There is nothing to be done with the pack, simply allows the player to see their starting money and weight.
I think its interesting to look at and see what it generates, but I really am unsure about just where to take it now.
Code: (Select All)
TYPE Player_Stat
Name AS STRING * 16
Title AS _BYTE
Strength AS _BYTE
Dexterity AS _BYTE
Constitution AS _BYTE
Intelligence AS _BYTE
Wisdom AS _BYTE
Charisma AS _BYTE
HP AS _BYTE
MP AS _BYTE
Max_HP AS _BYTE
Max_MP AS _BYTE
Xp AS LONG
Nxp AS LONG
Level AS _BYTE
Age AS _UNSIGNED _BYTE
Race AS _BYTE
Weapon AS _BYTE
Armor AS _BYTE
Cp AS LONG
Sp AS LONG
Gp AS LONG
Pp AS LONG
Ix AS _BYTE 'portrat location
Iy AS _BYTE ' " "
Ac AS _BYTE
Bonus AS _BYTE
END TYPE
TYPE Item
Name AS STRING * 24
Pow AS _BYTE 'Attack Bonus 0 to 18
Ac AS _BYTE 'AC bonus -5 to +15
Cost AS LONG 'Cost in Cp
Weight AS LONG
END TYPE
SCREEN _NEWIMAGE(800, 600, 32)
RANDOMIZE TIMER
CONST TRUE = -1, FALSE = NOT TRUE
DIM SHARED Layer(8) AS LONG, Font(4) AS LONG, P AS Player_Stat, Pack(12, 1) AS _BYTE, L%%
DIM SHARED Titles(15) AS STRING, Race(5) AS STRING, Wep(63) AS Item, Arm(63) AS Item, Item(127) AS Item
DATA "Adventurer","Novice","Aspirant","Battler","Fighter","Adept","Chevalier","Veteran","Warrior","Swordman","Hero","Soldier","Myrmidon","Champion","Superhero","Paladin": ',"Lord"
DATA "Mystery","Human","Zombie","Dwarf","Elf","Anthromorph"
DATA "Bare Fist",0,0,0,0,"Bamboo Stick",1,0,15,125
DATA "Thin Cloth",0,0,0,200,"Heavy Cloth",0,1,75,550,"Gambeson",0,4,250,2200
DATA "Herb Pack",0,0,5,50,"Ration",0,0,25,250,"Water Skin",0,0,100,1000,"Picks(L_Gr)",0,0,250,125,"Tent",0,0,2500,5000
DATA "Keys of Diamond",0,0,25000,285
FOR i% = 0 TO 15: READ Titles(i%): NEXT
FOR i% = 0 TO 5: READ Race(i%): NEXT
FOR i% = 0 TO 1: READ Wep(i%).Name, Wep(i%).Pow, Wep(i%).Ac, Wep(i%).Cost, Wep(i%).Weight: NEXT
FOR i% = 0 TO 2: READ Arm(i%).Name, Arm(i%).Pow, Arm(i%).Ac, Arm(i%).Cost, Arm(i%).Weight: NEXT
FOR i% = 1 TO 6: READ Item(i%).Name, Item(i%).Pow, Item(i%).Ac, Item(i%).Cost, Item(i%).Weight: NEXT
Layer(0) = _DISPLAY
Layer(1) = _COPYIMAGE(Layer(0))
'Layer(2) = _LOADIMAGE("8x6CharSheet.bmp", 32)
'Layer(3) = _LOADIMAGE("portraits2.jpg", 32)
'Layer(4) = _LOADIMAGE("ButtonOver.bmp", 32)
'Layer(5) = _LOADIMAGE("8x6PackSheet.bmp", 32)
'Layer(6) = _LOADIMAGE("8x6MakerSheet.bmp", 32)
'Font(1) = _LOADFONT("ComicRunes.otf", 40, "monospace")
'Font(2) = _LOADFONT("ComicRunes.otf", 24, "monospace")
'Font(3) = _LOADFONT("DwarvenStonecraftCyr.otf", 24, "monospace")
Nul%% = _MOUSEINPUT
IF _MOUSEX > 30 AND _MOUSEY > 444 AND _MOUSEX < 264 AND _MOUSEY < 478 THEN 'Reroll
_PUTIMAGE (29, 441), Layer(4), Layer(1), (1, 188)-STEP(239, 43)
Selection%% = 1
ELSEIF _MOUSEX > 30 AND _MOUSEY > 490 AND _MOUSEX < 264 AND _MOUSEY < 524 THEN 'Pick
_PUTIMAGE (28, 487), Layer(4), Layer(1), (1, 234)-STEP(239, 43)
Selection%% = 2
ELSEIF _MOUSEX > 30 AND _MOUSEY > 536 AND _MOUSEX < 264 AND _MOUSEY < 570 THEN 'Exit
_PUTIMAGE (29, 533), Layer(4), Layer(1), (1, 50)-STEP(239, 43)
Selection%% = 3
ELSEIF _MOUSEX > 598 AND _MOUSEY > 222 AND _MOUSEX < 662 AND _MOUSEY < 254 THEN 'Portrat left
_PUTIMAGE (593, 221), Layer(4), Layer(1), (42, 282)-STEP(69, 32)
Selection%% = 4
ELSEIF _MOUSEX > 688 AND _MOUSEY > 222 AND _MOUSEX < 752 AND _MOUSEY < 254 THEN 'Portrat right
_PUTIMAGE (688, 220), Layer(4), Layer(1), (135, 281)-STEP(69, 32)
Selection%% = 5
ELSE
Selection%% = 0
END IF
IF _MOUSEBUTTON(1) THEN
SELECT CASE Selection%%
CASE 1 'Reroll
IF Rolls%% THEN 'only remake states if player has rolls left
Rolls%% = Rolls%% - 1
Stat_Maker
END IF
CASE 2 ' Pick this character
Exitflag%% = TRUE
IF Rolls%% = 6 THEN END: Stat_Maker_Auto 'if player never rolled then auto roll stats
CASE 3 'Exit
Exitflag%% = TRUE
CASE 4 ' Prev portrat
P.Ix = P.Ix - 1
IF P.Ix < 0 THEN P.Ix = 10: P.Iy = P.Iy - 1
IF P.Iy < 0 THEN P.Iy = 9
IF P.Iy = 9 AND P.Ix > 8 THEN P.Ix = 8
CASE 5 'Next portrat
P.Ix = P.Ix + 1
IF P.Ix > 10 THEN P.Ix = 0: P.Iy = P.Iy + 1
IF P.Iy = 9 AND P.Ix = 9 THEN P.Ix = 0: P.Iy = 0
END SELECT
Mouse_Lock 'pause while button is depressed
END IF
IF INKEY$ = CHR$(27) THEN Exitflag%% = TRUE
_PRINTSTRING (208, 442), LTRIM$(STR$(Rolls%%)), Layer(1) 'display rolls player has left over button
_DEST Layer(1)
Fill_Stats
_FONT Font(2)
_DEST Layer(0)
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 60
DO: LOOP WHILE _MOUSEINPUT
LOOP UNTIL Exitflag%%
END SUB
SUB Mouse_Lock
DO
nul% = _MOUSEINPUT
_LIMIT 90
LOOP WHILE _MOUSEBUTTON(1)
END SUB
FUNCTION Determine_Race%%
Result%% = TRUE
SELECT CASE P.Ix + (P.Iy * 11)
CASE 0, 1, 2, 8, 9, 10, 14, 18, 20, 22, 30, 34 TO 42, 56, 58 TO 62, 74, 80 TO 86, 96 TO 100 'human
P.Race = 1
CASE 3, 7, 11, 12, 13, 33, 43, 63 TO 71, 75, 76 'mystery
P.Race = 0
CASE 93, 101 TO 107 'Zombie
P.Race = 2
CASE 6, 15, 16, 17, 19, 31, 32, 45, 46, 57, 79 'Dwarf
P.Race = 3
CASE 21, 23 TO 29, 87, 92, 95 'Elf
P.Race = 4
CASE 4, 5, 44, 47 TO 55, 77, 78, 88 TO 91, 94 'Anthromorph
P.Race = 5
CASE ELSE
P.Race = INT(RND * 5)
Result%% = FALSE 'error flag denoting value not found.
END SELECT
Determine_Race = Result%%
END FUNCTION
SUB RunPack
CLS
_PUTIMAGE , Layer(5), Layer(0)
Fill_Pack
Layer(7) = _COPYIMAGE(_DISPLAY)
DO
_PUTIMAGE , Layer(7), Layer(1)
Nul%% = _MOUSEINPUT
IF _MOUSEX > 280 AND _MOUSEY > 536 AND _MOUSEX < 512 AND _MOUSEY < 570 THEN 'use\equip
_PUTIMAGE (277, 531), Layer(4), Layer(1), (1, 96)-STEP(239, 43)
Selection%% = 1
ELSEIF _MOUSEX > 525 AND _MOUSEY > 536 AND _MOUSEX < 756 AND _MOUSEY < 570 THEN 'Drop
_PUTIMAGE (521, 529), Layer(4), Layer(1), (1, 142)-STEP(239, 43)
Selection%% = 2
ELSEIF _MOUSEX > 30 AND _MOUSEY > 536 AND _MOUSEX < 264 AND _MOUSEY < 570 THEN 'Exit
_PUTIMAGE (29, 533), Layer(4), Layer(1), (1, 50)-STEP(239, 43)
Selection%% = 3
ELSE
Selection%% = 0
END IF
IF _MOUSEBUTTON(1) THEN
SELECT CASE Selection%%
CASE 1 'Use\Equip
CASE 3 'Exit
ExitFlag%% = TRUE
_DELAY .1
END SELECT
END IF
IF INKEY$ = CHR$(27) THEN ExitFlag%% = TRUE
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 60
DO: LOOP WHILE _MOUSEINPUT
LOOP UNTIL ExitFlag%%
_FONT Font(3)
_PRINTSTRING (293 - 19 * (LEN(RTRIM$(Titles(P.Title))) / 2), 144), Titles(P.Title)
FOR i%% = 0 TO 11 STEP 2
IF Pack(i%%, 1) > 0 THEN _PRINTSTRING (230, 220 + 25 * i%%), "x"
IF Pack(i%% + 1, 1) > 0 THEN _PRINTSTRING (505, 220 + 25 * i%%), "x"
NEXT i%%
END SUB
FUNCTION Load_Weight!
Result& = 7000 'base weight of empty pack(grams)
Result& = Result& + P.Cp * 5 + P.Sp * 5 + P.Gp * 5 + P.Pp * 5 'weight of coins
Result& = Result& + Wep(P.Weapon).Weight + Arm(P.Armor).Weight 'weight of main equiped items
FOR i%% = 1 TO 12 'weight of items in pack
T& = T& + Item(Pack(i%%, 0)).Weight * Pack(i%%, 1)
NEXT i%%
KgOut! = Result& + T&
Load_Weight = INT(KgOut! / 10) / 100 '0.01 inc
END FUNCTION
FUNCTION Attack_Bonus%%
IF P.Strength <= 3 THEN Result%% = -1
IF P.Strength = 1 THEN Result%% = -2
IF P.Strength = 0 THEN Result%% = 0 'dont allow -1 before stat creation
IF P.Strength >= 13 THEN Result%% = 1
IF P.Strength = 15 THEN Result%% = 2
Attack_Bonus = Wep(P.Weapon).Pow + Result%%
END FUNCTION
FUNCTION Ac_Bonus%%
IF P.Dexterity <= 3 THEN Result%% = -1
IF P.Dexterity = 1 THEN Result%% = -2
IF P.Dexterity = 0 THEN Result%% = 0 'dont allow -1 before stat creation
IF P.Dexterity >= 13 THEN Result%% = 1
IF P.Dexterity = 15 THEN Result%% = 2
Ac_Bonus = Arm(P.Armor).Ac + Result%%
END FUNCTION
SUB Enter_Name
DO
_PUTIMAGE , Layer(6), Layer(1)
KBD& = _KEYHIT
SELECT CASE KBD&
CASE 13
ExitFlag%% = TRUE
P.Name = n$
IF n$ = "" THEN P.Name = "Loser"
CASE 8 'Back Space
n$ = LEFT$(n$, LEN(n$) - 1)
CASE 32 TO 122
IF LEN(n$) < 16 THEN n$ = n$ + CHR$(KBD&)
END SELECT
_PRINTSTRING (144, 144), "Pick a Name " + STR$(LEN(n$)) + "of 16 letters", Layer(1)
_PRINTSTRING (293 - 18 * 8, 28), n$, Layer(1)
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 60
LOOP UNTIL ExitFlag%%
L%% = LEN(RTRIM$(P.Name))
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~%%
Layer(2) = LoadGFX(FOffset(1), Size(1))
Layer(3) = LoadGFX(FOffset(2), Size(2))
Layer(4) = LoadGFX(FOffset(3), Size(3))
Layer(5) = LoadGFX(FOffset(4), Size(4))
Layer(6) = LoadGFX(FOffset(5), Size(5))
Font(1) = LoadFFX(FOffset(6), Size(6), 40)
Font(2) = LoadFFX(FOffset(6), Size(6), 24)
Font(3) = LoadFFX(FOffset(7), Size(7), 24)
CLOSE #1
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
END SUB
REM '$include: 'MFI_Loader2.bi'
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
FUNCTION LoadFFX& (Foff&, Size&, Fize%%)
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
LoadFFX& = _LOADFONT("temp.dat", Fize%%, "monospace")
END FUNCTION
FUNCTION LoadSFX& (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
LoadSFX& = _SNDOPEN("temp.dat")
END FUNCTION
Hello !
Not long ago I experimented with surround sound. I made a game for it, the basis of which is that you have to feel the direction of the sound source.
'No graphics'! Put on the headphones and catch the animals!
Print"This screen is the size of your desktop, but it has some inherent issues."; _Width, _Height Print Print"Hit the <SPACE BAR> and watch as we position it in different manners:" Sleep _ScreenMove0, 0 Print Print"To start with, this is a _SCREENMOVE 0,0 call. It places the TITLEBAR's top left corner at position 0,0." Print"If you notice, the bottom of the screen is now hidden as the titlebar has shifted us down below the max resolution our screen will display." Sleep ScreenMove0, 0 Print Print"Now, this is a Steve Approved(tm) ScreenMove method to move the screen itself to position 0,0." Print"Now, as you can tell (if your taskbar is set to hide itself), the program window now covers the screen perfectly." Print"The only problem with this method is that we are now hiding the title bar over the top of the screen!" Sleep
Print Print"To fix these issues, we use the functions here to figure out EXACTLY what size our screen needs to be." Print Print"Title Bar Height = "; TH Print"Screen Border ="; BW; "on each side." Print"Task Bar Height ="; TBH Print"Task Bar Width ="; TBW Print"Task Bar Top = "; taskbar_top Print"Task Bar Left = "; taskbar_left Print"Task Bar Bottom = "; taskbar_bottom Print"Task Bar Right = "; taskbar_right Print Print"This is a screen perfectly sized to fit on your screen."; _Width, _Height Print"See how it fits your visible screen perfectly?" Print Print"Note: If you have transparent borders, or if your theme has them set to opaque, it may appear to be a gap around your screen. That transparent gap IS the screen border. Set it a solid color and you can see it." Print Print"At this point, you should have your title bar up top. You screen shouldn't cover, or be covered, by the task bar." Print"Everything should be visible and accessable for you." Print Print"To my way of thinking, THIS is the maximum resolution that your screen should run in with a program. " Sleep
Print"Or THIS height, if one wants to include the titlebar and boarder and use the whole screen, without covering the taskbar.)" Print Print"This is a screen perfectly sized to fit on your screen. (with Titlebar and Borders)"; _Width, _Height Print"See how it fits your visible screen perfectly?"
