Options:
<file> Source file to load
-c Compile instead of edit
-o <output file> Write output executable to <output file>
-x Compile instead of edit and output the result to the
console
-w Show warnings
-q Quiet mode (does not inhibit warnings or errors)
-m Do not colorize compiler output (monochrome mode)
-e Enable OPTION _EXPLICIT, making variable declaration
mandatory (per-compilation; doesn't affect the
source file or global settings)
-s[witch=true/false] View/edit compiler settings
-l:<line number> Start the IDE at the specified line number
-p Purge all pre-compiled content first
-z Generate C code without compiling to executable
If you run HelloRawInput (see attached "HelloRawInput_minimal.zip", run the batch file to compile with QB64), it counts the system devices. When you plug in a 2nd USB mouse, the count increases.
If you run ShowMultipleMiceValues (see attached "ShowMultipleMiceValues.zip", run the batch file to compile with QB64), with 2 USB mice plugged in, and move one, it displays the device ID and some values. Then if you move the second mouse, the device ID changes. Running it from Windows, where 2 USB mice plugged in both control the same mouse pointer, there is only one set of x/y coordinates. So this example doesn't show separate x/y coordinates for each mouse.
However JStookey provides a raw mouse API to read separate coordinates from multiple mice (see attached "raw_mouse_test_(attempt_1).zip", and "raw_mouse_test_(attempt_2).zip" where I tried to clean up code putting compound IF statements inside braces, etc.), but either way compiling gives errors (see "errors1.txt").
I am not C-savvy enough to really understand the erorrs but I did see some comments on the page about needing to convert libraries and massage header files to make it work for MinGW. They talk about using a program called, "reimp" (part of MinGW tools) on the MS Platform SDK "user32.lib" file. I don't think I have "reimp" and don't know what this MS Platform SDK is, so I haven't gotten far enough along to try and do the things they are talking about to make it work, and was hoping someone more familiar with that stuff might be able to help figure it out or guide me through some/any of it?
The hope is that this version (or one slightly modified) could read separate coordinates for each mouse, and QB64 could talk to it and get back separate input for each mouse plugged in. Think of the multiplayer Pong and puzzle games you could make! LoL
Then there is an example program that lists all the raw input devices on the computer (see attached "ListRawInputDevices_vc++.zip") which similarly doesn't compile. That one is in C++, which I have even less of a clue about making work, but GCC should be able to handle C++ so maybe it can work?
Anyway, at least 2 of these examples compile right out of the box, and if anyone has got any interest & spare time to help get the raw mouse API example to work, we could have a way to read 2 or more mice as separate input devices from QB64 (how to get QB64 to talk to a C program is a separate problem, I figure we can tackle another day!)
Meanwhile I will try to mess around with converting libraries / header files as time allows, to see if I can figure it out, but I am sure someone who actually knows what they're doing with the C stuff would have a better chance at succeeding...
drawGO v0.1
a really simple interpreter to evaluate DRAW commands without having to compile a basic program.
it technically supports all draw commands but entering a few of them can be a bit tricky so the interpreter has a few commands to deal with that and a handful of editing commands.
The interpreter can save and load lists of cod to and from a text file.
There's a very simple HELP listing.
commands added to draw:
setX <n> sets the X position of the pen to coordinate n
setY <n> sets the X position of the pen to coordinate n
setX and setY will move the draw pen without drawing a line. the program can't track pen movements from within draw commands.
setRED <n> set the red value of the 32 bit color
setGREEN <n> set the red value of the 32 bit color
setBLUE <n> set the red value of the 32 bit color
Circle <n> draw a circle of radius r , restricted to current color and the position established by setX and setY commands
PRINT will print all characters on the line following the print command to the coordinated set by setX and setY.
editor commands (not embedded in the saved code)
back goes back one code step erasing that line of code
list to list the code
go or redraw to execute the entered code
save and load to save and load a text file and save it into the drawGO code.
Code: (Select All)
'drawGO v0.1
'
'a simple interpreter to evaluate draw commands with a little bit extra functionality.
'
Screen _NewImage(800, 500, 32)
'$dynamic
Dim c$(100), tt$(0)
Dim cred&, cgreen&, cblue&
Dim dklr As _Unsigned Long
Dim eklr As _Unsigned Long
cred& = 250
cgreen& = 250
cblue& = 250
dklr = _RGB32(cred&, cgreen&, cblue&)
eklr = _RGB32(250, 250, 250)
D$ = ""
n = 0
T$ = ""
varX = 400
varY = 250
Draw "bm400,250"
Do
If Len(a$) > 0 Then
n = n + 1
c$(n) = a$
End If
Draw a$
Line Input a$
If a$ = "cls" Then
Cls
a$ = ""
End If
If a$ = "redraw" Or a$ = "go" Then
Cls
varX = 400: varY = 250
Color eklr
dklr = _RGB32(250, 250, 250)
Draw "c" + Str$(_RGB32(250, 250, 250))
Draw "bm400,250"
For x = 1 To n
If LCase$(Left$(c$(x), 4)) = "call" Then 'processing CALL functions
a$ = Right$(c$(x), Len(c$(x)) - 4)
If Left$(a$, 6) = "circle" Then
B$ = Right$(a$, Len(a$) - 6)
r = Val(B$)
PSet Step(0, 0)
Circle Step(0, 0), r
End If
If Left$(a$, 5) = "print" Then
B$ = Right$(a$, Len(a$) - 5)
Color dklr
_PrintString (varX, varY), B$
Color eklr
n = n + 1
End If
If Left$(a$, 4) = "home" Then
Draw "bm" + Str$(varX) + "," + Str$(varY)
n = n + 1
End If
If LCase$(Left$(a$, 4)) = "setx" Then
B$ = _Trim$(Right$(a$, Len(a$) - 4))
varX = Val(B$)
Draw "bm" + Str$(varX) + "," + Str$(varY)
n = n + 1
End If
If LCase$(Left$(a$, 4)) = "sety" Then
B$ = _Trim$(Right$(a$, Len(a$) - 4))
varY = Val(B$)
Draw "bm" + Str$(varX) + "," + Str$(varY)
n = n + 1
End If
If LCase$(Left$(a$, 6)) = "setred" Then
B$ = _Trim$(Right$(a$, Len(a$) - 6))
cred& = Val(B$)
dklr = _RGB32(cred&, cgreen&, cblue&)
Draw "c" + Str$(_RGB32(cred&, cgreen&, cblue&))
n = n + 1
a$ = ""
End If
If LCase$(Left$(a$, 8)) = "setgreen" Then
B$ = _Trim$(Right$(a$, Len(a$) - 8))
cgreen& = Val(B$)
dklr = _RGB32(cred&, cgreen&, cblue&)
Draw "c" + Str$(_RGB32(cred&, cgreen&, cblue&))
n = n + 1
a$ = ""
End If
If LCase$(Left$(a$, 7)) = "setblue" Then
B$ = _Trim$(Right$(a$, Len(a$) - 7))
cblue& = Val(B$)
Draw "c" + Str$(_RGB32(cred&, cgreen&, cblue&))
Color dklr
n = n + 1
a$ = ""
End If
a$ = ""
Else
Draw c$(x)
End If
Next x
a$ = ""
End If
If a$ = "list" Then
Print "command list"
For x = 1 To n
Print x, c$(x)
Next
a$ = ""
End If
If a$ = "quit" Then
T$ = "quit"
a$ = ""
End If
If a$ = "clear all" Then
ReDim c$(100)
a$ = ""
n = 0
End If
If a$ = "back" Then
c$(n) = ""
n = n - 1
a$ = ""
End If
If Left$(a$, 6) = "circle" Then
B$ = Right$(a$, Len(a$) - 6)
r = Val(B$)
PSet Step(0, 0)
Circle Step(0, 0), r
n = n + 1
c$(n) = "CALL" + a$
a$ = ""
End If
If Left$(a$, 5) = "print" Then
B$ = Right$(a$, Len(a$) - 6)
_PrintString (varX, varY), B$
n = n + 1
c$(n) = "CALL" + a$
a$ = ""
End If
If Left$(a$, 5) = "join" Then
ReDim tt$(n)
tn = 1
For m = 1 To n
If Left$(c$(m), 4) <> "CALL" Then
If lst$ = "call" Then tn = tn + 1
tt$(tn) = tt$(tn) + c$(m)
lst$ = "draw"
Else
tn = tn + 1
tt$(tn) = c$(m)
lst$ = "call"
End If
Next m
ReDim c$(100)
For x = 1 To tn
c$(x) = tt$(x)
Next x
n = tn
a$ = ""
End If
If Left$(a$, 4) = "save" Then
B$ = _Trim$(Right$(a$, Len(a$) - 4))
Print B$
n = n + 1
c$(n) = "END"
Open B$ For Output As #1
For x = 1 To n
If c$(x) <> "" Then Write #1, c$(x)
Next x
Close #1
a$ = ""
End If
If Left$(a$, 4) = "load" Then
B$ = _Trim$(Right$(a$, Len(a$) - 4))
Open B$ For Input As #1
n = 0
Do
n = n + 1
Input #1, c$(n)
Loop Until c$(n) = "END"
Close #1
n = n - 1
a$ = ""
End If
If LCase$(Left$(a$, 4)) = "setx" Then
B$ = _Trim$(Right$(a$, Len(a$) - 4))
varX = Val(B$)
Draw "bm" + Str$(varX) + "," + Str$(varY)
n = n + 1
c$(n) = "CALL" + a$
a$ = ""
End If
If LCase$(Left$(a$, 4)) = "sety" Then
B$ = _Trim$(Right$(a$, Len(a$) - 4))
varY = Val(B$)
Draw "bm" + Str$(varX) + "," + Str$(varY)
n = n + 1
c$(n) = "CALL" + a$
a$ = ""
End If
If Left$(a$, 4) = "home" Then
n = n + 1
Draw "bm" + Str$(varX) + "," + Str$(varY)
c$(n) = "CALLhome"
a$ = ""
End If
If LCase$(Left$(a$, 7)) = "callcls" Then
n = n + 1
c$(n) = "CALLcls"
a$ = ""
End If
If LCase$(Left$(a$, 6)) = "setred" Then
n = n + 1
B$ = _Trim$(Right$(a$, Len(a$) - 6))
c$(n) = "CALLSETRED" + B$
cred& = Val(B$)
dklr = _RGB32(cred&, cgreen&, cblue&)
Draw "c" + Str$(_RGB32(cred&, cgreen&, cblue&))
a$ = ""
End If
If LCase$(Left$(a$, 8)) = "setgreen" Then
n = n + 1
B$ = _Trim$(Right$(a$, Len(a$) - 8))
c$(n) = "CALLSETGREEN" + B$
cgreen& = Val(B$)
dklr = _RGB32(cred&, cgreen&, cblue&)
Draw "c" + Str$(_RGB32(cred&, cgreen&, cblue&))
a$ = ""
End If
If LCase$(Left$(a$, 7)) = "setblue" Then
n = n + 1
B$ = _Trim$(Right$(a$, Len(a$) - 7))
c$(n) = "CALLSETBLUE" + B$
cblue& = Val(B$)
dklr = _RGB32(cred&, cgreen&, cblue&)
Draw "c" + Str$(_RGB32(cred&, cgreen&, cblue&))
a$ = ""
End If
If Left$(a$, 4) = "help" Then
Cls
Print "HELP"
Print "================="
Print "edit commands"
Print "================="
Print "join compress code by joinign code line that only contain draw statements"
Print "save saves code to a file name"
Print "load load code from a file name"
Print "print print text at varX,varY"
Print "cls clear the screen"
Print "back step back and erase last line of code"
Print "list list program code"
Print "redraw or go to execute code"
Print ""
Print "Command words"
Print "==============================="
Print "setX set the value of X"
Print "setY set the value of Y"
Print "circle n draw a circle with a radius of numerical value n at current position"
Print "home sets the draw postions to varX and VarY"
Print "<draw commands> supports all draw commands"
Print "setred n set red value to n"
Print "setgreen n set green value to n"
Print "setblue n set blue value to n"
Print "CALLcls call cls from code"
a$ = ""
End If
Loop Until T$ = "quit"
Print
Print "command list"
For x = 1 To n
Trying to make my in house harvest database more usable for the non-technical members of my family, I came up with a GUI number pad for entering weight and moisture test data. The original was heavily dependent on my growing library of routines, but I incorporated all those into a single function to make it a little more universal for others to use. It will accept mouse click or keyboard input interchangeably. Numbers, period, enter or backspace are accepted.
Although it is for a 32 bit screen, it accepts LOCATE position data, in the row/column order as the second and third parameter. The first parameter sends a true if a floating point number is required, and a false if an integer is required by disabling the period input. It leaves the data echoed at the entry point.
Code: (Select All)
'OldMoses' number pad input subroutine - no sub/function dependencies
SCREEN _NEWIMAGE(1024, 512, 32)
CONST true = -1
CONST false = 0
DO
CLS
FOR x% = 0 TO 1024 STEP 64
LINE (0, x%)-(1023, x%), &H7F7F7F7F
LINE (x%, 0)-(x%, 511), &H7F7F7F7F
NEXT x%
LOCATE 4, 1
PRINT ">>>"
row% = 4: col% = 4
num! = Number_Pad(true, row%, col%)
LOCATE row%, col%
PRINT num!
IF num! <> 0 THEN
LOCATE 24, 5
PRINT "number @ 24,20>"
num2! = Number_Pad(true, 24, 20)
LOCATE 24, 20
PRINT num2!
'LOCATE 15, 15
'PRINT "number @ 15,30>"
x1% = INT(RND * 100) + 1
y1% = INT(RND * 30) + 1
num3& = Number_Pad(false, y1%, x1%)
LOCATE y1%, x1%
PRINT num3&
SLEEP
END IF
LOOP UNTIL num! = 0
END
'Description:
'Display a number pad at upper left (xpos, ypos) position
'Set flt to -1 to enable floating point, 0 to disable
FUNCTION Number_Pad (flt AS INTEGER, ypos AS INTEGER, xpos AS INTEGER)
backimg& = _COPYIMAGE(0) ' copy screen before number pad draw
pm% = _PRINTMODE ' get prior printmode state
c~& = &HFFAFAFAF ' set button color
_PRINTMODE _KEEPBACKGROUND
si% = _SHL(xpos, 3) ' set in position from left edge
sd% = _SHL(ypos, 4) ' set down position from top edge
IF sd% + 216 > _HEIGHT(0) THEN ' keep within screen limits, set vertical adjust & vertical offset
sd% = sd% - 216
va% = 200: vo% = 208
ELSE
va% = -16: vo% = -8
END IF
lb$ = "789456123.0E" ' button label characters
IF flt THEN al$ = "0123456789." ELSE al$ = "0123456789" ' allowable if float or not float
df& = _DEFAULTCOLOR ' save default text color
COLOR &HFF000000 ' button label color black
FOR row% = 0 TO 3 ' button vertical ranks iteration
sdr% = sd% + row% * 50
FOR col% = 0 TO 2 ' button horizontal ranks iteration
ps% = ps% + 1
LINE (si% + col% * 50, sdr%)-(si% + 49 + col% * 50, sdr% + 49), c~&, BF
c = 0
FOR bb = 0 TO 12 ' SierraKen's button bevel
c = c + 100 / 12
LINE (si% + col% * 50 + bb, sdr% + bb)-(si% + 50 + col% * 50 - 1 - bb, sdr% + 50 - 1 - bb),_
_RGBA32(_RED32(c~&) - 100 + c, _GREEN32(c~&) - 100 + c, _BLUE32(c~&) - 100 + c, _ALPHA(c~&)), B
NEXT bb
_PRINTSTRING (si% + 21 + col% * 50, sdr% + 18), _TRIM$(MID$(lb$, ps%, 1)) 'button label
IF NOT flt AND ps% = 10 THEN
LINE (si% + col% * 50, sdr%)-(si% + col% * 50 + 50, sdr% + 50), &HAF000000, BF 'blank period
END IF
NEXT col%, row%
COLOR df&
DO ' Building number loop
LINE (si%, sd% + va%)-(si% + 150, sd% + va% + 16), &HFF0000FF, BF ' blue number echo field
LINE (si% + 125, sd% + va%)-(si% + 150, sd% + va% + 16), &HFF7F7F00, BF 'backspace arrow field
_PRINTSTRING (si% + 125, sd% + va%), "®®®" ' backspace indicator
_PRINTSTRING (si%, sd% + va%), num$ ' entry echo
k$ = INKEY$
IF k$ = CHR$(13) THEN ' enter pressed
in% = -1
ELSE
IF k$ <> "" THEN GOSUB addstring
k$ = ""
END IF
WHILE _MOUSEINPUT: WEND
IF _MOUSEBUTTON(1) THEN
DO UNTIL NOT _MOUSEBUTTON(1) ' Clear mouse button queue
WHILE _MOUSEINPUT: WEND ' to prevent multiple numbers / click
LOOP
IF ABS(_MOUSEY - (sd% + 25)) < 25 THEN ' within top button row
IF ABS(_MOUSEX - (si% + 25)) < 25 THEN k$ = "7": GOSUB addstring
IF ABS(_MOUSEX - (si% + 75)) < 25 THEN k$ = "8": GOSUB addstring
IF ABS(_MOUSEX - (si% + 125)) < 25 THEN k$ = "9": GOSUB addstring
ELSEIF ABS(_MOUSEY - (sd% + 75)) < 25 THEN ' within second button row
IF ABS(_MOUSEX - (si% + 25)) < 25 THEN k$ = "4": GOSUB addstring
IF ABS(_MOUSEX - (si% + 75)) < 25 THEN k$ = "5": GOSUB addstring
IF ABS(_MOUSEX - (si% + 125)) < 25 THEN k$ = "6": GOSUB addstring
ELSEIF ABS(_MOUSEY - (sd% + 125)) < 25 THEN ' within third button row
IF ABS(_MOUSEX - (si% + 25)) < 25 THEN k$ = "1": GOSUB addstring
IF ABS(_MOUSEX - (si% + 75)) < 25 THEN k$ = "2": GOSUB addstring
IF ABS(_MOUSEX - (si% + 125)) < 25 THEN k$ = "3": GOSUB addstring
ELSEIF ABS(_MOUSEY - (sd% + 175)) < 25 THEN ' within fourth button row
IF ABS(_MOUSEX - (si% + 25)) < 25 AND flt THEN k$ = ".": GOSUB addstring
IF ABS(_MOUSEX - (si% + 75)) < 25 THEN k$ = "0": GOSUB addstring
IF ABS(_MOUSEX - (si% + 125)) < 25 THEN in% = -1 'enter clicked
ELSEIF ABS(_MOUSEY - (sd% + vo%)) < 8 THEN ' withing number line/backspace row
IF ABS(_MOUSEX - (si% + 137)) < 12 THEN ' within backspace arrow in number line
IF LEN(num$) > 0 THEN num$ = LEFT$(num$, LEN(num$) - 1) 'if digits then remove least significant
END IF
END IF
END IF
_LIMIT 30
IF NOT _AUTODISPLAY THEN _DISPLAY ' display changes if in display mode
LOOP UNTIL in% ' loop until number entered
_PUTIMAGE , backimg& ' redisplay original screen
_FREEIMAGE backimg&
SELECT CASE pm% ' return to prior printmode
CASE 2: _PRINTMODE _ONLYBACKGROUND
CASE 3: _PRINTMODE _FILLBACKGROUND
END SELECT
Number_Pad = VAL(num$) ' return value
EXIT FUNCTION ' leave before gosub code
addstring:
IF k$ = CHR$(8) THEN ' if backspace pressed
IF LEN(num$) > 0 THEN num$ = LEFT$(num$, LEN(num$) - 1)
ELSE
IF INSTR(al$, k$) <> 0 THEN num$ = num$ + _TRIM$(k$) ' add number to string
END IF
k$ = ""
RETURN
END FUNCTION 'Number_Pad
f = _LoadFont("courbd.ttf", 128, "monospace")
f1 = _LoadFont("courbd.ttf", 32, "monospace")
_Font f1
One = TextToImage("1", f, Yellow, Transparent, 1)
Zero = TextToImage("0", f, Green, Transparent, 1)
Cliff = TextToImage(" ", f, BrickRed, BrickRed, 1)
w = _Width(One): h = _Height(One)
'Demo Shifting
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 0 To 6: DisplayImage Zero, 200 + w * i, 400 - h, 1, 1, 0, 1: Next
DisplayImage One, 200 + w * i, 400 - h, 1, 1, 0, 1
PCopy 0, 1
Color SkyBlue
_PrintString (10, 100), "First, let's show how bit sifting works."
_Delay Delay
PCopy 1, 0
_Font f
_PrintString (250, 100), "SHIFT!"
_Font f1
_Delay 1
Cls
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 0 To 5: DisplayImage Zero, 200 + w * i, 400 - h, 1, 1, 0, 1: Next
DisplayImage One, 200 + w * i, 400 - h, 1, 1, 0, 1
PCopy 0, 1
_PrintString (10, 100), "See how everything shifted left once?"
_Delay Delay
PCopy 1, 0
_PrintString (10, 100), "Of course, bytes need 8 bits!!"
_Delay Delay
PCopy 1, 0
_PrintString (10, 100), "Fill in the blank spot with 0..."
_Delay Delay
PCopy 1, 0
DisplayImage Zero, 200 + w * i + w, 400 - h, 1, 1, 0, 1
PCopy 0, 1
_Delay Delay
_PrintString (10, 100), "And we've now shifted once..."
_Delay Delay
PCopy 1, 0
_PrintString (10, 100), "Let's continue shifting!!!"
_Delay Delay
PCopy 1, 0
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For j = 4 To -2 Step -1
_Font f
_PrintString (250, 100), "SHIFT!"
_Font f1
_Delay 1
Cls
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 0 To j: DisplayImage Zero, 200 + w * i, 400 - h, 1, 1, 0, 1: Next
If j <> -2 Then DisplayImage One, 200 + w * i, 400 - h, 1, 1, 0, 1
For i = 5 To j Step -1: DisplayImage Zero, 200 + w * (i + 2), 400 - h, 1, 1, 0, 1: Next
_Delay Delay
Next
_PrintString (10, 100), "We've shifted everything to zero..."
_Delay Delay
Beep
rotate:
'Demo rotating
Cls
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 0 To 6: DisplayImage Zero, 200 + w * i, 400 - h, 1, 1, 0, 1: Next
DisplayImage One, 200 + w * i, 400 - h, 1, 1, 0, 1
PCopy 0, 1
Color SkyBlue
_PrintString (10, 100), "Now, let's see how we rotate."
_Delay Delay
PCopy 1, 0
_Font f
_PrintString (250, 100), "ROTATE!"
_Font f1
_Delay 1
Cls
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 1 To 6: DisplayImage Zero, 200 + w * i, 400 - h, 1, 1, 0, 1: Next
DisplayImage One, 200 + w * i, 400 - h, 1, 1, 0, 1
PCopy 0, 1
For j = 0 To 100
PCopy 1, 0
DisplayImage Zero, 200, 400 - h - j, 1, 1, 0, 1
_Delay .01
Next
_PrintString (10, 100), "Save the leftmost number."
_Delay Delay
Cls
_PrintString (10, 100), "shift the remaining values."
DisplayImage Zero, 200, 300 - h, 1, 1, 0, 1
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For j = 0 To w
Line (200, 400 - h)-Step(w * 8, h), Black, BF 'erase our old numbers
For i = 1 To 6: DisplayImage Zero, 200 + w * i - j, 400 - h, 1, 1, 0, 1: Next
DisplayImage One, 200 + w * i - j, 400 - h, 1, 1, 0, 1
_Delay .01
Next
_Delay Delay
Cls
_PrintString (10, 100), "move that saved number."
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 1 To 6: DisplayImage Zero, 200 + w * i - w, 400 - h, 1, 1, 0, 1: Next
DisplayImage One, 200 + w * i - w, 400 - h, 1, 1, 0, 1
For j = 0 To w * 7
Line (200, 300 - h)-Step(w * 8, 99), Black, BF 'erase our old numbers
DisplayImage Zero, 200 + j, 300 - h, 1, 1, 0, 1
_Delay .01
Next
For j = 0 To 99
Line (200 + w * 7, 300 - h + j)-Step(w, 99), Black, BF 'erase our old numbers
DisplayImage Zero, 200 + w * 7, 300 - h + j, 1, 1, 0, 1
_Delay .01
Next
Line (10, 100)-(1900, 200), Black, BF
PCopy 0, 1
_PrintString (10, 100), "Notice that rotation at work?"
_Delay Delay
PCopy 1, 0
_PrintString (10, 100), "Let's continue rotating!!!"
_Delay Delay
PCopy 1, 0
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For j = 4 To -1 Step -1
_Font f
_PrintString (250, 100), "ROTATE!"
_Font f1
_Delay 1
Cls
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 0 To j: DisplayImage Zero, 200 + w * i, 400 - h, 1, 1, 0, 1: Next
If j <> -2 Then DisplayImage One, 200 + w * i, 400 - h, 1, 1, 0, 1
For i = 5 To j Step -1: DisplayImage Zero, 200 + w * (i + 2), 400 - h, 1, 1, 0, 1: Next
_Delay Delay
Next
_Font f
_PrintString (250, 100), "ROTATE!"
_Font f1
_Delay 1
Cls
DisplayImage Cliff, 200, 400, 1, 1, 0, 1
For i = 0 To 6: DisplayImage Zero, 200 + w * i, 400 - h, 1, 1, 0, 1: Next
DisplayImage One, 200 + w * i, 400 - h, 1, 1, 0, 1
_Delay Delay
_PrintString (10, 100), "We've rotated back to start!!"
_Delay Delay
Cls
Print "See the difference?"
Print "One shifts the bits."
Print "One rotates the bits."
Print
Print "That's all there is to it!"
Color White
End
Function TextToImage& (text$, font&, fc&, bfc&, mode As _Byte)
'text$ is the text that we wish to transform into an image.
'font& is the handle of the font we want to use.
'fc& is the color of the font we want to use.
'bfc& is the background color of the font.
'Mode 1 is print forwards
'Mode 2 is print backwards
'Mode 3 is print from top to bottom
'Mode 4 is print from bottom up
'Mode 0 got lost somewhere, but it's OK. We check to see if our mode is < 1 or > 4 and compensate automatically if it is to make it one (default).
If mode < 1 Or mode > 4 Then mode = 1
dc& = _DefaultColor: bgc& = _BackgroundColor
D = _Dest
F = _Font
T2Idown = CsrLin: T2Iright = Pos(0)
If font& <> 0 Then _Font font&
If mode < 3 Then
'print the text lengthwise
w& = _PrintWidth(text$): h& = _FontHeight
Else
'print the text vertically
For i = 1 To Len(text$)
If w& < _PrintWidth(Mid$(text$, i, 1)) Then w& = _PrintWidth(Mid$(text$, i, 1))
Next
h& = _FontHeight * (Len(text$))
End If
TextToImage_temp& = _NewImage(w&, h&, 32)
TextToImage = TextToImage_temp&
_Dest TextToImage_temp&
If font& <> 0 Then _Font font&
Color fc&, bfc&
Select Case mode
Case 1
'Print text forward
_PrintString (0, 0), text$
Case 2
'Print text backwards
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
_PrintString (0, 0), temp$
Case 3
'Print text upwards
'first lets reverse the text, so it's easy to place
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
'then put it where it belongs
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(temp$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(temp$, i, 1)
Next
Case 4
'Print text downwards
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(text$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(text$, i, 1)
Next
End Select
_Dest D
Color dc&, bgc&
_Font F
Locate T2Idown, T2Iright
End Function
Sub DisplayImage (Image As Long, x As Integer, y As Integer, xscale As Single, yscale As Single, angle As Single, mode As _Byte)
'Image is the image handle which we use to reference our image.
'x,y is the X/Y coordinates where we want the image to be at on the screen.
'angle is the angle which we wish to rotate the image.
'mode determines HOW we place the image at point X,Y.
'Mode 0 we center the image at point X,Y
'Mode 1 we place the Top Left corner of oour image at point X,Y
'Mode 2 is Bottom Left
'Mode 3 is Top Right
'Mode 4 is Bottom Right
Dim px(3) As Integer, py(3) As Integer, w As Integer, h As Integer
Dim sinr As Single, cosr As Single, i As _Byte
w = _Width(Image): h = _Height(Image)
Select Case mode
Case 0 'center
px(0) = -w \ 2: py(0) = -h \ 2: px(3) = w \ 2: py(3) = -h \ 2
px(1) = -w \ 2: py(1) = h \ 2: px(2) = w \ 2: py(2) = h \ 2
Case 1 'top left
px(0) = 0: py(0) = 0: px(3) = w: py(3) = 0
px(1) = 0: py(1) = h: px(2) = w: py(2) = h
Case 2 'bottom left
px(0) = 0: py(0) = -h: px(3) = w: py(3) = -h
px(1) = 0: py(1) = 0: px(2) = w: py(2) = 0
Case 3 'top right
px(0) = -w: py(0) = 0: px(3) = 0: py(3) = 0
px(1) = -w: py(1) = h: px(2) = 0: py(2) = h
Case 4 'bottom right
px(0) = -w: py(0) = -h: px(3) = 0: py(3) = -h
px(1) = -w: py(1) = 0: px(2) = 0: py(2) = 0
End Select
sinr = Sin(angle / 57.2957795131): cosr = Cos(angle / 57.2957795131)
For i = 0 To 3
x2 = xscale * (px(i) * cosr + sinr * py(i)) + x: y2 = yscale * (py(i) * cosr - px(i) * sinr) + y
px(i) = x2: py(i) = y2
Next
_MapTriangle (0, 0)-(0, h - 1)-(w - 1, h - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(w - 1, 0)-(w - 1, h - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
Having been wondering what bit rotation would be good for and seeing that it has applications in cryptography, here's a quick and easy scrambler. It might even fend off NSA for a few pico-seconds.
You'll need the new release for this one to work.
Code: (Select All)
'simple rotate encryption demo - by OldMoses
CLS
INPUT "Type a phrase ", a$
INPUT "enter a password ", ky$
PRINT "original phrase"
PRINT a$
DIM b(LEN(a$)) AS _UNSIGNED _BYTE ' phrase array
DIM e(LEN(a$)) AS _UNSIGNED _BYTE ' encrypted array
DIM d(LEN(a$)) AS _UNSIGNED _BYTE ' decrypted array
DIM k(LEN(ky$)) AS _UNSIGNED _BYTE ' keyword array
FOR x% = 1 TO LEN(ky$) ' configure keyword
k(x%) = ASC(ky$, x%)
NEXT x%
i% = 0
FOR x% = 1 TO LEN(a$) ' encrypt
b(x%) = ASC(a$, x%)
i% = i% + 1
IF i% > UBOUND(k) THEN i% = 1
e(x%) = _ROR(b(x%), k(i%))
e$ = e$ + CHR$(e(x%))
NEXT x%
PRINT
PRINT "encrypted phrase"
PRINT e$
PRINT
INPUT "password ", ps$
DIM p(LEN(ps$)) AS _UNSIGNED _BYTE ' password array
FOR x% = 1 TO LEN(ps$) ' configure password
p(x%) = ASC(ps$, x%)
NEXT x%
i% = 0
FOR x% = 1 TO LEN(e$) ' decrypt
b(x%) = ASC(e$, x%)
i% = i% + 1
IF i% > UBOUND(p) THEN i% = 1
d(x%) = _ROL(b(x%), p(i%))
d$ = d$ + CHR$(d(x%))
NEXT x%
PRINT
PRINT "decrypted phrase"
PRINT d$
Creates randomly generated animations of alien worlds.
Code: (Select All)
' Planet View v0.1
'by James D. Jarvis
'creates animated views of randomly generated worlds
'
' press any key for a new planet, esc to quit
'
Screen _NewImage(800, 600, 32)
Dim Shared map&
Randomize Timer
map& = _NewImage(480, 360, 32)
cloud& = _NewImage(480, 360, 32)
Dim p As _Unsigned Long
Dim alpha$(24), con$(30), roman$(12)
For x = 1 To 24
Read alpha$(x)
Next x
For x = 1 To 30
Read con$(x)
Next x
For x = 1 To 12
Read roman$(x)
Next x
Do
_Limit 30
_Source map&
_Dest 0
Cls
Print planet$
For y = -r + 1 To r - 1
x1 = Sqr(r2 - y * y)
tv = (_Asin(y / r) + 1.5) / 3
For x = -x1 To x1
tu = (_Asin(x / x1) + 1.5) / 6
_Source map&
p = Point((xo + tu * gw) Mod gw, tv * gh)
PSet (x + xc, y + yc), p
Next x
Next y:
xo = xo + 1
co = co + 1.5
_Display
kk$ = InKey$
Loop Until kk$ <> ""
Loop Until kk$ = Chr$(27)
Data " Alpha","Beta","Gamma","Delta","Epsilon","Zeta"
Data "Eta"," Theta","Iota","Kappa","Lambda","Mu"
Data "Nu","Xi","Omicron 16","Pi","Rho","Sigma"
Data "Tau","Upsilon","Phi","Chi","Psi","Omega"
Data "Aries","Taurus","Gemini","Cancer","Leo","Virgo","Libra","Scorpio","Ophiuchus","Sagitarius"
Data "Capricorn","Pisces","Aquila","Cassiopeia"," Cygnus","Andromeda","Apus","Canis","Centaurus","Cetus"
Data "Corvus","Draco","Fornax","Hydraxis","Tyranus","Zecadus","Voltanis","Adromeda","Rigel","Zaris"
Data "I","II","III","IV","V","VI","VII","VIII","IX","X","XI","XII"
Sub makemap (m&)
Dim mcolor As _Unsigned Long
Dim sea As _Unsigned Long
Dim p As _Unsigned Long
Dim pp(4) As _Unsigned Long
Dim tklr(4, 3) As Long
_Source m&
_Dest m&
'Screen map&
mw = _Width
mh = _Height
rr& = Int(Rnd * 128 + 64)
bb& = Int(Rnd * 128 + 64)
gg& = Int(Rnd * 128 + 64)
mcolor = _RGB32(rr&, gg&, bb&)
Line (0, 0)-(mw, mh), mcolor, BF
mares = Int(Rnd * 60) - 30
icecap = Int(((Rnd * mh + Rnd * mh) / 2) / Int(1 + Rnd * 3))
For y = 0 To mh
For x = 0 To mw
cv = Int(1 + Rnd * 20) + Int(1 + Rnd * 21)
If y < (icecap + Rnd * 8) Then cv = Int(Rnd * 6)
If y > (mh - icecap + Rnd * 8) Then cv = Int(Rnd * 6)
Select Case cv
Case 1, 2, 3, 4
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), _RGB32(Int((rr& - Rnd * 24 + 255) / 2), Int((gg& - Rnd * 24 + 255) / 2), Int((bb& - Rnd * 24 + 255) / 2)), BF
Case 5
r = Int(2 + Rnd * 6)
For cr = 0 To r
Circle (x, y), cr, _RGB32(rr& + cr, gg& + cr, bb& + cr)
Next cr
Case 35
r = Int(2 + Rnd * 24)
For cr = 0 To r
Circle (x, y), cr, _RGB32(Int((rr& - Rnd * 24 + 187) / 2), Int((gg& - Rnd * 24 + 187) / 2), Int((bb& - Rnd * 24 + 187) / 2)), BF
Next cr
Case 9, 10, 11, 12
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), _RGB32(Int((rr& + 12 + Rnd * 64) / 2), Int((gg& + 8 + Rnd * 32) / 2), Int((bb& + 12 + Rnd * 4) / 2)), BF
Case 21
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), mcolor, BF
Case 35
Circle (x, y), Int(2 + Rnd * 6), _RGB32(Int((rr& - Rnd * 24 + 255) / 2), Int((gg& - Rnd * 24 + 255) / 2), Int((bb& - Rnd * 24 + 255) / 2)), BF
End Select
Next
Next
If mares > 0 Then
mbr& = Int((Rnd * 96 + rr&) / 2)
mbg& = Int((Rnd * 96 + gg&) / 2)
mbb& = Int((Rnd * 96 + bb&) / 2)
sea = _RGB32(mbr&, mbg&, mbb&)
For mm = 1 To mares
sx = Rnd * _Width * .75 + 42
sy = icecap * 2 + Rnd * (_Height - icecap * 3)
r = Int(12 + Rnd * 30)
rsqrd = r * r
my = -r
While my <= r
x = Sqr(rsqrd - my * my)
x1 = Int(Rnd * (r - Abs(x)))
x2 = Int(Rnd * (r - Abs(x)))
Line (sx - x - x1, sy + my)-(sx + x + x2, sy + my), sea, BF
If Rnd * 6 < 4.5 Then
For c = 0 To Int(1 + Rnd * x1) Step 0.5
Circle (sx - x - x1, sy + my), c, sea
Next c
End If
If Rnd * 6 < 4.5 Then
For c = 0 To x1 - (Rnd * 3) Step 0.5
Circle (sx + x + x2, sy + my), c, sea
Next c
my = my + 1
End If
Wend
Next mm
End If
bands = Int(Rnd * 39) - 32
If bands > 0 Then
bdiv = mh / bands
y = bands
For b = 1 To bands
y = y + bdiv - Rnd * 6 + Rnd * 6
tbr& = Int((Rnd * 256 + rr&) / 2)
tbb& = Int((Rnd * 256 + gg&) / 2)
tbg& = Int((Rnd * 256 + bb&) / 2)
thick = Int(7 + Rnd * 20)
Line (0, y)-(mw, y + thick), _RGB32(tbr&, tbb&, tbg&, Int(140 + Rnd * 80)), BF
For xn = 0 To thick
reps = Int(2 + Rnd * 5)
For breps = 1 To reps
Line (mw / 2 + Int(Rnd * mw / 2), y)-(mw, y + thick), _RGB32(tbr&, tbb&, tbg&, Int(140 + Rnd * 80)), BF
Next
Next xn
Line (0, y)-(mw, y + thick), _RGB32(200, 200, 200, Int(Rnd * 200 + 40)), BF
Next b
End If
'average the pixels
For y = 1 To mh - 1
For x = 1 To mw - 1
p = Point(x, y)
pp(1) = Point(x + 1, y)
pp(2) = Point(x - 1, y)
pp(3) = Point(x, y - 1)
pp(4) = Point(x, y + 1)
For n = 1 To 4
tklr(n, 1) = _Red32(pp(n))
tklr(n, 2) = _Green32(pp(n))
tklr(n, 3) = _Blue32(pp(n))
Next n
tr& = Int((_Red32(p) + tklr(1, 1) + tklr(2, 1) + tklr(2, 1) + tklr(2, 1)) / 5)
tg& = Int((_Green32(p) + tklr(1, 2) + tklr(2, 2) + tklr(2, 2) + tklr(2, 2)) / 5)
tb& = Int((_Blue32(p) + tklr(1, 3) + tklr(2, 3) + tklr(2, 3) + tklr(2, 3)) / 5)
PSet (x, y), _RGB32(tr&, tg&, tb&)
Next
Next
c = Int(1 + Rnd * 3)
a = Int(Rnd * 200)
If c = 1 Then 'cloud layer is extra blurry
For y = 1 To mh - 1
For x = 1 To mw - 1
p = Point(x, y)
pp(1) = Point(x + 1, y)
pp(2) = Point(x - 1, y)
pp(3) = Point(x, y - 1)
pp(4) = Point(x, y + 1)
For n = 1 To 4
tklr(n, 1) = _Red32(pp(n))
tklr(n, 2) = _Green32(pp(n))
tklr(n, 3) = _Blue32(pp(n))
Next n
tr& = Int((_Red32(p) + tklr(1, 1) + tklr(2, 1) + tklr(2, 1) + tklr(2, 1) + 512) / 7)
tg& = Int((_Green32(p) + tklr(1, 2) + tklr(2, 2) + tklr(2, 2) + tklr(2, 2) + 512) / 7)
tb& = Int((_Blue32(p) + tklr(1, 3) + tklr(2, 3) + tklr(2, 3) + tklr(2, 3) + 512) / 7)
PSet (x, y), _RGB32(tr&, tg&, tb&, Int((a + Rnd * 256) / 2))
Next
Next
End If
'fix the seam - not perfect but it gets it right now and again
For y = 1 To mh
mix = Int(5 + Rnd * 5)
p = Point(mw - mix, y)
PSet (mx, y), p
Next y
Do you like crossword puzzles? If so, how do we write them so that we can figure them out together, no matter what level of English (or any other language) we are at?
After all, we have one thing in common. Speech that everyone on this forum will understand. That speech is QB64 and QBasic. Keywords, metacommand names, and function names. We all know it. How well do you know QB64 statements?
I dropped the OpenGL commands.
The following program is inspired by Fugo's Words of Wonders Android game. I play it sometimes, so I thought - can to write this? And it succeeded. I did not deal with graphic orgies and effects. I was only interested in the principle, the keyboard clone, and the puzzle itself.
To the point. After starting, the first crossword will start. In the right part is the keyboard. Hover the mouse over the first letter of the word you want to insert into the crossword puzzle, press and hold the left mouse button and create the whole word by successively choosing the letters (command QB64). If the word is a valid command, it will appear in the crossword puzzle. If not used in the crossword, but is a valid command name (as to QB64 version 2.02), this word is counted among the premium words.
Don't know what to do? Click the letter H with the mouse. The program will reveal a random letter in the crossword!
I dont use $. So is possible using statements without $: STR, COMMAND...
This is the lighter part of the program. WoW files are made by an editor with a database, I will post that next time. Attached are the required crossword files and font file.
Code: (Select All)
'World of Words clone - A clone of the game for Android re-writed for Windows/Linux in qb64
'public version, english commented source code. Written by Petr Preclik, 09/2022
'program accept COMMAND$ parameter - wow file: if this source is compiled as WoW.exe and file with crossword (CrossWord.WoW) is in the same directory run it as: WoW.exe CrossWord.WoW
'crossword program A (it lets you solve WoW crosswords, it doesn't let you create them)
$NoPrefix
Title "Words of Wonders clone (inspired by Fugo original game for Android), modified to Qbasic/QB64 statements"
Dim Shared Kbd$ ' structure for wordcross
Type WoW
W As String * 23
Xpos As Unsigned Byte
Ypos As Unsigned Byte
O As Byte
End Type
Type HelpA ' structure for built-in Help function
Char As Unsigned Byte
V As Byte
End Type
Screen NewImage(1300, 1024, 32)
Fnt& = LoadFont("arialbd.ttf", 18, "bold")
Font Fnt&, 0
For GameLevels = 1 To 10 ' 10 WordCross for you
ReDim Shared Words(-1) As WoW ' own words in wordcross
ReDim Shared CW(24, 24) As Unsigned Byte, Orientation As Byte
ReDim Shared CorrectWords(0) As String
ReDim Shared HelpA(24, 24) As HelpA ' array for Help function, show which character can be displayed after help use
Orientation = 1 ' 1 = vertical, -1 = horizontal
If Command$ <> "" Then
WoWFileName$ = Command$
Else
If GameLevels < 10 Then in$ = "0" Else in$ = ""
WoWFileName$ = "CrossWord" + in$ + LTrim$(Str$(GameLevels)) + ".WoW"
End If
WoWLoad WoWFileName$ '
ReDim Shared Visible(UBound(words)) As Byte
Game = 0
' draw empty grid (just used cells!)
For sx = 0 To 23
For sy = 0 To 22
GPositionX = 10 + sx * 40
GPositionY = 50 + sy * 40
If CW(sx, sy) > 0 Then
Line (GPositionX - 19, GPositionY - 19)-(GPositionX + 19, GPositionY + 19), , B
'fill array for help function:
HelpA(sx, sy).Char = CW(sx, sy)
If HelpA(sx, sy).V = 0 Then HelpA(sx, sy).V = -1
End If
Next sy, sx
PCopy 0, 1
Do Until Game = 1
' test, if word, you try inserting to crossword is correct, or not
PCopy 1, 0
Correct = 0
BlickVal = 0
For test = 0 To UBound(words)
If UCase$(o$) = Trim$(Words(test).W) And Visible(test) = 1 Then BlickVal = test 'blick if user try inserting the same word twice
If UCase$(o$) = Trim$(Words(test).W) Then Visible(test) = 1
If Visible(test) = 1 Then Correct = Correct + 1 ' 'correct inserted words counter
Next
' print correct words to screen
For PrintCorrect = 0 To UBound(words)
If Visible(PrintCorrect) = 1 Then
WordX = Words(PrintCorrect).Xpos
WordY = Words(PrintCorrect).Ypos
WordO = Words(PrintCorrect).O
Word$ = Trim$(Words(PrintCorrect).W)
Select Case WordO
Case 1 ' vertical [Y]
posit = 0
For GY = GPositionY To GPositionY + 40 * NoCh Step 40
posit = posit + 1
PrintString (GPositionX - 8, GY - 8), Mid$(Word$, posit, 1)
HelpA(WordX, WordY + posit - 1).V = 1
Next
Case -1 ' horizontal [X]
posit = 0
For GX = GPositionX To GPositionX + 40 * NoCh Step 40
posit = posit + 1
PrintString (GX - 8, GPositionY - 8), Mid$(Word$, posit, 1)
HelpA(WordX + posit - 1, WordY).V = 1
Next
End Select
End If
Next
If BlickVal > 0 Then Blick BlickVal ' signaling in writing that this word is already here only happens after rendering all the already entered words in the puzzle
' Finding the premium word (i.e. the word that is valid but not in the puzzle)
If Len(o$) > 0 Then
For t = LBound(correctwords) To UBound(correctwords)
If Trim$(o$) = Trim$(CorrectWords(t)) Then PremiumWord = PremiumWord + 1: CorrectWords(t) = "": Exit For
Next
End If
PrintString (1100, 100), "Premium Words:" + Str$(PremiumWord)
' ----------------- HELP -------------------------
Xpos = 1100
Ypos = 130
' letters will be printed here, which are already with a help set as visibile
NoCh2 = 0
For sx = 0 To 23
For sy = 0 To 22
If HelpA(sx, sy).V = 1 Then
'spocitat graficke souradnice
GPositionX = 10 + sx * 40
GPositionY = 50 + sy * 40
PrintString (GPositionX - 8, GPositionY - 8), Chr$(HelpA(sx, sy).Char)
End If
If HelpA(sx, sy).V = -1 Then NoCh2 = NoCh2 + 1 ' count the number of still invisible letters
Next sy, sx
If mx > Xpos And mx < Xpos + 24 Then
If my > Ypos And my < Ypos + 32 Then
If lb = -1 Then HelpMe NoCh2: lb = 0
End If
End If
o$ = WoWKeyBoard$(Kbd$, 1100, 800)
Display
Limit 20
If Correct = UBound(words) + 1 Then
Sleep 2
CLS2
If Command$ <> "" Then
message$ = "Crossword from command line complete."
PrintString (Width / 2 - PrintWidth(message$) / 2, 376), message$: Display: Sleep 2: System
End If
Level = Level + 1
If Level < 10 Then message$ = "Level" + Str$(Level) + " done!" Else message$ = "Next Crosswords you can yourself making by Petr's CrossWords editor. Demo over."
PrintString (Width / 2 - PrintWidth(message$) / 2, 376), message$
Display
Sleep 2
Correct = 0
Kbd$ = ""
Game = 1
End If
PrintString (Width / 2 - PrintWidth(message$) / 2, 376), Space$(PrintWidth(message$))
Loop
Erase Words
ReDim CW(23, 22) As Unsigned Byte ' for own words in crossword
Kbd$ = ""
Next
End
Sub CLS2 ' CLS set not transparent background. CLS2 set transparent background, as if is NEWIMAGE created.
D = Dest
S& = Width(D) * Height(D) * PixelSize(D)
Dim m As MEM, C As Unsigned Long
m = MemImage(D)
C~& = &H00000000
MemFill m, m.OFFSET, S&, C~& As UNSIGNED LONG
MemFree m
End Sub
Sub HelpMe (Nch)
NoCh = Nch
If NoCh > 0 Then
' in the auxiliary field HELP (x,y), a letter is written to help the help display
ShowChar = Int((NoCh \ 2) * Rnd) + 1
If ShowChar > NoCh Then ShowChar = NoCh
For sx = 0 To 23
For sy = 0 To 22
If HelpA(sx, sy).V = -1 Then ShowChar = ShowChar - 1 ' count the number of still invisible letters
If ShowChar = 0 Then HelpA(sx, sy).V = 1: Exit For
Next sy, sx
End If
' it is still necessary to check whether help did not reveal the whole word. If so, it must be recorded
' the check will take place based on the sum of the cells in the HelpA field with a cell value of 1 according
' to the orientation of the entry in the Words field:
For WordCompleteControl = LBound(visible) To UBound(visible)
WordX = Words(WordCompleteControl).Xpos
WordY = Words(WordCompleteControl).Ypos
WordO = Words(WordCompleteControl).O
Word$ = Trim$(Words(WordCompleteControl).W)
WLen = Len(Word$)
HelpLen = 0
Select Case WordO
Case 1 ' check in vertical orientation (WordO = 1)
For T = WordY To WordY + WLen
If HelpA(WordX, T).V = 1 Then HelpLen = HelpLen + 1: CW(WordX, T) = HelpA(WordX, T).Char 'number of characters from the word that can be seen according to the HelpA field
Next T
If HelpLen = WLen Then ' the number of exposed characters is the same as the length of the word. Check if it is marked as resolved
Visible(WordCompleteControl) = 1
End If
Case -1 ' check in horizontal orientation (WordO = -1)
For T = WordX To WordX + WLen
If HelpA(T, WordY).V = 1 Then HelpLen = HelpLen + 1: CW(T, WordY) = HelpA(T, WordY).Char
Next T
If HelpLen = WLen Then ' the number of exposed characters is the same as the length of the word. Check if it is marked as resolved
'Beep
Visible(WordCompleteControl) = 1
End If
End Select
Next
KeyClear
Delay .3
End Sub
Sub Blick (i) ' it flashes written words when you enter the same word again
WordX = Words(i).Xpos
WordY = Words(i).Ypos
WordO = Words(i).O
Word$ = Trim$(Words(i).W)
GPositionX = 10 + WordX * 40
GPositionY = 50 + WordY * 40
NoCh = Len(Word$) - 1
Display
Select Case WordO
Case -1
bc& = BackgroundColor
For Warning = 1 To 50
posit = 0
For GX = GPositionX To GPositionX + 40 * NoCh Step 40
posit = posit + 1
PrintString (GX - 8, GPositionY - 8), Mid$(Word$, posit, 1)
Color , RGB32(255 - 4 * Warning)
Next
Display
Limit 20
Next
Color , RGB32(bc&)
Case 1
bc& = BackgroundColor
For Warning = 1 To 50
posit = 0
For GY = GPositionY To GPositionY + 40 * NoCh Step 40
posit = posit + 1
PrintString (GPositionX - 8, GY - 8), Mid$(Word$, posit, 1)
Color , RGB32(255 - 4 * Warning)
Next
Display
Limit 20
Next
Color , RGB32(bc&)
End Select
End Sub
Sub WoWLoad (file$)
' load WoW file to RAM
ff = FreeFile
If FileExists(file$) Then
Dim ID As String * 42
Dim B As Unsigned Byte
Open file$ For Binary As ff
Get ff, 1, ID$
If ID$ = "Petr's World of Words for QB64 file format" Then
Get ff, , B
Kbd$ = Space$(B)
Get ff, , Kbd$ ' keyboard characters
Get ff, , B ' counter of words in crossword
ReDim Words(B) As WoW
Get ff, , Words() ' load WoW structure array type
Close ff
' fill field CW using Words array
ReDim CW(23, 22) As Unsigned Byte
For LW = 0 To B
Select Case Words(LW).O
Case 1 ' vertical [Y]
wp = 0
For GY = Words(LW).Ypos To Words(LW).Ypos + Len(Trim$(Words(LW).W)) - 1
wp = wp + 1
CW(Words(LW).Xpos, GY) = Asc(Words(LW).W, wp)
Next
Case -1 ' horizontal [X]
wp = 0
For GX = Words(LW).Xpos To Words(LW).Xpos + Len(Trim$(Words(LW).W)) - 1
wp = wp + 1
CW(GX, Words(LW).Ypos) = Asc(Words(LW).W, wp)
Next
End Select
Next LW
Find Kbd$, CorrectWords()
' valid words must be deleted from the found words, so that only premium words remain in the
' CorrectWords field (not used in the quiz)
For EraseValid = LBound(CorrectWords) To UBound(CorrectWords)
For T = LBound(words) To UBound(words)
If Trim$(CorrectWords(EraseValid)) = Trim$(Words(T).W) Then CorrectWords(EraseValid) = ""
Next
Next
' delete blank spaces in the Correctwords field
Dim RW(0) As String
iRW = 0
For CutCorrectWords = LBound(correctwords) To UBound(correctwords)
If Trim$(CorrectWords(CutCorrectWords)) <> "" Then iRW = iRW + 1: ReDim Preserve RW(iRW) As String: RW(iRW) = CorrectWords(CutCorrectWords)
Next
ReDim CorrectWords(UBound(rw))
For reload = LBound(rw) To UBound(rw)
CorrectWords(reload) = RW(reload)
Next
Erase RW
Else
Print "File "; file$; " exists, but file has unknown format.": Display: Sleep 3: System
End If
Else
Print "File "; file$; " not found.": Display: Sleep 3: System
End If
End Sub
Function WoWKeyBoard$ (characters As String, Xpos, Ypos)
image& = CopyImage(0, 32)
NoC = Len(characters)
O = Pi(2) * NoC
Type WoWKbdType
char As Unsigned Byte
Xpos As Integer
Ypos As Integer
Act As Byte
End Type
Dim ch(1 To NoC) As WoWKbdType
Dim LI(1 To NoC) As Byte
For C = 1 To NoC
ch(C).char = Asc(characters, C)
Next
kStp = 360 / NoC
i = 0
p = 0
Do Until i = NoC
i = i + 1
angle = D2R(p)
ch(i).Xpos = Xpos + Cos(angle) * O
ch(i).Ypos = Ypos + Sin(angle) * O
PrintString (ch(i).Xpos, ch(i).Ypos), Chr$(ch(i).char)
p = p + kStp
Loop
Mouse mx, my, lb
PosInWord = 0
ii = 0
OldX = 0
OldY = 0
OldT = 0
If mx > Xpos - O - 32 And mx < mx + Xpos + O + 32 Then
If my > Ypos - O - 32 And my < my + Ypos + O + 32 Then
Do Until lb = 0
Mouse mx, my, lb
Line (Xpos - O - 32, Ypos - O - 32)-(Xpos + O + 32, Ypos + O + 32), &HFF000000, BF 'clear keyboard window
LIi = 2
For test = 1 To NoC
' block mouse cursor in keyboard window
Mouse mx, my, lb
ControlMx = MIN(mx, Xpos - O - 32)
ControlMx = MAX(ControlMx, Xpos + O + 32)
ControlMy = MIN(my, Ypos - O - 32)
ControlMy = MAX(ControlMy, Ypos + O + 32)
REM MouseMove ControlMx, ControlMy
mx = ControlMx
my = ControlMy
'-----------------------------
Status = CircleDetect(mx, my, ch(test).Xpos, ch(test).Ypos)
If Status = 1 Then
' test if it is not already registered
used = 0
u = 0
output$ = ""
LIindex = 0
For T = 1 To NoC
If ch(T).Act Then output$ = output$ + Chr$(ch(ch(T).Act).char)
PrintString (1100, 300), Space$(50)
PrintString (1100, 300), output$ ' ok, it shows the text continuously
If ch(T).Act = test Then
' lock the logic so that the character is sold only once in the chain, OK
used = 1
OldT = T
End If
' filter the positions of all used .ACT and paint the circle in one step
If ch(T).Act > 0 Then
' used letters are marked with a circle
Circle (ch(ch(T).Act).Xpos + 6, ch(ch(T).Act).Ypos + 8), 16, &H50FFFFFF
' the indexes numbers of all used letters are written in field LI
LIindex = LIindex + 1
LI(LIindex) = ch(T).Act
End If
Next T
' drawn LINE OK, this is for the case that the mouse is on the correct letter
If LIindex > 0 Then
Line (mx, my)-(ch(LI(LIindex)).Xpos, ch(LI(LIindex)).Ypos)
For AllChars = 1 To LIindex - 1
Line (ch(LI(AllChars)).Xpos, ch(LI(AllChars)).Ypos)-(ch(LI(AllChars + 1)).Xpos, ch(LI(AllChars + 1)).Ypos)
Next
End If
If used = 0 Then
If ii < NoC Then
ii = ii + 1
ch(ii).Act = test
used = 1
LockCh = 1
End If
End If
' deleting the last character
If ii > 1 And LockCh = 0 Then
If ch(ii - 1).Act = test Then
LockCh = 1
ch(ii).Act = 0
ii = ii - 1
End If
End If
Else
For T = 1 To NoC
If ch(T).Act > 0 Then
' used letters are marked with a circle even when the mouse is not in the detection zone
Circle (ch(ch(T).Act).Xpos + 6, ch(ch(T).Act).Ypos + 8), 16, &H50FFFFFF
End If
Next
' drawing a line between letters even if the mouse is outside the letter
If LIindex > 0 Then
Line (mx, my)-(ch(LI(LIindex)).Xpos, ch(LI(LIindex)).Ypos)
For AllChars = 1 To LIindex - 1
Line (ch(LI(AllChars)).Xpos, ch(LI(AllChars)).Ypos)-(ch(LI(AllChars + 1)).Xpos, ch(LI(AllChars + 1)).Ypos)
Next
End If
End If
Next test
LockCh = 0
' rendered keyboard letters
i = 0
p = 0
Do Until i = NoC
i = i + 1
angle = D2R(p)
ch(i).Xpos = Xpos + Cos(angle) * O
ch(i).Ypos = Ypos + Sin(angle) * O
PrintString (ch(i).Xpos, ch(i).Ypos), Chr$(ch(i).char)
p = p + kStp
Loop
PutImage , image&, 0
Display
Limit 20
Loop
End If
End If
FreeImage image&
WoWKeyBoard$ = output$
KeyClear
End Function
Sub Mouse (mx, my, lb)
While MouseInput
Wend
mx = MouseX
my = MouseY
lb = MouseButton(1)
End Sub
Function CircleDetect (x As Long, y As Long, cx As Long, cy As Long)
CircleDetect = 0
r& = 16
xy& = ((x& - cx&) ^ 2) + ((y& - cy&) ^ 2) 'Pythagorean theorem
If r& ^ 2 >= xy& Then CircleDetect = 1 Else CircleDetect = 0
End Function
Sub Find (ij$, a() As String) ' according to the keyboard character, finds valid words in the database (that is, those that can be written using the character from the keyboard)
i$ = ij$
ReDim Cache(0) As String
NoCh = Len(i$)
Restore database
For r = 1 To 420 ' 420 words (QB64 statements, metacommands and functions) in database
Read d$
If Len(d$) <= NoCh Then
Cache(ci) = d$
ci = ci + 1
ReDim Preserve Cache(ci) As String
End If
Next r
ReDim Preserve Cache(ci - 1) As String
' check characters
For l = 0 To ci - 1 ' go through the entire field of words
If IsValid(ij$, Cache(l)) Then
a(fi) = Cache(l)
fi = fi + 1
ReDim Preserve a(fi) As String
End If
Next
database:
'A 26 recs
Data "ACCEPTFILEDROP","ACOS","ACOSH","ALLOWFULLSCREEN","ALPHA","ALPHA32","ARCCOT","ARCCSC","ARCSEC","ASIN","ASINH","ASSERT","ASSERTS","ATAN2","ATANH","AUTODISPLAY","AXIS","ABS","ABSOLUTE","ACCESS","ALIAS","AND","APPEND","AS","ASC","ATN"
'B 14 recs
Data "BEEP","BINARY","BLOAD","BSAVE","BYVAL","BACKGROUNDCOLOR","BIT","BLEND","BLINK","BLUE","BLUE32","BUTTON","BUTTONCHANGE","BYTE"
'C 32+19 recs
Data "CALL","CASE","CHAIN","CHDIR","CHR","CINT","CIRCLE","CLEAR","CLNG","CLOSE","CLS","COLOR","COMMAND","COMMON","CONST","COS","CSNG","CSRLIN","CVD","CVDMBF","CVI","CVL","CVS","CVSMBF","CAPSLOCK","CHECKING","CEIL","CINP","CLEARCOLOR","CLIP","CLIPBOARD","CLIPBOARDIMAGE"
Data "COLOR","COMMANDCOUNT","CONNECTED","CONNECTIONADDRESS","CONSOLE","CONSOLEINPUT","CONSOLETITLE","CONTINUE","CONTROLCHR","COPYIMAGE","COPYPALETTE","COT","COTH","COSH","CSC","CSCH","CV","CWD"
'D 28+6 recs
Data "DATA","DATE","DECLARE","DEFDBL","DEFINT","DEFLNG","DEFSNG","DEFSTR","DIM","DO","DOUBLE","DRAW","DYNAMIC","D2G","D2R","DEBUG","DEFAULTCOLOR","DEFINE","DEFLATE","DELAY","DEPTHBUFFER","DESKTOPHEIGHT","DESKTOPWIDTH","DEST","DEVICE","DEVICEINPUT","DEVICES","DIR"
Data "DIREXISTS","DISPLAY","DISPLAYORDER","DONTBLEND","DONTWAIT","DROPPEDFILE"
'E 22 recs
Data "ELSE","ELSEIF","END","ENVIRON","ENVIRON","EOF","EQV","ERASE","ERL","ERR","ERROR","EXIT","EXP","ECHO","ENVIRONCOUNT","ERROR","ERRORLINE","ERRORMESSAGE","EXEICON"
'F 17 recs
Data "FIELD","FILES","FIX","FOR","FREE","FREEFILE","FUNCTION","FILEEXISTS","FINISHDROP","FLOAT","FONT","FONTHEIGHT","FONTWIDTH","FREEFONT","FREEIMAGE","FREETIMER","FULLSCREEN"
'G 7 recs
Data "GET","GOSUB","GOTO","G2D","G2R","GREEN","GREEN32"
'H 4 recs
Data "HEX","HEIGHT","HIDE","HYPOT"
'I 18 recs
Data "IF","IMP","INCLUDE","INKEY","INP","INPUT","INSTR","INT","INTEGER","INTERRUPT","INTERRUPTX","ICON","INCLERRORFILE","INCLERRORLINE","INFLATE","INSTRREV","INTEGER64"
'J 0 recs
'K 5 recs
Data "KEY","KILL","KEYCLEAR","KEYDOWN","KEYHIT"
'L 25 recs
Data "LBOUND","LCASE","LEFT","LEN","LET","LINE","LIST","LOC","LOCATE","LOCK","LOF","LOG","LONG","LOOP","LPOS","LPRINT","LSET","LTRIM","LASTAXIS","LASTBUTTON","LASTWHEEL","LIMIT","LOADFONT","LOADIMAGE","LOAD"
'M 28+6 recs
Data "MID","MKD","MKDIR","MKDMBF","MKI","MKL","MKS","MKSMBF","MOD","MAPTRIANGLE","MAPUNICODE","MEM","MEMCOPY","MEMELEMENT","MEMEXISTS","MEMFILL","MEMFREE","MEMGET","MEMIMAGE","MEMNEW","MEMPUT","MEMSOUND","MIDDLE","MK","MOUSEBUTTON","MOUSEHIDE","MOUSEINPUT","MOUSEMOVE"
Data "MOUSEMOVEMENTX","MOUSEMOVEMENTY","MOUSESHOW","MOUSEWHEEL","MOUSEX","MOUSEY"
'N 6 recs
Data "NAME","NEXT","NOT","NEWIMAGE","NOPREFIX","NUMLOCK"
'O 13 recs
Data "OCT","OFF","ON","OPEN","OR","OUT","OUTPUT","OFFSET","OPENCLIENT","OPENCONNECTION","OPENHOST","OPTION","OS"
'P 22 recs
Data "PAINT","PALETTE","PCOPY","PEEK","PLAY","PMAP","POINT","POKE","POS","PRESET","PRINT","PSET","PUT","PALETTECOLOR","PI","PIXELSIZE","PRESERVE","PRINTIMAGE","PRINTMODE","PRINTSTRING","PRINTWIDTH","PUTIMAGE"
'Q 0 recs
'R 30 recs
Data "RANDOM","RANDOMIZE","READ","REDIM","REM","RESET","RESTORE","RESUME","RETURN","RIGHT","RMDIR","RND","RSET","RTRIM","RUN","R2D","R2G","RED","RED32","READBIT","RESETBIT","RESIZE","RESIZE","RESIZEHEIGHT","RESIZEWIDTH","RGB","RGB32","RGBA","RGBA32","ROUND"
'S 26+22+23 recs
Data "SADD","SCREEN","SEEK","SELECT","SGN","SHARED","SHELL","SIN","SINGLE","SLEEP","SOUND","SPACE","SPC","SQR","STATIC","STEP","STICK","STOP","STR","STRIG","STRING","SUB","SWAP","SYSTEM"
Data "SCREENCLICK","SCREENEXISTS","SCREENHIDE","SCREENICON","SCREENIMAGE","SCREENMOVE","SCREENPRINT","SCREENSHOW","SCREENX","SCREENY","SCROLLLOCK","SETALPHA","SETBIT","SHELLHIDE","SHL","SHR","SINH","SNDBAL","SNDCLOSE","SNDCOPY"
Data "SNDGETPOS","SNDLEN","SNDLIMIT","SNDLOOP","SNDOPEN","SNDOPENRAW","SNDPAUSE","SNDPAUSED","SNDPLAY","SNDPLAYCOPY","SNDPLAYFILE","SNDPLAYING","SNDRATE","SNDRAW","SNDRAWDONE","SNDRAWLEN","SNDSETPOS","SNDSTOP","SNDVOL","SOURCE","STARTDIR","STRCMP","STRICMP"
'T 13 recs
Data "TAB","TAN","THEN","TIME","TIMER","TO","TYPE","TANH","TITLE","TOGGLEBIT","TOTALDROPPEDFILES","TRIM"
'U 5 recs
Data "UBOUND","UCASE","UNLOCK","UNTIL","UNSIGNED"
'V 5 recs
Data "VAL","VARPTR","VARSEG","VIEW"
'W 9 recs
Data "WAIT","WEND","WHILE","WIDTH","WINDOW","WRITE","WHEEL","WINDOWHANDLE","WINDOWHASFOCUS"
'X 1 rec
Data "XOR"
End Sub
Function IsValid (keyboard2$, database$) 'check if a character from keyboard2$ can be used to build the some word in database$ (if yes, return 1, otherwise return 0)
K$ = keyboard2$: W$ = database$
keyboard$ = K$
WordLenght = Len(W$)
Pass = 0
For test = 1 To Len(K$)
keyboard$ = Mid$(K$, test, 1)
Position = InStr(1, W$, keyboard$)
If Position > 0 Then W$ = Mid$(W$, 1, Position - 1) + Mid$(W$, Position + 1, Len(W$) - Position): Pass = Pass + 1
Next
If Pass = WordLenght Then IsValid = 1 Else IsValid = 0
End Function
Function MIN (variable, value)
If variable < value Then MIN = value Else MIN = variable
End Function
Function MAX (variable, value)
If variable > value Then MAX = value Else MAX = variable
End Function
Hi,
It looks like codepage 437 isn't quite the same as it was in MS-DOS back then.
I live in Belgium and there we have an AZERTY keyboard with the keys é (ASCII 233), è (ASCII 232), §çàùµ£€ etc. These are not displayed correctly.
I live in a region where these French characters are not really necessary, but the idea that it is not correct bothers me.
I've been messing around with the _MAPUNICODE unicode_code& TO ascii_code& statement but this didn't help.
The codes below (from the wiki page) are therefore probably not correct
'Microsoft_pc_cp437
199,252,233,226,228,224,229,231,234,235,232,239,238,236,196,197
201,230,198,244,246,242,251,249,255,214,220,162,163,165,8359,402
225,237,243,250,241,209,170,186,191,8976,172,189,188,161,171,187
9617,9618,9619,9474,9508,9569,9570,9558,9557,9571,9553,9559,9565,9564,9563,9488
9492,9524,9516,9500,9472,9532,9566,9567,9562,9556,9577,9574,9568,9552,9580,9575
9576,9572,9573,9561,9560,9554,9555,9579,9578,9496,9484,9608,9604,9612,9616,9600
945,223,915,960,931,963,181,964,934,920,937,948,8734,966,949,8745
8801,177,8805,8804,8992,8993,247,8776,176,8729,183,8730,8319,178,9632,160
QB64 has had _Shl and Shr for a while now, they are useful for quick multiply/divide by a power of 2, here'a factorial using only addition/subtraction and shifts
I can't think of a practical use for rol and ror
Code: (Select All)
Dim As _Integer64 N, b, c, p
Dim As Long i
For i = 0 To 20
N = i
c = N - 1
p = 1
While c > 0
p = 0
b = c
While b > 0
If b And 1 Then
p = p + N
End If
b = _ShR(b, 1)
N = _ShL(N, 1)
Wend
N = p
c = c - 1
Wend
Print i; "! = "; p
Next
witch=true/false] View/edit compiler settings
![[Image: wow.jpg]](https://i.ibb.co/BsBJqbY/wow.jpg)
