| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 483
» Latest member: aplus
» Forum threads: 2,804
» Forum posts: 26,428
Full Statistics
|
|
|
| Lesson's 10 Exercise (Partial solution) |
|
Posted by: marbac74 - 06-05-2024, 02:03 PM - Forum: Terry Ritchie's Tutorial
- Replies (4)
|
 |
Hello everyone,
I'm working on Lesson's 10 assignment...it's definitely more complicated than the previous ones  I'm not finished with it yet, but I wanted to post the intermediate result, because there are a couple of things worth noticing: the exercise is full of tricks so make use of the wiki information...for example at line 49 in the code below...you need to use a semicolon otherwise some of your print statements will disappear from screen and you'll be left wondering why..."they were there ten minutes ago and now they don't show up anymore...but I didn't change anything so how can it be?". If you reach the end of screen you must add a semicolon to the last print statement to prevent...I don't remember the name but in order that everything shows up as it is written. Today I worked on the DrawSymbol subroutine and I'm quite happy with it, it works as expected, but I don't know if there is a more efficient way to code it... Here is the partial solution to the exercise:
Code: (Select All)
SCREEN _NEWIMAGE(340, 340, 32)
_TITLE "Slot Machine"
CONST RED = _RGB32(255, 0, 0)
CONST GREEN = _RGB32(0, 255, 0)
CONST BLUE = _RGB32(0, 0, 255)
CONST PURPLE = _RGB32(255, 0, 255)
CONST YELLOW = _RGB32(255, 255, 0)
CONST CYAN = _RGB32(0, 255, 255)
CONST BLACK = _RGB32(0)
CONST GREY = _RGB32(70)
DIM Score%
Score% = 0
PAINT (170, 170), GREY
_PRINTMODE _KEEPBACKGROUND
LOCATE 1, 16
COLOR YELLOW: PRINT "SLOT MACHINE"
LINE (10, 20)-(110, 120), BLACK, BF
DrawSymbol "DIAMOND", 1
LINE (120, 20)-(220, 120), BLACK, BF
DrawSymbol "DIAMOND", 2
LINE (230, 20)-(330, 120), BLACK, BF
DrawSymbol "DIAMOND", 3
LOCATE 9, 2
COLOR YELLOW: PRINT "ENTER to spin"; SPC(7); Score%; SPC(7); "ESC to exit"
LOCATE 11, 18
PRINT "PAYOUTS"
LOCATE 13, 10
COLOR YELLOW: PRINT "3 Double Circles - 500"
LOCATE 14, 10
COLOR YELLOW: PRINT "3 Squares - 25"
LOCATE 15, 10
COLOR YELLOW: PRINT "3 Triangles - 25"
LOCATE 16, 10
COLOR YELLOW: PRINT "3 Circles - 25"
LOCATE 17, 10
COLOR YELLOW: PRINT "2 Circles - 10"
LOCATE 18, 10
COLOR YELLOW: PRINT "3 Diamonds - 10"
LOCATE 19, 10
COLOR YELLOW: PRINT "2 Diamonds - 5"
LOCATE 20, 10
COLOR YELLOW: PRINT "1 Diamond - 1";
SLEEP
SUB DrawSymbol (Figure$, Box%)
IF Figure$ = "SQUARE" AND Box% = 1 THEN
LINE (20, 30)-(100, 110), BLUE, BF
ELSEIF Figure$ = "SQUARE" AND Box% = 2 THEN
LINE (130, 30)-(210, 110), BLUE, BF
ELSEIF Figure$ = "SQUARE" AND Box% = 3 THEN
LINE (240, 30)-(320, 110), BLUE, BF
ELSEIF Figure$ = "CIRCLE" AND Box% = 1 THEN
CIRCLE (60, 70), 40, RED
PAINT (60, 70), RED, RED
ELSEIF Figure$ = "CIRCLE" AND Box% = 2 THEN
CIRCLE (170, 70), 40, RED
PAINT (170, 70), RED, RED
ELSEIF Figure$ = "CIRCLE" AND Box% = 3 THEN
CIRCLE (280, 70), 40, RED
PAINT (280, 70), RED, RED
ELSEIF Figure$ = "SPECIAL" AND Box% = 1 THEN
CIRCLE (60, 70), 40, CYAN
PAINT (60, 70), CYAN, CYAN
CIRCLE (60, 70), 20, BLUE
PAINT (60, 70), BLUE, BLUE
ELSEIF Figure$ = "SPECIAL" AND Box% = 2 THEN
CIRCLE (170, 70), 40, CYAN
PAINT (170, 70), CYAN, CYAN
CIRCLE (170, 70), 20, BLUE
PAINT (170, 70), BLUE, BLUE
ELSEIF Figure$ = "SPECIAL" AND Box% = 3 THEN
CIRCLE (280, 70), 40, CYAN
PAINT (280, 70), CYAN, CYAN
CIRCLE (280, 70), 20, BLUE
PAINT (280, 70), BLUE, BLUE
ELSEIF Figure$ = "UPTRIANGLE" AND Box% = 1 THEN
LINE (20, 110)-(100, 110), YELLOW
LINE -(60, 30), YELLOW
LINE -(20, 110), YELLOW
PAINT (60, 70), YELLOW, YELLOW
ELSEIF Figure$ = "UPTRIANGLE" AND Box% = 2 THEN
LINE (130, 110)-(210, 110), YELLOW
LINE -(170, 30), YELLOW
LINE -(130, 110), YELLOW
PAINT (170, 70), YELLOW, YELLOW
ELSEIF Figure$ = "UPTRIANGLE" AND Box% = 3 THEN
LINE (240, 110)-(320, 110), YELLOW
LINE -(280, 30), YELLOW
LINE -(240, 110), YELLOW
PAINT (280, 70), YELLOW, YELLOW
ELSEIF Figure$ = "DOWNTRIANGLE" AND Box% = 1 THEN
LINE (20, 30)-(100, 30), PURPLE
LINE -(60, 110), PURPLE
LINE -(20, 30), PURPLE
PAINT (60, 70), PURPLE, PURPLE
ELSEIF Figure$ = "DOWNTRIANGLE" AND Box% = 2 THEN
LINE (130, 30)-(210, 30), PURPLE
LINE -(170, 110), PURPLE
LINE -(130, 30), PURPLE
PAINT (170, 70), PURPLE, PURPLE
ELSEIF Figure$ = "DOWNTRIANGLE" AND Box% = 3 THEN
LINE (240, 30)-(320, 30), PURPLE
LINE -(280, 110), PURPLE
LINE -(240, 30), PURPLE
PAINT (280, 70), PURPLE, PURPLE
ELSEIF Figure$ = "DIAMOND" AND Box% = 1 THEN
LINE (60, 110)-(100, 70), GREEN
LINE -(60, 30), GREEN
LINE -(20, 70), GREEN
LINE -(60, 110), GREEN
PAINT (60, 70), GREEN, GREEN
ELSEIF Figure$ = "DIAMOND" AND Box% = 2 THEN
LINE (170, 110)-(210, 70), GREEN
LINE -(170, 30), GREEN
LINE -(130, 70), GREEN
LINE -(170, 110), GREEN
PAINT (170, 70), GREEN, GREEN
ELSEIF Figure$ = "DIAMOND" AND Box% = 3 THEN
LINE (280, 110)-(320, 70), GREEN
LINE -(280, 30), GREEN
LINE -(240, 70), GREEN
LINE -(280, 110), GREEN
PAINT (280, 70), GREEN, GREEN
END IF
END SUB
|
|
|
| Extended KotD #15.2: _UPRINTSTRING (Part 2) |
|
Posted by: SMcNeill - 06-04-2024, 11:28 PM - Forum: Keyword of the Day!
- Replies (1)
|
 |
As before, let me ask folks reading this to do a few things first:
1) Grab the following font for use with examples/discussion:
DejaVuSansMono.7z (Size: 159.23 KB / Downloads: 61)
2) Extract that in your QB64PE folder so QB64PE can find it and make use of it.
And with that out of the way, let me start by backing up and illustrating perfectly what I was talking about back in 15.1:
Code: (Select All)
SCREEN _NEWIMAGE(1000, 600, 32)
Font$ = "DejaVuSansMono.ttf"
LargeFont = _LOADFONT(Font$, 40, "monospace")
Text$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789______"
_FONT LargeFont
FOR i = 14 TO 24
CLS
Font = _LOADFONT(Font$, i, "monospace")
_UPRINTSTRING (100, 25), "Deja Vu Sans Mono Font, Size" + STR$(i)
_UPRINTSTRING (0, 100), " Print :"
_UPRINTSTRING (0, 200), "_PrintString :"
_UPRINTSTRING (0, 300), "_UPrintString:"
_FONT Font
LOCATE 150 \ _FONTHEIGHT, 350 \ _FONTWIDTH: PRINT Text$
_PRINTSTRING (350, 230), Text$
_UPRINTSTRING (350, 330), Text$
_FONT LargeFont
_FREEFONT Font
SLEEP
NEXT
Run that, and pay attention to those underscores at each font size. In particular, tell me where they are at sizes 14 through 16...
And THAT's the issue with our existing PRINT and _PRINTSTRING in a noticeable, testable, very visible way! As you can plainly see (or NOT see, in this case), PRINT and _PRINTSTRING aren't large enough (they max size at the size you specify) that it even draws those underscores at size 15 and 16. It just cuts them off and gives you a basic blank space where they exist.
.
.
.
Now, when folks ask, "Should I go back and redo all my old code?", I have one simple question for them:
"Do you see that problem with your existing code and fonts?"
If not, then I wouldn't worry over it. What you have works. Going back and redoing old stuff is a PITA. Why break what's working??
I'm certainly not in a rush to go back and redo all my old stuff to swap over from PRINT and _PRINTSTRING. I just plan on making use of _UPRINTSTRING in the future, when I make use of any custom fonts. 
And with that basic recap out of the way, let's take a look at the actual syntax and how to use this command:
QB64PE Wiki Link: https://qb64phoenix.com/qb64wiki/index.php/UPRINTSTRING
Format Syntax: _UPRINTSTRING (column, row), textExpression$[, maxWidth&][, utfEncoding&][, fontHandle&]
And for those who want to compare, here's the PRINSTSTRING pages/info:
QB64PE Wiki Link: https://qb64phoenix.com/qb64wiki/index.php/PRINTSTRING
Format Syntax: _PRINTSTRING(column, row), textExpression$[, imageHandle&]
As you can see, _UPRINTSTRING does everything that PRINTSTRING does, plus more -- with the exception of [,&imageHandle]....
...and, to be 100% honest, we simply overlooked adding [,imageHandle] as an optional parameter to _UPRINTSTRING. Expect to see it added as an option to the command, in an upcoming update.
(Hey, what can I say?? We're human too! We overlook stuff. It's why posts and topics such as these KotD are so important -- they help make certain we double, then triple back to our work -- and then go back to it one more time! We miss stuff. We admit it. We fit it. Everyone prospers and we move on!  )
And with all that said, let me break down that syntax for us:
_UPRINTSTRING (column, row), textExpression$[, maxWidth&][, utfEncoding&][, fontHandle&][,imageHandle&]
Note the red [,imageHandle&] parameter in there. It doesn't exist yet in our language, but will probably with the next update, so I'm going to go ahead and include it in here first. 
_UPRINTSTRING <-- essential name of the command
(column, row) <-- exact same coordinate system that we currently use with _PRINTSTRING. (Though the wiki should read (x, y) here, in my opinion.)
textExpression$ <-- the text that we want to print. Works exactly the same as _PRINTSTRING (though we don't clip off characters like Print and PrintString do.)
So, for most folks, this is all they're going to need -- and it works exactly like _PRINTSTRING does. The only difference is the font height/width is going to be a little wider/taller, but if you're used to using _PRINTSTRING, you should be able to adapt to _UUPRINTSTRING with zero issues.
Just get in the habit of typing that U between the underscore and the P, and for most folks, this command -- by itself -- should work with no issues for them.
(Keeping in mind that I continue to mention that we'll print a little taller/wider to the screen. I'll cover the new commands to deal with those in the next few days with _UFontHeight, _UPrintWidth, and such.)
So basic functionality for this command shouldn't be anything new for folks. At its core, it's simply a FIX (at least Steve will always consider this a FIX) for a serious problem with Print and PrintString, without breaking folks existing code. The basic syntax is the same. Usage is the same. It's just got an U in front of it to distingish it from the old command.
That, and while working on adding this command, we added in some missing functionality with those new, optional, parameters that I haven't covered yet. Let me get to them now:
[, maxWidth&] <-- This new parameter lets you set a max width for what you want to print. Like PrintString, _UPrintString does *NOT* do any word wrap, page scrolling, or printing down on the next line. Send it a line of 1000 characters, for a screen which can only hold 80, and it'll print 1000 characters....
...the only problem is it'll only print 80 on the given line, with 920 characters being "printed" and lost off-screen!!
Set the maxWidth& here, and the command will quit once it reaches the width you specify, which can help speed up your programs and keep things organized neatly for you.
[, utfEncoding&] <-- Now this parameter is one more for "Advanced Users". It lets you specify if the text$ you're sending it is going to be ASC, or UTF-8, UTF-16, or UTF-32.
Note that the IDE only supports ASC encoding, so it's going to be hard to type the unicode into the IDE. This parameter will probably only be of use with external text files.
Honestly, I imagine 99.9999% of the user-base can just safely skip this parameter, in most cases. IF *YOU* happen to be the one guy who needs something like this, then you already know it. If you're uncertain, then just skip this parameter and move on to the next one.
[, fontHandle&] <-- A new, optional paramater so you don't have to _FONT this and _FONT that, all the dang time. Supply the loaded handle here, use it, and don't change what you already have set for your screen. In my personal opinion, this is brilliant!!
And that's it, in a nutshell!
The new command works basically with the same syntax as the old command. The only difference really being:
1) The font rendered is going to be a little wider and taller.
2) That font isn't going to get cut off like it did with the old statements. It'll look crisper, prettier, and overall nicer.
3) There's a few extra parameters added as options to this new statement, just for ease and quality of life.
For most folks, if they've ever used _PrintString in the past, swapping over to _UPrintString should be just 100% intuitive for them.
If anyone has questions, concerns, or comments, feel free to ask below. I'll cover them ASAP for everyone.
|
|
|
|
| Some MOUSE Routines |
|
Posted by: TerryRitchie - 06-04-2024, 10:01 PM - Forum: Programs
- Replies (2)
|
 |
I was updating my mouse library to incorporate a windows API call and was having a heck of a time. So I wrote this little program to get everything straight in my head before incorporating the changes. I thought others might find the code useful.
Note: This will only work with Windows.
If you run the code let me know if you find any of the values off. Everything tests ok with my Windows 7 Pro machine but I know some changes related to DPI were introduced with Windows 10 that may cause these to be inaccurate. Please let me know if this is the case.
Code: (Select All)
'MOUSE test
TYPE TYPE_IPOINT ' 2D x,y point definition
x AS LONG ' x long integer coordinate
y AS LONG ' y long integer coordinate
END TYPE
DECLARE DYNAMIC LIBRARY "user32"
'get current mouse x/y position
'http://allapi.mentalis.org/apilist/GetCursorPos.shtml
FUNCTION GetCursorPos% (lpPoint AS TYPE_IPOINT)
'system window metrics in pixels
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getsystemmetrics
FUNCTION GetSystemMetrics% (BYVAL nIndex AS INTEGER)
END DECLARE
DIM GetXY AS INTEGER ' dummy variable to use with API function call
DIM Mouse AS TYPE_IPOINT ' absolute mouse location on dekstop
DIM CaptionHeight AS INTEGER ' program window caption height
DIM BorderHeight AS INTEGER ' program window border height
DIM BorderWidth AS INTEGER ' program window border width
DIM WindowX1 AS INTEGER ' location of program window on desktop
DIM WindowY1 AS INTEGER ' (everything including borders)
DIM WindowX2 AS INTEGER
DIM WindowY2 AS INTEGER
DIM ClientX1 AS INTEGER ' location of client window on desktop
DIM ClientY1 AS INTEGER ' (the SCREEN statement)
DIM ClientX2 AS INTEGER
DIM ClientY2 AS INTEGER
DIM CaptionX1 AS INTEGER ' location of client window caption on desktop
DIM CaptionY1 AS INTEGER ' (the _TITLE bar)
DIM CaptionX2 AS INTEGER
DIM CaptionY2 AS INTEGER
DIM ClientMouseX AS INTEGER ' relative mouse location on client window
DIM ClientMouseY AS INTEGER
DIM WindowMouseX AS INTEGER ' relative mouse location on program window
DIM WindowMouseY AS INTEGER
DIM CaptionMouseX AS INTEGER ' relative mouse location on program window's caption
DIM CaptionMouseY AS INTEGER
DIM ProgramTitle AS STRING ' program title to display
DIM OldTitle AS STRING ' the old program title (to reduce flickering)
'+-----------------+
'| Begin main code |
'+-----------------+
SCREEN _NEWIMAGE(800, 600, 32) ' create client window
'+---------------------------------------------------------------+
'| Get the program window's caption height and border dimensions |
'| |
'| Note: This would need to go into the loop to pick up theme |
'| changes made by user. |
'+---------------------------------------------------------------+
CaptionHeight = GetSystemMetrics(4) ' caption height (from windows)
BorderHeight = GetSystemMetrics(33) - GetSystemMetrics(6) ' sizing border width - window border width (from windows)
BorderWidth = GetSystemMetrics(32) - GetSystemMetrics(5) ' sizing border height - window border height (from windows)
DO
'+---------------------------------------------------------------+
'| Calculate absolute x,y locations of program window on desktop |
'+---------------------------------------------------------------+
WindowX1 = _SCREENX
WindowY1 = _SCREENY
WindowX2 = WindowX1 + BorderWidth * 2 + _WIDTH - 1
WindowY2 = WindowY1 + CaptionHeight + BorderHeight * 2 + _HEIGHT - 1
'+--------------------------------------------------------------+
'| Calculate absolute x,y locations of client window on desktop |
'+--------------------------------------------------------------+
ClientX1 = _SCREENX + BorderWidth
ClientY1 = _SCREENY + CaptionHeight + BorderHeight
ClientX2 = ClientX1 + _WIDTH - 1
ClientY2 = ClientY1 + _HEIGHT - 1
'+-----------------------------------------------------------------------+
'| Calculate absolute x,y locations of program window caption on desktop |
'+-----------------------------------------------------------------------+
CaptionX1 = ClientX1
CaptionY1 = _SCREENY + BorderHeight
CaptionX2 = ClientX2
CaptionY2 = CaptionY1 + CaptionHeight
'+-----------------------------------------------------+
'| Get absolute mouse location on desktop |
'| |
'| Calculate relative mouse location on program window |
'| Calculate relative mouse location on client window |
'+-----------------------------------------------------+
GetXY = GetCursorPos(Mouse) ' absolute mouse location on desktop
WindowMouseX = Mouse.x - WindowX1 ' relative mouse location on program window
WindowMouseY = Mouse.y - WindowY1
ClientMouseX = Mouse.x - ClientX1 ' relative mouse location on client window
ClientMouseY = Mouse.y - ClientY1
CaptionMouseX = Mouse.x - CaptionX1
CaptionMouseY = Mouse.y - CaptionY1
LOCATE 2, 1 ' print some variables
PRINT " Mouse Locations:"
PRINT
PRINT " ABSOLUTE DESKTOP X ="; Mouse.x
PRINT " ABSOLUTE DESKTOP Y ="; Mouse.y
PRINT
PRINT " RELATIVE WINDOW X ="; WindowMouseX
PRINT " RELATIVE WINDOW Y ="; WindowMouseY
PRINT
PRINT " RELATIVE CAPTION X ="; CaptionMouseX
PRINT " RELATIVE CAPTION Y ="; CaptionMouseY
PRINT
'+-------------------------------------------------------------------------------------------------+
'| Note: _MOUSEX and _MOUSEY won't even be needed and probably should be avoided because of delays |
'| caused by calling the API and then clearing the buffer with WHILE _MOUSEINPUT: WEND |
'+-------------------------------------------------------------------------------------------------+
WHILE _MOUSEINPUT: WEND
PRINT " RELATIVE CLIENT X ="; ClientMouseX, "_MOUSEX ="; _MOUSEX; " ", "These values should equal"
PRINT " RELATIVE CLIENT Y ="; ClientMouseY, "_MOUSEY ="; _MOUSEY; " ", "when pointer is in client"
PRINT
PRINT " Program window coordinates on desktop: ("; WindowX1; ","; WindowY1; ") - ("; WindowX2; ","; WindowY2; ")"
PRINT
PRINT " Client window coordinates on desktop: ("; ClientX1; ","; ClientY1; ") - ("; ClientX2; ","; ClientY2; ")"
PRINT
PRINT " Caption window coordinates on desktop: ("; CaptionX1; ","; CaptionY1; ") - ("; CaptionX2; ","; CaptionY2; ")"
PRINT
IF MouseWithin(Mouse.x, Mouse.y, ClientX1, ClientY1, ClientX2, ClientY2) THEN
ProgramTitle = "In CLIENT Area "
ELSEIF MouseWithin(Mouse.x, Mouse.y, CaptionX1, CaptionY1, CaptionX2, CaptionY2) THEN
ProgramTitle = "In CAPTION Area "
ELSEIF MouseWithin(Mouse.x, Mouse.y, WindowX1, WindowY1, WindowX2, WindowY2) THEN
ProgramTitle = "On WINDOW Border "
ELSE
ProgramTitle = "Mouse OUTSIDE of program"
END IF
PRINT " "; ProgramTitle
IF OldTitle <> ProgramTitle THEN
_TITLE ProgramTitle
OldTitle = ProgramTitle
END IF
LOOP UNTIL _KEYDOWN(27)
SYSTEM
FUNCTION MouseWithin% (mx AS INTEGER, my AS INTEGER, x1 AS INTEGER, y1 AS INTEGER, x2 AS INTEGER, y2 AS INTEGER)
'Quick and dirty rectangular collision routine
MouseWithin% = 0
IF mx >= x1 AND mx <= x2 AND my >= y1 AND my <= y2 THEN MouseWithin% = -1
END FUNCTION
|
|
|
|
| CrossMath Game |
|
Posted by: SMcNeill - 06-04-2024, 03:48 AM - Forum: Works in Progress
- Replies (10)
|
|
Inspired by some of @Dav 's latest works, this is the start of a little Crossword type game, but which features addition instead of letters.
Code: (Select All)
$COLOR:32
CONST ShowAnswers = 0, Difficulty = 5 'can toggle to show answers, or change difficulty (1 to 10, higher = harder)
RANDOMIZE TIMER
SCREEN _NEWIMAGE(1280, 720, 32)
DIM SHARED AS INTEGER grid(-1 TO 10, -1 TO 10), player(-1 TO 10, -1 TO 10)
DO
randomgrid
PlayGame
LOOP
SUB PlayGame
'find first block
Show = 10 - Difficulty 'player can show up to 3 blocks to help them with the puzzle
IF Show < 0 THEN Show = 0
LargeFont = _LOADFONT("courbd.ttf", 48, "monospace")
FOR y = 0 TO 9
FOR x = 0 TO 9
IF grid(x, y) GOTO start
NEXT
NEXT
start:
Xon = x: Yon = y
DO
CLS
drawgrid
'draw player highlight
LINE (Xon * 60 + 60, Yon * 60 + 60)-STEP(60, 60), Green, BF
k = _KEYHIT
IF _KEYDOWN(100306) OR _KEYDOWN(100305) THEN
SELECT CASE k
CASE 19200: IF Xon > 0 THEN x = Xon - 1 'CTRL + left arrow
CASE 19712: IF Xon < 9 THEN Xon = Xon + 1 'CTRL + right arrow
CASE 18432: IF Yon > 0 THEN Yon = Yon - 1 'CTRL + up arrow
CASE 20480: IF Yon < 9 THEN Yon = Yon + 1 'CTRL + down arrow
END SELECT
ELSE
SELECT CASE k
CASE 48 TO 57 'number keys
IF grid(Xon, Yon) THEN player(Xon, Yon) = k - 48
CASE 27 'ESC
SYSTEM
CASE 19200 'left arrow
FOR x = Xon - 1 TO 0 STEP -1
IF grid(x, Yon) THEN Xon = x: EXIT FOR
NEXT
CASE 19712 'right arrow
FOR x = Xon + 1 TO 9
IF grid(x, Yon) THEN Xon = x: EXIT FOR
NEXT
CASE 18432 'up arrow
FOR y = Yon - 1 TO 0 STEP -1
IF grid(Xon, y) THEN Yon = y: EXIT FOR
NEXT
CASE 20480 'down arrow
FOR y = Yon + 1 TO 9
IF grid(Xon, y) THEN Yon = y: EXIT FOR
NEXT
CASE ASC("S"), ASC("s"), ASC("H"), ASC("h"), ASC("?")
IF Show THEN
player(Xon, Yon) = grid(Xon, Yon)
Show = Show - 1
END IF
END SELECT
END IF
_FONT LargeFont
_PRINTSTRING (800, 40), "HINTS:" + STR$(Show)
FOR x = 0 TO 9 'Display the current numbers
FOR y = 0 TO 9
IF player(x, y) THEN _PRINTSTRING (x * 60 + 70, y * 60 + 66), _TRIM$(STR$(player(x, y)))
NEXT
NEXT
win = -1
FOR x = -1 TO 9
FOR y = -1 TO 9
IF CheckDown(grid(), x, y) <> CheckDown(player(), x, y) THEN win = 0: GOTO keep_playing
NEXT
NEXT
IF win THEN
BEEP
BEEP
BEEP
_PRINTSTRING (800, 110), "YOU WIN!!!"
_DISPLAY
SLEEP
EXIT SUB
END IF
keep_playing:
_FONT 16
_DISPLAY
_LIMIT 30
LOOP
END SUB
SUB randomgrid
FOR x = -1 TO 10 'reset the game values to 0
FOR y = -1 TO 10
grid(x, y) = 0
player(x, y) = 0
NEXT
NEXT
FOR j = 1 TO 90
x = INT(RND * 10)
y = INT(RND * 10)
z = INT(RND * 9) + 1
grid(x, y) = z
NEXT
DO 'this eliminates any stray numbers just floating off by themselves
fixed = -1
FOR x = 0 TO 9
FOR y = 0 TO 9
IF grid(x, y) <> 0 THEN
IF grid(x - 1, y) = 0 AND grid(x, y - 1) = 0 AND grid(x, y + 1) = 0 AND grid(x + 1, y) = 0 THEN
grid(x, y) = 0
x = INT(RND * 10)
y = INT(RND * 10)
z = INT(RND * 10)
grid(x, y) = z
fixed = 0
END IF
END IF
NEXT
NEXT
LOOP UNTIL fixed
END SUB
SUB drawgrid
startX = 60
startY = 60
endX = 660
endY = 660
FOR x = startX TO endX STEP 60
LINE (x, 60)-(x, 660)
NEXT
FOR y = startY TO endY STEP 60
LINE (60, y)-(660, y)
NEXT
FOR y = -1 TO 9
FOR x = -1 TO 9
IF grid(x, y) = 0 THEN
x1 = x * 60 + 60: y1 = y * 60 + 60
LINE (x1, y1)-STEP(60, 60), LightGray, BF
sum = CheckDown(grid(), x, y)
IF sum THEN
COLOR Black, 0
FillTriangle x1, y1, x1 + 60, y1, x1, y1 + 60, Red
_PRINTSTRING (x1 + 5, y1 + 5), STR$(sum)
END IF
sum = CheckRight(grid(), x, y)
IF sum THEN
COLOR White, 0
FillTriangle x1 + 60, y1, x1, y1 + 60, x1 + 60, y1 + 60, Blue
_PRINTSTRING (x1 + 35, y1 + 35), STR$(sum)
END IF
ELSE
COLOR White, 0
IF ShowAnswers THEN _PRINTSTRING (x * 60 + 80, y * 60 + 80), "(" + STR$(grid(x, y)) + ")"
END IF
NEXT
NEXT
END SUB
SUB FillTriangle (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
$CHECKING:OFF
STATIC a&, m AS _MEM
IF a& = 0 THEN a& = _NEWIMAGE(1, 1, 32): m = _MEMIMAGE(a&)
_MEMPUT m, m.OFFSET, K
_MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
$CHECKING:ON
END SUB
FUNCTION CheckDown (array() AS INTEGER, x, y)
sum = 0
FOR i = y + 1 TO 9
IF array(x, i) <> 0 THEN
sum = sum + array(x, i)
ELSE
EXIT FOR
END IF
NEXT
IF sum <> array(x, y + 1) THEN CheckDown = sum ELSE CheckDown = 0
END FUNCTION
FUNCTION CheckRight (array() AS INTEGER, x, y)
sum = 0
FOR i = x + 1 TO 9
IF array(i, y) <> 0 THEN
sum = sum + array(i, y)
ELSE
EXIT FOR
END IF
NEXT
IF sum <> array(x + 1, y) THEN CheckRight = sum ELSE CheckRight = 0
END FUNCTION
The way this works is it creates a crossword style grid, and then it gives you some clues in the form of the colored tiles and numbers. Red is the sum of the numbers adding downwards. Blue is the sum of the numbers adding right.
Game is loosely based off a variety of the puzzle Kakuro: https://www.kakuroconquest.com
Main difference here is I'm not checking for unique values, so you can have the same value multiple times in a row/column, which means there's no "unique" solution to puzzle.
|
|
|
|
| Makes shift lights blink in a binary pattern |
|
Posted by: eoredson - 06-04-2024, 03:37 AM - Forum: Programs
- Replies (1)
|
 |
Here is a fun post that makes the shift lights blink in a binary pattern:
Code: (Select All) Rem makes shift lights blink in a binary pattern.
Color 15, 1
Print "Blink lights.."
Color , 0
Color 14
C = 8 ' set default color.
Do
' rotate color.
C = C + 1
If C = 15 Then C = 9
Color C
For x = 0 To 7
Select Case x
Case 0 ' off
_Numlock Off
_CapsLock Off
_Scrolllock Off
Print "Numlock Off Capslock Off Scrolllock Off"
Case 1
_Numlock On
_CapsLock Off
_Scrolllock Off
Print "Numlock On Capslock Off Scrolllock Off"
Case 2
_Numlock Off
_CapsLock On
_Scrolllock Off
Print "Numlock Off Capslock On Scrolllock Off"
Case 3
_Numlock Off
_CapsLock Off
_Scrolllock On
Print "Numlock Off Capslock Off Scrolllock On"
Case 4
_Numlock On
_CapsLock On
_Scrolllock Off
Print "Numlock On Capslock On Scrolllock Off"
Case 5
_Numlock On
_CapsLock Off
_Scrolllock On
Print "Numlock On Capslock Off Scrolllock On"
Case 6
_Numlock Off
_CapsLock On
_Scrolllock On
Print "Numlock Off Capslock On Scrolllock On"
Case 7 ' all on
_Numlock On
_CapsLock On
_Scrolllock On
Print "Numlock On Capslock On Scrolllock On"
End Select
_Delay 1.5
If Len(InKey$) Then
_Numlock Off
_CapsLock Off
_Scrolllock Off
Color 7
End
End If
Next
Loop
End
|
|
|
|
| Geometry Tools |
|
Posted by: bplus - 06-04-2024, 01:33 AM - Forum: Works in Progress
- Replies (1)
|
 |
Needs lots of clean up eg 2 slope routines but things appear to be working correctly:
circumscribe any triangle
Code: (Select All) _Title "Circumscribe Triangle" ' b+ 2024-06-03 trans to qb64pe from
'circumscribe Triangle.bas in SmallBASIC 2015-09-12 MGA/B+
'Thanks to ScriptBasic for posting 1968 Dartmouth Code
'OK now try to find point where I can circumscribe a circle about triangle
Screen _NewImage(800, 600, 32)
_ScreenMove 200, 60
Dim Shared A, B, C, D, E, F, U, V, W ' standard eq coefficients
Dim Shared SolvedX, SolvedY
Dim px(0 To 2), py(0 To 2), mpx(0 To 2), mpy(0 To 2)
Do
Color &HFFFFFFFF
Cls
Print "To find origin to circumscribe triangle, click 3 points to draw Triangle."
For i = 0 To 2
getClick px(i), py(i), kh&
If kh& = 0 Then
Circle (px(i), py(i)), 2
Print "point"; Str$(i); " = ("; ts$(px(i)); ","; ts$(py(i)); ")"
_Delay .2
Else
End
End If
Next
drawTri px(), py() ' draw triangle
'line p1x,p1y,p2x,p2y
' calc midpoints
For i = 0 To 2
mpx(i) = (px(i) + px((i + 1) Mod 3)) / 2
mpy(i) = (py(i) + py((i + 1) Mod 3)) / 2
Circle (mpx(i), mpy(i)), 2
Next
'? "and...Center!"
ABCs4StdFrm px(1), py(1), mpx(0), mpy(0) ' sets U, V, W
A = U: B = V: C = W ' Save as A, B, C
ABCs4StdFrm px(2), py(2), mpx(1), mpy(1) ' sets U, V, W
D = U: E = V: F = W 'Save as D, E, F
Solve4XY
Circle (SolvedX, SolvedY), 2, &HFFFFFF00
Line (SolvedX, SolvedY)-(mpx(0), mpy(0)), &HFFFFFF00
Line (SolvedX, SolvedY)-(mpx(1), mpy(1)), &HFFFFFF00
Line (SolvedX, SolvedY)-(mpx(2), mpy(2)), &HFFFFFF00
radius = ((px(0) - SolvedX) ^ 2 + (py(0) - SolvedY) ^ 2) ^ .5
Circle (SolvedX, SolvedY), radius, &HFFFFFF00
_PrintString (50, _Height - 20), "zzz... press any for another run"
Sleep
Loop
Function slope (q1x, q1y, q2x, q2y)
slope = (q2y - q1y) / (q2x - q1x)
End Function
Sub ABCs4StdFrm (r1x, r1y, r2x, r2y)
'takes two points that define line and gets A,B,C's for Standard Form of line
m = slope(r1x, r1y, r2x, r2y)
'Ax + By = C find equation of line perpendicular through point r2x,r2y
U = 1 / m: V = 1: W = r2x / m + r2y 'U,V,W are global these are perpendicular line calcs
End Sub
Sub Solve4XY ()
'globals A,B,C of eq1 Ax+By=C D,E,F of eq2 Dx+Ey=F
G = A * E - B * D
If G = 0 Then Print "NO UNIQUE SOLUTION": Exit Sub
SolvedX = (C * E - B * F) / G
SolvedY = (A * F - C * D) / G
End Sub
Sub getClick (mx, my, q) ' from 000 test\getClick test
'getClick returns the mouse x, y position WHEN THE MOUSE WAS RELEASED! or keypress ASC 27 or 32 to 125
'2019-08-06 Test now with new mBox and inputBox procedures
'found mBox needed a _KEYCLEAR, how about inputBox? OK had _KEYCLEAR already
mb = _MouseButton(1)
While mb
While _MouseInput: Wend '<<<<<<<<<<<<<<<<<<<< clear previous mb
mb = _MouseButton(1)
Wend
_KeyClear 'clear previous key presses
mx = -1: my = -1: q = 0
Do While mx = -1 And my = -1
q = _KeyHit
If q = 27 Or (q > 31 And q < 126) Then _KeyClear: Exit Sub
i = _MouseInput: mb = _MouseButton(1)
'IF mb THEN
Do While mb 'wait for release
q = _KeyHit
If q = 27 Or (q > 31 And q < 126) Then Exit Sub
i = _MouseInput: mb = _MouseButton(1): mx = _MouseX: my = _MouseY
_Limit 1000
Loop
_Limit 1000
Loop
End Sub
Function ts$ (N)
ts$ = _Trim$(Str$(Int(N)))
End Function
Sub drawTri (px(), py())
' px(), py() arrays 1 to 3 of points
Line (px(0), py(0))-(px(1), py(1))
Line (px(1), py(1))-(px(2), py(2))
Line (px(2), py(2))-(px(0), py(0))
End Sub
that was the easy one
|
|
|
|
| Need a Printer/Tester |
|
Posted by: SMcNeill - 06-03-2024, 11:08 PM - Forum: Help Me!
- Replies (14)
|
|
A little routine I wrote which should print out a file to the printer:
Code: (Select All)
$COLOR:32
PrintScreen = _NEWIMAGE(850, 1100, 32) 'to represent an 8.5" x 11" sheet of paper
SCREEN PrintScreen
File$ = _OPENFILEDIALOG$("Choose file to Print", _CWD$, "*.*", "Any File")
OPEN File$ FOR BINARY AS #1
CLS , White, PrintScreen
COLOR Black, 0
DO
LINE INPUT #1, temp$
PCOPY 0, 1
PRINT temp$
IF CSRLIN >= _HEIGHT - 3 THEN 'we probably scrolled the page. Rip off this sheet of paper and start a new page!
PCOPY 1, 0
_PRINTIMAGE PrintScreen
CLS , White, PrintScreen
PRINT temp$
END IF
LOOP UNTIL EOF(1)
CLOSE
Problem is, when I went to test it, my printer is all out of ink and such. 
Anyone want to give this a test run for us? Uses _PrintImage, so is a Windows-Only program, so Linux and Mac folks can't make yse of this until we expand the functionality to include them.
If you can, try this with a short, 1-page program (Hello World would work fine.) Then try it with something that might take a couple of pages to print out. It *should* sort things out and print across multiple pages without issue.
I hope, anyway.
Note: IF this prints out 1000 pages and doesn't stop.... I apologize in advance!
|
|
|
|
| ClickAwayBalls - click moving balls in order before timer ends |
|
Posted by: Dav - 06-03-2024, 12:04 AM - Forum: Games
- Replies (1)
|
 |
ClickAwayBalls is another little game that @bplus helped me with at the old forum. Numbered balls bounce around over a moving plasma background. You click them away in order before the timer runs out. Updated it to fit larger desktops and added new font style and win/lose message.
- Dav
Code: (Select All)
'ClickAwayBalls.bas v1.2
'by Dav, JUN/2024
'* NEW: using a new font, larger screen size, fixed gameover flag.
'Some helpful mod & tweaks by bplus. Thanks bplus!!!
'Click on balls in order, starting at 1 until all gone,
'Do this before the timer runs out.
Randomize Timer
dw = Int(_DesktopWidth * .75) 'set board size based on user desktop size
dh = Int(_DesktopHeight * .75)
Screen _NewImage(dw, dh, 32)
_Delay .25
_ScreenMove _Middle
_PrintMode _KeepBackground
balls = 15: size = 45: speed = 3
ReDim BallX(balls), BallY(balls), BallDx(balls), BallDy(balls), BallSize(balls), BallShow(balls), BallC(balls) As _Unsigned Long
w = _Width: h = _Height: w2 = _Width / 2: h2 = _Height / 2
restart:
'Generate random ball data
For B = 1 To balls
BallSize(B) = 50 + (Rnd * 50)
BallX(B) = BallSize(B) + Rnd * (w - 2 * BallSize(B)): BallY(B) = BallSize(B) + Rnd * (h - 2 * BallSize(B))
a = Rnd * _Pi(2): Ballspeed = 2 + B
BallDx(B) = Ballspeed * Cos(a): BallDy(B) = Ballspeed * Sin(a)
BallShow(B) = 1: BallC(B) = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
Next
curball = 1
gametime = Timer
gameover = 0
timelimit = 45
Do
Cls
'compute ball movement
For t = 1 To balls
BallX(t) = BallX(t) + BallDx(t) 'move ball then make sure in bounds
BallY(t) = BallY(t) + BallDy(t)
If BallX(t) > w - BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = w - BallSize(t)
If BallX(t) < BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = BallSize(t)
If BallY(t) > h - BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = h - BallSize(t)
If BallY(t) < BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = BallSize(t)
Next
'draw background
t = Timer
For x = 0 To w Step 6
For y = 0 To h Step 6
r = Sin(1.1 * t) * h2 - y + h2
Line (x, y)-Step(5, 5), _RGB(r, r - y, -r), BF
Next
t = t + .01
GoSub GetMouseClick
Next
If gameover = 1 Then
Play "o2l16cegagfefgabgc3l4"
cx = _Width / 2: cy = _Height / 2
Line (cx - 300, cy - 130)-(cx + 300, cy + 30), _RGBA(0, 0, 0, 150), BF
Line (cx - 300, cy - 130)-(cx + 300, cy + 30), _RGB(128, 255, 128), B
PPRINT cx - 200, cy - 90, 60, _RGB(128, 255, 128), 1, "WINNER!!"
_Display
Sleep 4
GoTo restart
End If
'draw balls
For i = 1 To balls
If BallShow(i) = 1 Then
drawBall BallX(i), BallY(i), BallSize(i), BallC(i)
'PPRINT BallX(i) - 12, BallY(i) - 12, 30, _RGB(1, 1, 1), 1, Right$("0" + _Trim$(Str$(i)), 2)
PPRINT BallX(i) - 10, BallY(i) - 20, 30, _RGB(255, 255, 255), 1, Right$("0" + _Trim$(Str$(i)), 2)
End If
Next
'Locate 1, 1: Print "Click ball.."; curball;
PPRINT 20, 10, 20, _RGB(255, 0, Rnd * 255), 1, "Click ball: " + _Trim$(Str$(curball))
'Locate 2, 1: Print timelimit - Int(Timer - gametime);
PPRINT 20, 40, 30, _RGB(255, 0, Rnd * 255), 1, Str$(timelimit - Int(Timer - gametime))
_Display: _Limit 30
'If click on one ball (no overlayed oned) remove it
If found = 1 Then
If firstball = curball Then
'erase ball
drawBall BallX(firstball), BallY(firstball), BallSize(firstball), BallC(firstball)
BallShow(firstball) = 0
Play "mbl32o2ceg"
_Display: _Delay .05
curball = curball + 1
found = 0
Else
found = found + 1
lastfound = firstball
End If
End If
'check if all clicked
anyleft = 0
For c = 1 To balls
If BallShow(c) = 1 Then anyleft = anyleft + 1
Next
If anyleft = 0 Then
gameover = 1
End If
If Timer - gametime > timelimit Then
Play "mbo1l4dl8ddl4dl8feeddc#l2d"
cx = _Width / 2: cy = _Height / 2
Line (cx - 300, cy - 130)-(cx + 300, cy + 30), _RGBA(0, 0, 0, 150), BF
Line (cx - 300, cy - 130)-(cx + 300, cy + 30), _RGB(128, 255, 128), B
PPRINT cx - 200, cy - 90, 60, _RGB(128, 255, 128), 1, "TIME OUT"
_Display
Sleep 4
GoTo restart
End If
Loop
End
'==============
GetMouseClick:
'==============
mi = _MouseInput
If _MouseButton(1) = 0 Then done = 0
If _MouseButton(1) And done = 0 Then
mx = _MouseX: my = _MouseY
found = 0
For m = 1 To balls
If BallShow(m) = 1 Then
If Sqr((mx - BallX(m)) ^ 2 + (my - BallY(m)) ^ 2) < BallSize(m) Then
If found = 0 Then firstball = m
found = found + 1
If found > 1 Then
lastfound = m
End If
End If
End If
Next
done = 1
End If
Return
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub PPRINT (x, y, size, clr&, trans&, text$)
'This sub outputs to the current _DEST set
'It makes trans& the transparent color
'x/y is where to print text
'size is the font size to use
'clr& is the color of your text
'trans& is the background transparent color
'text$ is the string to print
'=== get users current write screen
orig& = _Dest
'=== if you are using an 8 or 32 bit screen
bit = 32: If _PixelSize(0) = 1 Then bit = 256
'=== step through your text
For t = 0 To Len(text$) - 1
'=== make a temp screen to use
pprintimg& = _NewImage(16, 16, bit)
_Dest pprintimg&
'=== set colors and print text
Cls , trans&: Color clr&
Print Mid$(text$, t + 1, 1);
'== make background color the transprent one
_ClearColor _RGB(0, 0, 0), pprintimg&
'=== go back to original screen to output
_Dest orig&
'=== set it and forget it
x1 = x + (t * size): x2 = x1 + size
y1 = y: y2 = y + size
_PutImage (x1 - (size / 2), y1)-(x2, y2 + (size / 3)), pprintimg&
_FreeImage pprintimg&
Next
End Sub
|
|
|
|
| RocoLoco - Row & Column math puzzle game. |
|
Posted by: Dav - 06-02-2024, 05:35 PM - Forum: Games
- Replies (3)
|
|
RocoLoco is a math puzzle game where you make the rows & columns of numbers in the red inside grid add up the total amount on the edges. Click the red numbers on/off. When the row/column adds up correct, the edge total number will turn on white. Goal is to make the grid numbers all add up correct so all edge numbers are lit up at the same time.
Grid size increases with each level. You can jump to other levels by using the +/- keys. Press H for help menu. ESC quits.
- Dav
Code: (Select All)
'============
'RoCoLoco.bas v2.0
'============
'Row & Column number adding puzzle game.
'Based on popular math game found online.
'Coded by Dav for QB64-PE, Nov/2022
'New for v2: * Playing board now adapts to users desktop size.
' It should displays the same on every screen.
' (Screen size is not hardcoded to specific size)
' * No longer uses external .jpg images for numbers.
' * Change grid size using the +/- keys.
' * Added HELP screen (not much) - press H for it.
' * Added some cheap sound effects.
'
'~~~~~~~~~~~
'HOW TO PLAY:
'Click numbers inside the grid to turn them on/off.
'Each row/column of red number totals must add up to the number
'on the edge of the grid. When they do, the edge numbers will
'turn on too. You must tun on all the edge numbers to solve it.
'
'~~~~~~~~
'CONTROLS:
'
'You can change the grid size anytime by using +/- keys.
'H = Show a simple help screen
'SPACE = Generate a new puzzle grid
'ESC = Quits game
'============================================================
ReDim Shared grid, tiles
'defaults....
grid = 6 '4x4 grid size (4 for inside tiles, 2 for edges = 6)
gridmax = 15
'===
top:
'===
_Title "RoCoLoco - Working..."
tiles = grid * grid ' total number of tiles on board
Screen _NewImage(_DesktopHeight * .80, _DesktopHeight * .80, 32)
tilesize = (_DesktopHeight * .80) / grid
Cls , _RGB(77, 77, 77)
ReDim Shared tilev(tiles) 'make array for all titles values
ReDim Shared tilef(tiles) 'make array for flag if tile is on/off
ReDim Shared tilex(tiles), tiley(tiles) 'x/y positions for tiles
Randomize Timer 'set random seed
'init x/y values for drawing tiles
bc = 1
For x = 1 To grid
For y = 1 To grid
tilex(bc) = (x * tilesize) - tilesize: tiley(bc) = (y * tilesize) - tilesize
tilev(bc) = Int(Rnd * 9 + 1) '<<< for testing only, give all some data
bc = bc + 1
Next
Next
SCRAMTIME = Timer
'==========
regenerate:
'==========
Sound 500 + Rnd * 1000, 1
'generate random tile value and on/off settings
T = grid + 2
For y = 2 To grid - 1
regeneratex:
makesurex = 0: thold = T
For x = 2 To grid - 1
tilev(thold) = Int(Rnd * 5 + 1) 'make random number, from 1-5
If Int(Rnd * grid - (Int(Rnd * 1.5))) = 0 Then
tilef(thold) = 0 'randomly turn tile on/off
makesurex = 1 'make sure at least one out on this column
Else
tilef(thold) = 1
End If
'show something while computing...
Line (tilex(thold), tiley(thold))-(tilex(thold) + tilesize, tiley(thold) + tilesize), _RGB(255, 100, 100), BF
PPRINT tilex(thold) + (tilesize / 1.8), tiley(thold) + (tilesize / 4.5), tilesize / 2, _RGB(255, 255, 255), 0, LTrim$(Str$(tilev(thold)))
thold = thold + 1
Next
'if row didnt have one turned off, do this column over...
If makesurex = 0 Then GoTo regeneratex
T = thold + 2
_Limit 10 * grid 'slow down, let's see it.
Next
'now check rows left to right for on/off, if none off, regenerate
For x = 0 To grid - 3
makesurex = 0
For y = grid + 2 To (grid * grid) - grid - 2 Step grid
If tilef(y + x) = 0 Then makesurex = 1
Next
If makesurex = 0 Then GoTo regenerate
Next
If Timer < (SCRAMTIME + 1) Then GoTo regenerate
'compute left/right edges totals
For y = 0 To grid - 3
total = 0
For x = grid + 2 To (grid * grid) - grid - 2 Step grid
If tilef(y + x) = 1 Then
total = total + tilev(y + x)
End If
Next
tilev(y + x) = total 'set total data to tile
Next
'compute top/bottom edges
For x = grid + 2 To (grid * grid) - grid - 2 Step grid
total = 0
For y = 0 To grid - 3
If tilef(y + x) = 1 Then
total = total + tilev(y + x)
End If
Next
tilev(y + x) = total
Next
'Lastly, mark all inside grid tiles as on, hiding generated solution.
For T = grid + 2 To (grid * grid) - grid - 1
'skip the outside rows
For tt = 1 To grid * grid Step grid
If T = tt Then GoTo skipmark
If T = tt + (grid - 1) Then GoTo skipmark
Next
tilef(T) = 1
skipmark:
Next
GoSub RedrawBoard
tit$ = "RoCoLoco" + Str$(grid - 2) + "x" + LTrim$(Str$(grid - 2)) + " | H = Help"
_Title tit$
_Icon _Display
Do
'wait until mouse button up to continue
While _MouseButton(1) <> 0: n = _MouseInput: Wend
trap = _MouseInput
If _MouseButton(1) Then
mx = _MouseX: my = _MouseY
'cycle through tiles
For T = grid + 2 To (grid * grid) - grid - 1
'skip the outside rows
For tt = 1 To grid * grid Step grid
If T = tt Then GoTo skip
If T = tt + (grid - 1) Then GoTo skip
Next
tx = tilex(T): tx2 = tilex(T) + tilesize
ty = tiley(T): ty2 = tiley(T) + tilesize
If mx >= tx And mx <= tx2 Then
If my >= ty And my <= ty2 Then
If tilef(T) = 0 Then
tilef(T) = 1: 'mark it on
Sound 2500, .1
Else
tilef(T) = 0: 'mark it off
Sound 2000, .1
End If
GoSub RedrawBoard
'check for win
End If
End If
skip:
Next
End If
k$ = UCase$(InKey$)
If k$ <> "" Then
'ESC key quits
If k$ = Chr$(27) Then System
'space key generates new board
If k$ = " " Then GoTo top
If k$ = "+" Then
If grid < 15 Then grid = grid + 1: GoTo top
End If
If k$ = "-" Then
If grid > 5 Then grid = grid - 1: GoTo top
End If
If k$ = "H" Then
back& = _CopyImage(_Display)
Cls , _RGB(77, 77, 77)
ps = (_DesktopHeight * .80) / 5
PPRINT ps / 2 + 2, ps / 3 + 2, ps / 3, _RGB(255, 255, 255), 0, "ROCOLOCO HELP"
PPRINT ps / 2, ps / 3, ps / 3, _RGB(255, 100, 100), 0, "ROCOLOCO HELP"
PPRINT ps / 2, (ps / 3) * 3, ps / 6, _RGB(196, 196, 196), 0, "Click on the numbers to"
PPRINT ps / 2, (ps / 3) * 4, ps / 6, _RGB(196, 196, 196), 0, "turn them On or Off."
PPRINT ps / 2, (ps / 3) * 5, ps / 6, _RGB(196, 196, 196), 0, "Rows And Columns must"
PPRINT ps / 2, (ps / 3) * 6, ps / 6, _RGB(196, 196, 196), 0, "add up to the number on"
PPRINT ps / 2, (ps / 3) * 7, ps / 6, _RGB(196, 196, 196), 0, "the edges. When correct,"
PPRINT ps / 2, (ps / 3) * 8, ps / 6, _RGB(196, 196, 196), 0, "edges will turn white."
PPRINT ps / 2, (ps / 3) * 9, ps / 6, _RGB(196, 196, 196), 0, "Make all edges white to"
PPRINT ps / 2, (ps / 3) * 10, ps / 6, _RGB(196, 196, 196), 0, "solve the math puzzle."
PPRINT ps / 2, (ps / 3) * 11, ps / 6, _RGB(196, 196, 196), 0, "Use +/- keys to change"
PPRINT ps / 2, (ps / 3) * 12, ps / 6, _RGB(196, 196, 196), 0, "the size of the grid."
PPRINT ps / 2, (ps / 3) * 14, ps / 6, _RGB(255, 255, 255), 0, " - PRESS ANY KEY - "
A$ = Input$(1)
_PutImage (0, 0), back&
_FreeImage back&
End If
End If
Loop
End
'========================================================================================
RedrawBoard:
'===========
win = 1
'Draw inside grid numbers first
For d = grid + 2 To (grid * grid) - grid - 1
'skiping the outside rows
For dd = 1 To grid * grid Step grid
If d = dd Then GoTo skipit
If d = dd + (grid - 1) Then GoTo skipit
Next
If tilef(d) = 1 Then
'on
Line (tilex(d), tiley(d))-(tilex(d) + tilesize, tiley(d) + tilesize), _RGB(255, 100, 100), BF
PPRINT tilex(d) + (tilesize / 1.8), tiley(d) + (tilesize / 4.5), tilesize / 2, _RGB(255, 255, 255), 0, LTrim$(Str$(tilev(d)))
Else
'off
Line (tilex(d), tiley(d))-(tilex(d) + tilesize, tiley(d) + tilesize), _RGB(77, 77, 77), BF
PPRINT tilex(d) + (tilesize / 1.8), tiley(d) + (tilesize / 4.5), tilesize / 2, _RGB(96, 96, 96), 0, LTrim$(Str$(tilev(d)))
End If
skipit:
Next
'compute and draw left/right edges
For y = 0 To grid - 3
total = 0
For x = grid + 2 To (grid * grid) - grid - 2 Step grid
If tilef(y + x) = 1 Then
total = total + tilev(y + x)
End If
Next
If tilev(y + x) = total Then
'if total match, highlight it
Line (tilex(y + x), tiley(y + x))-(tilex(y + x) + tilesize, tiley(y + x) + tilesize), _RGB(255, 255, 255), BF 'right side
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) + (tilesize / 2.5), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) + (tilesize / 1.7), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
End If
Line (tilex(y + x) - (tilex(y + x)), tiley(y + x))-((tilex(y + x) - (tilex(y + x))) + tilesize, tiley(y + x) + tilesize), _RGB(255, 255, 255), BF 'left side
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) - tilex(y + x) + (tilesize / 2.5), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) - tilex(y + x) + (tilesize / 1.7), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
End If
Else
'total doesnt match, don't highlight edge
win = 0
Line (tilex(y + x), tiley(y + x))-(tilex(y + x) + tilesize, tiley(y + x) + tilesize), _RGB(77, 77, 77), BF 'right side
Line (tilex(y + x), tiley(y + x))-(tilex(y + x) + tilesize, tiley(y + x) + tilesize), _RGB(196, 196, 196), B 'right side
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) + (tilesize / 2.5), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(196, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) + (tilesize / 1.7), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(195, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
End If
Line (tilex(y + x) - (tilex(y + x)), tiley(y + x))-((tilex(y + x) - (tilex(y + x))) + tilesize, tiley(y + x) + tilesize), _RGB(77, 77, 77), BF 'left side
Line (tilex(y + x) - (tilex(y + x)), tiley(y + x))-((tilex(y + x) - (tilex(y + x))) + tilesize, tiley(y + x) + tilesize), _RGB(196, 196, 196), B 'left side
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) - tilex(y + x) + (tilesize / 2.5), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(196, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) - tilex(y + x) + (tilesize / 1.7), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(196, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
End If
End If
Next
'compute and draw top/bottom edges
For x = grid + 2 To (grid * grid) - grid - 2 Step grid
total = 0
For y = 0 To grid - 3
If tilef(y + x) = 1 Then
total = total + tilev(y + x)
End If
Next
If tilev(y + x) = total Then
'total matches, hight top/bottom
Line (tilex(y + x), tiley(y + x))-(tilex(y + x) + tilesize, tiley(y + x) + tilesize), _RGB(255, 255, 255), BF 'bottom
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) + (tilesize / 2.5), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) + (tilesize / 1.7), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
End If
Line (tilex(y + x), tiley(y + x) - tiley(y + x))-(tilex(y + x) + tilesize, (tiley(y + x) - tiley(y + x)) + tilesize), _RGB(255, 255, 255), BF 'top
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) + (tilesize / 2.5), tiley(y + x) - tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) + (tilesize / 1.7), tiley(y + x) - tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(32, 32, 32), 0, LTrim$(Str$(tilev(y + x)))
End If
Else
'doesnt' match, dont hightlight top/bottom edges
win = 0
Line (tilex(y + x), tiley(y + x))-(tilex(y + x) + tilesize, tiley(y + x) + tilesize), _RGB(77, 77, 77), BF 'bottom
Line (tilex(y + x), tiley(y + x))-(tilex(y + x) + tilesize, tiley(y + x) + tilesize), _RGB(196, 196, 196), B 'bottom
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) + (tilesize / 2.5), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(196, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) + (tilesize / 1.7), tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(196, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
End If
Line (tilex(y + x), tiley(y + x) - tiley(y + x))-(tilex(y + x) + tilesize, (tiley(y + x) - tiley(y + x)) + tilesize), _RGB(77, 77, 77), BF 'top
Line (tilex(y + x), tiley(y + x) - tiley(y + x))-(tilex(y + x) + tilesize, (tiley(y + x) - tiley(y + x)) + tilesize), _RGB(196, 196, 196), B 'top
If Len(LTrim$(Str$(tilev(y + x)))) = 2 Then
PPRINT tilex(y + x) + (tilesize / 2.5), tiley(y + x) - tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(196, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
Else
PPRINT tilex(y + x) + (tilesize / 1.7), tiley(y + x) - tiley(y + x) + (tilesize / 3.2), tilesize / 3, _RGB(196, 196, 196), 0, LTrim$(Str$(tilev(y + x)))
End If
End If
Next
'see if puzzle completed
If win = 1 Then
Play "mbl16o2cdedefgabagfedc"
'remove unused numbers
For T = grid + 2 To (grid * grid) - grid - 1
'skip the outside rows
For tt = 1 To grid * grid Step grid
If T = tt Then GoTo skipcheck
If T = tt + (grid - 1) Then GoTo skipcheck
Next
If tilef(T) = 0 Then
Line (tilex(T), tiley(T))-(tilex(T) + tilesize, tiley(T) + tilesize), _RGB(77, 77, 77), BF
End If
skipcheck:
Next
_Delay 5
If grid < 15 Then grid = grid + 1
GoTo top
End If
Return
Sub PPRINT (x, y, SquareSize, clr&, trans&, text$)
orig& = _Dest
bit = 32: If _PixelSize(0) = 1 Then bit = 256
For t = 0 To Len(text$) - 1
pprintimg& = _NewImage(16, 16, bit)
_Dest pprintimg&
Cls , trans&: Color clr&
Print Mid$(text$, t + 1, 1);
_ClearColor _RGB(0, 0, 0), pprintimg&
_Dest orig&
x1 = x + (t * SquareSize): x2 = x1 + SquareSize
y1 = y: y2 = y + SquareSize
_PutImage (x1 - (SquareSize / 2), y1)-(x2, y2 + (SquareSize / 3)), pprintimg&
_FreeImage pprintimg&
Next
End Sub
|
|
|
|
| 3.13.1 bug report - keyboard characters swapped |
|
Posted by: Circlotron - 06-02-2024, 10:54 AM - Forum: General Discussion
- Replies (3)
|
 |
Just loaded version 3.13.1 on my HP Envy Win10 laptop and found the characters " and @ are swapped.
Also, # produces u with a right tilted accent above it.
Using the default lucon.ttf font.
Tried DejaVu Sans Mono that I normally use on Linux, but this time on Win10 and same problem.
|
|
|
|
|
