| 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: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Reading a single value from Registry (Win) |
|
Posted by: euklides - 06-05-2022, 03:51 PM - Forum: General Discussion
- Replies (1)
|
 |
I'm looking for a way to read a single value from the registry (Win).
This exemple lists recents files opened in CorelDRAW Home & Student
Program written in VBA Excel.
Is it possible to have something same in QB64 ???
Thank's for help.
'---VBA EXCEL PROG---
a$ = "HKEY_CURRENT_USER\Software\Corel\CorelDRAW Home & Student\18.0\PPHome\Application Preferences\Framework\RecentFiles"
MsgBox RegKeyRead(a$)
stop
'---
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object
On Error Resume Next
Set myWS = CreateObject("WScript.Shell")
RegKeyRead = myWS.RegRead(i_RegKey)
End Function
'---
|
|
|
| Digital Cube |
|
Posted by: SierraKen - 06-04-2022, 10:28 PM - Forum: Programs
- No Replies
|
 |
![[Image: Sierraken-s-Digital-Cube.jpg]](https://i.ibb.co/r633tvW/Sierraken-s-Digital-Cube.jpg)
Was playing with SIN and COS again today and came across a cool color-changing layered cube that changes from strange lines to fuzzy pixels. It's much brighter than this photo shows.
Code: (Select All) Screen _NewImage(800, 600, 32)
_Title "Sierraken's Digital Cube"
Do
_Limit 50
c1 = Rnd * 255
c2 = Rnd * 255
c3 = Rnd * 255
tt = (Rnd * 360)
For t = 0 To tt Step .1
r = (Rnd * 50) - 25
x = (Sin(r) * 100 + r) + 400 + r
y = (Cos(tt) * 100 + r) + 300 + r
Circle (x, y), 1, _RGB32(c1, c2, c3)
Next t
Loop Until InKey$ = Chr$(27)
|
|
|
|
| XONIX |
|
Posted by: DANILIN - 06-04-2022, 04:35 PM - Forum: Programs
- Replies (7)
|
 |
? xonix ? ... XoniX ... !!! XONIX !!!
Code: (Select All) Randomize Timer: b = Int(Rnd*15+5): a = Int(Rnd*15+5): ' xonix.bas
y = Int(Rnd*(b-3)+3): x = Int(Rnd*(a-3)+3): d=Int(Rnd*4+1)
'y = 5: x = 5: b = 10: a = 20: d=1 ' xonix.bas
For i = 1 To a: Print "#";: Next: Print ' area
For j = 1 To b-2: Print "#";: For k = 1 To a-2: Print ".";: Next: Print "#": Next
For i = 1 To a: Print "#";: Next
For q = 1 To 1000: _Delay .03: Locate y, x: Print " "
If d=1 Then If (y-1 = 1) And (x+1 = a) Then d=3
If d=1 Then If (y-1 > 1) And (x+1 = a) Then d=4
If d=1 Then If (y-1 = 1) And (x+1 < a) Then d=2
If d=1 Then y = y-1: x = x+1
If d=2 Then If (y+1 = b) And (x+1 = a) Then d=4
If d=2 Then If (y+1 < b) And (x+1 = a) Then d=3
If d=2 Then If (y+1 = b) And (x+1 < a) Then d=1
If d=2 Then y = y+1: x = x+1
If d=3 Then If (y+1 = b) And (x-1 = 1) Then d=1
If d=3 Then If (y+1 < b) And (x-1 = 1) Then d=2
If d=3 Then If (y+1 = b) And (x-1 > 1) Then d=4
If d=3 Then y = y+1: x = x-1
If d=4 Then If (y-1 = 1) And (x-1 = 1) Then d=2
If d=4 Then If (y-1 > 1) And (x-1 = 1) Then d=1
If d=4 Then If (y-1 = 1) And (x-1 > 1) Then d=3
If d=4 Then y = y-1: x = x-1
Locate y, x: Print "@"
Next
qbasic qb64 xonix
gif 45 kB
https://en.wikipedia.org/wiki/Xonix
en.wikipedia.org/wiki/Xonix
|
|
|
|
| A QuickBasic game that supports Oculus ?? |
|
Posted by: madscijr - 06-03-2022, 09:07 PM - Forum: General Discussion
- No Replies
|
 |
I came across this today while browsing around.
A QuickBasic game that supports the Oculus headset??
I haven't tried running it (and I don't have an Oculus!)
but in case anyone is curious...
(It would be rad if QB64 added VR support!)
- Gridfighter 3D - '80s style arcade shooter written in Quickbasic. Also the very first known DOS game that supports Oculus Rift VR headset.
|
|
|
|
| Backgammon: Blot/JanusBlot |
|
Posted by: BG 7 - 06-03-2022, 09:05 AM - Forum: Programs
- No Replies
|
 |
Hi !
Just want to share (again) our freeware backgammon program using QB64 respectively now QB64 Phoenix Edition:
Blot/JanusBlot
Blot is a real "oldtimer" - first appearance in 1984 - with old fashioned retro graphics - but a unique AI
(handcrafted evaluation, no neural net).
Blot/JanusBlot is suitable for novices to experts, on average the play is estimated to be at
an intermediate/advanced level.
As you can see here, Blot/JanusBlot is hosted together with the 1. Backgammon-computer rating list,
please have a look at:
www.mustrum.de/blot.html
The site is in german. If you download Blot respectively JanusBlot (recommended)
there is a short description and documentation in english.
Have fun with Blot/JanusBlot !
Hans-Jürgen
|
|
|
|
| Spring Toy |
|
Posted by: SierraKen - 06-03-2022, 01:24 AM - Forum: Programs
- Replies (6)
|
|
A few years ago we were making Slinky toys with QB64 and today I was just goofing around with graphics and math and came across this spring that stretches and comes back. Someone probably made this before but I want to show you guys what I did myself.  It's non-stop until you end it, back and forth. You can press Esc to end.
Code: (Select All) _Title "Spring Toy"
Screen _NewImage(800, 600, 32)
xx = 200
yy = 200
length = 100
r = 1
c = _RGB32(0, 255, 0)
Do
If more = 0 Then xx = xx - .5: length = length + .5
If more = 0 Then yy = yy - .5: length = length + .5
If more = 1 Then xx = xx + .5: length = length - .5
If more = 1 Then yy = yy + .5: length = length - .5
If xx < 10 Then more = 1
If xx > 200 Then more = 0
For t = 0 To length Step .01
cx = (Sin(t) * xx) + xx + t
cy = (Cos(t) * yy) + yy + t
fillCircle cx, cy, r, c
Next t
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
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
|
|
|
|
| Tesselated hex grid routine |
|
Posted by: OldMoses - 06-03-2022, 12:42 AM - Forum: Utilities
- Replies (4)
|
 |
Back on the old forum I did a program for overlaying square and hex grids over maps & images. The square grid was easy peasy, the hex grid posed a somewhat greater challenge. In revisiting that program, I felt the need to make the hex grid more versatile and modular. Here's a demo of what I came up with.
Code: (Select All) 'Tesselated Hex Grid Demo- OldMoses
SCREEN _NEWIMAGE(1024, 512, 32)
test& = _NEWIMAGE(512, 256, 32)
_DEST test&
CLS , &HFFFF0000
_DEST 0
in% = -1
hsiz = 50
xoff = 0
yoff = 0
DO
DO
k$ = INKEY$
IF k$ <> "" THEN
SELECT CASE LCASE$(k$)
CASE IS = "t" ' "t" tilt grid 90 degrees
t = NOT t
CASE IS = "+" ' "+" increase grid size
hsiz = hsiz + 1
CASE IS = "-" ' "-" decrease grid size
hsiz = hsiz - 1: IF hsiz < 6 THEN hsiz = 6
CASE IS = "e" ' "e" bias grid up
yoff = yoff - 1
CASE IS = "x" ' "x" bias grid down
yoff = yoff + 1
CASE IS = "s" ' "s" bias grid to left
xoff = xoff - 1
CASE IS = "d" ' "d" bias grid to right
xoff = xoff + 1
CASE IS = "q" ' "q" return to system
SYSTEM
END SELECT
in% = -1
END IF
_LIMIT 30
LOOP UNTIL in%
in% = 0
CLS , &HFFB0B0B0
_DEST test&
CLS , &HFFFF0000
_DEST 0
Hex_Grid hsiz * 2, 0, xoff, yoff, t, &HFF000000 ' draw double sized grid on screen
Hex_Grid hsiz, test&, xoff, yoff, NOT t, &HFF000000 ' draw base sized, rotated grid on test insert image
_PUTIMAGE (256, 64), test&, 0
_DISPLAY
LOOP
'Tessellated hex grid drawing subroutine
'siz = distance in pixels between opposite sides
'img = destination image for grid
'h = horizontal offset
'v = vertical offset
'vert = {0} opposite vertices horizontal {-1} opposite vertices vertical
SUB Hex_Grid (siz AS INTEGER, img AS LONG, h AS INTEGER, v AS INTEGER, vert AS _BYTE, cl AS _UNSIGNED LONG)
old& = _DEST
grd& = _NEWIMAGE(_WIDTH(img), _HEIGHT(img), 32) ' temporary grid image
_DEST grd&
'Base geometric algorithm
side_len = siz / SQR(3) ' length of side
side_hlf = _SHR(side_len, 1) ' 1/2 length of side (for slope line offsets)
siz_hlf = _SHR(siz, 1) ' length from center to orthogonal side
a = side_len: b = 0 ' orthogonal line offsets
c = side_hlf: d = -siz_hlf ' left angled line offsets
e = side_hlf: f = siz_hlf ' right angled line offsets
IF vert THEN
offA = side_len + side_hlf + _SHR(side_hlf, 1) ' column spacing (x) when vertical opposite vertices
offB = siz - _SHR(side_hlf, 1) ' row spacing (y) when vertical
SWAP a, b: SWAP c, d: SWAP e, f ' rotate figure end points 90 degrees around (x, y)
ELSE
offA = _SHL(side_len + side_hlf, 1) ' column spacing (x) when horizontal
offB = _SHR(siz, 1) ' row spacing (y) when horizontal
END IF
row = -1
DO
column = -1
y = row * offB + v ' set origin point y
of = -(_SHR(offA, 1)) * (row MOD 2 = 0) ' bias alternating rows by half
DO
x = column * offA + h + of ' set origin point x
LINE (x, y)-(x - a, y - b), cl ' display orthogonal line
LINE (x, y)-(x + c, y + d), cl ' draw angled right/up
LINE (x, y)-(x + e, y + f), cl ' draw angled left/down
column = column + 1 ' move to next column position
LOOP UNTIL (column - 1) * offA > _WIDTH(grd&)
row = row + 1
LOOP UNTIL (row - 1) * offB > _HEIGHT(grd&)
'end base geometric algorithm
_PUTIMAGE , grd&, img ' overlay grid to img
_FREEIMAGE grd&
_DEST old&
END SUB 'Hex_Grid
|
|
|
|
| My old Turtle Graphics Fractals |
|
Posted by: triggered - 06-02-2022, 03:37 PM - Forum: Programs
- Replies (9)
|
|
I decided to try and implement a graphics method I'm particularly fond of:
Code: (Select All) Screen 12
Dim a$
a$ = "FRRFRRF"
Dim j
For j = 1 To 4
a$ = stReplace$(a$, "F", "FLFRRFLF")
Next j
TurtleGraphics 320 / 2, 240 / 2, 0, 5, a$
End
Sub TurtleGraphics (x0 As Double, y0 As Double, a0 As Double, ssize As Double, path As String)
Dim As Double x, y, angle, stepsize
Dim w As String
Dim t As String
x = x0
y = y0
angle = a0
w = path
stepsize = ssize
PReset (x0, y0)
Do While Len(w)
t = Left$(w, 1)
w = Right$(w, Len(w) - 1)
Select Case t
Case "F"
x = x + stepsize * Cos(angle)
y = y + stepsize * Sin(angle)
Case "L"
angle = angle - 60 * _Pi / 180
Case "R"
angle = angle + 60 * _Pi / 180
End Select
Line -(x, y), 15
Loop
End Sub
Function stReplace$ (a As String, b As String, c As String)
Dim i As Integer
Dim g As String
Dim r As String
For i = 1 To Len(a)
g = Mid$(a, i, 1)
If g = b Then
r = r + c
Else
r = r + g
End If
Next
stReplace = r
End Function
|
|
|
|
|
