| 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
|
|
|
| fancypat |
|
Posted by: James D Jarvis - 06-14-2022, 05:46 PM - Forum: Programs
- No Replies
|
 |
This isn't a library, it isn't a utility, so I'm sharing it here. This is a recently tweaked version of a mark-up scheme I've been using in programs for years to get a little more out of print or to make it easier for me. I've been using the shortest sub for decades and the rest have evolved over the years depending on my need and exposure to other things such as html. Several years ago I worked up a similar looking markup-up lib but I've long since lost track of that code that was in powerbasic for dos and c and metal for use on macs (never bothered with a windows version).
Embedding draw commands is brand new to me just seems to fit, I'm sure I'll figure out how to make more use of it in the future.
It's called fancypat because fancy print at just seemed too long.
Code: (Select All) 'fancy pat
'print at options
'by James D. Jarvis
' I've been using variations of these for years and felt it was time to share
' it's really just a simple set of option tags embedded in the text and a simple parser
' embedding draw commands in this is the only real new part (for me).
Dim Shared swid, sheight, tmax, tdeep
swid = 800: sheight = 560
Screen _NewImage(swid, sheight, 256) 'can be any size but generally intended for 256 color screens
Dim Shared bkg_klr, frg_klr
Dim Shared gg$(3)
tmax = Int(swid / 8)
tdeep = Int(sheight / 16)
For x = 1 To 3 'builidng sample graphic tiles for demo
Read gg$(x)
Next x
_ControlChr Off
bkg_klr = 0
frg_klr = 15
Cls
'a super-duper demo
rpat 2, 2, "\c3\\k4\Bob\k0\ is blue on red but this text isn't, \c15\ I'm not even blue anymore."
rpat 2, 4, "\c4\\a202\\a215\\c15\ just printed ascii character 202 and 215 in red."
rpat 2, 6, "\c7\ \pFF0101010101010101010101010101FF\\c15\ is a hex pattern 8 pixels wide. Need a leading space in the string to draw the pattern."
rpat 2, 8, "\c7\ \pFFFF03030303030303FFFF\\c15\is a hex pattern 8 pixels wide, it isn't as deep as the previous one."
rpat 20, 15, "\c14\This is just a long line of text that will wrap around to the next line instead of throwing up an error when trying to locate text past the edge of the screen."
rpat 2, 12, "\Dc8r4d4l4\BB\Dc11bd15L16\"
rpat 20, 20, "A \Du7l12d12\\a219\\c6\\a220\\c7\\a219\ \c8\ Text, draw, asc chars and color changes in one line."
rpat 10, 10, "\c0\\k4\ I AM NOT A BUTTON ! \Dc15bu1d16l168u16r168bu2br2d20l172u20r172\\k0\\c15\it really isn't (for now)"
rpat 0, 0, "\k0\ \c15\" 'printing to positon 0,0 let's you change colors without putting anything on the sceen
rpat 2, 20, "\c2\\a202\\c15\ - character 202"
rpat 2, 23, "XX" 'this is just to show the relative size of the graphics tile
rpat 2, 24, " \g3\- this is a 16 pixel wide graphics tile from a predfeined graphic string."
cpat 2, 27, "I'm rpats poor little brother cpat.", 12, 0
cpat 2, 28, "cpat - colored text printed at.", 12, 0
rpat 2, 29, "Oh yeah...\c3\ rpat\c15\ is for \k8\RICH PRINT AT\k0\"
'really feeble graphic tiles just knocked out to demo the concept
Data "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa0000111122223333444455555555666666677777777888888000GG"
Data "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333"
Data "¿8¿7¿0Ÿ2Ÿ4"
'the subs, this is the parts that actually matter
Sub pat (tcol, trow, txt$)
'print at is just locate rearranged and in one command, it's not even in this demo but I have probably been using it since 88
'i just feel it is easier to keep track of columns and rows in my head in that order when placing text in a program
Locate trow, tcol
Print txt$
End Sub
Sub cpat (tcol, trow, txt$, tklr, tbkg)
'color print at
Color tklr, tbkg
Locate trow, tcol
Print txt$
Color frg_klr, bkg_klr
End Sub
Sub rpat (tcol, trow, txt$)
'rich print at
n = -1
c = 0
Do
c = c + 1
A$ = Mid$(txt$, c, 1)
If A$ <> "\" Then
n = n + 1
If tcol + n > tmax Then
trow = trow + 1
n = 0
End If
If tcol <> 0 Then Locate trow, tcol + n
If tcol <> 0 Then Print A$
Else
B$ = Mid$(txt$, c + 1, 1)
Select Case B$
Case "C", "c":
D$ = gettag$(txt$, c)
Color Val(D$)
c = c + Len(D$) + 1
Case "K", "k":
D$ = gettag$(txt$, c)
Color , Val(D$)
c = c + Len(D$) + 1
Case "A", "a":
D$ = gettag$(txt$, c)
DV = Val(D$)
Locate trow, tcol + n
Print Chr$(DV)
n = n + 1
c = c + Len(D$) + 1
Case "P", "p"
D$ = gettag$(txt$, c)
phex tcol, trow, D$
c = c + Len(D$) + 1
Case "D", "d"
D$ = gettag$(txt$, c)
n = n + 1
xx = ((tcol + n) - 1) * 8
yy = (trow - 1) * 16
PSet (xx, yy)
Draw D$
c = c + Len(D$) + 1
Case "G", "g"
D$ = gettag$(txt$, c)
DD = Val(D$)
gpat tcol, trow, DD
c = c + Len(D$) + 1
End Select
End If
Loop Until c > Len(txt$)
End Sub
Function gettag$ (txt$, c)
D$ = ""
cc = c + 1
Do
cc = cc + 1
C$ = Mid$(txt$, cc, 1)
D$ = D$ + C$
Loop Until C$ = "\"
gettag$ = Left$(D$, Len(D$) - 1)
End Function
Sub phex (tc, tr, hx$)
'monochrome pattern
'I orignally wrote this before _bit was part of qb64, might rework it some day, might not
xx = (tc - 1) * 8
yy = (tr - 1) * 16
For c = 1 To Len(hx$) Step 2
bt = 0
For p = 0 To 1
AA$ = Mid$(hx$, c + p, 1)
A = Val("&H" + AA$)
Select Case A
Case 0: BB$ = "0000"
Case 1: BB$ = "0001"
Case 2: BB$ = "0010"
Case 3: BB$ = "0011"
Case 4: BB$ = "0100"
Case 5: BB$ = "0101"
Case 6: BB$ = "0110"
Case 7: BB$ = "0111"
Case 8: BB$ = "1000"
Case 9: BB$ = "1001"
Case 10: BB$ = "1010"
Case 11: BB$ = "1011"
Case 12: BB$ = "1100"
Case 13: BB$ = "1101"
Case 14: BB$ = "1110"
Case 15: BB$ = "1111"
End Select
For b = 1 To 4
If Mid$(BB$, b, 1) = "1" Then
PSet (xx + bt, yy)
'remember this uses the last defined color
Else
PSet (xx + bt, yy), bkg_klr
End If
bt = bt + 1
Next b
Next p
yy = yy + 1
bt = 0
Next c
End Sub
Sub gpat (tc, tr, ggN)
xx = (tc - 1) * 8
yy = (tr - 1) * 16
x = 0
y = 0
For c = 1 To Len(gg$(ggN))
a$ = Mid$(gg$(ggN), c, 1)
If Asc(a$) < 128 Then
PSet (xx + x, yy + y), Val(a$)
x = x + 1
If x = 16 Then
x = 0
y = y + 1
End If
Else
n = Asc(a$) - 127
c = c + 1
a$ = Mid$(gg$(ggN), c, 1)
For nn = 1 To n
PSet (xx + x, yy + y), Val(a$)
x = x + 1
If x = 16 Then
x = 0
y = y + 1
End If
Next nn
End If
Next c
End Sub
|
|
|
| Very Simple GUI |
|
Posted by: bplus - 06-14-2022, 04:15 AM - Forum: Works in Progress
- Replies (98)
|
 |
One day into it, here is my starter:
Code: (Select All) Option _Explicit
_Title "GUI - starter 2022-06" 'b+ 2022-06-13
' Very simple buttons and textboxes for starters"
' Use white border for active control, black for inactive ones.
' Use Tab and Shift+Tab for shifting active control else Mouse Click, to cursor position in TextBox.
' Main loop will decide active control ID is basically the Index order for controls same as you
' post them with NewControl conType, X, Y, W, H, Text
' textBox is _RGB32(255, 255, 200) on _RGB32(0, 0, 128)
' height needs to be at least 32 pixels high for cursor below letters in box
' conType = 2 N1 is cursor position, N2 to track toggle for blinking cursor
Type Control ' all are boxes with colors, 1 is active
As Long ID, ConType, X, Y, W, H, N1, N2 ' N1, N2 sometimes controls need extra numbers for special functions
' ID is actually index number same order as you enter NewControls
As String Text, Text2 ' dims are pixels Text2 is for future selected text from list box
' default wnd = 0, btn = 1, txtBx = 2
End Type
Dim Shared Xmax, Ymax, NControls, ActiveControl
ReDim Shared con(0) As Control
Dim As Long kh, mx, my, mb1, i, shift1, shift2, lc
Xmax = 800: Ymax = 600 ' shared throughout program
OpenWindow Xmax, Ymax, "Test GUI Starter" ' set your window size and title
'set your controls
NewControl 2, 10, 10, 200, 32, "Textbox 1" ' i = 1
NewControl 2, 10, 52, 200, 32, "Textbox 2" ' i = 2
NewControl 2, 10, 94, 200, 32, "Textbox 3" ' i = 3
NewControl 2, 10, 136, 200, 32, "Test pqg 4" ' i = 4
NewControl 1, 220, 178, 100, 32, "Button 1" ' i = 5
NewControl 1, 220, 220, 100, 32, "Clear" ' i = 6
Do
' mouse clicks and tabs will decide the active control
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1)
If mb1 Then ' find which control
For i = 1 To NControls
If mx >= con(i).X And mx <= con(i).X + con(i).W Then
If my >= con(i).Y And my <= con(i).Y + con(i).H Then
If i <> ActiveControl Then
activateControl ActiveControl, 0
ActiveControl = i
activateControl ActiveControl, -1
BtnClickEvent i
End If
Exit For
End If
End If
Next
If con(ActiveControl).ConType = 2 Then ' move cursor to click point
con(ActiveControl).N1 = Int((mx - con(ActiveControl).X - 4) / 8) + 1
drwTB -1, i
End If
_Delay .1 ' user release key wait
End If
kh = _KeyHit
shift1 = _KeyDown(100304)
shift2 = _KeyDown(100303)
If kh = 9 Then 'tab
If shift1 Or shift2 Then
activateControl ActiveControl, 0
ActiveControl = ActiveControl - 1
If ActiveControl = 0 Then ActiveControl = NControls
activateControl ActiveControl, -1
Else
activateControl ActiveControl, 0
ActiveControl = ActiveControl + 1
If ActiveControl > NControls Then ActiveControl = 1
activateControl ActiveControl, -1
End If
ElseIf kh = 13 And con(ActiveControl).ConType = 1 Then ' enter on a btn
BtnClickEvent ActiveControl
ElseIf kh = 13 And con(ActiveControl).ConType = 2 Then '
activateControl ActiveControl, 0
ActiveControl = ActiveControl + 1
If ActiveControl > NControls Then ActiveControl = 1
activateControl ActiveControl, -1
End If
If con(ActiveControl).ConType = 2 Then
TBKeyEvent ActiveControl, kh ' this handles keypress in active textbox
If lc Mod 10 = 9 Then con(ActiveControl).N2 = 1 - con(ActiveControl).N2 ' this is for blinking cursor
If con(ActiveControl).N2 Then
Line (con(ActiveControl).X + 4 + 8 * (con(ActiveControl).N1 - 1), con(ActiveControl).Y + (con(ActiveControl).H - 16) / 2 + 17)-Step(8, 3), &HFFFFFFFF, BF
Else
Line (con(ActiveControl).X + 4 + 8 * (con(ActiveControl).N1 - 1), con(ActiveControl).Y + (con(ActiveControl).H - 16) / 2 + 17)-Step(8, 3), _RGB32(0, 0, 128), BF
End If
End If
_Display
lc = lc + 1
_Limit 60
Loop Until _Exit
Sub activateControl (i, activate)
Select Case con(i).ConType
Case 1: drwBtn activate, i
Case 2: drwTB activate, i
End Select
End Sub
Sub OpenWindow (WinWidth As Long, WinHeight As Long, title$)
Screen _NewImage(WinWidth, WinHeight, 32)
_ScreenMove 100, 20
_PrintMode _KeepBackground
_Title title$
Color &HFFFFFFFF, _RGB32(100, 180, 120)
Cls
End Sub
Sub NewControl (ConType As Long, X As Long, Y As Long, W As Long, H As Long, s$) ' dims are pixels
Dim As Long a
NControls = NControls + 1
ReDim _Preserve con(0 To NControls) As Control
con(NControls).ID = NControls
con(NControls).ConType = ConType
con(NControls).X = X
con(NControls).Y = Y
con(NControls).W = W
con(NControls).H = H
con(NControls).Text = s$
ActiveControl = 1
If NControls = 1 Then a = 1 Else a = 0
Select Case ConType
Case 1: drwBtn a, NControls
Case 2: drwTB a, NControls: con(NControls).N1 = Len(s$) + 1: con(NControls).N2 = 0 ' N1 is what letter position we are on or cursor for line
'N2 is the toggle for cursor blinking
End Select
End Sub
Sub drwBtn (active As Long, i As Long) ' gray back, black text
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), _RGB32(230, 200, 250), BF
If active Then Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), _RGB32(255, 255, 255), B Else _
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), _RGB32(0, 0, 0), B
Color _RGB32(0, 0, 0)
_PrintString (con(i).X + (con(i).W - 8 * Len(con(i).Text)) / 2, (con(i).Y + (con(i).H - 16) / 2)), con(i).Text
End Sub
Sub drwTB (active As Long, i As Long) ' blue back, white text
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), _RGB32(0, 0, 128), BF
If active Then
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), _RGB32(255, 255, 255), B
Else
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), _RGB32(0, 0, 0), B
End If
Color _RGB32(255, 255, 200)
_PrintString (con(i).X + 4, con(i).Y + (con(i).H - 16) / 2), con(i).Text
End Sub
Sub BtnClickEvent (i As Long) ' attach you button click code in here
Select Case i
Case 5: Color &HFFFFFF00: _PrintString (500, 20), "You pushed my button!"
Case 6: Line (500, 20)-Step(8 * Len("You pushed my button!"), 16), _RGB32(100, 180, 120), BF
End Select
End Sub
Sub TBKeyEvent (i As Long, ky As Long) ' for all text boxes
If ky = 19200 Then 'left arrow
If con(i).N1 > 1 Then con(i).N1 = con(i).N1 - 1: drwTB -1, i
ElseIf ky = 19712 Then ' right arrow
If con(i).N1 < Int((con(i).W - 16) / 8) Then con(i).N1 = con(i).N1 + 1: drwTB -1, i
ElseIf ky = 18176 Then 'home
con(i).N1 = 1: drwTB -1, i
ElseIf ky = 20224 Then ' end
If Len(con(i).Text) + 1 <= Int((con(i).W - 16) / 8) Then con(i).N1 = Len(con(i).Text) + 1: drwTB -1, i
ElseIf ky >= 32 And ky <= 128 Then
If Len(con(i).Text) + 1 <= Int((con(i).W - 16) / 8) Then
con(i).Text = Mid$(con(i).Text, 1, con(i).N1 - 1) + Chr$(ky) + Mid$(con(i).Text, con(i).N1)
con(i).N1 = con(i).N1 + 1: drwTB -1, i
End If
ElseIf ky = 8 Then 'backspace
If con(i).N1 > 1 Then
con(i).Text = Mid$(con(i).Text, 1, con(i).N1 - 2) + Mid$(con(i).Text, con(i).N1)
con(i).N1 = con(i).N1 - 1: drwTB -1, i
End If
ElseIf ky = 21248 Then 'delete
con(i).Text = Mid$(con(i).Text, 1, con(i).N1 - 1) + Mid$(con(i).Text, con(i).N1 + 1): drwTB -1, i
End If
End Sub
|
|
|
|
| DrawTrek |
|
Posted by: James D Jarvis - 06-13-2022, 09:30 PM - Forum: Programs
- Replies (8)
|
|
DrawTrek Demo1. To boldly go where we've likely gone before with little to no copyright or trademark violations!
Code: (Select All) 'Drawtrek demo1
'an epic space opera demo
'by James D. Jarvis
Screen _NewImage(800, 600, 256)
Randomize Timer
Dim Shared shieldstr
Dim Shared kshieldstr
Dim Shared shieldmax
Dim Shared kshieldmax
Dim Shared st(100, 2)
For s = 1 To 100
st(s, 1) = Int(Rnd * 800)
st(s, 2) = Int(Rnd * 600)
Next s
shieldmax = 50
shieldstr = 50
kshieldstr = 50
kshieldmax = 50
For px = 100 To 300 Step 10
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan 400 + px / 3, 300
_Display
Next px
For x = 300 To 500 Step 8
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan 500 + Int(x / 16), 300
dburst x, 300, 4, 11
_Display
Next x
For dspan = 4 To 20
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan 500 + Int(x / 16), 300
dburst x, 300, dspan - Int(Rnd * 3), 12
kshieldstr = kshieldstr - 1
_Display
Next dspan
Cls
kx = 500 + Int(x / 16)
drawstars
drawplayership 270, 300
drawkremulan kx, 300
_Delay 0.14
For x = 300 To 500 Step 8
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan kx, 300
dburst x, 300, 4, 11
_Display
Next x
For dspan = 4 To 20
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan 500 + Int(x / 16), 300
dburst x, 300, dspan - Int(Rnd * 3), 12
kshieldstr = kshieldstr - 3
_Display
Next dspan
_Delay 0.14
For x = 300 To 500 Step 8
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan kx, 300
dburst x, 300, 4, 11
_Display
Next x
For dspan = 4 To 20
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan kx, 300
dburst x, 300, dspan - Int(Rnd * 3), 12
kshieldstr = kshieldstr - 3
_Display
Next dspan
For boom = 1 To 30
_Limit 60
Cls
drawstars
drawplayership px, 300
drawkremulan kx, 300
dburst kx + Int(Rnd * 12), 300 + Int(Rnd * 7) - Int(Rnd * 7), Int(Rnd * 12) + boom / 2, 12
If Int(Rnd * 3) < 2 Then dburst kx + Int(Rnd * 12), 300 + Int(Rnd * 7) - Int(Rnd * 7), Int(Rnd * 12) + boom / 2, 14
If Int(Rnd * 3) < 2 Then dburst kx + Int(Rnd * 12), 300 + Int(Rnd * 7) - Int(Rnd * 7), Int(Rnd * 12) + boom / 2, 4
_Display
Next boom
Cls
a = 0
For Y = 300 To -20 Step -5
_Limit 60
Cls
If a < 90 Then
a = a + 5
px = px + 3
End If
drawstars
Draw "ta" + Str$(a)
drawplayership px, Y
_Display
Next Y
Sub drawplayership (xx, yy)
PSet (xx, yy), 0
Color 15
Circle (xx, yy), 5, 15
Draw " bm -10,0 r10 bm -10,-4 d8 l3 br3 bu8 l3"
sc = 10
If shieldstr < shieldmax * .8 Then sc = 2
If shieldstr < shieldmax * .6 Then sc = 14
If shieldstr < shieldmax * .4 Then sc = 12
If shieldstr < shieldmax * .2 Then sc = 4
If shieldstr > 0 Then Circle (xx, yy), 20, sc, 0, (2 * _Pi) * (shieldstr / shieldmax)
Draw "ta0"
End Sub
Sub drawkremulan (xx, yy)
PSet (xx, yy), 0
kk = 6
Color kk
Circle (xx, yy - 2), 2, kk
Circle (xx, yy + 2), 2, kk
Draw "bm -0,-2 l10 e3 l5 r5 g3 f3 l5 "
sc = 10
If kshieldstr < kshieldmax * .8 Then sc = 2
If kshieldstr < kshieldmax * .6 Then sc = 14
If kshieldstr < kshieldmax * .4 Then sc = 12
If kshieldstr < kshieldmax * .2 Then sc = 4
If kshieldstr > 0 Then Circle (xx, yy), 20, sc, 0, (2 * _Pi) * (kshieldstr / kshieldmax)
End Sub
Sub drawmraar (xx, yy)
PSet (xx, yy), 0
kk = 13
Color kk
Line (xx - 4, yy - 4)-(xx + 4, yy + 4), kk, B
Draw "l18 d4 u4 r18 u8 l18 u4"
sc = 10
If kshieldstr < kshieldmax * .8 Then sc = 2
If kshieldstr < kshieldmax * .6 Then sc = 14
If kshieldstr < kshieldmax * .4 Then sc = 12
If kshieldstr < kshieldmax * .2 Then sc = 4
Circle (xx, yy), 20, sc, 0, (2 * _Pi) * (kshieldstr / kshieldmax)
End Sub
Sub drawvelnax (xx, yy)
PSet (xx, yy), 0
kk = 10
Color kk
Line (xx - 3, yy - 3)-(xx + 5, yy + 3), kk, B
PSet (xx, yy)
Draw "l15 u7 d14 u7 r4 u7 d14 "
sc = 10
If kshieldstr < kshieldmax * .8 Then sc = 2
If kshieldstr < kshieldmax * .6 Then sc = 14
If kshieldstr < kshieldmax * .4 Then sc = 12
If kshieldstr < kshieldmax * .2 Then sc = 4
Circle (xx, yy), 20, sc, 0, (2 * _Pi) * (kshieldstr / kshieldmax)
End Sub
Sub dcircle (xx, yy, r, klr)
'draw a circle
PSet (xx, yy), klr
Draw "c" + Str$(klr)
For d = 0 To 360 Step 1
Draw "ta " + Str$(d) + " r" + Str$(r) + " bl" + Str$(r)
Next d
End Sub
Sub dburst (xx, yy, r, klr)
PSet (xx, yy), klr
Draw "c" + Str$(klr)
For d = 0 To 360 Step (1 + Rnd * 10)
rv = Int(r \ 1.9 + Rnd * (r / 2))
Draw "ta " + Str$(d) + " r" + Str$(rv) + " bl" + Str$(rv)
Next d
End Sub
Sub darc (xx, yy, r, klr, arc1, arc2)
'draws an arc, will draw an unfilled circle if the arc goes from 0 to 360
PSet (xx, yy), klr
Draw "c" + Str$(klr)
For d = arc1 To arc2 Step 1
Draw "ta " + Str$(d) + " br" + Str$(r - 1) + "r bl" + Str$(r)
Next d
End Sub
Sub drawstars
For s = 1 To 100
PSet (st(s, 1), st(s, 2)), 15
Next s
End Sub
|
|
|
|
| Draw circles |
|
Posted by: James D Jarvis - 06-13-2022, 06:45 PM - Forum: Programs
- Replies (5)
|
|
A few circle drawing routines that use the draw command. You can never have too many options.
Code: (Select All) 'draw circles
'by James D. Jarvis
' a few subs with to draw circles and pie charts
Screen _NewImage(800, 500, 256)
'$dynamic 'this is just set to dynamic for the piechart part of the demo
Print "A few subs to draw cricles, arcs, and pie charts using simple math and the draw command."
Print "Not perfect yet, but they work for smaller circles."
Locate 3, 1: Print "A simple filled circle"
_Delay 0.85
dcircle 200, 100, 10, 12
Locate 3, 1: Print "An arc from 0 t0 270"
_Delay 0.85
darc 200, 100, 20, 13, 0, 270
Locate 3, 1: Print "An arc from 140 0 320"
_Delay 0.85
darc 200, 100, 56, 10, 140, 320
Locate 3, 1: Print "A pie slice with different color borders "
_Delay 0.85
dpieslice 100, 100, 20, 2, 10, 0, 60
Dim pd(3)
pd(1) = 5
pd(2) = 10
pd(3) = 15
piechart 300, 300, 70, 15, pd()
For t = 1 To 10
_Limit 5
Next t
Cls
'showing a pie chart if one of the fields grows and another has a decreese
For x = 5 To 20
_Limit 3
pd(1) = x
pd(3) = pd(3) * .9
Cls
dcircle 200, 100, 10, 12 'copied so it doesn't vanish
darc 200, 100, 20, 13, 0, 270 'copied so it doesn't vanish
darc 200, 100, 56, 13, 140, 320 'copied so it doesn't vanish
dpieslice 100, 100, 20, 2, 10, 0, 60 'copied so it doesn't vanish
piechart 300, 300, 70, 15, pd()
_Display
Next x
'showing a pie chart gaining entries
For n = 1 To 12
_Limit 3
np = UBound(pd) + n
ReDim _Preserve pd(np)
pd(np) = 15 - n
Cls
dcircle 200, 100, 10, 12 'copied so it doesn't vanish
darc 200, 100, 20, 13, 0, 270 'copied so it doesn't vanish
darc 200, 100, 56, 13, 140, 320 'copied so it doesn't vanish
dpieslice 100, 100, 20, 2, 10, 0, 60 'copied so it doesn't vanish
piechart 300, 300, 70, 15, pd()
_Display
'getting a color leak I haven't figured out just yet
Locate 1, 1: Print "Haven't tracked down why that bleed happens just yet. Hope you find some of this useful."
Next n
Sub dcircle (xx, yy, r, klr)
'draw a circle
PSet (xx, yy), klr
Draw "c" + Str$(klr)
For d = 0 To 360 Step 1
Draw "ta " + Str$(d) + " r" + Str$(r) + " bl" + Str$(r)
Next d
End Sub
Sub darc (xx, yy, r, klr, arc1, arc2)
'draws an arc, will draw an unfilled circle if the arc goes from 0 to 360
PSet (xx, yy), klr
Draw "c" + Str$(klr)
For d = arc1 To arc2 Step 1
Draw "ta " + Str$(d) + " br" + Str$(r - 1) + "r bl" + Str$(r)
Next d
End Sub
Sub dpieslice (xx, yy, r, klr, fill, arc1, arc2)
'draws and fills a pie slice
PSet (xx, yy), klr
Draw "c" + Str$(klr)
For d = arc1 To arc2 Step 0.3
Draw "ta " + Str$(d) + " br" + Str$(r - 1) + "r bl" + Str$(r)
Next d
Draw "ta" + Str$(arc1) + " r " + Str$(r) + "bl" + Str$(r)
Draw "ta" + Str$(arc2) + " r " + Str$(r) + "bl" + Str$(r)
Draw "ta" + Str$((arc1 + arc2) / 2) + "br " + Str$(Int(r / 2)) + "P" + Str$(fill) + "," + Str$(klr) + " bl" + Str$(Int(r / 2))
End Sub
Sub piechart (xx, yy, r, klr, a())
'takes array a() as raw data and calculates size of pie wedges to be drawn
Dim portion(UBound(a))
total = 0
For ss = 1 To UBound(a)
total = a(ss) + total
Next ss
For ss = 1 To UBound(a)
portion(ss) = a(ss) / total
Next ss
a1 = 0
'pie wedges are drawn AND filled with colors starting from color 1
For ss = 1 To UBound(a)
ap = portion(ss) * 360
a2 = a1 + ap
dpieslice xx, yy, r, klr, ss, a1, a2
a1 = a2
Next ss
End Sub
|
|
|
|
| could someone kindly bring me up to date with a couple qb64 items? |
|
Posted by: madscijr - 06-13-2022, 06:32 PM - Forum: General Discussion
- Replies (7)
|
 |
I'm a little confused today... Going to qb64.com, in the Community > Forums section, there was always a link to here (which appeared last on the list, not sure why) but now it says there are no official forums for QB64, and no link to these forums at all.
Searching for answers, I wound up at
https://barnes.x10host.com/pages/BASIC-R...ources.php
where a link to these forums is first on the list.
This may be a dumb question, but I'm not entirely clear what barnes.x10host.com is for, or why all this QB64 stuff isn't under one qb64.com domain?
I realize things tend to change quickly in this crazy world of ours, and I don't follow the discord thread constantly, and maybe I missed a memo, so could someone explain what's up with that?
Also, I see the talk about the new QB 0.81. The last version of QB64 that I downloaded, before the fiasco with what's his name, was 2.0.2. I imagine that after The Jerk kicked everyone off of the forums which included the git project for the source code, that the project had to be forked or recreated or whatever it was the devs had to so, but does that mean the only code we could pick up from was from before 1.0, or did the devs decide that QB64 PE was now a different project, and decide on some beta version numbering?
I never saw a memo about the version numbering, so am not sure how that all came about.
I would think that even if we "rebranded" QB64 as "phoenix edition", that we would want to keep incrementing the version number we had, and the next release would be version 2.1.x, 3.x, or similar?
This kind of reminds me of back in the day when the marketing people for Intel started calling their CPUs Pentium, Pentium II, Pentium III, etc. instead of 586, 686, 786, etc. It's mildly annoying but as long as the stuff works right? I just want to understand how this newest version 0.81 compares to the old version 2.0.2, before upgrading...
Anyway, if anyone could please set me straight on the forums and the version numbering and which Web sites / domains are for what, it would be much appreciated!
|
|
|
|
| HUNTER AND HUNTED |
|
Posted by: James D Jarvis - 06-13-2022, 01:02 PM - Forum: Programs
- Replies (2)
|
|
Hunter and Hunted is a spin on the classic text based grid hunting game Hurkle. This time it isn't just you and the Hurkle as you are also being hunted by the Bellicose Behinder. Can you find the Hurkle before the Bellicose Behinder finds you?
Code: (Select All) 'HUNTER AND HUNTED
_Title "HUNTER AND HUNTED"
Randomize Timer
Locate , 10: Print "H U N T E R A N D H U N T E D"
Print: Print: Print
Print "A Hurkle hunting game where you are both predator and prey"
Print: Print: Print
Do
eaten$ = "no": found$ = "no": n = 15: g = 20
hx = Int(Rnd * g) + 1: hy = Int(Rnd * g) + 1
'the behinder starts
b = Int(Rnd * 4)
Select Case b
Case 0:
bx = 1
by = Int(Rnd * g) + 1
Case 1:
bx = g
by = Int(Rnd * g) + 1
Case 2:
by = 1
bx = Int(Rnd * g) + 1
Case 3:
by = g
bx = Int(Rnd * g) + 1
End Select
Print "A Hurkle is hiding somwhere in a "; g; " by"; g; " grid."
Print "Homebase is at 0,0 and you must guess the hurkles location."
Print "(X is West - East, Y is North - South)"
Print "But BEWARE a BELLICOSE BEHINDER is also on the hunt..."
Print "... and you are the prey."
Print "Each turn you may enter your move as an x,y coordinate."
Print "Hints will be provided as you play."
Print
Do
Print "You have "; n; " turns left."
If (Abs(x - bx) < 3 And Abs(y - by) < 3) Or (Abs(x - hx) < 4 And Abs(y - hy) < 4) Then
Print "Something is stirring to the ";
If y < by Then Print "north";
If y > by Then Print "south";
If x < bx Then Print "east";
If x > bx Then Print "west";
Print "."
End If
Input "Where do you think the Hurkle is Hiding? ", x, y
n = n - 1
Print
If x = hx And y = hy Then
found$ = "yes"
Print "YOU FOUND THE HURKLE !"
Print
Else
Print "Look ...";
If y < hy Then Print "north";
If y > hy Then Print "south";
If x < hx Then Print "east"
If x > hx Then Print "west"
Print
End If
'there's a chance the behinder moves.... oh yeah it's coming for you
If Int(Rnd * 100) < 31 Then
Print
Print "You hear the Behinder bounding."
Print
b = Int(Rnd * 4)
Select Case b
Case 0: bx = bx - 1
Case 1: bx = bx + 1
Case 2: by = by - 1
Case 3: by = by + 1
End Select
End If
If bx = x And by = y Then
Print "OH NO !"
Print
Print "THE BELLICOSE BEHINDER HAS POUNCED ON YOU!"
Print
eaten$ = "yes"
End If
Loop Until found$ = "yes" Or n = 0 or eaten$="yes"
If found$ = "yes" Then
Print "That was just "; n; " turns!"
Else
If eaten$ = "yes" Then
Print
Print "YOUR HUNT IS OVER."
Print
Else
Print
Print "SORRY YOU DON'T HAVE ANY TURNS LEFT."
Print
End If
End If
Print
Input "Play again ? (Yes or No) ", askquit$
askquit$ = Left$(LCase$(askquit$), 1)
Loop Until askquit$ = "n"
|
|
|
|
| Problem with User Defined Function |
|
Posted by: RNBW - 06-13-2022, 10:08 AM - Forum: Help Me!
- Replies (2)
|
|
When I try to compile this snippet
Code: (Select All) Type ButtonT
x As Integer 'Position left top
y As Integer
w As Integer 'Height
h As Integer 'Width
text As String 'label
End Type
Function Button(x As Integer, y As Integer, w As Integer, h As Integer, Text As String) As ButtonT
'Defines and draws a new button
Dim As ButtonT btn
btn.x = x
btn.y = y
btn.h = h
btn.w = w
btn.text = text
'Button_Draw(btn, ButtonColor)
Return btn
End Function
------------------------
Expected )
Caused by (or after):
Line 9:
Function Button_New(x As Integer, y As Integer, w As Integer, h As Integer, Text As String) As Button
------------------------
Can someone clarify what I am doing wrong.
|
|
|
|
| VM with Linux install |
|
Posted by: Richard - 06-12-2022, 09:06 AM - Forum: Help Me!
- Replies (16)
|
|
I have some experience with Windows + QB64.
I am now trying out LINUX (never used/studied Linux before) on a Virtual Machine (VM).
Would appreciate some help to install QB64 into VM Linux - to be able to get to a working "Hello World" program.
Thanks in advance.
|
|
|
|
|
). - The picture of the firebird ist free.![[Image: Neues-Logo2022-06-14.jpg]](https://i.ibb.co/vqLLsBY/Neues-Logo2022-06-14.jpg){kind=logo}
![[Image: 8-2022.jpg]](https://i.ibb.co/Jq5GKqs/8-2022.jpg)
