Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
b+ Beginners Corner
#51
Quote:Also remember to put on the quirk that Dimster desires... the pulldown animation. [Image: smile.png]

Dang! I missed that. Stay Tuned... oh this is going to be tougher than I thought!
Code: (Select All)
Option _Explicit '                                            no typos for variables if you please
_Title "Drop Menu more 2 function test" ' b+ 2023-06-27
' Instigated by Dimster here:
' https://qb64phoenix.com/forum/showthread...7#pid17117
' More! = 1. Highlite mouse overs 2. Handle extra long menu descriptions up to .5 screen width
' So sorry Ultraman, no tool tips but extra long descriptions is better than nutt'n.

Const ButtonW = 100, ButtonH = 20 ' basic rectangle size for title of menu panel
Type BoxType ' to be used for MouseZone click checking
As String Label ' menu title
As Long LeftX, TopY, BoxW, BoxH ' left most, top most , box width, box height
End Type

Dim Shared As Integer NBoxes ' setting up a demo in main
NBoxes = 72 ' exorbinant amount of menu titles
Dim Shared Boxes(1 To NBoxes) As BoxType ' data array for positions and labels
Dim As Integer i, x, y, mz, nItems, choice ' index, positions, menu count, choice selected
ReDim menu$(1 To 1) ' dynamic array to store quick menu's into
Dim s$ ' a string variable

Screen _NewImage(800, 600, 32) ' screen stuff
_ScreenMove 250, 50 ' somewhere in middle of my laptop, you may prefer to change for your screen
_PrintMode _KeepBackground ' preserve background when printing stuff
Cls ' so we have solid black background for image saving

x = 0: y = 0 ' set up boxes x, y for top left box corner
For i = 1 To NBoxes
Boxes(i).Label = "Box" + Str$(i) ' quick menu title
Boxes(i).LeftX = x: Boxes(i).TopY = y ' top left corner
Boxes(i).BoxW = ButtonW ' width to constant set for all
Boxes(i).BoxH = ButtonH ' height to constant set for all
If (x + 2 * ButtonW) > _Width Then ' spread out the menu titles left right, top down
x = 0: y = y + ButtonH ' next title didn't fit across so start new row
Else
x = x + ButtonW ' fits going across
End If
DrawTitleBox i ' draw the menu title panel
Next

Do
mz = MouseZone% ' reports which menu panel has been clicked and mouse
If mz Then ' quick make up a list of items for the menu title box
nItems = Int(Rnd * 10) + 1 ' pick random 1 to 10 inclusive
ReDim menu$(1 To nItems) ' resize menu$ by nItems
For i = 1 To nItems ' menu option and description
s$ = "Box" + Str$(mz) + " Menu Item:" + Str$(i) ' still needs to be less
s$ = s$ + " with extra, extra, long description." ' than .5 screen width
menu$(i) = s$ ' item is described with fairly good width to it
Next ' his was alternate to tool tips
choice = getButtonNumberChoice%(Boxes(mz).LeftX, Boxes(mz).TopY, menu$())
If choice = 0 Then s$ = "You quit menu by clicking outside of it." Else s$ = menu$(choice)
_MessageBox "Drop Menu Test", "Your Menu Choice was: " + s$, "info"
End If
_Limit 30
Loop Until _KeyDown(27)

Sub DrawTitleBox (i) ' draw a box according to shared Boxes array then print label
Line (Boxes(i).LeftX + 1, Boxes(i).TopY + 1)-Step(ButtonW - 2, ButtonH - 2), &HFF550088, BF
Color &HFFFFFFFF
_PrintString (Boxes(i).LeftX + (ButtonW - _PrintWidth(Boxes(i).Label)) / 2, _
Boxes(i).TopY + ButtonH / 2 - 8), Boxes(i).Label
End Sub

Sub DrawChoiceBox (highliteTF%, leftX, topY, BoxW As Integer, S$) ' draw menu items for menu title
If highliteTF% Then ' reverse colors as mouse is over this item
Line (leftX, topY)-Step(BoxW, ButtonH), &HFFAAAAAA, BF
Color &HFF333333
_PrintString (leftX + (BoxW - _PrintWidth(S$)) / 2, topY + ButtonH / 2 - 8), S$
Else
Line (leftX, topY)-Step(BoxW, ButtonH), &HFF333333, BF
Color &HFFAAAAAA
_PrintString (leftX + (BoxW - _PrintWidth(S$)) / 2, topY + ButtonH / 2 - 8), S$
End If
Line (leftX, topY)-Step(BoxW, ButtonH), &HFF000000, B ' draw black box around item
End Sub

Function MouseZone% ' returns the Shared Boxes() index clicked or 0 none clicked
' Set the following up in your Main code of app
'Type BoxType ' to be used for mouse click checking
' As Long LeftX, TopY, BoxW, BoxH ' left most, top most, box width, box height
'End Type
'Dim Shared As Integer NBoxes
'Dim Shared Boxes(1 To NBoxes) As BoxType

Dim As Integer i, mb, mx, my

While _MouseInput: Wend ' poll mouse
mb = _MouseButton(1) ' looking for left click
If mb Then
_Delay .25
mx = _MouseX: my = _MouseY ' get the mouse position
For i = 1 To NBoxes ' see if its in a menu tile box from data in Shared Boxes array
If mx > Boxes(i).LeftX And mx < Boxes(i).LeftX + Boxes(i).BoxW Then
If my > Boxes(i).TopY And my < Boxes(i).TopY + Boxes(i).BoxH Then
MouseZone% = i: Exit Function ' yes a click in this box index
End If
End If
Next
End If
End Function

Function getButtonNumberChoice% (BoxX As Integer, BoxY As Integer, choice$())
' This fucion uses Sub DrawChoiceBox (highliteTF%, leftX, topY, BoxW As Integer, S$)
' BoxX, BoxY are top left corner from the Menu Title Panel
' We will be drawing our Menu Items below that panel
Dim As Integer ub, lb, b ' choice$() boundaries and an index, b, to run through items
Dim As Integer longest ' find the longest string length in choices
Dim As Integer menuW, menuX ' use menuWidth and menuX start box side so long menu strings fit
Dim As Integer mx, my, mb ' mouse status of position and left button
Dim As Long save ' we are saving the whole screen before drop down to redraw after click
Dim As Long drawerDown ' save drawer down after animate dropping drawers for Dimster

ub = UBound(choice$): lb = LBound(choice$) ' array boundaries
For b = lb To ub ' find longest string in choice
If Len(choice$(b)) > longest Then longest = Len(choice$(b))
Next
If (longest + 2) * 8 > ButtonW Then ' don't use default button Width string too long
menuW = (longest + 2) * 8 ' calculate the needed width, up to half screen fits
If BoxX < _Width / 2 - 3 Then ' -3 ?? wouldn't work right until took 3 off middle
menuX = BoxX ' use the same left side of box to start
Else
menuX = BoxX + ButtonW - menuW ' right side box align minus menu width = x start box
End If
Else
menuW = ButtonW ' use default sizes that fit nicely under menu title panel
menuX = BoxX
End If
save = _NewImage(_Width, _Height, 32) ' save our beautiful screen before dropping menu
_PutImage , 0, save

' Animate dropping drawers for Dimster
For b = lb To ub ' clear any previous highlites
DrawChoiceBox 0, menuX, BoxY + b * ButtonH, menuW, choice$(b)
_Display
_Limit 5
Next
drawerDown = _NewImage(_Width, _Height, 32) ' save our beautiful screen after dropping menu
_PutImage , 0, drawerDown

Do ' until a mouse click occurs
_PutImage , drawerDown, 0 ' actually this is better to clear screen with image
While _MouseInput: Wend ' poll mouse
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
For b = lb To ub ' scan through the box dimension to see if mouse is in one
If mx > menuX And mx <= menuX + menuW Then
If my >= BoxY + b * ButtonH And my <= BoxY + b * ButtonH + ButtonH Then
If mb Then ' item is clicked!
_PutImage , save, 0 ' put image of screen back
_FreeImage save ' throw out screen image so no memory leak
_FreeImage drawerDown
' delay before exit to give user time to release mouse button
' set function, restore autodisplay and exit
getButtonNumberChoice% = b: _Delay .25: _AutoDisplay: Exit Function
Else
' indicate mouse over this menu item! draw highlight in box = -1
DrawChoiceBox -1, menuX, BoxY + b * ButtonH, menuW, choice$(b)
_Display
End If
End If
End If
Next
If mb Then ' there was a click outside the menu = cancel
_PutImage , save, 0 ' put image before dropdown draw back up
_FreeImage save ' leaving sub avoid memory leak, dump image
_FreeImage drawerDown
' delay before exit to give user time to release mouse button
' set function, restore autodisplay and exit
getButtonNumberChoice% = 0: _Delay .25: _AutoDisplay: Exit Function
End If
_Display ' display was needed here to avoid blinking when redrawing the highlited item
'_Limit 60
Loop ' until a mouse click occurs
End Function
b = b + ...
Reply
#52
Dang I can't edit above or I will lose that pretty edge!

@Dimster or @mnrvovrfc try out the above code, I have the code "rolling down" (each panel drawn after last instead of all at once) the menu items after a menu title button is clicked. I think this is the animation desired?
b = b + ...
Reply
#53
The code is OK on my side. The animation is done like on mine but it's less obvious from just looking at the code.

The really long descriptions as part of menu entry could be hard. It might be better to have "Help" drawers instead that open a message box or other dialog that describes something in detail. Personally I don't like long menu entries. Although I had to deal with that regularly on REAPER, because it could be important in a music-creation application with many choices and which is deeply configurable.
Reply
#54
Thanks b+ , that animation is working great for me. I've been playing with the Limit to speed up and slow down the drop. This is such an improvement over the old days when you had to erase and redraw the dropping box to create that animation effect.

I know what you mean Minerva on long descriptions as, in the past, I only used the Main Menus to offer options and the Dropping Box to display more menu items. I had no long descriptions, but after trying to adapt Tempodi's child windows, I came to realize that the Main Menu could display a variety of topics (as opposed to options) and the multiple drop boxes  display the various info items on the selected topic. This does call for a long descriptive box.

Anyway, this version of the drop box amazing. Thanks again
Reply
#55
It still needs to be tested in real apps to see if really useful.
b = b + ...
Reply
#56
Drawing Numbers without Repetition


Code: (Select All)
_Title "Drawing numbers without repetitions" 'b+ 2024-06-03

DefLng A-Z ' all variables are long
Randomize Timer

highest = 50 ' draw numbers from 1 to 50
drawNumber = 10 ' how many numbers to draw

restart:
ReDim deckOfNumbers(1 To highest) ' long also

' load the deck with numbers
For i = 1 To highest
    deckOfNumbers(i) = i ' so the deck so far is very orderly
Next

' here is Fisher - Yates shuffle routine the most efficient known to mathematicians
For i = highest To 2 Step -1
    Swap deckOfNumbers(i), deckOfNumbers(Int(Rnd * i) + 1) ' swap i with 1 to i
Next

'      now the deck is shuffled !!! check it out
For i = 1 To drawNumber
    Print deckOfNumbers(i);
Next
Print

' now maybe we want to list numbers in order
ReDim order(1 To highest)
For i = 1 To drawNumber
    order(deckOfNumbers(i)) = 1 ' mark the numbers in order
Next
For i = 1 To highest
    If order(i) Then Print i;
Next
Print
Print "... that should show:"; drawNumber; "numbers between 1 and"; highest; ", in order, no repeats."
Print: Print
Input " Please enter Highest number "; highest
Input "    Please enter Draw number "; drawNumber
If highest <> 0 And drawNumber < highest Then GoTo restart
b = b + ...
Reply
#57
(06-04-2024, 01:17 AM)bplus Wrote:
Drawing Numbers without Repetition


Code: (Select All)
_Title "Drawing numbers without repetitions" 'b+ 2024-06-03

DefLng A-Z ' all variables are long
Randomize Timer

highest = 50 ' draw numbers from 1 to 50
drawNumber = 10 ' how many numbers to draw

restart:
ReDim deckOfNumbers(1 To highest) ' long also

' load the deck with numbers
For i = 1 To highest
    deckOfNumbers(i) = i ' so the deck so far is very orderly
Next

' here is Fisher - Yates shuffle routine the most efficient known to mathematicians
For i = highest To 2 Step -1
    Swap deckOfNumbers(i), deckOfNumbers(Int(Rnd * i) + 1) ' swap i with 1 to i
Next

'      now the deck is shuffled !!! check it out
For i = 1 To drawNumber
    Print deckOfNumbers(i);
Next
Print

' now maybe we want to list numbers in order
ReDim order(1 To highest)
For i = 1 To drawNumber
    order(deckOfNumbers(i)) = 1 ' mark the numbers in order
Next
For i = 1 To highest
    If order(i) Then Print i;
Next
Print
Print "... that should show:"; drawNumber; "numbers between 1 and"; highest; ", in order, no repeats."
Print: Print
Input " Please enter Highest number "; highest
Input "    Please enter Draw number "; drawNumber
If highest <> 0 And drawNumber < highest Then GoTo restart

I got a shock when I saw this post!
Just last night I was working on this exact problem: are you spying on me ???  Big Grin
Here's what I ahd done: is this randomising less efficient than the one you used?
Code: (Select All)
For t = 1 To NumTickets
   For a = 1 To 7 '                                                         b is ball pick number
      GetOne:
      ball = Int(Rnd * 35) + 1 '                                            Ball is ball number
      For b = 1 To 7
         If Tickets(t, b) = ball Then
            GoTo GetOne
         End If
      Next
      Tickets(t, a) = ball
   Next
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#58
oh ha! we are on same frequency @PhilOfPerth !

Here is some code i was fixing this morning for Carlos who likes his numbers in order
Code: (Select All)
Randomize Timer
For times = 1 To 20  ' do this 20 times
    ReDim NUMEROS(1 To 25) ' reset all to zero
    For j = 1 To 15
        tryAgain:
        temp = Int(Rnd * 25) + 1 ' random from 1 to 25 inclusive
        If NUMEROS(temp) Then GoTo tryAgain Else NUMEROS(temp) = 1 ' if already have try again for this time
    Next
    For i = 1 To 25 ' see what we got in order
        If NUMEROS(i) Then Print i;
    Next
    Print
Next

more efficient? depends is always a safe answer Smile for shuffling a deck, Fisher Yates is the best according to Wiki on subject but the method you understand the best and can use properly is pretty good too, a B+
b = b + ...
Reply
#59
Hi to all. I hope to be the right place to post my little code.

For a long time I wanted to be able to make my own applications in QB64 but I had the difficulty with the little English I know and with the little time I have, how to be able to see Greek characters in my applications. And voila.

Code: (Select All)
 
REM My Greek Letters
SCREEN _NEWIMAGE(800, 600, 32) ' Create new screen

' Load a font that supports Greek characters
fontfile$ = "C:\windows\fonts\lucon.ttf"
f& = _LOADFONT(fontfile$, 20, "MONOSPACE")
_FONT f&

PRINT "Αν δεν θες να περιμένεις πάτα ένα πλήκτρο"
PRINT "If you don't want to wait pushing a button."
sleep 10

GreekChange

PRINT "Αν δεν θες να περιμένεις πάτα ένα πλήκτρο"
PRINT "If you don't want to wait pushing a button."

sleep 10
EnglChange

PRINT "Αν δεν θες να περιμένεις πάτα ένα πλήκτρο"
PRINT "If you don't want to wait pushing a button."

sleep 10
EXODOS:
SYSTEM

SUB GreekChange
    RESTORE GreekUnicodeMap
    FOR ASCIIcode = 128 TO 255
        READ unicode
        _MAPUNICODE unicode TO ASCIIcode
    NEXT

    GreekUnicodeMap:
    'Microsoft_windows_cp1253
    DATA 8364,0,8218,402,8222,8230,8224,8225,0,8240,0,8249,0,0,0,0
    DATA 0,8216,8217,8220,8221,8226,8211,8212,0,8482,0,8250,0,0,0,0
    DATA 160,901,902,163,164,165,166,167,168,169,0,171,172,173,174,8213
    DATA 176,177,178,179,900,181,182,183,904,905,906,187,908,189,910,911
    DATA 912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927
    DATA 928,929,0,931,932,933,934,935,936,937,938,939,940,941,942,943
    DATA 944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959
    DATA 960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,0

END SUB
SUB EnglChange

    RESTORE EnglUnicodeMap
    FOR ASCIIcode = 128 TO 255
        READ unicode
        _MAPUNICODE unicode TO ASCIIcode
    NEXT

    EnglUnicodeMap:
    'Microsoft_pc_cp437
    DATA 199,252,233,226,228,224,229,231,234,235,232,239,238,236,196,197
    DATA 201,230,198,244,246,242,251,249,255,214,220,162,163,165,8359,402
    DATA 225,237,243,250,241,209,170,186,191,8976,172,189,188,161,171,187
    DATA 9617,9618,9619,9474,9508,9569,9570,9558,9557,9571,9553,9559,9565,9564,9563,9488
    DATA 9492,9524,9516,9500,9472,9532,9566,9567,9562,9556,9577,9574,9568,9552,9580,9575
    DATA 9576,9572,9573,9561,9560,9554,9555,9579,9578,9496,9484,9608,9604,9612,9616,9600
    DATA 945,223,915,960,931,963,181,964,934,920,937,948,8734,966,949,8745
    DATA 8801,177,8805,8804,8992,8993,247,8776,176,8729,183,8730,8319,178,9632,160

END SUB


Thats it

Do you have a nice day from beautiful Greece.

Gaslouk
Reply
#60
Snake Game Starter Code


I recently updated my Snake game code to allow practice with really long snakes. This is allowing the snake to take only one step in direction of arrow (unless you hold button down) thus hard to accidently cash into wall or it's own body.

A 4x4 cell screen is set up to demo a quick fill the screen game. The game will freeze when the sanke's body takes all but the last square with apple because there is no place to put the next apple. Black circle is snake head, red circle is the apple/food that makes the snake grow.

Code: (Select All)
_Title "Walk the Snake Yourself, b+ mod 2024-06-30"
' mod 2024-06-30 I don't like the snake moving without being told
' this will fix that and now if you crash into wall you die you dummy! LOL
' oh also fix the apple so it's never on snake body

Option _Explicit
Const sps = 4 ' cells per row or column   !!!! < try 4 cells for quick garden fill!!!
Const sq = 20 ' pixels per cell
Const xmax = sps * sq, ymax = xmax
Screen _NewImage(400, 400, 12)
Dim px, py, ax, ay, tail, i, keypress$, crash, moved
Dim trailX(1000), trailY(1000)
px = 0 ' snake head
py = 0
ax = 2 ' apple food
ay = 2
tail = 1 ' how long snake is
trailX(0) = px
trailY(0) = py
Do ' update display first, get key and then update game
    Line (0, 0)-(xmax, ymax), 6, BF ' clear garden 6
    For i = 0 To tail - 1 'show snake
        If i = 0 Then
            Circle (trailX(i) * sq + .5 * sq, trailY(i) * sq + .5 * sq), .5 * sq, 0
            Paint (trailX(i) * sq + .5 * sq, trailY(i) * sq + .5 * sq), 0, 0
        Else
            Line (trailX(i) * sq + 2, trailY(i) * sq + 2)-Step(sq - 4, sq - 4), (i Mod 4) + 7, BF
        End If
    Next
    Circle (ax * sq + .5 * sq, ay * sq + .5 * sq), .5 * sq, 4 ' show apple
    Paint (ax * sq + .5 * sq, ay * sq + .5 * sq), 4, 4
    _Display
    _Limit 30
    moved = 0 ' this walks snake step by step with arrow keys no stupid timing required
    keypress$ = InKey$
    If keypress$ = Chr$(0) + Chr$(72) Then 'up
        py = py - 1: moved = 1
    ElseIf keypress$ = Chr$(0) + Chr$(80) Then 'down
        py = py + 1: moved = 1
    ElseIf keypress$ = Chr$(0) + Chr$(77) Then 'right
        px = px + 1: moved = 1
    ElseIf keypress$ = Chr$(0) + Chr$(75) Then 'left
        px = px - 1: moved = 1
    ElseIf keypress$ = "q" Or keypress$ = Chr$(27) Then
        End '>>>>>>>> here is quit or escape clause!!!!
    End If
    _KeyClear
    If moved Then
        ' check for wall crashes
        If px < 0 Then crash = 1
        If px > sps - 1 Then crash = 1
        If py < 0 Then crash = 1
        If py > sps - 1 Then crash = 1
        For i = 0 To tail - 1 ' check for snake crashes into self
            If px = trailX(i) And py = trailY(i) Then crash = 2: Exit For
        Next
        If crash Then
            If crash = 1 Then
                _PrintString (84, 192), "Crashed into wall - GAME OVER!"
            Else
                _PrintString (54, 192), "Snake crashed into self - GAME OVER!"
            End If
            _Display
            End
        End If
        If ax = px And ay = py Then ' snake eats apple and grows
            tail = tail + 1
            GoSub update_snake
            newapple:
            ax = Int(Rnd * sps) ' set new place for apple
            ay = Int(Rnd * sps)
            For i = 0 To tail - 1 ' check update apple
                If ax = trailX(i) And ay = trailY(i) Then GoTo newapple
            Next
        Else
            GoSub update_snake
        End If
    End If
Loop
update_snake:
For i = tail - 1 To 1 Step -1
    trailX(i) = trailX(i - 1): trailY(i) = trailY(i - 1)
Next
trailX(0) = px
trailY(0) = py
Return
b = b + ...
Reply




Users browsing this thread: 3 Guest(s)