and another one for your toolbox...

[bplus]

OK I am sure this has been done 10x's over again and again...

But without a toolbox, one has to figure it out again and again when the occasion arises.

First the story, I was checking into XOR even before Steve provided the link in the Xbox tunnel of love thread when I discovered that &H has the reverse HEX$ and &O has the reverse OCT$ but poor 'ole &B has squat!

So here is BIN$ for your edification and toolbox:

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. 'does QB64 reverse &B numbers conver HEX$ for base 16, OCT$ for base 8, no base 2?
3. DIM test AS _INTEGER64
4. DO
5.     INPUT "Enter integer to convert to binary (0 to quit) "; test
6.     PRINT "Dec2Base$(test, 2) = "; Dec2Base$(test, 2), "BIN$(test) = "; BIN$(test)
7.     PRINT "and  VAL(" + CHR$(34) + "&B" + CHR$(34) + " + BIN$(test)) ="; VAL("&B" + BIN$(test))
8.     PRINT
9. LOOP UNTIL test = 0
10.  
11. FUNCTION Dec2Base$ (nDec AS INTEGER, bs AS INTEGER)
12.     DIM n AS INTEGER, p AS INTEGER, pow AS INTEGER, d AS INTEGER, b$
13.     n = nDec 'copy this because or nDec gets changed effecting main code
14.     WHILE bs ^ p <= n
15.         p = p + 1
16.     WEND
17.     FOR pow = p TO 0 STEP -1
18.         IF n >= bs ^ pow THEN
19.             d = INT(n / bs ^ pow)
20.             IF d < 10 THEN
21.                 b$ = b$ + _TRIM$(STR$(d))
22.             ELSE
23.                 b$ = b$ + CHR$(65 + d - 10)
24.             END IF
25.             n = n - d * bs ^ pow
26.         ELSE
27.             IF b$ <> "" THEN b$ = b$ + "0"
28.         END IF
29.     NEXT
30.     IF b$ = "" THEN b$ = "0"
31.     Dec2Base$ = b$
32. END FUNCTION
33.  
34. '2019-12-02 latest eliminates &B prefix
35. FUNCTION BIN$ (integerBase10 AS _INTEGER64) 'no more &B because easier to add than to remove
36.     DIM j AS INTEGER
37.     IF integerBase10 = 0 THEN BIN$ = "0": EXIT FUNCTION
38.     WHILE 2 ^ j <= integerBase10
39.         IF (integerBase10 AND 2 ^ j) > 0 THEN BIN$ = "1" + BIN$ ELSE BIN$ = "0" + BIN$
40.         j = j + 1
41.     WEND
42. END FUNCTION
43.  

Who needs Bill, the toolbox librarian, just start your own thread! ;- +

BTW, wouldn't it be better if HEX$(base10Integer) returned the string as "&H...." and OCT$ as "&O..." ?

You know, label the number base if it is not your standard base 10.

EDIT: For library code, probably should DIM everything, something a librarian might remind us of if one were present. ;-))

EDIT: 2019-12-01 more elegant version of BIN$
EDIT: 2019-12-02 reconsidered again with RhoSigma's input no &B prefix, also get rid of the limit test for integer and the other junk in demo! see reasons in reply #46


UPDATE: This stuff has been incorporated into QB64 since v1.3 I think, 1.4 for sure.

[bplus]

It is important to have a palindrome detector handy, so that when one is in our midst, we might know:

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. 'Palindrome tester.txt for JB 2015-11-01 MGA/B+ thanks to BP.org and Wiki
3. DIM t$
4. WHILE t$ <> "END"
5.     READ t$
6.     PRINT t$;
7.     IF isPalindrome(t$) THEN PRINT " is a palindrome." ELSE PRINT " is NOT a palindrome."
8. WEND
9. DATA "A dog, a plan, a canal: pagoda!","A dog, a panic, in a pagoda."
10. DATA "A man, a plan, a cat, a ham, a yak, a yam, a hat, a canal-Panama!"
11. DATA "Yada yada day a day"
12. DATA "RATS","END"
13.  
14. FUNCTION isPalindrome (phrase$)
15.     DIM copy$, b$, p$, char$, i AS INTEGER
16.     copy$ = UCASE$(phrase$)
17.     FOR i = 1 TO LEN(copy$) ' I don't see palindromes getting much longer than 32000
18.         char$ = MID$(copy$, i, 1)
19.         IF ASC(char$) > 64 AND ASC(char$) < 91 THEN b$ = b$ + char$: p$ = char$ + p$
20.     NEXT
21.     IF b$ = p$ THEN isPalindrome = -1
22. END FUNCTION
23.  

Today we have a classic one in our midst.  ;-)) which reminded me of this old code exercise for people who need to get comfortable with using SUBs and FUNCTIONs.

EDIT: line 19 too long, too many redundant calls to MID$ for same thing. I bit the bullet and added another variable for clarity.

UPDATE: Hardy an auspicious start for a mighty thread ;-))

[johnno56]

"Madam, I'm Adam."

[bplus]

Top Ten Code:

Code: QB64: [Select]

1. Option _Explicit
2. _Title "Top Ten Tester" ' B+ started 2019-07-28
3. '2019-07-28 All enclosed in a sub, possible feed it score and see how it stacks up.
4. '2019-07-28 fix to fill all 10 slots.
5. '2019-07-29 2nd fix with an n > 10 check, change to a function and get GoAgain reply.
6.  
7. ' ref https://www.qb64.org/forum/index.php?topic=1511.msg107586#msg107586
8.  
9. Randomize Timer
10. Dim score, again$
11. 'testing function with random scores, would be good to start with
12. For score = 1 To 15
13.     again$ = topTenGoAgain$(score * 5 * Rnd)
14.     If Len(again$) Then Print "Player wants to quit.": End Else Print "Player wants to go again."
15.     If score = 15 Then
16.         Print "End of test."
17.     End If
18. Next
19.  
20. ' This FUNCTION creates a file in the same folder as your .bas source or .exe
21. 'EDIT: 2019-07-29 change to FUNCTION to combine Top Ten update functions with Go Again reply.
22. Function topTenGoAgain$ (compareScore As Integer)
23.     Dim fName$, n As Integer, names$(1 To 10), scores(1 To 10), name$, score As Integer
24.     Dim settleScore As Integer, i As Integer, dummy$
25.     fName$ = "Top 10 Scores.txt" '<<<  since this is toolbox code change this as needed for app
26.     Cls: Print: Print "Your score was:"; compareScore: Print: Print "Top Ten Scorers and Scores:"
27.     If _FileExists(fName$) Then
28.         Open fName$ For Input As #1
29.         While EOF(1) = 0 And n < 10
30.             n = n + 1
31.             Input #1, name$
32.             Input #1, score
33.             If compareScore >= score And settleScore = 0 Then
34.                 Print "You have made the Top Ten!"
35.                 Input "Type your name here: ", names$(n)
36.                 scores(n) = compareScore
37.                 settleScore = -1
38.                 n = n + 1
39.                 If n <= 10 Then names$(n) = name$: scores(n) = score
40.             Else
41.                 scores(n) = score: names$(n) = name$
42.             End If
43.         Wend
44.         Close #1
45.         If n < 10 And settleScore = 0 Then
46.             Print "There is a slot open for your name and score."
47.             Input "Type your name here: ", name$
48.             If name$ <> "" Then n = n + 1: names$(n) = name$: scores(n) = compareScore
49.         End If
50.         Open fName$ For Output As #1
51.         If n > 10 Then n = 10
52.         For i = 1 To n
53.             Print #1, names$(i): Print #1, scores(i)
54.             Print i, names$(i), scores(i)
55.         Next
56.         Close #1
57.     Else
58.         Print "You are first into file!"
59.         Input "Type your name here:"; name$
60.         Open fName$ For Output As #1
61.         Print #1, name$: Print #1, compareScore
62.         Close #1
63.     End If
64.     Print: Input "Press <Enter> to play again, <q (or any) + Enter> to quit... "; dummy$
65.     topTenGoAgain$ = dummy$
66. End Function
67.  
68.  
69.  

Works OK for me. How did name$ get to be NAME$ here in forum post?

Update: Sorry, I did not test the sub enough, only with increasingly good scores. But what happens if score is not better and you have 9 slots left in Top Ten? You fill the next slot, Fixed.

Update: 2019-07-29 found another thing to fix, check if n > 10 Also changed the SUB to a FUNCTION and used it to get Go Again information from the player. It seems the perfect time to ask the player if they want to go again and combining functions saves the player a 2nd question and key press answer to make. This is demo'd in the test code.

2021-10-27 Modified for new Function change in QB64 v 2.0

[SMcNeill]

Here's one I think all toolboxes should have (if bplus doesn't mind me adding to his collection here):

Code: [Select]

SUB SubState (toggle)
    STATIC DefaultColor, BackGroundColor, Font, Dest, Source
    IF toggle THEN
        _FONT Font
        COLOR DefaultColor, BackGroundColor
        _DEST Dest
        _SOURCE Source
    ELSE
        Font = _FONT
        DefaultColor = _DEFAULTCOLOR
        BackGroundColor = _BACKGROUNDCOLOR
        Dest = _DEST
        Source = _SOURCE
    END IF
END SUB
When writing a lot of subs, I've found that a majority of them tend to require the same things at the top and bottom of them so that they play nicely with my main routines -- a means to save the main program state and then restore it upon exit.

For example:

Code: QB64: [Select]

1. SUB QPrint (x, y, kolor, text$)
2.    LOCATE x,y
3.    COLOR kolor
4.    PRINT text$
5. END SUB

Now, the above SUB isn't very library friendly, and it's a PITA to plug into most programs.  It changes the default color that we we're printing with when we entered the sub, and it's now something completely different when we exit the sub.  It just doesn't play nice with others.

So how to fix that?

Code: QB64: [Select]

1. SUB QPrint (x, y, kolor, text$)
2.    SubState 1
3.    LOCATE x,y
4.    COLOR kolor
5.    PRINT text$
6.    SubState 0
7. END SUB

Note:  This version of SubState isn't for use with recursive routines, or for routines which call others which alter default values on us.  If you guys are interested in it, I'll share it as well for you.  Use this for quick save/exit routines for single call SUB/FUNCTION as illustrated above.  ;)

[bplus]

Thanks Steve that's a great idea.

Here is the tail end (currently, it keeps needing more things) to my mBox (messageBox) sub and inputBox sub:

Code: QB64: [Select]

1.     'put things back
2.     COLOR _RGB32(255, 255, 255), _RGB32(0, 0, 0): CLS
3.     _PUTIMAGE , backScrn
4.     _DISPLAY
5.     COLOR fg, bg
6.     _FREEIMAGE backScrn
7.     _FREEIMAGE mbx
8.     'clear key presses
9.     _KEYCLEAR
10.     IF autoDis THEN _AUTODISPLAY ELSE _DISPLAY
11.     LOCATE curRow, curCol
12.     'clear mouse clicks
13.     WHILE _MOUSEINPUT: WEND
14.     mb = _MOUSEBUTTON(1)
15.     IF mb THEN
16.         DO
17.             WHILE _MOUSEINPUT: WEND
18.             mb = _MOUSEBUTTON(1)
19.             _LIMIT 100
20.         LOOP UNTIL mb = 0
21.     END IF
22.  

I was wondering if I was missing more items. I did not do _FONT nor _SOURCE but I do put back row and col, and _AUTODISPLAY / _DISPLAY setting and found the need to clear both mouse click and key press (esc or enter mainly need to be cleared so main program isn't short circuited).

Collecting all these settings and then putting them back really distracts from the code for the procedure, so this could be very useful to use with tool box procedures. Thanks again, I will put a version of this in my toolbox.

[bplus]

MessageBox sub that you can drag around the screen called: mBox title$, message$
(Employs a scnState sub discussed earlier in this thread suggested by SMcNeill.)


Speaking of message Box here is my current version which I updated recently with better mouse button clear (I think) and adding of _DISPLAY / _AUTODISPLAY resets.

The advantage is you don't need Windows and since it is Tool Box code and not Library code, you can copy / paste into your program and are free to modify to needs of program eg, you won't like my colors for message box (I don't like my colors) but you are free to change to fit program you are using message box in. Trying to anticipate every mod change that might be needed for message box turns it into a complex Swiss Army Knife too awkward to be of practical use IMO. So this has the simple parameters of Title$ and message$:

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. '
3. ' 2019-05-18 new version of mBox developed from scrollWindow test code (Array Window.bas)
4. ' hmm... old version saved curRow and curCol ? put back in
5. ' new version clears mouse clicks
6.  
7. ' 2019-07-25  save _autodisplay setting and set it back before leaving, rework clearing mb
8. 'test #1 does message box work in screen 0
9. 'mBox "Well?", "Test mBox in Screen 0"    NO! for graphic screens ONLY!!!
10.  
11. '2019-07-31 attempt to assimulate Steve's idea for saving and restoring the screen state
12. ' before a sub messes with all the settings, so in future mBox and inputBox$ will need this
13. ' helper sub. Damn the fan is back!  Also fix this to make it easier to change colors.
14. ' OK tests here now try scrollWindow and Geometry Circle Intersects...
15.  
16. SCREEN _NEWIMAGE(800, 600, 32)
17. _SCREENMOVE 100, 20
18.  
19. DIM m$, enter$, k$, kh AS LONG, mNum AS INTEGER
20. COLOR &HFF000000, &HFF888888
21. CLS
22. PRINT "REMINDER: press escape, enter or spacebar to exit the message box. Escape (again?) to exit this test."
23. PRINT "Here is some stuff on screen."
24.  
25. m$ = "This is the message for mBox in 800x 600 _NEWIMAGE setup, "
26. m$ = m$ + "how does it handle a long line?   Yeah! grab title bar and move this box around!" 'great
27. mBox "This is Demo Title", m$
28.  
29. PRINT "here is more stuff, is it printing exactly below last stuff?" ' OK now with center fix too!
30. INPUT "For next test [h | m] for mBox, [esc | space | enter] to quit it and then [esc] again to quit, enter for next test...", enter$
31.  
32. 'draw stuff, until h or m press, then show message box
33.  
34. WHILE 1
35.     k$ = INKEY$
36.     IF k$ = "m" OR k$ = "h" THEN doMessage: mNum = mNum + 1: PRINT mNum; "Message done..."
37.     kh = 0
38.     LINE (RND * _WIDTH, RND * _HEIGHT)-STEP(RND * 80, RND * 60), _RGB32(RND * 255, RND * 255, RND * 255), BF
39.     kh = _KEYHIT
40.     IF kh = 27 THEN EXIT WHILE
41.     ' _DISPLAY  '<<<< comment out to see if _AUTODISPLAY mode, yep! good
42.     _LIMIT 60
43. WEND
44. PRINT "OK where is this print line going to end up, hopefully under the last '# message done'." 'yes! Excellent!
45.  
46. SUB doMessage
47.     DIM title$, mess$
48.     mess$ = "This is line 1 followed by LF" + CHR$(10)
49.     mess$ = mess$ + "This is line 2 followed by CR + LF" + CHR$(13) + CHR$(10)
50.     mess$ = mess$ + "Line 3 is followed by a double LF to make a space." + CHR$(10) + CHR$(10)
51.     mess$ = mess$ + "Here is a long line that hopefully won't all fit across the screen, so I just keep going on and on ..."
52.     mess$ = mess$ + "until the screen is half full of this single long, long line so I can test the wrapping my code does "
53.     mess$ = mess$ + "with this long thing! ending with a double CR." + CHR$(13) + CHR$(13)
54.     mess$ = mess$ + CHR$(9) + "This line started with a tab which should be replaced by spaces so now this line should be running too long. The End."
55.     title$ = "123456789012345678901234567890123456789012345678901234567890"
56.     mBox title$, mess$
57. END SUB
58.  
59. 'title$ limit is 57 chars, all lines are 58 chars max, version 2019-07-31
60. 'THIS SUB NOW NEEDS SUB scnState(restoreTF) for saving and restoring screen settings
61. SUB mBox (title AS STRING, m AS STRING)
62.  
63.     DIM bg AS _UNSIGNED LONG, fg AS _UNSIGNED LONG
64.     bg = &H33404040
65.     fg = &HFF33AAFF
66.  
67.     'first screen dimensions and items to restore at exit
68.     DIM sw AS INTEGER, sh AS INTEGER
69.     DIM curScrn AS LONG, backScrn AS LONG, mbx AS LONG 'some handles
70.     DIM ti AS INTEGER, limit AS INTEGER 'ti = text index for t$(), limit is number of chars per line
71.     DIM i AS INTEGER, j AS INTEGER, ff AS _BIT, add AS _BYTE 'index, flag and
72.     DIM bxH AS INTEGER, bxW AS INTEGER 'first as cells then as pixels
73.     DIM mb AS INTEGER, mx AS INTEGER, my AS INTEGER, mi AS INTEGER, grabx AS INTEGER, graby AS INTEGER
74.     DIM tlx AS INTEGER, tly AS INTEGER 'top left corner of message box
75.     DIM lastx AS INTEGER, lasty AS INTEGER, t AS STRING, b AS STRING, c AS STRING, tail AS STRING
76.     DIM d AS STRING, r AS SINGLE, kh AS LONG
77.  
78.     'screen and current settings to restore at end ofsub
79.     scnState 0
80.     sw = _WIDTH: sh = _HEIGHT
81.  
82.     _KEYCLEAR '<<<<<<<<<<<<<<<<<<<< do i still need this?   Yes 2019-08-06
83.  
84.     'screen snapshot
85.     curScrn = _DEST
86.     backScrn = _NEWIMAGE(sw, sh, 32)
87.     _PUTIMAGE , curScrn, backScrn
88.  
89.     'setup t() to store strings with ti as index, linit 58 chars per line max, b is for build
90.     REDIM t(0) AS STRING: ti = 0: limit = 58: b = ""
91.     FOR i = 1 TO LEN(m)
92.         c = MID$(m, i, 1)
93.         'are there any new line signals, CR, LF or both? take CRLF or LFCR as one break but dbl LF or CR means blank line
94.         SELECT CASE c
95.             CASE CHR$(13) 'load line
96.                 IF MID$(m, i + 1, 1) = CHR$(10) THEN i = i + 1
97.                 t(ti) = b: b = "": ti = ti + 1: REDIM _PRESERVE t(ti) AS STRING
98.             CASE CHR$(10)
99.                 IF MID$(m, i + 1, 1) = CHR$(13) THEN i = i + 1
100.                 t(ti) = b: b = "": ti = ti + 1: REDIM _PRESERVE t(ti)
101.             CASE ELSE
102.                 IF c = CHR$(9) THEN c = SPACE$(4): add = 4 ELSE add = 1
103.                 IF LEN(b) + add > limit THEN
104.                     tail = "": ff = 0
105.                     FOR j = LEN(b) TO 1 STEP -1 'backup until find a space, save the tail end for next line
106.                         d = MID$(b, j, 1)
107.                         IF d = " " THEN
108.                             t(ti) = MID$(b, 1, j - 1): b = tail + c: ti = ti + 1: REDIM _PRESERVE t(ti)
109.                             ff = 1 'found space flag
110.                             EXIT FOR
111.                         ELSE
112.                             tail = d + tail 'the tail grows!
113.                         END IF
114.                     NEXT
115.                     IF ff = 0 THEN 'no break? OK
116.                         t(ti) = b: b = c: ti = ti + 1: REDIM _PRESERVE t(ti)
117.                     END IF
118.                 ELSE
119.                     b = b + c 'just keep building the line
120.                 END IF
121.         END SELECT
122.     NEXT
123.     t(ti) = b
124.     bxH = ti + 3: bxW = limit + 2
125.  
126.     'draw message box
127.     mbx = _NEWIMAGE(60 * 8, (bxH + 1) * 16, 32)
128.     _DEST mbx
129.     COLOR _RGB32(128, 0, 0), _RGB32(225, 225, 255)
130.     LOCATE 1, 1: PRINT LEFT$(SPACE$((bxW - LEN(title) - 3) / 2) + title + SPACE$(bxW), bxW)
131.     COLOR _RGB32(225, 225, 255), _RGB32(200, 0, 0)
132.     LOCATE 1, bxW - 2: PRINT " X "
133.     COLOR fg, bg
134.     LOCATE 2, 1: PRINT SPACE$(bxW);
135.     FOR r = 0 TO ti
136.         LOCATE 1 + r + 2, 1: PRINT LEFT$(" " + t(r) + SPACE$(bxW), bxW);
137.     NEXT
138.     LOCATE 1 + bxH, 1: PRINT SPACE$(limit + 2);
139.  
140.     'now for the action
141.     _DEST curScrn
142.  
143.     'convert to pixels the top left corner of box at moment
144.     bxW = bxW * 8: bxH = bxH * 16
145.     tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
146.     lastx = tlx: lasty = tly
147.     'now allow user to move it around or just read it
148.     WHILE 1
149.         CLS
150.         _PUTIMAGE , backScrn
151.         _PUTIMAGE (tlx, tly), mbx, curScrn
152.         _DISPLAY
153.         WHILE _MOUSEINPUT: WEND
154.         mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
155.         IF mb THEN
156.             IF mx >= tlx AND mx <= tlx + bxW AND my >= tly AND my <= tly + 16 THEN 'mouse down on title bar
157.                 IF mx >= tlx + bxW - 24 THEN EXIT WHILE
158.                 grabx = mx - tlx: graby = my - tly
159.                 DO WHILE mb 'wait for release
160.                     mi = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
161.                     mx = _MOUSEX: my = _MOUSEY
162.                     IF mx - grabx >= 0 AND mx - grabx <= sw - bxW AND my - graby >= 0 AND my - graby <= sh - bxH THEN
163.                         'attempt to speed up with less updates
164.                         IF ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .5 > 10 THEN
165.                             tlx = mx - grabx: tly = my - graby
166.                             CLS
167.                             _PUTIMAGE , backScrn
168.                             _PUTIMAGE (tlx, tly), mbx, curScrn
169.                             lastx = tlx: lasty = tly
170.                             _DISPLAY
171.                         END IF
172.                     END IF
173.                     _LIMIT 400
174.                 LOOP
175.             END IF
176.         END IF
177.         kh = _KEYHIT
178.         IF kh = 27 OR kh = 13 OR kh = 32 THEN EXIT WHILE
179.         _LIMIT 400
180.     WEND
181.  
182.     'put things back
183.     COLOR _RGB32(255, 255, 255), _RGB32(0, 0, 0): CLS '
184.     _PUTIMAGE , backScrn
185.     _DISPLAY
186.     _FREEIMAGE backScrn
187.     _FREEIMAGE mbx
188.     scnState 1 'Thanks Steve McNeill
189. END SUB
190.  
191. ' for saving and restoring screen settins
192. SUB scnState (restoreTF AS INTEGER) 'Thanks Steve McNeill
193.     STATIC Font AS LONG, DefaultColor AS _UNSIGNED LONG, BackGroundColor AS _UNSIGNED LONG, Dest AS LONG, Source AS LONG
194.     STATIC row AS INTEGER, col AS INTEGER, autodisplay AS INTEGER, mb AS INTEGER
195.     IF restoreTF THEN
196.         _FONT Font
197.         COLOR DefaultColor, BackGroundColor
198.         _DEST Dest
199.         _SOURCE Source
200.         LOCATE row, col
201.         IF autodisplay THEN _AUTODISPLAY ELSE _DISPLAY
202.         _KEYCLEAR
203.         WHILE _MOUSEINPUT: WEND 'clear mouse clicks
204.         mb = _MOUSEBUTTON(1)
205.         IF mb THEN
206.             DO
207.                 WHILE _MOUSEINPUT: WEND
208.                 mb = _MOUSEBUTTON(1)
209.                 _LIMIT 100
210.             LOOP UNTIL mb = 0
211.         END IF
212.     ELSE
213.         Font = _FONT: DefaultColor = _DEFAULTCOLOR: BackGroundColor = _BACKGROUNDCOLOR
214.         Dest = _DEST: Source = _SOURCE
215.         row = CSRLIN: col = POS(0): autodisplay = _AUTODISPLAY
216.     END IF
217. END SUB
218.  
219.  

This will be soon be modified with my version of Steve's new subState (toggle) along with InputBox$

Update: 2019-07-31 11AM: OK modified with more complete srnState(restoreTF) SUB as promised but I see now Steve has improved his further into two SUBs, sheez hard to keep up! I also made it easier to modify colors in mBox sub, see fg, bg settings at top of sub for foreground and background.

Anyway mBox works well and tested in a couple of programs from which I caught bugs earlier:
 

Here I try semi-transparent background in mBox SUB.


2019-08-06 Update: _KEYCLEAR was needed when starting mBox, I found the test code that proved it.
comment removed from this line:
_KEYCLEAR '<<<<<<<<<<<<<<<<<<<< do i still need this?

[SMcNeill]

And, as promised, here's my expanded routines to save states:

Code: [Select]

SCREEN _NEWIMAGE(120, 25, 0)

PRINT "Currently my print cursor is here =>";
SLEEP
QPrint 10, 10, 4, "Then I jump to 10,10"
SLEEP
PRINT "But I'm still here! =>";
SLEEP
RQPrint 3, 3, 1, "Hello World"
SLEEP
PRINT "And, even after all the recursive work, I'm still here!!"




SUB QPrint (y, x, kolor, text$)
    s = SaveState
    LOCATE x, y
    COLOR kolor
    PRINT text$
    RestoreState s
END SUB

SUB RQPrint (y, x, kolor, text$)
    s = SaveState
    IF kolor < 15 THEN RQPrint x + 1, y + 1, kolor + 1, text$ + "."
    LOCATE x, y
    COLOR kolor
    PRINT text$
    RestoreState s
END SUB




FUNCTION SaveState
    TYPE SaveStateType
        InUse AS INTEGER
        DC AS INTEGER
        BG AS INTEGER
        F AS INTEGER
        D AS INTEGER
        S AS INTEGER
        Disp AS INTEGER
        CurX AS INTEGER
        CurY AS INTEGER
    END TYPE
    DIM SS AS SaveStateType, Temp AS SaveStateType
    SHARED NSS AS LONG 'Number of Saved States
    SHARED SaveMem AS _MEM
    IF _MEMEXISTS(SaveMem) THEN
        'do nothing
    ELSE
        SaveMem = _MEMNEW(LEN(SS) * 255) 'Save up to 255 save states; More than 255 and we toss an error
        $CHECKING:OFF
        _MEMFILL SaveMem, SaveMem.OFFSET, SaveMem.SIZE, 0 AS _UNSIGNED _BYTE
        $CHECKING:ON
    END IF

    'Data to Save
    SS.InUse = -1
    SS.F = _FONT
    SS.DC = _DEFAULTCOLOR
    SS.BG = _BACKGROUNDCOLOR
    SS.D = _DEST
    SS.S = _SOURCE
    SS.Disp = _AUTODISPLAY
    SS.CurX = POS(0)
    SS.CurY = CSRLIN
    $CHECKING:OFF
    FOR i = 1 TO NSS
        o = (i - 1) * LEN(SS)
        _MEMGET SaveMem, SaveMem.OFFSET + o, Temp
        IF Temp.InUse = 0 THEN
            _MEMPUT SaveMem, SaveMem.OFFSET + o, SS
            SaveState = i
            EXIT FUNCTION
        END IF
    NEXT
    _MEMPUT SaveMem, SaveMem.OFFSET + NSS * LEN(SS), SS
    $CHECKING:ON
    NSS = NSS + 1
    SaveState = NSS
END SUB

SUB RestoreState (WhichOne)
    DIM SS AS SaveStateType
    SHARED NSS AS LONG 'Number of Saved States
    SHARED SaveMem AS _MEM
    $CHECKING:ON
    _MEMGET SaveMem, SaveMem.OFFSET + (WhichOne - 1) * LEN(SS), SS
    IF SS.InUse THEN
        SS.InUse = 0 'Let the routine know that we're no longer in use for this handle
        _MEMPUT SaveMem, SaveMem.OFFSET + (WhichOne - 1) * LEN(SS), SS
        _FONT SS.F
        COLOR SS.DC, SS.BG
        _DEST SS.D
        _SOURCE SS.S
        IF SS.Disp THEN _AUTODISPLAY ELSE _DISPLAY
        LOCATE SS.CurY, SS.CurX
    END IF
    $CHECKING:ON
END SUB

Notice here that we get a handle for a saved state, and then when we exit the sub we restore that handle.  This allows us to have one sub call another sub, or recursively call itself, and yet preserves the original information without any problem for us.

One thing to note with this method:  Just like GOSUB can run out of stack space if you call them and exit without using RETURN, this also has a limit of 255 states being saved at a time.  IMHO, that's more than enough for any program I write, unless I've got a glitch somewhere where I'm exiting the sub/function without restoring values. (In which case, I've created a memory leak, and I'd want to find it and fix it anyway...)

[bplus]

Hi Steve,

You know I just started wondering about multiple mBox windows going... how the setting for different windows up might be saved. You anticipated that.

But what happens if you close the windows / screens out of the order they were opened? You would be restoring the wrong settings. Or what happens should any of the other screens start messing with the their settings in between.

Might be a can or worms here, unless keep everything modal.

[SMcNeill]

Sometimes you just have to do things manually.

Let’s say I have a red screen and print stuff on it.

Now, open a green box in the center of it, and preserve the background so you can restore it later.

Now, open a blue box in the center of that one, and preserve the background so you can restore it later.

If you close the blue box, then the green box, your background will go back to looking as it originally did.

If you close the green box first, then the blue box, your background is now red, with a green box where the blue one used to be.  (You restored the original background when you closed the green box, but closing the blue box put the background behind it — the part of the green box it covered up — back onto the screen.)

As long as you call the routines and exit the routines in order, all is good.  If they’re going to be truly “independent boxes” and not “pop-up boxes” which require closing them in order, then sequentially stacking settings won’t be possible.  You’re looking at Z-order style handling at that point, which is a bit more than the routines above handle.

[Petr]

We seem to have encountered the same problem that I solved, BPlus. When opening multiple windows, I enter a number in the TYPE field that indicates in which order this  window is  (it is added by _PRESERVE to the window field and at start this number is the same as the record number in the window field). When this window is clicked, the window display order for all windows is changed from the window number. Try the following code. More  complicated code is in objecteditor, which develop version will be released as soon as possible. There is solved also window positioning.

Example for four windows.

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(1800, 1600, 256)
2. DIM x(4), y(4), position(1 TO 4)
3. g = 1
4. FOR f = 0 TO 1350 STEP 450
5.     x(g) = f
6.     g = g + 1
7. NEXT
8. g = 1
9. FOR f = 0 TO 1200 STEP 400
10.     y(g) = f
11.     g = g + 1
12. NEXT
13. FOR N = 1 TO 4
14.     position(N) = N
15. NEXT N
16. DO
17.     WHILE _MOUSEINPUT: WEND
18.     FOR d = 1 TO 4
19.         LINE (x(d), y(d))-(x(d) + 400, y(d) + 350), , B
20.         _PRINTSTRING (x(d), y(d)), STR$(position(d))
21.         IF _MOUSEX >= x(d) AND _MOUSEX <= x(d) + 400 THEN
22.             IF _MOUSEY >= x(y) AND _MOUSEY <= y(d) + 350 THEN
23.                 IF _MOUSEBUTTON(1) THEN
24.                     old = position(d)
25.                     IF position(d) <> 1 THEN
26.                         position(d) = 1
27.                         FOR R = 1 TO 4
28.                             IF R <> d THEN
29.                                 position(R) = position(R) + 1
30.                                 IF position(R) > 4 THEN position(R) = old + 1
31.                             END IF
32.                         NEXT
33.                     END IF
34.                 END IF
35.             END IF
36.         END IF
37.     NEXT
38. LOOP
39.  

Previous code show you windows positions.

For correct view on screen then use Window nr.1 as UBOUND next array, Window nr.2 as second,  Window nr.3 as third and Window with nr.4 as last - LBOUND.

For correct view on screen then just use

FOR ViewIt = Lbound(WindowArray) Ubound(WindowArray)
....
....
graphic operations
NEXT

As you see, UBOUND is last, so window nr.1 as UBOUND in array is always on top.


And you get the answer to the question - what if I close the window in a different order? Window numbers are reduced by one, minimized, or closed is deleted from the field FOR VIEW (so I suggest using an extra field only for window rendering and another field with window position, text, and so on) (so there will only be three), the same loop  render it. There will be another graphic loop below the windows that will not be overwritten by the window array at this location if the window is closed before calling _DISPLAY. Pseudocode:

Loop for background drawing on screen
Loop for rendering windows
_DISPLAY

This way you can make transparent windows, behind which will run  - spiders :).

[bplus]

Hi Petr,

You guys and your giant screens! Your demo does not fit my screen but OK because I am totally unprepared to take on a Windows management discussion in this thread. For this thread I have other fish to fry... ;-))

Good to know, you have worked on this problem though and are ready with help. Also I am so proud that spiders made such on impression on you! :)

[Petr]

Yes BPlus, Spiders are perfect. I hope I understood the topic correctly and did not respond quite badly? If so, just say it and I delete the post, I don't want to spam your tools thread.

[bplus]

Yes BPlus, Spiders are perfect. I hope I understood the topic correctly and did not respond quite badly? If so, just say it and I delete the post, I don't want to spam your tools thread.

Hi Petr, you are fine coder, no way a spammer!

To all,

Here is the a complementary tool to mBox that I wanted to get posted with mBox, inputBox$.

This lets you get some information from user without any disturbance of the screen. Like mBox you can grab the title bar and move it around the screen.

I combined that with cText, a way to print any size text around the midpoint x, y and overhauled the Top Ten screen used in Invaders bplus style.

inputBox$ and demo:

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. _TITLE "inputBox$ tester.bas started 2018-10-26 need an input box for WS Editor"
3. ' 2019-07-32 assimulate scnState(restoreTF) used to save and restore screen settings
4. ' so sub can do it's thing and restore settings, Thanks Steve McNeill for starter code and idea.
5.  
6. SCREEN _NEWIMAGE(800, 600, 32)
7. _SCREENMOVE 100, 20
8. DIM well$, enter$, k$, kh AS LONG
9.  
10. COLOR &HFFFFFF00, &HFF880000
11. PRINT "Here is some stuff on screen."
12. well$ = inputBox$("Well?", "Test inputBox$", 20)
13. PRINT "inputBox$ returned: "; well$; ". Is this line printing exactly below last stuff sentence?" ' OK now with center fix too!
14. INPUT "OK? enter for next test, use h or m keypress to invoke inputBox$...", enter$
15.  
16. 'draw stuff, until h or m press, then show message box
17. WHILE 1
18.     k$ = INKEY$
19.     IF k$ = "m" OR k$ = "h" THEN
20.         well$ = inputBox$("Well?", "Test call inputBox", 36)
21.         PRINT "inputBox$() returned: *"; well$; "*"
22.     END IF
23.     'kh = 0  'should not need this to stop esc keypress in input box
24.     LINE (RND * _WIDTH, RND * _HEIGHT)-STEP(RND * 80, RND * 60), _RGB32(RND * 255, RND * 255, RND * 255), BF
25.     kh = _KEYHIT
26.     IF kh = 27 THEN EXIT WHILE
27.     '_DISPLAY   '<< should not need this
28.     _LIMIT 5
29. WEND
30. PRINT "OK where is this print line going to end up, hopefully under the last inputBox returned." 'yes! Excellent!
31. PRINT "InputBox$() last returned: "; well$; ",  Goodbye!"
32. END
33.  
34. ' You can grab this box by title and drag it around screen for full viewing while answering prompt.
35. ' Only one line allowed for prompt$
36. ' boxWidth is 4 more than the allowed length of input, it needs to be longer than title$ and prompt$ also
37. ' Utilities > Input Box > Input Box 1 tester v 2019-07-31
38. FUNCTION inputBox$ (prompt$, title$, boxWidth AS _BYTE)
39.     DIM ForeColor AS _UNSIGNED LONG, BackColor AS _UNSIGNED LONG, White AS _UNSIGNED LONG
40.     DIM sw AS INTEGER, sh AS INTEGER, curScrn AS LONG, backScrn AS LONG, ibx AS LONG 'some handles
41.  
42.     'colors
43.     ForeColor = &HFF000055 '<  change as desired  prompt text color, back color or type in area
44.     BackColor = &HFF6080CC '<  change as desired  used fore color in type in area
45.     White = &HFFFFFFFF
46.  
47.     'items to restore at exit
48.     scnState 0
49.  
50.     'screen snapshot
51.     sw = _WIDTH: sh = _HEIGHT: curScrn = _DEST
52.     backScrn = _NEWIMAGE(sw, sh, 32)
53.     _PUTIMAGE , curScrn, backScrn
54.  
55.     'moving box around on screen
56.     DIM bxW AS INTEGER, bxH AS INTEGER
57.     DIM mb AS INTEGER, mx AS INTEGER, my AS INTEGER, mi AS INTEGER, grabx AS INTEGER, graby AS INTEGER
58.     DIM tlx AS INTEGER, tly AS INTEGER 'top left corner of message box
59.     DIM lastx AS INTEGER, lasty AS INTEGER
60.     DIM inp$, kh&
61.  
62.     'draw message box
63.     bxW = boxWidth * 8: bxH = 7 * 16
64.     ibx = _NEWIMAGE(bxW, bxH, 32)
65.     _DEST ibx
66.     COLOR &HFF880000, White
67.     LOCATE 1, 1: PRINT LEFT$(SPACE$(INT((boxWidth - LEN(title$) - 3)) / 2) + title$ + SPACE$(boxWidth), boxWidth)
68.     COLOR White, &HFFBB0000
69.     LOCATE 1, boxWidth - 2: PRINT " X "
70.     COLOR ForeColor, BackColor
71.     LOCATE 2, 1: PRINT SPACE$(boxWidth);
72.     LOCATE 3, 1: PRINT LEFT$(SPACE$((boxWidth - LEN(prompt$)) / 2) + prompt$ + SPACE$(boxWidth), boxWidth);
73.     LOCATE 4, 1: PRINT SPACE$(boxWidth);
74.     LOCATE 5, 1: PRINT SPACE$(boxWidth);
75.     LOCATE 6, 1: PRINT SPACE$(boxWidth);
76.     inp$ = ""
77.     GOSUB finishBox
78.  
79.     'convert to pixels the top left corner of box at moment
80.     bxW = boxWidth * 8: bxH = 5 * 16
81.     tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
82.     lastx = tlx: lasty = tly
83.     _KEYCLEAR
84.     'now allow user to move it around or just read it
85.     WHILE 1
86.         CLS
87.         _PUTIMAGE , backScrn
88.         _PUTIMAGE (tlx, tly), ibx, curScrn
89.         _DISPLAY
90.         WHILE _MOUSEINPUT: WEND
91.         mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
92.         IF mb THEN
93.             IF mx >= tlx AND mx <= tlx + bxW AND my >= tly AND my <= tly + 16 THEN 'mouse down on title bar
94.                 IF mx >= tlx + bxW - 24 THEN EXIT WHILE
95.                 grabx = mx - tlx: graby = my - tly
96.                 DO WHILE mb 'wait for release
97.                     mi = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
98.                     mx = _MOUSEX: my = _MOUSEY
99.                     IF mx - grabx >= 0 AND mx - grabx <= sw - bxW AND my - graby >= 0 AND my - graby <= sh - bxH THEN
100.                         'attempt to speed up with less updates
101.                         IF ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .5 > 10 THEN
102.                             tlx = mx - grabx: tly = my - graby
103.                             CLS
104.                             _PUTIMAGE , backScrn
105.                             _PUTIMAGE (tlx, tly), ibx, curScrn
106.                             lastx = tlx: lasty = tly
107.                             _DISPLAY
108.                         END IF
109.                     END IF
110.                     _LIMIT 400
111.                 LOOP
112.             END IF
113.         END IF
114.         kh& = _KEYHIT
115.         SELECT CASE kh& 'whew not much for the main event!
116.             CASE 13: EXIT WHILE
117.             CASE 27: inp$ = "": EXIT WHILE
118.             CASE 32 TO 128: IF LEN(inp$) < boxWidth - 4 THEN inp$ = inp$ + CHR$(kh&): GOSUB finishBox ELSE BEEP
119.             CASE 8: IF LEN(inp$) THEN inp$ = LEFT$(inp$, LEN(inp$) - 1): GOSUB finishBox ELSE BEEP
120.         END SELECT
121.  
122.         _LIMIT 60
123.     WEND
124.  
125.     'put things back
126.     scnState 1 'need fg and bg colors set to cls
127.     CLS '? is this needed YES!!
128.     _PUTIMAGE , backScrn
129.     _DISPLAY
130.     _FREEIMAGE backScrn
131.     _FREEIMAGE ibx
132.     scnState 1 'because we have to call _display, we have to call this again
133.     inputBox$ = inp$
134.     EXIT FUNCTION
135.  
136.     finishBox:
137.     _DEST ibx
138.     COLOR BackColor, ForeColor
139.     LOCATE 5, 2: PRINT LEFT$(" " + inp$ + SPACE$(boxWidth - 2), boxWidth - 2)
140.     _DEST curScrn
141.     RETURN
142. END FUNCTION
143.  
144. 'from mBox v 2019-07-31 update
145. ' for saving and restoring screen settins
146. SUB scnState (restoreTF AS INTEGER) 'Thanks Steve McNeill
147.     STATIC Font AS LONG, DefaultColor AS _UNSIGNED LONG, BackGroundColor AS _UNSIGNED LONG, Dest AS LONG, Source AS LONG
148.     STATIC row AS INTEGER, col AS INTEGER, autodisplay AS INTEGER, mb AS INTEGER
149.     IF restoreTF THEN
150.         _FONT Font
151.         COLOR DefaultColor, BackGroundColor
152.         _DEST Dest
153.         _SOURCE Source
154.         LOCATE row, col
155.         IF autodisplay THEN _AUTODISPLAY ELSE _DISPLAY
156.         _KEYCLEAR
157.         WHILE _MOUSEINPUT: WEND 'clear mouse clicks
158.         mb = _MOUSEBUTTON(1)
159.         IF mb THEN
160.             DO
161.                 WHILE _MOUSEINPUT: WEND
162.                 mb = _MOUSEBUTTON(1)
163.                 _LIMIT 100
164.             LOOP UNTIL mb = 0
165.         END IF
166.     ELSE
167.         Font = _FONT: DefaultColor = _DEFAULTCOLOR: BackGroundColor = _BACKGROUNDCOLOR
168.         Dest = _DEST: Source = _SOURCE
169.         row = CSRLIN: col = POS(0): autodisplay = _AUTODISPLAY
170.     END IF
171. END SUB
172.  
173.  

Here is cText, text and demo:

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. _TITLE "Text sub tests" 'B+ started 2019-03-25
3.  
4. RANDOMIZE TIMER
5. CONST xmax = 1200
6. CONST ymax = 700
7.  
8. SCREEN _NEWIMAGE(xmax, ymax, 32)
9. _SCREENMOVE 100, 40
10.  
11. DIM y, i
12.  
13. COLOR _RGB32(0, 0, 255)
14. PRINT "Hello World"
15. 'test& = _NEWIMAGE(xmax, ymax, 32)
16. 'DEST test&
17. y = ymax
18. FOR i = 1 TO 60 STEP .5
19.     CLS
20.     y = y - 60 / i
21.     cText xmax / 2, y, 240 / i, _RGB32(255, 0, 0), "So how is this looking?"
22.     _DISPLAY
23.     _LIMIT 5
24. NEXT
25. '_DEST 0
26. '_PUTIMAGE , test&, 0
27. PRINT "OK, blue?"
28.  
29. SUB Text (x, y, textHeight, K AS _UNSIGNED LONG, txt$)
30.     DIM fg AS _UNSIGNED LONG, cur&, I&, mult, xlen
31.     fg = _DEFAULTCOLOR
32.     'screen snapshot
33.     cur& = _DEST
34.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
35.     _DEST I&
36.     COLOR K, _RGBA32(0, 0, 0, 0)
37.     _PRINTSTRING (0, 0), txt$
38.     mult = textHeight / 16
39.     xlen = LEN(txt$) * 8 * mult
40.     _PUTIMAGE (x, y)-STEP(xlen, textHeight), I&, cur&
41.     COLOR fg
42.     _FREEIMAGE I&
43. END SUB
44.  
45. 'center the text
46. SUB cText (x, y, textHeight, K AS _UNSIGNED LONG, txt$)
47.     DIM fg AS _UNSIGNED LONG, cur&, I&, mult, xlen
48.     fg = _DEFAULTCOLOR
49.     'screen snapshot
50.     cur& = _DEST
51.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
52.     _DEST I&
53.     COLOR K, _RGBA32(0, 0, 0, 0)
54.     _PRINTSTRING (0, 0), txt$
55.     mult = textHeight / 16
56.     xlen = LEN(txt$) * 8 * mult
57.     _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
58.     COLOR fg
59.     _FREEIMAGE I&
60. END SUB
61.  
62.  

Here is topTenGoAgain$ code and tester reworked with cText and inputBox$:

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. _TITLE "Top Ten mod with cText tester" ' B+ started 2019-07-31
3. '2019-07-28 All enclosed in a sub, possible feed it score and see how it stacks up.
4. '2019-07-28 fix to fill all 10 slots.
5. '2019-07-29 2nd fix with an n > 10 check, change to a function and get GoAgain reply.
6. '2019-07-31 modify Top Ten Screen with cText and inputBox$
7. ' 1. to make it look better, 2
8. ' 2. for demo in thread "another one for the tool box"
9. ' 3. improve Invaders look
10. ' 4. test new revsions to inputBox$
11.  
12. SCREEN _NEWIMAGE(800, 600, 32)
13. _SCREENMOVE 300, 20
14.  
15. RANDOMIZE TIMER
16. DIM score, again$
17.  
18. 'for testing
19. 'IF _FILEEXISTS("Top 10 Scores.txt") THEN KILL "Top 10 Scores.txt"
20.  
21. 'testing function with random scores, would be good to start with
22. FOR score = 1 TO 15
23.     again$ = topTenGoAgain$(score * 5 * RND)
24.     CLS
25.  
26.     IF LEN(again$) THEN PRINT "Player wants to quit." ELSE PRINT "Player wants to go again."
27.     IF score = 15 OR LEN(again$) THEN
28.         PRINT "End of test.": END
29.     ELSE
30.         INPUT "Press <enter> to continue testing TopTenGoAgain$ Function.", again$
31.     END IF
32. NEXT
33.  
34.  
35. ' This FUNCTION creates a file in the same folder as your .bas source or .exe
36. 'EDIT: 2019-07-31 this function needs:
37. ' SUB cText(x, y, pixelTextHeight, Colr)
38. ' SUB inputBox$(prompt$, title$, maxBoxWidth)
39. ' which needs scnState(restoreTF)
40. FUNCTION topTenGoAgain$ (compareScore AS INTEGER)
41.     DIM fName$, n AS INTEGER, names$(1 TO 10), scores(1 TO 10), name$, score AS INTEGER
42.     DIM settleScore AS INTEGER, i AS INTEGER, yc, s$
43.  
44.     fName$ = "Top 10 Scores.txt" '<<<  since this is toolbox code change this as needed for app
45.     CLS
46.     cText _WIDTH / 2, _HEIGHT / 8, 20, &HFF0000FF, "Your score was:" + STR$(compareScore)
47.     IF _FILEEXISTS(fName$) THEN
48.         OPEN fName$ FOR INPUT AS #1
49.         WHILE EOF(1) = 0 AND n < 10
50.             n = n + 1
51.             INPUT #1, name$
52.             INPUT #1, score
53.             IF compareScore >= score AND settleScore = 0 THEN
54.                 names$(n) = inputBox$("Please enter your name here:", "You have made the Top Ten!", 40)
55.                 scores(n) = compareScore
56.                 settleScore = -1
57.                 n = n + 1
58.                 IF n <= 10 THEN names$(n) = name$: scores(n) = score
59.             ELSE
60.                 scores(n) = score: names$(n) = name$
61.             END IF
62.         WEND
63.         CLOSE #1
64.         IF n < 10 AND settleScore = 0 THEN
65.             name$ = inputBox$("Please enter your name here:", "Top Ten has slot open for you:", 40)
66.             IF name$ <> "" THEN n = n + 1: names$(n) = name$: scores(n) = compareScore
67.         END IF
68.         IF n > 10 THEN n = 10
69.         yc = (_HEIGHT - 20 * (n + 2)) / 2
70.         cText _WIDTH / 2, yc, 40, &HFFFFFF00, "Top Ten Scorers and Scores:"
71.         OPEN fName$ FOR OUTPUT AS #1
72.         FOR i = 1 TO n
73.             PRINT #1, names$(i): PRINT #1, scores(i)
74.             s$ = RIGHT$(" " + STR$(i), 2) + "  " + LEFT$(names$(i) + STRING$(25, "."), 20)
75.             s$ = s$ + RIGHT$(SPACE$(10) + STR$(scores(i)), 10)
76.             cText _WIDTH / 2, yc + 30 + i * 20, 20, &HFF00FFFF, s$
77.         NEXT
78.         _DISPLAY
79.         _DELAY 3.5
80.         CLOSE #1
81.     ELSE
82.         name$ = inputBox("Please enter your name here:", "You are first into Top Ten file.", 40)
83.         OPEN fName$ FOR OUTPUT AS #1
84.         PRINT #1, name$: PRINT #1, compareScore
85.         CLOSE #1
86.     END IF
87.     topTenGoAgain$ = inputBox$("Press <Enter> to play again, enter q (or any) to quit... ", "Play Again?", 66)
88. END FUNCTION
89.  
90. 'center the text around (x, y) point, needs a graphics screen!
91. SUB cText (x, y, textHeight, K AS _UNSIGNED LONG, txt$)
92.     DIM fg AS _UNSIGNED LONG, cur&, I&, mult, xlen
93.     fg = _DEFAULTCOLOR
94.     'screen snapshot
95.     cur& = _DEST
96.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
97.     _DEST I&
98.     COLOR K, _RGBA32(0, 0, 0, 0)
99.     _PRINTSTRING (0, 0), txt$
100.     mult = textHeight / 16
101.     xlen = LEN(txt$) * 8 * mult
102.     _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
103.     COLOR fg
104.     _FREEIMAGE I&
105. END SUB
106.  
107. ' You can grab this box by title and drag it around screen for full viewing while answering prompt.
108. ' Only one line allowed for prompt$
109. ' boxWidth is 4 more than the allowed length of input, it needs to be longer than title$ and prompt$ also
110. ' Utilities > Input Box > Input Box 1 tester v 2019-07-31
111. ' This FUNCTION needs scnState(restroreTF)
112. FUNCTION inputBox$ (prompt$, title$, boxWidth AS _BYTE)
113.     DIM ForeColor AS _UNSIGNED LONG, BackColor AS _UNSIGNED LONG, White AS _UNSIGNED LONG
114.     DIM sw AS INTEGER, sh AS INTEGER, curScrn AS LONG, backScrn AS LONG, ibx AS LONG 'some handles
115.  
116.     'colors
117.     ForeColor = &HFF000055 '<  change as desired  prompt text color, back color or type in area
118.     BackColor = &HFF6080CC '<  change as desired  used fore color in type in area
119.     White = &HFFFFFFFF
120.  
121.     'items to restore at exit
122.     scnState 0
123.  
124.     'screen snapshot
125.     sw = _WIDTH: sh = _HEIGHT: curScrn = _DEST
126.     backScrn = _NEWIMAGE(sw, sh, 32)
127.     _PUTIMAGE , curScrn, backScrn
128.  
129.     'moving box around on screen
130.     DIM bxW AS INTEGER, bxH AS INTEGER
131.     DIM mb AS INTEGER, mx AS INTEGER, my AS INTEGER, mi AS INTEGER, grabx AS INTEGER, graby AS INTEGER
132.     DIM tlx AS INTEGER, tly AS INTEGER 'top left corner of message box
133.     DIM lastx AS INTEGER, lasty AS INTEGER
134.     DIM inp$, kh&
135.  
136.     'draw message box
137.     bxW = boxWidth * 8: bxH = 7 * 16
138.     ibx = _NEWIMAGE(bxW, bxH, 32)
139.     _DEST ibx
140.     COLOR &HFF880000, White
141.     LOCATE 1, 1: PRINT LEFT$(SPACE$(INT((boxWidth - LEN(title$) - 3)) / 2) + title$ + SPACE$(boxWidth), boxWidth)
142.     COLOR White, &HFFBB0000
143.     LOCATE 1, boxWidth - 2: PRINT " X "
144.     COLOR ForeColor, BackColor
145.     LOCATE 2, 1: PRINT SPACE$(boxWidth);
146.     LOCATE 3, 1: PRINT LEFT$(SPACE$((boxWidth - LEN(prompt$)) / 2) + prompt$ + SPACE$(boxWidth), boxWidth);
147.     LOCATE 4, 1: PRINT SPACE$(boxWidth);
148.     LOCATE 5, 1: PRINT SPACE$(boxWidth);
149.     LOCATE 6, 1: PRINT SPACE$(boxWidth);
150.     inp$ = ""
151.     GOSUB finishBox
152.  
153.     'convert to pixels the top left corner of box at moment
154.     bxW = boxWidth * 8: bxH = 5 * 16
155.     tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
156.     lastx = tlx: lasty = tly
157.     _KEYCLEAR
158.     'now allow user to move it around or just read it
159.     WHILE 1
160.         CLS
161.         _PUTIMAGE , backScrn
162.         _PUTIMAGE (tlx, tly), ibx, curScrn
163.         _DISPLAY
164.         WHILE _MOUSEINPUT: WEND
165.         mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
166.         IF mb THEN
167.             IF mx >= tlx AND mx <= tlx + bxW AND my >= tly AND my <= tly + 16 THEN 'mouse down on title bar
168.                 IF mx >= tlx + bxW - 24 THEN EXIT WHILE
169.                 grabx = mx - tlx: graby = my - tly
170.                 DO WHILE mb 'wait for release
171.                     mi = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
172.                     mx = _MOUSEX: my = _MOUSEY
173.                     IF mx - grabx >= 0 AND mx - grabx <= sw - bxW AND my - graby >= 0 AND my - graby <= sh - bxH THEN
174.                         'attempt to speed up with less updates
175.                         IF ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .5 > 10 THEN
176.                             tlx = mx - grabx: tly = my - graby
177.                             CLS
178.                             _PUTIMAGE , backScrn
179.                             _PUTIMAGE (tlx, tly), ibx, curScrn
180.                             lastx = tlx: lasty = tly
181.                             _DISPLAY
182.                         END IF
183.                     END IF
184.                     _LIMIT 400
185.                 LOOP
186.             END IF
187.         END IF
188.         kh& = _KEYHIT
189.         SELECT CASE kh& 'whew not much for the main event!
190.             CASE 13: EXIT WHILE
191.             CASE 27: inp$ = "": EXIT WHILE
192.             CASE 32 TO 128: IF LEN(inp$) < boxWidth - 4 THEN inp$ = inp$ + CHR$(kh&): GOSUB finishBox ELSE BEEP
193.             CASE 8: IF LEN(inp$) THEN inp$ = LEFT$(inp$, LEN(inp$) - 1): GOSUB finishBox ELSE BEEP
194.         END SELECT
195.  
196.         _LIMIT 60
197.     WEND
198.  
199.     'put things back
200.     scnState 1 'need fg and bg colors set to cls
201.     CLS '? is this needed YES!!
202.     _PUTIMAGE , backScrn
203.     _DISPLAY
204.     _FREEIMAGE backScrn
205.     _FREEIMAGE ibx
206.     scnState 1 'because we have to call _display, we have to call this again
207.     inputBox$ = inp$
208.     EXIT FUNCTION
209.  
210.     finishBox:
211.     _DEST ibx
212.     COLOR BackColor, ForeColor
213.     LOCATE 5, 2: PRINT LEFT$(" " + inp$ + SPACE$(boxWidth - 2), boxWidth - 2)
214.     _DEST curScrn
215.     RETURN
216. END FUNCTION
217.  
218. 'from mBox v 2019-07-31 update
219. ' for saving and restoring screen settins
220. SUB scnState (restoreTF AS INTEGER) 'Thanks Steve McNeill
221.     STATIC Font AS LONG, DefaultColor AS _UNSIGNED LONG, BackGroundColor AS _UNSIGNED LONG, Dest AS LONG, Source AS LONG
222.     STATIC row AS INTEGER, col AS INTEGER, autodisplay AS INTEGER, mb AS INTEGER
223.     IF restoreTF THEN
224.         _FONT Font
225.         COLOR DefaultColor, BackGroundColor
226.         _DEST Dest
227.         _SOURCE Source
228.         LOCATE row, col
229.         IF autodisplay THEN _AUTODISPLAY ELSE _DISPLAY
230.         _KEYCLEAR
231.         WHILE _MOUSEINPUT: WEND 'clear mouse clicks
232.         mb = _MOUSEBUTTON(1)
233.         IF mb THEN
234.             DO
235.                 WHILE _MOUSEINPUT: WEND
236.                 mb = _MOUSEBUTTON(1)
237.                 _LIMIT 100
238.             LOOP UNTIL mb = 0
239.         END IF
240.     ELSE
241.         Font = _FONT: DefaultColor = _DEFAULTCOLOR: BackGroundColor = _BACKGROUNDCOLOR
242.         Dest = _DEST: Source = _SOURCE
243.         row = CSRLIN: col = POS(0): autodisplay = _AUTODISPLAY
244.     END IF
245. END SUB
246.  

and a screen shot of the revised screen after installed in Invaders b0_4:
 

[SMcNeill]

And another rather simple routine for your toolbox collection -- a quick mouse handler.

Code: QB64: [Select]

1. DO
2.     CLS
3.     held$ = ""
4.     SELECT CASE MBS
5.         CASE 1: left = left + 1
6.         CASE 2: right = right + 1
7.         CASE 3: middle = middle + 1
8.         CASE 4: held$ = "Left held"
9.         CASE 5: held$ = "Right held"
10.         CASE 6: held$ = "Middle held"
11.     END SELECT
12.  
13.     PRINT "MouseX: "; _MOUSEX
14.     PRINT "MouseY: "; _MOUSEY
15.     PRINT "Left pressed: "; left
16.     PRINT "Right pressed: "; right
17.     PRINT "Middle pressed: "; middle
18.     PRINT held$
19.     _LIMIT 10
20. LOOP
21.  
22.  
23. FUNCTION MBS 'Mouse Button Status
24.     STATIC StartTimer AS _FLOAT
25.     STATIC ButtonDown AS INTEGER
26.     STATIC ClickCount AS INTEGER
27.     CONST ClickLimit## = 0.2 '2/10th of a second to down, up a key to count as a CLICK.  Down longer counts as a HOLD event.
28.  
29.     WHILE _MOUSEINPUT: WEND 'Remark out this line, if mouse main input/clear is going to be handled manually in main program.
30.  
31.     IF StartTimer = 0 THEN
32.         IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
33.             ButtonDown = 1: StartTimer = TIMER(0.01)
34.         ELSEIF _MOUSEBUTTON(2) THEN
35.             ButtonDown = 2: StartTimer = TIMER(0.01)
36.         ELSEIF _MOUSEBUTTON(3) THEN
37.             ButtonDown = 3: StartTimer = TIMER(0.01)
38.         END IF
39.     ELSE
40.         BD = ButtonDown MOD 3
41.         IF BD = 0 THEN BD = 3
42.         IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit.  It's a click
43.             IF _MOUSEBUTTON(BD) = 0 THEN MouseHandler = ButtonDown: ButtonDown = 0: StartTimer = 0
44.         ELSE
45.             IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
46.                 MouseHandler = 0: ButtonDown = 0: StartTimer = 0
47.             ELSE 'We've now started the hold event
48.                 MouseHandler = ButtonDown + 3
49.             END IF
50.         END IF
51.     END IF
52. END SUB

One quick command to tell you if a button was clicked or held, for any of the 3 mouse buttons.