| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 755
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 30
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 31
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 1,978
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,230
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 312
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 122
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,348
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 241
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 146
|
|
|
| Screen Scrolling Commands |
|
Posted by: SMcNeill - 04-20-2022, 02:39 AM - Forum: SMcNeill
- No Replies
|
 |
A simple set of two commands which can scroll the screen up or down for us, regardless of what screen mode we decide to use it in. Use the "U" and "D" keys in the demo to see how it works. 
Code: (Select All) SCREEN _NEWIMAGE(640, 480, 32)
PRINT "This is a test of the Steve Scrolling System"
PRINT "This is only a test."
FOR i = 1 TO 15: PRINT i: NEXT
DO
_LIMIT 30
a$ = UCASE$(INKEY$)
IF a$ = "U" THEN ScrollUp
IF a$ = "D" THEN ScrollDown
LOOP UNTIL a$ = CHR$(27)
SUB ScrollUp
$CHECKING:OFF
DIM m AS _MEM
m = _MEMIMAGE(0)
p = _PIXELSIZE
IF p = 0 THEN w = _WIDTH * 2 ELSE w = _FONTHEIGHT * _WIDTH * p
t$ = SPACE$(m.SIZE - w)
_MEMGET m, m.OFFSET + w, t$
CLS
_MEMPUT m, m.OFFSET, t$
_MEMFREE m
$CHECKING:ON
END SUB
SUB ScrollDown
$CHECKING:OFF
DIM m AS _MEM
m = _MEMIMAGE(0)
p = _PIXELSIZE
IF p = 0 THEN w = _WIDTH * 2 ELSE w = _FONTHEIGHT * _WIDTH * p
t$ = SPACE$(m.SIZE - w)
_MEMGET m, m.OFFSET, t$
CLS
_MEMPUT m, m.OFFSET + w, t$
_MEMFREE m
$CHECKING:ON
END SUB
|
|
|
| MemSort |
|
Posted by: SMcNeill - 04-20-2022, 02:38 AM - Forum: SMcNeill
- No Replies
|
|
The following routine is a quick and efficient way to sort almost any type of array, regardless of data type. (The one thing it doesn't sort is variable-length strings, as _MEM doesn't support those at all.)
Code: (Select All) SUB Sort (m AS _MEM)
DIM i AS _UNSIGNED LONG
$IF 64BIT THEN
DIM ES AS _INTEGER64, EC AS _INTEGER64
$ELSE
DIM ES AS LONG, EC AS LONG
$END IF
IF NOT m.TYPE AND 65536 THEN EXIT SUB 'We won't work without an array
IF m.TYPE AND 1024 THEN DataType = 10
IF m.TYPE AND 1 THEN DataType = DataType + 1
IF m.TYPE AND 2 THEN DataType = DataType + 2
IF m.TYPE AND 4 THEN IF m.TYPE AND 128 THEN DataType = DataType + 4 ELSE DataType = 3
IF m.TYPE AND 8 THEN IF m.TYPE AND 128 THEN DataType = DataType + 8 ELSE DataType = 5
IF m.TYPE AND 32 THEN DataType = 6
IF m.TYPE AND 512 THEN DataType = 7
'Convert our offset data over to something we can work with
DIM m1 AS _MEM: m1 = _MEMNEW(LEN(ES))
_MEMPUT m1, m1.OFFSET, m.ELEMENTSIZE: _MEMGET m1, m1.OFFSET, ES 'Element Size
_MEMPUT m1, m1.OFFSET, m.SIZE: _MEMGET m1, m1.OFFSET, EC 'Element Count will temporily hold the WHOLE array size
_MEMFREE m1
EC = EC / ES - 1 'Now we take the whole element size / the size of the elements and get our actual element count. We subtract 1 so our arrays start at 0 and not 1.
'And work with it!
DIM o AS _OFFSET, o1 AS _OFFSET, counter AS _UNSIGNED LONG
SELECT CASE DataType
CASE 1 'BYTE
DIM temp1(-128 TO 127) AS _UNSIGNED LONG
DIM t1 AS _BYTE
i = 0
DO
_MEMGET m, m.OFFSET + i, t1
temp1(t1) = temp1(t1) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = -128
DO
DO UNTIL temp1(i1) = 0
_MEMPUT m, m.OFFSET + counter, i1 AS _BYTE
counter = counter + 1
temp1(i1) = temp1(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 127
CASE 2: 'INTEGER
DIM temp2(-32768 TO 32767) AS _UNSIGNED LONG
DIM t2 AS INTEGER
i = 0
DO
_MEMGET m, m.OFFSET + i * 2, t2
temp2(t2) = temp2(t2) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = -32768
DO
DO UNTIL temp2(i1) = 0
_MEMPUT m, m.OFFSET + counter * 2, i1 AS INTEGER
counter = counter + 1
temp2(i1) = temp2(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 32767
CASE 3 'SINGLE
DIM T3a AS SINGLE, T3b AS SINGLE
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
IF _MEMGET(m, o, SINGLE) > _MEMGET(m, o1, SINGLE) THEN
_MEMGET m, o1, T3a
_MEMGET m, o, T3b
_MEMPUT m, o1, T3b
_MEMPUT m, o, T3a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 4 'LONG
DIM T4a AS LONG, T4b AS LONG
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
IF _MEMGET(m, o, LONG) > _MEMGET(m, o1, LONG) THEN
_MEMGET m, o1, T4a
_MEMGET m, o, T4b
_MEMPUT m, o1, T4b
_MEMPUT m, o, T4a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 5 'DOUBLE
DIM T5a AS DOUBLE, T5b AS DOUBLE
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
IF _MEMGET(m, o, DOUBLE) > _MEMGET(m, o1, DOUBLE) THEN
_MEMGET m, o1, T5a
_MEMGET m, o, T5b
_MEMPUT m, o1, T5b
_MEMPUT m, o, T5a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 6 ' _FLOAT
DIM T6a AS _FLOAT, T6b AS _FLOAT
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 32
o1 = m.OFFSET + (i + gap) * 32
IF _MEMGET(m, o, _FLOAT) > _MEMGET(m, o1, _FLOAT) THEN
_MEMGET m, o1, T6a
_MEMGET m, o, T6b
_MEMPUT m, o1, T6b
_MEMPUT m, o, T6a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 7 'String
DIM T7a AS STRING, T7b AS STRING, T7c AS STRING
T7a = SPACE$(ES): T7b = SPACE$(ES): T7c = SPACE$(ES)
gap = EC
DO
gap = INT(gap / 1.247330950103979)
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * ES
o1 = m.OFFSET + (i + gap) * ES
_MEMGET m, o, T7a
_MEMGET m, o1, T7b
IF T7a > T7b THEN
T7c = T7b
_MEMPUT m, o1, T7a
_MEMPUT m, o, T7c
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = false
CASE 8 '_INTEGER64
DIM T8a AS _INTEGER64, T8b AS _INTEGER64
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
IF _MEMGET(m, o, _INTEGER64) > _MEMGET(m, o1, _INTEGER64) THEN
_MEMGET m, o1, T8a
_MEMGET m, o, T8b
_MEMPUT m, o1, T8b
_MEMPUT m, o, T8a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 11: '_UNSIGNED _BYTE
DIM temp11(0 TO 255) AS _UNSIGNED LONG
DIM t11 AS _UNSIGNED _BYTE
i = 0
DO
_MEMGET m, m.OFFSET + i, t11
temp11(t11) = temp11(t11) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = 0
DO
DO UNTIL temp11(i1) = 0
_MEMPUT m, m.OFFSET + counter, i1 AS _UNSIGNED _BYTE
counter = counter + 1
temp11(i1) = temp11(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 255
CASE 12 '_UNSIGNED INTEGER
DIM temp12(0 TO 65535) AS _UNSIGNED LONG
DIM t12 AS _UNSIGNED INTEGER
i = 0
DO
_MEMGET m, m.OFFSET + i * 2, t12
temp12(t12) = temp12(t12) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = 0
DO
DO UNTIL temp12(i1) = 0
_MEMPUT m, m.OFFSET + counter * 2, i1 AS _UNSIGNED INTEGER
counter = counter + 1
temp12(i1) = temp12(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 65535
CASE 14 '_UNSIGNED LONG
DIM T14a AS _UNSIGNED LONG, T14b AS _UNSIGNED LONG
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
IF _MEMGET(m, o, _UNSIGNED LONG) > _MEMGET(m, o1, _UNSIGNED LONG) THEN
_MEMGET m, o1, T14a
_MEMGET m, o, T14b
_MEMPUT m, o1, T14b
_MEMPUT m, o, T14a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 18: '_UNSIGNED _INTEGER64
DIM T18a AS _UNSIGNED _INTEGER64, T18b AS _UNSIGNED _INTEGER64
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
IF _MEMGET(m, o, _UNSIGNED _INTEGER64) > _MEMGET(m, o1, _UNSIGNED _INTEGER64) THEN
_MEMGET m, o1, T18a
_MEMGET m, o, T18b
_MEMPUT m, o1, T18b
_MEMPUT m, o, T18a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
END SELECT
END SUB
And, an example of the routine in action with various different data type arrays:
Code: (Select All) SCREEN _NEWIMAGE(1280, 720, 256)
RANDOMIZE TIMER
DIM m AS _MEM
DIM x(5) AS _BYTE
DIM y(7) AS DOUBLE
DIM z(5) AS STRING * 5
'Let's see if we can sort the integer array
'Initialize Data
FOR i = 0 TO 5: x(i) = RND * 100: PRINT x(i),: NEXT: PRINT
PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
'Sort
m = _MEM(x())
Sort m
_MEMFREE m
'Result
FOR i = 0 TO 5: PRINT x(i),: NEXT: PRINT
PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
PRINT
PRINT
'Try the same routine with a different data type array to sort
'Initialize Data
FOR i = 0 TO 7: y(i) = RND * 100: PRINT y(i),: NEXT
PRINT
PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
'Sort
m = _MEM(y())
Sort m
_MEMFREE m
'Result
FOR i = 0 TO 7: PRINT y(i),: NEXT: PRINT
PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
PRINT
PRINT
'To test with fixed length string arrays
z(0) = "Doggy": z(1) = "Pudding": z(2) = "Frog ": z(3) = "test2": z(4) = "Test2": z(5) = "test1"
FOR i = 0 TO 5: PRINT z(i),: NEXT: PRINT
PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
m = _MEM(z())
Sort m
_MEMFREE m
'Result
FOR i = 0 TO 5: PRINT z(i),: NEXT: PRINT
SLEEP
SYSTEM
SUB Sort (m AS _MEM)
DIM i AS _UNSIGNED LONG
$IF 64BIT THEN
DIM ES AS _INTEGER64, EC AS _INTEGER64
$ELSE
DIM ES AS LONG, EC AS LONG
$END IF
IF NOT m.TYPE AND 65536 THEN EXIT SUB 'We won't work without an array
IF m.TYPE AND 1024 THEN DataType = 10
IF m.TYPE AND 1 THEN DataType = DataType + 1
IF m.TYPE AND 2 THEN DataType = DataType + 2
IF m.TYPE AND 4 THEN IF m.TYPE AND 128 THEN DataType = DataType + 4 ELSE DataType = 3
IF m.TYPE AND 8 THEN IF m.TYPE AND 128 THEN DataType = DataType + 8 ELSE DataType = 5
IF m.TYPE AND 32 THEN DataType = 6
IF m.TYPE AND 512 THEN DataType = 7
'Convert our offset data over to something we can work with
DIM m1 AS _MEM: m1 = _MEMNEW(LEN(ES))
_MEMPUT m1, m1.OFFSET, m.ELEMENTSIZE: _MEMGET m1, m1.OFFSET, ES 'Element Size
_MEMPUT m1, m1.OFFSET, m.SIZE: _MEMGET m1, m1.OFFSET, EC 'Element Count will temporily hold the WHOLE array size
_MEMFREE m1
EC = EC / ES - 1 'Now we take the whole element size / the size of the elements and get our actual element count. We subtract 1 so our arrays start at 0 and not 1.
'And work with it!
DIM o AS _OFFSET, o1 AS _OFFSET, counter AS _UNSIGNED LONG
SELECT CASE DataType
CASE 1 'BYTE
DIM temp1(-128 TO 127) AS _UNSIGNED LONG
DIM t1 AS _BYTE
i = 0
DO
_MEMGET m, m.OFFSET + i, t1
temp1(t1) = temp1(t1) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = -128
DO
DO UNTIL temp1(i1) = 0
_MEMPUT m, m.OFFSET + counter, i1 AS _BYTE
counter = counter + 1
temp1(i1) = temp1(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 127
CASE 2: 'INTEGER
DIM temp2(-32768 TO 32767) AS _UNSIGNED LONG
DIM t2 AS INTEGER
i = 0
DO
_MEMGET m, m.OFFSET + i * 2, t2
temp2(t2) = temp2(t2) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = -32768
DO
DO UNTIL temp2(i1) = 0
_MEMPUT m, m.OFFSET + counter * 2, i1 AS INTEGER
counter = counter + 1
temp2(i1) = temp2(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 32767
CASE 3 'SINGLE
DIM T3a AS SINGLE, T3b AS SINGLE
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
IF _MEMGET(m, o, SINGLE) > _MEMGET(m, o1, SINGLE) THEN
_MEMGET m, o1, T3a
_MEMGET m, o, T3b
_MEMPUT m, o1, T3b
_MEMPUT m, o, T3a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 4 'LONG
DIM T4a AS LONG, T4b AS LONG
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
IF _MEMGET(m, o, LONG) > _MEMGET(m, o1, LONG) THEN
_MEMGET m, o1, T4a
_MEMGET m, o, T4b
_MEMPUT m, o1, T4b
_MEMPUT m, o, T4a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 5 'DOUBLE
DIM T5a AS DOUBLE, T5b AS DOUBLE
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
IF _MEMGET(m, o, DOUBLE) > _MEMGET(m, o1, DOUBLE) THEN
_MEMGET m, o1, T5a
_MEMGET m, o, T5b
_MEMPUT m, o1, T5b
_MEMPUT m, o, T5a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 6 ' _FLOAT
DIM T6a AS _FLOAT, T6b AS _FLOAT
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 32
o1 = m.OFFSET + (i + gap) * 32
IF _MEMGET(m, o, _FLOAT) > _MEMGET(m, o1, _FLOAT) THEN
_MEMGET m, o1, T6a
_MEMGET m, o, T6b
_MEMPUT m, o1, T6b
_MEMPUT m, o, T6a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 7 'String
DIM T7a AS STRING, T7b AS STRING, T7c AS STRING
T7a = SPACE$(ES): T7b = SPACE$(ES): T7c = SPACE$(ES)
gap = EC
DO
gap = INT(gap / 1.247330950103979)
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * ES
o1 = m.OFFSET + (i + gap) * ES
_MEMGET m, o, T7a
_MEMGET m, o1, T7b
IF T7a > T7b THEN
T7c = T7b
_MEMPUT m, o1, T7a
_MEMPUT m, o, T7c
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = false
CASE 8 '_INTEGER64
DIM T8a AS _INTEGER64, T8b AS _INTEGER64
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
IF _MEMGET(m, o, _INTEGER64) > _MEMGET(m, o1, _INTEGER64) THEN
_MEMGET m, o1, T8a
_MEMGET m, o, T8b
_MEMPUT m, o1, T8b
_MEMPUT m, o, T8a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 11: '_UNSIGNED _BYTE
DIM temp11(0 TO 255) AS _UNSIGNED LONG
DIM t11 AS _UNSIGNED _BYTE
i = 0
DO
_MEMGET m, m.OFFSET + i, t11
temp11(t11) = temp11(t11) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = 0
DO
DO UNTIL temp11(i1) = 0
_MEMPUT m, m.OFFSET + counter, i1 AS _UNSIGNED _BYTE
counter = counter + 1
temp11(i1) = temp11(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 255
CASE 12 '_UNSIGNED INTEGER
DIM temp12(0 TO 65535) AS _UNSIGNED LONG
DIM t12 AS _UNSIGNED INTEGER
i = 0
DO
_MEMGET m, m.OFFSET + i * 2, t12
temp12(t12) = temp12(t12) + 1
i = i + 1
LOOP UNTIL i > EC
i1 = 0
DO
DO UNTIL temp12(i1) = 0
_MEMPUT m, m.OFFSET + counter * 2, i1 AS _UNSIGNED INTEGER
counter = counter + 1
temp12(i1) = temp12(i1) - 1
IF counter > EC THEN EXIT SUB
LOOP
i1 = i1 + 1
LOOP UNTIL i1 > 65535
CASE 14 '_UNSIGNED LONG
DIM T14a AS _UNSIGNED LONG, T14b AS _UNSIGNED LONG
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
IF _MEMGET(m, o, _UNSIGNED LONG) > _MEMGET(m, o1, _UNSIGNED LONG) THEN
_MEMGET m, o1, T14a
_MEMGET m, o, T14b
_MEMPUT m, o1, T14b
_MEMPUT m, o, T14a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
CASE 18: '_UNSIGNED _INTEGER64
DIM T18a AS _UNSIGNED _INTEGER64, T18b AS _UNSIGNED _INTEGER64
gap = EC
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
IF _MEMGET(m, o, _UNSIGNED _INTEGER64) > _MEMGET(m, o1, _UNSIGNED _INTEGER64) THEN
_MEMGET m, o1, T18a
_MEMGET m, o, T18b
_MEMPUT m, o1, T18b
_MEMPUT m, o, T18a
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > EC
LOOP UNTIL gap = 1 AND swapped = 0
END SELECT
END SUB
This should work on all current and future versions of QB64 (after 08-02-2017).
|
|
|
|
| Word Count / Word List Generator |
|
Posted by: SMcNeill - 04-20-2022, 02:35 AM - Forum: SMcNeill
- No Replies
|
|
Here I'm using this to count the words of the bible, and to create a searchable list of them, but you could use this program with any txt file that you'd like. Grab a copy of the King James Bible below, if you need it for testing/running the demo, or feel free to substitute your own text file, as desired.
Code: (Select All) DEFLNG A-Z
'load the bible
file$ = "kjv10.txt"
OPEN file$ FOR BINARY AS #1
book$ = SPACE$(LOF(1))
GET #1, , book$
CLOSE
REDIM SHARED Words(0) AS STRING
REDIM SHARED WordCount(0) AS LONG
l = 0
DO
l = 0
l1 = INSTR(oldl, book$, CHR$(32))
l2 = INSTR(oldl, book$, CHR$(13)) 'CR
l3 = INSTR(oldl, book$, CHR$(10)) 'LF
IF l1 > 0 AND l1 < l2 AND l1 < l3 THEN l = l1: GOTO skipcheck
IF l2 > 0 AND l2 < l3 THEN l = l2: GOTO skipcheck
IF l3 > 0 THEN l = l3
skipcheck:
IF l = 0 THEN EXIT DO
word$ = UCASE$(MID$(book$, oldl, l - oldl))
i = 1
DO UNTIL i > LEN(word$)
IF ASC(word$, i) < 65 OR ASC(word$, i) > 90 THEN
word$ = LEFT$(word$, i - 1) + MID$(word$, i + 1)
ELSE
i = i + 1
END IF
LOOP
newword = -1
FOR i = 1 TO UBOUND(Words)
IF word$ = Words(i) THEN
newword = 0: EXIT FOR
END IF
NEXT
IF newword THEN
u = UBOUND(words) + 1
REDIM _PRESERVE Words(u)
REDIM _PRESERVE WordCount(u)
Words(u) = word$: WordCount(u) = 1
ELSE
WordCount(i) = WordCount(i) + 1
END IF
oldl = l + 1
DO UNTIL MID$(word$, oldl) <> CHR$(32) AND MID$(word$, oldl) <> CHR$(13) AND MID$(word$, oldl) <> CHR$(10)
oldl = oldl + 1
LOOP
LOCATE 1, 1: PRINT "Processing book:"; oldl; "/"; LEN(book$)
LOOP
CLS
PRINT "There are "; UBOUND(words); " words in the bible."
DO
PRINT "Give me a word to search for in the bible => (FULL LIST to see everything)"
PRINT " =>";
INPUT "", search$
search$ = UCASE$(search$)
IF search$ = "" THEN SYSTEM
found = 0
FOR i = 1 TO UBOUND(words)
IF search$ = Words(i) THEN PRINT Words(i), WordCount(i): found = -1: EXIT FOR
NEXT
IF NOT found THEN PRINT "Not in the bible"
LOOP UNTIL search$ = "FULL LIST" OR search$ = "FULLLIST"
PRINT "They are the following, and the appear this number of times each:"
combsort
FOR i = 1 TO UBOUND(words)
PRINT Words(i), WordCount(i)
IF i MOD 20 = 0 THEN SLEEP
NEXT
SUB combsort
'This is the routine I tend to use personally and promote.
'It's short, simple, and easy to implement into code.
gap = UBOUND(wordcount)
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
IF WordCount(i) < WordCount(i + gap) THEN
SWAP WordCount(i), WordCount(i + gap)
SWAP Words(i), Words(i + gap)
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > UBOUND(wordcount)
LOOP UNTIL gap = 1 AND swapped = 0
END SUB
King James Bible
|
|
|
|
| Scrabble Word Maker |
|
Posted by: SMcNeill - 04-20-2022, 02:32 AM - Forum: SMcNeill
- No Replies
|
|
A word making routine for use in scrabble. Give it the letters you have, it'll show you the possible words you can make with it.
2006 Scrabble Word List is attached as a link at the bottom of the post; don't forget to grab it. 
Code: (Select All) DEFLNG A-Z
REDIM SHARED WordList(0) AS STRING
REDIM SHARED Match(0) AS STRING
Init
DO
GetLetters text$
CheckMatchs text$
DisplayMatches
LOOP
SUB DisplayMatches
PRINT
PRINT "MATCHES :"
IF UBOUND(match) = 0 THEN PRINT "NONE": EXIT SUB
FOR i = 1 TO UBOUND(match)
PRINT Match(i),
NEXT
PRINT
END SUB
SUB CheckMatchs (text$)
text$ = LTRIM$(RTRIM$(text$))
DIM userletters(26), wordletters(26)
REDIM Match(0)
alpha$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
l = LEN(text$)
work$ = UCASE$(text$)
wordcount = 1 'the number of letters in the word we're looking for
FOR i = 1 TO l
a = ASC(work$, i)
IF a > 64 AND a < 91 THEN 'it's all good
userletters(a - 64) = userletters(a - 64) + 1
ELSE
PRINT "Invalid letters entered. Only use A-Z."
EXIT SUB
END IF
NEXT
FOR i = 1 TO UBOUND(wordlist)
FOR l = 1 TO 26: wordletters(l) = 0: NEXT 'reset wordletters back to 0
FOR l = 1 TO LEN(WordList(i)) 'count the letters in the word
a = ASC(WordList(i), l)
wordletters(a - 64) = wordletters(a - 64) + 1
NEXT
valid = -1 'assume it's a match
FOR l = 1 TO 26 'compare for matches
IF wordletters(l) > userletters(l) THEN valid = 0: EXIT FOR
NEXT
IF valid THEN
REDIM _PRESERVE Match(UBOUND(match) + 1)
Match(UBOUND(match)) = WordList(i)
END IF
NEXT
PRINT
END SUB
SUB GetLetters (text$)
PRINT
DO
PRINT "Give me the letters you want to check for word matches. (From 2-15 letters) => ";
INPUT text$
IF text$ = "" THEN SYSTEM
l = LEN(text$)
IF l < 2 OR l > 15 THEN PRINT "Invalid Letters. Try Again."
LOOP UNTIL l > 1 AND l < 16
END SUB
SUB Init
PRINT "Loading Dictionary..."
file$ = "Scrabble WordList 2006.txt"
OPEN file$ FOR BINARY AS #1
l = LOF(1)
WholeList$ = SPACE$(l)
GET #1, 1, WholeList$
PRINT "Parsing Dictionary..."
c = 0: i = 0
DO
c = INSTR(c1, WholeList$, CHR$(13))
IF c > 0 THEN
u = UBOUND(wordlist) + 1
REDIM _PRESERVE WordList(u)
WordList(u) = MID$(WholeList$, c1, c - c1)
c1 = c + 2 'our start pointer is now after the finish pointer
ELSE
EXIT DO
END IF
LOOP
PRINT u; " words are now loaded and ready for use."
CLOSE
END SUB
Scrabble Offical Word List for 2006
|
|
|
|
| A Simple Center Routine |
|
Posted by: SMcNeill - 04-20-2022, 02:30 AM - Forum: SMcNeill
- No Replies
|
|
The title really says it all...
Code: (Select All) SCREEN _NEWIMAGE(640, 480, 32)
Center 10, "A centered title", -1
'The 10 above is the line that we want to center our text on.
'"A centered title" is the text that we want centered.
'The -1 above says that we want to move the print positon to the next line down -- line 11 in this case.
Center 0, "by Steve", 0
'The 0 above says to print on the CURRENT LINE
'"by Steve" is simply the text we want centered.
'The 0 here says that we DON'T move the print position to the next line down.
'NOTE: In this case, our print cursor is going to be at line 11, position 1 (like LOCATE 11,1) for our next PRINT statement.
COLOR _RGB32(255, 255, 0)
PRINT "<<<<<<<<<<<<<<<<"
'Notice where the yellow arrows above printed on the screen -- it's the SAME line as "by Steve".
'If we wanted to move the cursor down to the next line automatically, we'd set that last parameter to anything other than 0.
'Because QB64 counts 0 as FALSE, all else as TRUE.
COLOR -1
Center 20, "Press <ANY KEY> to see this in SCREEN 0", 0
a$ = INPUT$(1)
SCREEN 0
Center 10, "A centered title", -1
Center 0, "by Steve", 0
Center 20, "Notice that the center command works fine in ALL screen modes?", 0
SUB Center (PrintLine AS INTEGER, text AS STRING, NewLine AS INTEGER)
IF PrintLine = 0 THEN
y = CSRLIN
ELSE
y = PrintLine
END IF
IF _PIXELSIZE <> 0 THEN Py = (y - 1) * _FONTHEIGHT ELSE Py = y
pw = _PRINTWIDTH(text)
w = _WIDTH
C = (w - pw) \ 2
_PRINTSTRING (C, Py), text
IF NewLine THEN LOCATE y + 1
END SUB
Note that we have a 3rd parameter for our Center routine, which is for the NEWLINE option. Basically this is used to toggle between two modes of behavior:
0 -- don't move the print position location from what it previously existed. (This allows us to center text wherever we want, without losing where we were printing before.)
Anything Else -- move the print position to the line directly below what we just centered, and to the left side of the screen, just as PRINT "something" would.
The rest should be easy enough to figure out.
|
|
|
|
| Basic WordWrap |
|
Posted by: SMcNeill - 04-20-2022, 02:29 AM - Forum: SMcNeill
- No Replies
|
|
A simple little routine which can be plugged in to break text and word wrap it nice and neat for us.
Code: (Select All) 'SCREEN _NEWIMAGE(640, 480, 32)
LOCATE 1, 21 'to test a line with an offset
test$ = "This is a very long sentence which runs on and on and one and even contains tipos and errors and goofs and mistakes and all sorts of junk, but it is good for testing if we have word breaks working properly for us!"
WordWrap test$, -1
PRINT 'to test a line from the starting point
WordWrap test$, -1
PRINT
PRINT "=============="
PRINT
WordWrap test$, 0 'And this shows that we can wordwrap text without automatically moving to a new line
WordWrap test$, -1 'As this line picks up right where the last one left off.
SUB WordWrap (text AS STRING, newline)
DIM BreakPoint AS STRING
BreakPoint = ",./- ;:!" 'I consider all these to be valid breakpoints. If you want something else, change them.
w = _WIDTH
pw = _PRINTWIDTH(text)
x = POS(0): y = CSRLIN
IF _PIXELSIZE <> 0 THEN x = x * _FONTWIDTH
firstlinewidth = w - x + 1
IF pw <= firstlinewidth THEN
PRINT text;
IF newline THEN PRINT
ELSE
'first find the natural length of the line
FOR i = 1 TO LEN(text)
p = _PRINTWIDTH(LEFT$(text, i))
IF p > firstlinewidth THEN EXIT FOR
NEXT
lineend = i - 1
t$ = RTRIM$(LEFT$(text, lineend)) 'at most, our line can't be any longer than what fits the screen.
FOR i = lineend TO 1 STEP -1
IF INSTR(BreakPoint, MID$(text, i, 1)) THEN lineend = i: EXIT FOR
NEXT
PRINT LEFT$(text, lineend)
WordWrap LTRIM$(MID$(text, lineend + 1)), newline
END IF
END SUB
|
|
|
|
|
![[Image: Phoenix-BASIC.png]](https://i.ibb.co/JmX7N32/Phoenix-BASIC.png)
![[Image: QB64-disco-error.png]](https://i.ibb.co/d5Sj0Gr/QB64-disco-error.png)
![[Image: screenshot.png]](https://i.ibb.co/M5bQ3mc/screenshot.png)
![[Image: Screenshot-2022-04-19-22-10-30.png]](https://i.ibb.co/nLhtRBJ/Screenshot-2022-04-19-22-10-30.png)
![[Image: Screenshot-2022-04-19-22-11-05.png]](https://i.ibb.co/1vngx09/Screenshot-2022-04-19-22-11-05.png)
![[Image: Screenshot-2022-04-19-22-11-25.png]](https://i.ibb.co/3W24Sqk/Screenshot-2022-04-19-22-11-25.png)
![[Image: Screenshot-2022-04-19-22-11-59.png]](https://i.ibb.co/1GrvLnh/Screenshot-2022-04-19-22-11-59.png)
![[Image: Screenshot-2022-04-19-22-24-17.png]](https://i.ibb.co/wB3rZnZ/Screenshot-2022-04-19-22-24-17.png)
![[Image: Screenshot-2022-04-19-22-12-48.png]](https://i.ibb.co/nmHyFn4/Screenshot-2022-04-19-22-12-48.png)
![[Image: Screenshot-2022-04-19-22-25-41.png]](https://i.ibb.co/y8tQzNQ/Screenshot-2022-04-19-22-25-41.png)
