Do
Cls
For r = 0 To .45 * _Height Step 1
fcirc _Width / 2, _Height / 2, r, _RGB32(255, 255, 255, 5)
Next
a = a + d * .05
If Abs(a) < .05 Then
If d < 0 Then a = -.05
If d > 0 Then a = .05
End If
If a < -1 Then a = -1: d = 1
If a > 1 Then a = 1: d = -1
If a > 0 Then RotoZoom3 _Width / 2, _Height / 2, star&, a, 1, 0 Else RotoZoom3 _Width / 2, _Height / 2, s2&, a, 1, 0
_Display
_Limit 60
Loop Until _KeyDown(27)
Sub XmasStar (xc, yc, r1, r2, r3, c As _Unsigned Long)
a = _Pi(2 / 16)
For p = 0 To 200
p1 = p / 200
For i = 0 To 15
If i Mod 2 = 1 Then
x1 = xc + p1 * r1 * Cos(i * a): y1 = yc + p1 * r1 * Sin(i * a)
ElseIf i Mod 4 = 0 Then
x1 = xc + p1 * r3 * Cos(i * a): y1 = yc + p1 * r3 * Sin(i * a)
ElseIf i Mod 4 = 2 Then
x1 = xc + p1 * r2 * Cos(i * a): y1 = yc + p1 * r2 * Sin(i * a)
End If
If i > 0 Then Line (lastx, lasty)-(x1, y1), _RGB32(255 - (p1 * 192), 255 - (p1 * 192), c, 60) Else firstx = x1: firsty = y1
lastx = x1: lasty = y1
Next
Line (lastx, lasty)-(firstx, firsty), _RGB32(255 - (p1 * 192), 255 - (p1 * 192), c, 60)
Next
End Sub
Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single) ' 0 at end means no scaling of x or y
Dim px(3) As Single: Dim py(3) As Single
Dim W&, H&, sinr!, cosr!, i&, x2&, y2&
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation)
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 _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle _Seamless(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
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub Pause
If _KeyHit Then System Else _Delay 2: If _KeyHit Then System
End Sub
Sub Rotate (overtime As _Float, toWhat As _Integer64)
D = _Dest: S = _Source
A = _AutoDisplay
tempscreen = _CopyImage(_Display)
whichScreen = _CopyImage(_Display)
If toWhat >= 0 Then 'it's a color
_Dest whichScreen
Cls , toWhat
_Dest D
Else
_PutImage , toWhat, whichScreen
End If
scale! = 1
Do
scale! = scale! - .01
angle! = angle! + 3.6
Cls , 0
DisplayImage tempscreen, _Width / 2, _Height / 2, scale!, scale!, angle!, 0
_Limit 100## / overtime
_Display
Loop Until scale! <= 0
scale! = 0: angle! = 0
Do
scale! = scale! + .01
angle! = angle! - 3.6
Cls , 0
DisplayImage whichScreen, _Width / 2, _Height / 2, scale!, scale!, angle!, 0
_Limit 100## / overtime
_Display
Loop Until scale! >= 1
_Dest D: _Source S
If A Then _AutoDisplay
_PutImage , whichScreen, _Display
_FreeImage whichScreen
End Sub
Sub Squares (overTime As _Float, toWhat As _Integer64)
Static P(100) As Long
If P(0) = 0 And P(1) = 0 Then 'initialize our static array on the first run
For i = 0 To 100: P(i) = i: Next
End If
D = _Dest: S = _Source
A = _AutoDisplay
whichScreen = _CopyImage(_Display)
If toWhat >= 0 Then 'it's a color
_Dest whichScreen
Cls , toWhat
_Dest D
Else
_PutImage , toWhat, whichScreen
End If
For i = 0 To 100: Swap P(i), P(Rnd * 100): Next 'shuffle our restore order
w = _Width / 10
h = _Height / 10
For i = 0 To 100
x = P(i) \ 10
y = P(i) Mod 10
_PutImage (x * w, y * h)-Step(w, h), whichScreen, _Display, (x * w, y * h)-Step(w, h)
_Limit 100## / overTime
_Display
Next
_Dest D: _Source S
If A Then _AutoDisplay
_PutImage , whichScreen, _Display
_FreeImage whichScreen
End Sub
Sub Circles (overTime As _Float, toWhat As _Integer64)
Dim As _MEM M, M2, M3
Dim As _Offset count
Dim As _Unsigned Long KolorPoint
D = _Dest: S = _Source
A = _AutoDisplay: B = _Blend
tempScreen = _CopyImage(_Display)
whichScreen = _CopyImage(_Display)
tempCircleScreen = _CopyImage(_Display)
If toWhat >= 0 Then 'it's a color
_Dest whichScreen
Cls , toWhat
_Dest D
Else
_PutImage , toWhat, whichScreen
End If
M = _MemImage(tempCircleScreen)
M2 = _MemImage(whichScreen)
M3 = _MemImage(_Display)
_Dest tempCircleScreen: _Source tempCircleScreen
_DontBlend
For i = 1 To 1000
_PutImage , tempScreen, _Display
CircleFill Rnd * _Width, Rnd * _Height, _Width / 20, &H12345678&&
count = 0
$Checking:Off
Do
_MemGet M, M.OFFSET + count, KolorPoint
If KolorPoint = &H12345678&& Then
_MemGet M2, M2.OFFSET + count, KolorPoint
_MemPut M3, M3.OFFSET + count, KolorPoint
End If
count = count + 4
Loop Until count >= M.SIZE
_Limit 1000## / overTime
$Checking:On
_Display
Next
_Dest D: _Source S
If A Then _AutoDisplay
If B Then _Blend
_PutImage , whichScreen, _Display
_FreeImage tempScreen: _FreeImage whichScreen: _FreeImage tempCircleScreen
End Sub
Sub FadeTo (overTime As _Float, toWhat As _Integer64)
D = _Dest: S = _Source
A = _AutoDisplay
For i = 0 To 255
tempScreen = _CopyImage(_Display)
_Dest tempScreen
If toWhat >= 0 Then
r = _Red32(toWhat)
g = _Green32(toWhat)
b = _Blue32(toWhat)
alpha = _Alpha32(toWhat) / 255 * i
Cls , _RGBA32(r, g, b, alpha)
Else
_PutImage (0, 0)-(_Width, _Height), toWhat, tempScreen
_SetAlpha i
End If
tempHardwareScreen = _CopyImage(tempScreen, 33)
_PutImage , tempHardwareScreen
_Display
_Limit 255## / overTime
_FreeImage tempHardwareScreen
_FreeImage tempScreen
Next
_Dest D: _Source S
If toWhat > 0 Then
Line (0, 0)-(_Width, _Height), toWhat, BF
Else
_PutImage , toWhat, _Display
End If
If A Then _AutoDisplay
End Sub
Sub Transition (overTime As _Float, toWhat As _Integer64, Direction As Long)
'Direction is: 1 = Left, 2 = Right, 3 = Up, 4 = Down
If Direction < 1 Or Direction > 4 Then Exit Sub
D = _Dest: S = _Source
A = _AutoDisplay
tempScreen = _CopyImage(_Display)
whichScreen = _CopyImage(_Display)
If toWhat >= 0 Then 'it's a color
_Dest whichScreen
Cls , toWhat
_Dest D
Else
_PutImage , toWhat, whichScreen
End If
Select Case Direction
Case 1
For x = _Width To 0 Step -1
Cls , 0
_PutImage (0, 0)-(x, _Height), tempScreen, _Display, (_Width - x, 0)-(_Width, _Height)
_PutImage (x, 0)-(_Width, _Height), whichScreen, _Display, (0, 0)-(_Width - x, _Height)
_Limit _Width / overTime
_Display
Next
Case 2
For x = 0 To _Width
Cls , 0
_PutImage (x, 0)-(_Width, _Height), tempScreen, _Display, (0, 0)-(_Width - x, _Height)
_PutImage (0, 0)-(x, _Height), whichScreen, _Display, (_Width - x, 0)-(_Width, _Height)
_Limit _Width / overTime
_Display
Next
Case 3
For y = _Height To 0 Step -1
Cls , 0
_PutImage (0, y)-(_Width, _Height), whichScreen, _Display, (0, 0)-(_Width, _Height - y)
_PutImage (0, 0)-(_Width, y), tempScreen, _Display, (0, _Height - y)-(_Width, _Height)
_Limit _Height / overTime
_Display
Next
Case 4
For y = 0 To _Height
Cls , 0
_PutImage (0, y)-(_Width, _Height), tempScreen, _Display, (0, 0)-(_Width, _Height - y)
_PutImage (0, 0)-(_Width, y), whichScreen, _Display, (0, _Height - y)-(_Width, _Height)
_Limit _Height / overTime
_Display
Next
End Select
_Dest D: _Source S
If A Then _AutoDisplay
_FreeImage tempScreen
_FreeImage whichScreen
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub 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
Someone shared a video on Discord the other day showcasing some screen transitions, and I told them that I'd thought RhoSigma or Terry Ritchie had already did a whole series of those type things. Digging through my old archives, however, I couldn't seem to find any of them. Either I never saved a copy, or else I've misplaced what I saved, but at the end of the day, I didn't have any, so I took a few moments to write a few simple ones of my own.
FadeTo, Transition, Circle, Square -- all work with either color values or screen handles, so they're pretty flexible like that, and all are set so you can specify how long it takes to complete the swap from one screen to the next.
FadeTo fades one screen/color into focus over time.
Transition moves one screen left/right/up/down, while the second screen pushes it out of the way.
Circle uses either colored circles, or colored circle fragments of the second screen, to overwrite the first one.
Squares works similar to circle, except it uses square/rectangle segments of the second screen to overwrite the first one.
I'll probably add some more effects to these over time, but this seems like a nice starter package for folks to play around with. Come up with a couple of your own, and we'll package them all together into a nice library format that anyone could make use of it they wanted to.
Thought I'd say hello, since that's what I'm told I should do in the T.R. game programming tutorial. This will maybe be my fourth attempt at learning to program. Hopefully this time I'll make a breakthrough. Any suggestions as to how I should proceed to learn are appreciated. What brings me here again is that I got a game on Steam called Retro Gadget. The game involves using Lua to program certain gadgets you create. It reminded me of how much I disliked Python, and Lua seems very similar. It got me thinking about how I seemed to enjoy learning with QB64 as it seems to sort of explain how things work "under the hood". So I figured why not give it another shot. With a bit more knowledge, I can create the gadgets in that game and actually feel like I built them myself.
I'm writing some small tool handling files or folders. It should be able to accept wildcards.
And I programmed a -R argument to recurse.
The thing I'm struggling on is that f.e. an argument as "test*.*" is returned in COMMAND$ als separate files that are matching.
Is it possible to get this argument just as test*.* instead of many arguments? Especiallly when combing this with recursing, this behaviour makes it difficult to handle it so for a user it feels logically.
Often I need the "FPS" of QB64 text mode, the scroll speed or rather the drawing speed of TTF/OTF, when symbols are many the speed drops significantly.
This benchmark is simple and ... straightforward.
By adjusting (in fact doubling the X and Y) the canvas, it should report for 4K mode as well, currently it says the WPS for FullHD.
My main laptop reaches only 23 Wagons-Per-Second, grmbl:
The QB64 sourcecode and Windows binary in the attachment:
Here's a little program to adjust your color palette in SCREEN 0. Each palette can be saved for later editing. When saving the palette, a .BI file is also created for import into QB64 or QB64PE.
The program works with the mouse, partly also with the keyboard.
Good luck with it, let me know what you think.
Code: (Select All)
DefInt A-Z
Dim Shared RGB(0 To 47) As Integer ' Huidige kleurenpalet
Dim Shared oRGB(0 To 47) As Integer 'Oud kleurenpalet
Dim Shared Abc$(4, 6)
Dim Shared Bar$, PLinks$, PRechts$, Bestand$, Map$, ProgNaam$, Versie$, Ikke$
Dim Shared vKleur, Kleur
Terug:
Do
k$ = InKey$
Do While _MouseInput
x = _MouseX: y = _MouseY
If x >= 3 And x <= 97 And y >= 7 And y <= 18 Then ' Klik op de kleuren
If _MouseButton(1) Then
Do: td = _MouseInput: Loop While _MouseButton(1)
ZetKader Kleur, 0
r = Fix((y - 7) / 7) * 8: K = Fix((x - 3) / 12): Kleur = r + K
Color Kleur, 0: vKleur = Kleur
ZetKader Kleur, 1
ZetRGB Kleur
End If
Else If x >= 9 And x <= 92 And y >= 27 And y <= 35 Then ' Klik op de schuifbalken
If _MouseButton(1) Then ' Wijzig 1 kleur
'DO: td = _MOUSEINPUT: LOOP WHILE _MOUSEBUTTON(1)
r = Fix((y - 27) / 3): K = Fix((x * 255) / 83) - 27
RGB((Kleur * 3) + r) = K
_PaletteColor Kleur, _RGB32(RGB((Kleur * 3)), RGB((Kleur * 3) + 1), RGB((Kleur * 3) + 2))
ZetRGB Kleur
ElseIf _MouseButton(2) Then ' Wijzig alle kleuren samen
K = Fix((x * 255) / 83) - 27
For xx = 0 To 2: RGB((Kleur * 3) + xx) = K: Next
_PaletteColor Kleur, _RGB32(RGB((Kleur * 3)), RGB((Kleur * 3) + 1), RGB((Kleur * 3) + 2))
ZetRGB Kleur
End If
Else If y = 38 Then ' Klik op onderste balk
If _MouseButton(1) Then
x = _MouseX
If x >= 90 Then k$ = Chr$(27): Exit Do 'ESC
If x >= 1 And x <= 10 Then k$ = Chr$(0) + Chr$(59): Exit Do 'F1
If x >= 11 And x <= 21 Then k$ = Chr$(0) + Chr$(60): Exit Do 'F2
If x >= 22 And x <= 33 Then k$ = Chr$(0) + Chr$(61): Exit Do 'F3
If x >= 34 And x <= 45 Then k$ = Chr$(0) + Chr$(62): Exit Do 'F4
If x >= 46 And x <= 60 Then k$ = Chr$(0) + Chr$(63): Exit Do 'F5
If x >= 61 And x <= 89 Then k$ = Chr$(0) + Chr$(134): Exit Do 'F12
End If
End If
End If
End If
Loop
Loop Until k$ <> ""
MuisLos
Select Case k$
Case Chr$(27)
Cls: System
Case Chr$(0) + Chr$(59) 'F1=View
F1View
TekenScherm
Case Chr$(0) + Chr$(60) 'F2=New
F2New
Case Chr$(0) + Chr$(61) 'F3=Load
F3Load
Case Chr$(0) + Chr$(62) 'F4=Save
F4Save
Case Chr$(0) + Chr$(63) 'F5=Restore
F5Restore
Case Chr$(0) + Chr$(134) 'F12=About
F12About
End Select
k$ = "": MuisLos: GoTo Terug
Sub F1View
F1_scherm1:
ZetHoofding
b$ = String$(12, 219)
For r = 4 To 20
fc = 0
For k = 3 To 87 Step 12
Locate r, k: Color fc, 0: Print b$;: fc = fc + 1
Next
Next
For r = 21 To 36
fc = 8
For k = 3 To 87 Step 12
Locate r, k: Color fc, 0: Print b$;: fc = fc + 1
Next
Next
fc = 8
For k = 3 To 87 Step 12
Locate 37, k: Color fc, 0: Print String$(12, 223);: fc = fc + 1
Next
r = 5: k = 7: Color 1, 7
For n = 0 To 15
Locate r, k: Print " "; Right$("0" + LTrim$(Str$(n)), 2); " ";
k = k + 12
If n = 7 Then k = 7: r = 22
Next
ZetInfo " Press ANY key for next screen", 1
a$ = AnyKey$
If a$ = Chr$(27) Then Exit Sub
F1_Scherm2:
ZetHoofding
r = 6: k = 4
For B = 0 To 15
Locate r, k: Color 7, 0
For f = 0 To 15
bc = B
fc = f
If B > 7 Then fc = fc Or 16
Color 7, 0: Print " ";
Color fc, bc: Print Right$(" " + Str$(fc), 2); ","; Right$(" " + Str$(bc), 2);
Next
r = r + 2
Next
Color 0, 3: A = 0: Locate 4, 2: Print Space$(98);
For k = 6 To 97 Step 6
Locate 4, k: Print Str$(A);: A = A + 1
Next
A = 0
For r = 5 To 36
Locate r, 2
If r And Not -2 Then
Print " ";
Else
Print Right$(" " + Str$(A), 2);: A = A + 1
End If
Next
ZetInfo " Press ANY key for next screen", 1
a$ = AnyKey$
If a$ = Chr$(27) Then Exit Sub
ZetHoofding
Color 15, 0: Locate 5, 2: Print "Foreground Color:";: Locate 13, 2: Print "Background Color:";
ZetKleurenbar 7: ZetKleurenbar 15
Center 36, "Move the mouse over the foreground and background colors to see the effect."
ZetInfo " Press ANY key for next screen, position the mouse over a color", 1
fc = 3: bc = 0: ofc = 3: obc = 0
GoSub F1_Terug1
eruit = 0
Do
k$ = InKey$
Do While _MouseInput
x = _MouseX: y = _MouseY
If x >= 3 And x <= 97 And y >= 7 And y <= 10 Then
'foreground color
fc = Fix((x - 3) / 6)
If bc > 7 Then fc = fc Or 16 Else If fc > 15 Then fc = fc - 16
End If
If x >= 3 And x <= 97 And y >= 15 And y <= 18 Then
'background color
bc = Fix((x - 3) / 6)
If bc > 7 Then fc = fc Or 16 Else If fc > 15 Then fc = fc - 16
End If
If y = 38 And _MouseButton(1) Then k$ = Chr$(27): Exit Do
If obc <> bc Or ofc <> fc Then GoSub F1_Terug1
Loop
Loop Until k$ <> ""
If k$ <> Chr$(27) Then GoTo F1_scherm1
Exit Sub 'ESC gedrukt
F1_Terug1:
Color 15, 0: Locate 5, 19: Print fc;: Locate 13, 19: Print bc;
Color fc, bc
For r = 21 To 34
Locate r, 1: Print Space$(100);
Next
For A = 1 To 26
Locate 23, 12 + (A * 2): Print Chr$(64 + A);
Locate 25, 12 + (A * 2): Print Chr$(96 + A);
Next
For A = 0 To 9
Locate 23, 68 + (A * 2): Print Chr$(48 + A);
Locate 25, 68 + (A * 2): Print Chr$(38 + A);
Next
Locate 27, 14: Print "ÚÄÄÂÄÄ¿ ÉÍÍËÍÍ»"
Locate 28, 14: Print "³ ³ ³ ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ º º º"
Locate 29, 14: Print "ÃÄÄÅÄÄ´ Û THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG Û ÌÍÍÎÍ͹"
Locate 30, 14: Print "³ ³ ³ ÛÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÛ º º º"
Locate 31, 14: Print "ÀÄÄÁÄÄÙ ÈÍÍÊÍͼ"
Locate 33, 14: Print " °°°±±±²²²ÛÛÛ the quick brown fox jumps over the lazy dog ÛÛÛ²²²±±±°°°"
obc = bc: ofc = fc
Return
End Sub
Sub F2New
MuisLos
ZetKader vKleur, 0
For A = 0 To 15
red = Int(Rnd * 256)
green = Int(Rnd * 256)
blue = Int(Rnd * 256)
RGB(A * 3) = red
RGB((A * 3) + 1) = green
RGB((A * 3) + 2) = blue
_PaletteColor A, _RGB32(red, green, blue)
Next
Kleur = 0: vKleur = 0
ZetKader Kleur, 1
ZetRGB Kleur
End Sub
Sub F3Load
Bestand$ = "": MuisLos
Bestand$ = _OpenFileDialog$("Open File", "", "*.pal", "Palette files", -1)
If Bestand$ <> "" Then
' Lees file in + toepassen
ff = FreeFile
Open Bestand$ For Input As #ff
For A = 0 To 47: Input #ff, RGB(A): Next
Close ff
For A = 0 To 15
red = RGB(A * 3)
green = RGB((A * 3) + 1)
blue = RGB((A * 3) + 2)
_PaletteColor A, _RGB32(red, green, blue)
Next
Kleur = 0: vKleur = 0
ZetKader Kleur, 1
ZetRGB Kleur
_MessageBox "Information", "File " + Bestand$ + " loaded."
End If
End Sub
Sub F4Save
Bestand$ = "": MuisLos
Bestand$ = _SaveFileDialog$("Save File", "", "*.pal", "Palette files")
If Bestand$ <> "" Then
'Bewaar als .PAL bestand
ff = FreeFile
Open Bestand$ For Output As #ff
For A = 0 To 47: Print #ff, RGB(A): Next
Close ff
'Bewaar als .BI bestand
Bestand1$ = Bestand$ + ".BI": t$ = ""
ff = FreeFile
Open Bestand1$ For Output As #ff
Print #ff, ";"
Print #ff, "; Use this file in your BASIC program."
Print #ff, "; You can edit the colors in 'Palette', a Palette Editor written by " + Ikke$ + "."
Print #ff, ";"
For A = 0 To 15
red = RGB(A * 3)
green = RGB((A * 3) + 1)
blue = RGB((A * 3) + 2)
t$ = "_PaletteColor" + Str$(A) + ", _RGB32(" + Str$(red) + "," + Str$(green) + "," + Str$(blue) + ")"
Print #ff, t$
Next
Close ff
_MessageBox "Information", "File will be saved to " + Bestand$ + " (for use with this program)" + Chr$(10) + Chr$(13) + "and is saved to " + Bestand1$ + " to import in your program."
End If
End Sub
Sub F5Restore
ZetKader vKleur, 0
For A = 0 To 47
RGB(A) = oRGB(A)
Next
For A = 0 To 15
red = RGB(A * 3)
green = RGB((A * 3) + 1)
blue = RGB((A * 3) + 2)
_PaletteColor A, _RGB32(red, green, blue)
Next
Kleur = 0: vKleur = 0
ZetKader Kleur, 1
ZetRGB Kleur
MuisLos
End Sub
Sub F12About
MuisLos
'Normale kleuren herstellen
For A = 0 To 15
red = oRGB(A * 3)
green = oRGB((A * 3) + 1)
blue = oRGB((A * 3) + 2)
_PaletteColor A, _RGB32(red, green, blue)
Next
Color 7, 0: Cls
For r = 0 To 4
For k = 0 To 6
Locate r + 11, 24 + (k * 8)
For t = 1 To 7
c$ = Mid$(Abc$(r, k), t, 1)
If c$ = Chr$(222) Then Color 8, 0 Else Color 9 + k, 0
Print c$;
Next
Print " ";
Next
Next
Color 15, 0: Center 17, ProgNaam$ + ", version " + Versie$
Center 18, "Written by " + Ikke$ + ", Bruges, Belgium"
Color 7, 0: Center 23, "Palette was developed in QB64. To save or read the files I wanted to use the"
Center 24, "standard Windows Open/Save interface. Therefore, the project was continued in QB64PE."
Center 25, "The reason was also that I suddenly didn't feel like programming everything"
Center 26, "with retrieving files etc. I have no idea if this program will ever be used,"
Center 27, "but I had fun programming it again."
Center 28, "The design of the screens was done in advance with Moebius, an ANSI and ASCII Editor."
Center 31, "Press [S] to switch between fullscreen or window"
Center 32, "Settings are saved in " + _CWD$ + "\palette.cfg"
Color 14, 0: Center 38, "Press ANY key to continue..."
a$ = AnyKey$
If a$ = "s" Or a$ = "S" Then
If _FullScreen = 0 Then
_FullScreen _Stretch , _Smooth
Else
_FullScreen _Off
End If
ff = FreeFile
Open _CWD$ + "\palette.cfg" For Output As #ff
Print #ff, _FullScreen
Close ff
End If
'Naar huidig palet
For A = 0 To 15
red = RGB(A * 3)
green = RGB((A * 3) + 1)
blue = RGB((A * 3) + 2)
_PaletteColor A, _RGB32(red, green, blue)
Next
TekenScherm
ZetKader Kleur, 1
ZetRGB Kleur
MuisLos
End Sub
Sub ZetKader (co, t)
'
' Teken kader rond kleur
' co = kleur
' t = 0: spaties, anders dubbele lijn
'
sKleur = co
If sKleur < 8 Then r = 6 Else r = 13: sKleur = sKleur - 8
K = Fix(sKleur * 12) + 3
Locate r, K: Color 7, 0
If t = 0 Then
Print Space$(12);
Locate r + 6, K: Print Space$(12);
Else
Print Chr$(201); String$(10, 205); Chr$(187);
Locate r + 6, K: Print Chr$(200); String$(10, 205); Chr$(188);
End If
For A = r + 1 To r + 5
Locate A, K
If t = 0 Then
Print " ";: Locate A, K + 11: Print " ";
Else
Print Chr$(186);: Locate A, K + 11: Print Chr$(186);
End If
Next
Color Kleur, 0
For r = 21 To 25
Locate r, 28: Print String$(49, 219);
Next
End Sub
Sub TekenScherm
'
' Teken het hoofdscherm
'
ZetHoofding
Color 7, 0
Center 4, "Click with the mouse on the color, then you can change the color with the 3 sliders."
Center 5, "Use the right mouse button to move all sliders together."
For r = 7 To 11
c = 0
For K = 4 To 98 Step 12
Locate r, K: Color c, 0: Print String$(10, 219);
c = c + 1
Next
Next
For r = 14 To 18
c = 8
For K = 4 To 98 Step 12
Locate r, K: Color c, 0: Print String$(10, 219);
c = c + 1
Next
Next
Color 15, 0: Locate 28, 2: Print " Red";: Locate 31, 2: Print "Green";: Locate 34, 2: Print " Blue";
Color 7, 0
For r = 28 To 34 Step 3
Locate r, 8: Print Chr$(204); String$(84, 205); Chr$(185); " 123 "; Chr$(186);
Locate r - 1, 93: Print Chr$(201); String$(5, 205); Chr$(187);
Locate r + 1, 93: Print Chr$(200); String$(5, 205); Chr$(188);
Next
Locate 20, 27: Print Chr$(218); String$(49, 196); Chr$(191);
For r = 21 To 25
Locate r, 27: Print Chr$(179); Space$(49); Chr$(179);
Next
Locate 26, 27: Print Chr$(192); String$(49, 196); Chr$(217);
ZetInfo " #F1#=View + #F2#=RND + #F3#=Load + #F4#=Save + #F5#=Restore + #F12#=About", 0
End Sub
Sub ZetHoofding
Color 7, 0: Cls
Color 0, 7: Print String$(100, 223);
Locate 2, 1: Print Space$(100);: Locate 2, 39: Color 1, 7: Print "*** P A L E T T E ***";
Locate 3, 1: Color 0, 7: Print String$(100, 220);
End Sub
Sub LeesRGB
'
' Lees huidig kleurenpalet en plaats ze in RGB() en in oRGB()
'
For c& = 0 To 15
value32& = _PaletteColor(c&, 0) 'sets color value to read of an image page handle.
red% = _Red32(value32&)
green% = _Green32(value32&)
blue% = _Blue32(value32&)
RGB(c& * 3) = red%: RGB((c& * 3) + 1) = green%: RGB((c& * 3) + 2) = blue%
oRGB(c& * 3) = red%: oRGB((c& * 3) + 1) = green%: oRGB((c& * 3) + 2) = blue%
Next
End Sub
Sub ZetRGB (sKleur)
'
' Zet de RGB kleuren nummers op scherm en pas de schuifbars aan
'
Color 7, 0: Kl = sKleur * 3
Locate 28, 94: Print " ";: Locate 28, 94: Print Str$(RGB(Kl));
Locate 31, 94: Print " ";: Locate 31, 94: Print Str$(RGB(Kl + 1));
Locate 34, 94: Print " ";: Locate 34, 94: Print Str$(RGB(Kl + 2));
Color 7, 0: Locate 28, 9: Print String$(84, 205);: Color 15, 0: Locate 28, 9 + Fix((RGB(Kl) / 256) * 84): Print Chr$(219);
Color 7, 0: Locate 31, 9: Print String$(84, 205);: Color 15, 0: Locate 31, 9 + Fix((RGB(Kl + 1) / 256) * 84): Print Chr$(219);
Color 7, 0: Locate 34, 9: Print String$(84, 205);: Color 15, 0: Locate 34, 9 + Fix((RGB(Kl + 2) / 256) * 84): Print Chr$(219);
End Sub
Sub ZetInfo (t$, l)
'
' Zet info op onderste rij
' t$= string met commando's
' # switch van zwart naar rood
' + scheidingsbar plaatsen (ascii nr 221)
' tekst = tekst
' l = 0: op kolom 90 komt | ESC=Quit
' l = 1: op kolom 90 komt | ESC=Back
'
zko = 1 'kolom
zkl = 0 'kleur
Locate 38, 1: Color 0, 3: Print Space$(89); Bar$; " ";: Color 4, 3: Print "ESC";: Color 0, 3
If l = 0 Then Print "=Quit "; Else Print "=Back ";
For A = 1 To Len(t$)
Locate 38, zko
c$ = Mid$(t$, A, 1)
If c$ = "+" Then c$ = Chr$(221)
If c$ = "#" Then If zkl = 0 Then zkl = 4 Else zkl = 0
If c$ <> "#" Then Color zkl, 3: Print c$;: zko = zko + 1
Next
End Sub
Sub ZetKleurenbar (rij)
For r = rij To rij + 3
zKL = 0
For k = 4 To 94 Step 6
Locate r, k: Color zKL, 0: Print String$(4, 219);
zKL = zKL + 1
Next
Next
End Sub
Sub Center (rij, txt$)
Locate rij, 50 - (Len(txt$) \ 2): Print txt$;
End Sub
Sub LeesABC
Dim xyz$(5)
xyz$(0) = "1222222122222212200001222222122222212222221222222"
xyz$(1) = "1220122122012212200001220000001220000122001220000"
xyz$(2) = "1222222122222212200001222200001220000122001222200"
xyz$(3) = "1220000122012212200001220000001220000122001220000"
xyz$(4) = "1220000122012212222221222222001220000122001222222"
xyz$(5) = "1120029906042100041719150011041919040112100120122"
Versie$ = "1.0": ProgNaam$ = "": Ikke$ = ""
For r = 0 To 4
For k = 1 To Len(xyz$(r))
c$ = Mid$(xyz$(r), k, 1)
If c$ = "0" Then c$ = Chr$(32)
If c$ = "1" Then c$ = Chr$(222)
If c$ = "2" Then c$ = Chr$(219)
Mid$(xyz$(r), k, 1) = c$
Next
Next
For r = 0 To 4
For k = 1 To 43 Step 7
Abc$(r, Fix((k - 1) / 7)) = Mid$(xyz$(r), k, 7)
Next
Next
c$ = "": r = 0
For a = 1 To 11
If a = 1 Or a = 5 Then r = 65 Else r = 97
c$ = c$ + Chr$(r + Val(Mid$(xyz$(5), (a * 2) - 1, 2)))
Next
Mid$(c$, 4, 1) = " ": Ikke$ = c$
c$ = "": r = 0
For a = 1 To 7
If a = 1 Then r = 65 Else r = 97
c$ = c$ + Chr$(r + Val(Mid$(xyz$(5), 21 + (a * 2), 2)))
Next
ProgNaam$ = c$
For r = 0 To 4
For k = 0 To 6
Locate r + 13, 24 + (k * 8)
For t = 1 To 7
c$ = Mid$(Abc$(r, k), t, 1)
If c$ = Chr$(222) Then Color 8, 0 Else Color 9 + k, 0
Print c$;
Next
Print " ";
Next
Next
'*** fullscreen?
a$ = _CWD$ + "\palette.cfg"
If _FileExists(a$) Then
ff = FreeFile
Open a$ For Input As #ff
Input #ff, r
Close ff
If r <> 0 Then
_FullScreen _Stretch , _Smooth
Else
_FullScreen _Off
End If
End If
_Title "*** " + ProgNaam$ + " ***"
Center 22, "*** " + ProgNaam$ + " ***"
Center 23, "Version " + Versie$
Center 24, "This is a VGA palette editor"
Center 25, "Written in 2022 by " + Ikke$
Center 38, "Press ANY key to start"
a$ = AnyKey$
End Sub
Sub MuisLos
Do While _MouseInput ' Check the mouse status
Do:
tmp = _MouseInput
Loop Until Not _MouseButton(1)
Loop
End Sub
Function AnyKey$ ()
MuisLos
Do
xx$ = InKey$
Do While _MouseInput
If _MouseButton(1) Then xx$ = " ": Exit Do
Loop
Loop Until xx$ <> ""
MuisLos
AnyKey$ = xx$
End Function
Sub elf (expression$)
If Val(Mid$(expression$, 3, 2)) < 26 Then SleighRide
End Sub
Sub SleighRide
Print "Paste your clipboard to your browser."
_Clipboard$ = "https://www.google.com/search?client=opera&q=sleigh+ride+song&sourceid=opera&ie=UTF-8&oe=UTF-8#fpstate=ive&vld=cid:95aee982.7113414d,vid:3oWbvWQcuPk,st:0"
Sleep 15
Cls
Print "Merry Christmas!"
End Sub
So... I had to one up it! Here's the new and improved "Steve(tm) Improved Pete.BAS"
Code: (Select All)
Screen Pete
_Title "Steve(tm) Improved Pete.BAS"
Randomize Timer
If Play(0) = 0 Then
Play "MBMNT210O3L4EEEP4EEEP4EGCDL1EL4FFFFFEEL8EEL4EDDEL2DL4G"
Play "P4O3L4EEEP4EEEP4EGCDL1EL4FFFFFEEL8EEL4GGFDL4CL1"
Play "MBMNT200O3L4CFL8FGFEL4DDDGL8GAGF"
Play "L4ECCAL8AB-AGL4FDL8CCL4DGEL2F"
Play "L4CFFFL2EL4EFEDL2CL4CAGF"
Play "O4L4CO3L4CL8CCL4DGEL2F"
Play "L4CFL8FGFEL4DDDGL8GAGFL4ECCAL8AB-AG"
Play "L4FDL8CCL4DGEL2F "
End If
Do
PlotChar "Xmas Pete"
_Limit 15
_Display
Loop Until _KeyHit
System
Sub PlotChar (text$)
Static tempScreen
If tempScreen = 0 Then tempScreen = _NewImage(8000, 100, 32)
d = _Dest: s = _Source
_Dest tempScreen
Cls , 0
Color , 0
Print text$;
_Source tempScreen
_Dest d
For i = 0 To Len(text$) - 1
a$ = Mid$(text$, i + 1, 1)
For y = 0 To 16
For x = 0 To 8
Color Int(Rnd * 16) + 16, Int(Rnd * 8)
Locate y + 5, i * 8 + x + 4
If Point(x + i * 8, y) Then Print a$;
Next
Next
Next
_Source s
End Sub
It's rude, it's crude, it's a classic that works most of the time.
X-Racer is a text mode racing game where you are in a timed trial to get to the finish line.
Avoid the barriers and the sides or you are going to crash. The game is key driven but doesn't wait for you to press the enter key for long.
space bar - to accelerate
< - turn (screen) left
> - turn (screen) right
b - to brake
(there's still a few problems with the code but if you don't explode at the start of the race you might be able to race to the end)
Code: (Select All)
'X-racer is an old school racing game using text graphics only
'press spacebar to get that engine going and < or > to steer b to brake!
_Title "X-RACER"
track$ = "####OOO................OOO####"
n = 13
trend = 0
obstacle = 10
Randomize Timer
Dim b$(2010)
Dim nn(2010)
start:
ask$ = "."
spd = 1
Do
Cls
For x = 1 To 2010
A$ = String$(n, 32)
b$(x) = A$ + track$
If x > 100 And x Mod obstacle Then
If Rnd * 100 < obstacle Then Mid$(b$(x), n + Int(3 + Rnd * 18), 1) = "O"
End If
n = n + Int(Rnd * 2) - Int(Rnd * 2) + trend
If n < 2 Then n = 2
If n > 35 Then n = 35
nn(x) = n
If Rnd * 100 < 3 Then
Select Case Int(Rnd * 3)
Case 0
trend = 0
Case 1
trend = -1
Case 2
trend = 1
End Select
End If
Next x
b$(1995) = A$ + "####O============O####"
b$(1991) = A$ + "####O============O####"
b$(1992) = A$ + "####O O####"
b$(1993) = A$ + "####O FINISH O####"
b$(1994) = A$ + "####O O####"
b$(1995) = A$ + "####O============O####"
For x = 1996 To 2010
b$(x) = A$ + "####O O####"
Next x
dp = nn(1) + 11
op = dp
For x = 1 To 2010
_Limit 20
If x > 10 Then Color 12: _PrintString (dp, 10), "X": Color 15
_PrintString (op, 9), "."
Print b$(x);
If x > 12 Then
If Mid$(b$(x - 13), dp, 1) = "O" Then GoTo crash
End If
op = dp
If x Mod 20 = 0 Then
Print " - "; x * 5
Else
Print
End If
If x > 10 Then
gg = 0
Do
_Limit 60
gg = gg + 1
kk$ = InKey$
Loop Until kk$ <> "" Or gg = 30 - spd
End If
If x = 12 Then t1 = Timer
Select Case kk$
Case ".", ">"
op = dp
dp = dp + 1
Case ",", "<"
op = dp
dp = dp - 1.
Case " "
spd = spd + 1
If spd > 28 Then spd = 28
Case "b"
spd = spd - 2
If spd < 1 Then spd = 1
End Select
mph$ = "MPH : " + Str$(spd * 10)
_PrintString (1, 2), mph$
Next x
t2 = Timer
Print
Print "Finished Course !"
Print
Print "Finish Time "; t2 - t1
Input "Play again (Y or N) ", ask$
ask$ = UCase$(ask$)
If ask$ = "N" Then GoTo alldone
Loop
End
crash:
For c = 1 To 6
_Limit 8
Color 12
For cx = dp - c To dp + c
For cy = 10 - c To c + 10
If Rnd * 6 < 3 Then _PrintString (cx, cy), "@"
Next cy
Next cx
Next c
Color 15
Print "YOU CRASHED"
Input "Play again (Y or N) ", ask$
ask$ = UCase$(ask$)
If ask$ = "N" Then GoTo alldone
GoTo start
alldone:
End
I'm off to a roaring start. Sure, I only have one keyword so far, CLS, but it works, flawlessly! Be sure to look it up in my Keyword for the Year blog.
One other consideration. PETE.BAS only runs on laptops and mobile devices. That's right, it's never PC!
