| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 499
» Latest member: Blayk
» Forum threads: 2,853
» Forum posts: 26,726
Full Statistics
|
| Latest Threads |
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
20 minutes ago
» Replies: 15
» Views: 200
|
Trojan infection !
Forum: Help Me!
Last Post: SMcNeill
2 hours ago
» Replies: 1
» Views: 19
|
Glow Bug
Forum: Programs
Last Post: PhilOfPerth
5 hours ago
» Replies: 6
» Views: 89
|
BAM Sample Programs
Forum: QBJS, BAM, and Other BASICs
Last Post: CharlieJV
Today, 02:50 AM
» Replies: 36
» Views: 1,968
|
Audio storage, stereo swi...
Forum: Programs
Last Post: Petr
Yesterday, 09:03 PM
» Replies: 8
» Views: 358
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
Yesterday, 12:24 PM
» Replies: 7
» Views: 127
|
Most efficient way to bui...
Forum: General Discussion
Last Post: ahenry3068
01-17-2025, 11:36 PM
» Replies: 9
» Views: 137
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: madscijr
01-17-2025, 11:24 PM
» Replies: 4
» Views: 135
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
01-17-2025, 05:50 AM
» Replies: 10
» Views: 269
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
01-17-2025, 02:33 AM
» Replies: 1
» Views: 56
|
|
|
| Another issue: Changing one variable instantly changes the value of another variable |
|
Posted by: hanness - 06-17-2022, 02:03 AM - Forum: General Discussion
- Replies (14)
|
 |
I have a short subroutine that takes a path and removes the quotes if the path is enclosed in quotes. It then removes any trailing backslash from the path if one exists.
I was getting some unexpected results, so into debug mode I went to find the problem. As I step through the code one line at a time, I find this problem:
As soon as I execute the line that reads Temp$ = "" not only does Temp$ get set to "" but in that very moment Path$ also gets set to "" (an empty string). For the life of me, I cannot make sense of why this happens.
A few notes:
1) Path$ is not defined outside of this subroutine, so it is local to the subroutine only.
2) Temp$ is DIMed at the start of my program as a SHARED string, so that variable should be available globally.
I apologize for not supplying the full code. The problem is that this is a part of a program almost 15,000 lines long now.
Can anyone give me anything to look for here? I simply cannot see how changing one variable would instantly change another variable as well.
Code: (Select All) Sub CleanPath (Path$)
' Remove quotes and trailing backslash from a path
' To use this subroutine: Pass the path to this sub, the sub will return the path
' without quotes and a trailing backslash in Temp$.
Dim x As Integer
' start by stripping the quotes
Temp$ = ""
For x = 1 To Len(Path$)
If Mid$(Path$, x, 1) <> Chr$(34) Then
Temp$ = Temp$ + Mid$(Path$, x, 1)
End If
Next x
' Remove the trailing backslash, if present
If Right$(Temp$, 1) = "\" Then
Temp$ = Left$(Temp$, (Len(Temp$) - 1))
End If
End Sub
|
|
|
| Confusion over passing by reference vs passing by value |
|
Posted by: hanness - 06-16-2022, 11:21 PM - Forum: General Discussion
- Replies (12)
|
|
Let's say that I have the following code:
Code: (Select All) Option _Explicit
Dim x As Integer
Dim a As String
Print "Passing a numerical variable by reference:"
x = 1
Test1 x
Print "Value of x after subroutine:"; x
Print
Print "Passing a numerical variable by value:"
x = 1
Test1 (x)
Print "Value of x after subroutine:"; x
Print
Print "Passing a string variable by reference:"
a$ = "String1"
Test2 a$
Print "Value of a$ after subroutine:"; a$
Print
Print "Passing a string variable by value:"
a$ = "String1"
Test2 (a$)
Print "Value of a$ after subroutine:"; a$
End
Sub Test1 (y As Integer)
y = y + 1
End Sub
Sub Test2 (b As String)
b$ = b$ + " and string 2"
End Sub
This code has 4 main sections:
Section 1: We set as variable "x" to 1 and pass it to a subroutine by reference to the variable "y". The subroutine adds one to the value of y. As expected, when we come out of the subroutine we find that the original variable "x" is now equal to 2.
Section 2: We set as variable "x" to 1 and pass it to a subroutine by value to the variable "y". The subroutine adds one to the value of y. As expected, when we come out of the subroutine we find that the original variable "x" is unchanged because we passed the variable by value rather than by reference.
But what about strings?
In section 3 and 4, I'm doing the same thing but with a string. I pass it to a subroutine both by reference and by value but in both cases the original string variable is changed.
Is this expected behavior? Is it possible to pass a string variable without affecting the original?
I know that I could work around it by assigning the variable to another variable within the subroutine like this:
Code: (Select All) Sub Test2 (b As String)
dim c as string
c$=b$
c$ = c$ + " and string 2"
End Sub
This way, I'm not modifying the original string. I just wanted to make sure I'm not missing something obvious.
|
|
|
|
| BLOCKMODE demo |
|
Posted by: James D Jarvis - 06-15-2022, 08:51 PM - Forum: Programs
- Replies (3)
|
|
In a world where high resolution graphics dominate the microcomputing industry and hobby programming it only seemed fitting to develop a display mode that was certainly not high-res.
Blockmode uses 4 traditional character codes to create graphics along with 256 colors in a massive display of low-res splendor of 160 x 98(ish) boxels. With block printing that allows 26 characters per line of text on 12 whole lines !
It's a marvel of mixed mode graphics that I couldn't think of a better name for.
I'd like to thank dcromley for developing and sharing microfont, without his contribution you might be seeing less block letters in the demo.
Code: (Select All) 'blockmodedemo
'lower-res graphics demo fun
'by James D. Jarvis
' uses microfont by dcromley
Dim Shared drawspace&, s&
drawspace& = _NewImage(161, 100, 256)
s& = _NewImage(1280, 1600, 256)
Screen s&
_FullScreen
_Scrolllock On
Randomize Timer
Dim Shared blk$(0 To 3), BSCR_klr, BSCR_bkg, Bgrid(160, 100, 3)
Dim Shared bfont$
Dim Shared b96$
blk$(0) = " ": blk$(1) = Chr$(176): blk$(2) = Chr$(177): blk$(3) = Chr$(178)
BSCR_klr = 15: BSCR_bkg = 0
Const bgblk = 1, bgklr = 2, bgbkg = 8
bstart
For x = 1 To 160
For y = 1 To 98
If y Mod 2 > 0 Then
If x Mod 2 > 0 Then
BSET x, y, 2, 3, 0
Else
BSET x, y, 1, 3, 9
End If
Else
If x Mod 2 > 0 Then
BSET x, y, 1, 3, 9
Else
BSET x, y, 2, 3, 0
End If
End If
Next y
Next x
drawblocks 1, 160, 1, 98
bat 1, 1, "BLOCKMODE"
bat 1, 2, "160 x 98 bloxels"
bat 1, 3, "Block Print 26 c by 12 r "
bat 1, 4, "abcdefghijklmnopqrstuvwxyz"
bat 1, 5, "Can use draw commands"
blat 80, 50, " ", 15, 0
bdraw "r5d7l5u7"
bdraw "br7c11r5d1c7l5d1c8r5"
bcircle 50, 60, 9, 5
barc 50, 60, 9, 12, 0, 360
bat 1, 11, "press any key"
Do
_Limit 60
A$ = InKey$
Loop Until A$ <> ""
'oh yeah ...
Cls
bat 1, 1, "To Boldy Block"
_Delay 0.3
bat 1, 2, "Where No Block"
_Delay 0.3
bat 1, 3, "Has Blocked Before"
_Delay 0.3
For x = 1 To 30
_Limit 10
blat 1, 99, " ", 15, 0
Next x
_Dest drawspace&
Cls
_Dest s&
For px = 1 To 22
_Limit 20
_Dest drawspace&: Cls
_Dest s&: Cls
drawplayership px, 50
_Display
Next px
For kx = 160 To 100 Step -1
_Limit 20
_Dest drawspace&: Cls
_Dest s&: Cls
drawplayership px, 50
drawkremulan kx, 60, 180
If kx < 140 Then
drawkremulan kx + 20, 70, 180
End If
If kx < 120 Then
drawkremulan kx + 40, 50, 180
End If
_Display
Next kx
bat 1, 1, "This Is Capt. Peek"
_Delay 0.5
_Display
bat 1, 2, " We"
_Delay 0.6
_Display
bat 5, 2, "Come"
_Delay 0.7
_Display
bat 10, 2, "In"
_Delay 0.8
_Display
bat 13, 4, "Peace"
_Display
_Delay 2
_Dest drawspace&: Cls
_Dest s&: Cls
drawplayership px, 50
drawkremulan kx, 60, 180
drawkremulan kx + 20, 70, 180
drawkremulan kx + 40, 50, 180
_Display
BSCR_klr = 6: BSCR_bkg = 0
bat 5, 2, "More FEDERATION LIES !"
_Display
_Delay 0.5
bat 5, 3, "The Real Question is "
_Display
_Delay 0.2
bat 6, 4, "To Block,": bat 7, 5, " Or Not To Block!"
_Display
_Delay 0.4
BSCR_klr = 15: BSCR_bkg = 0
bat 1, 11, "press any key..."
_Display
Do
A$ = InKey$
Loop Until A$ <> ""
_Dest drawspace&: Cls
_Dest s&: Cls
drawplayership px, 50
drawkremulan kx, 60, 180
drawkremulan kx + 20, 70, 180
drawkremulan kx + 40, 50, 180
_Display
kbx1 = kx - 4: kby1 = 60
kbx2 = kx + 16: kby2 = 70
kbx3 = kx + 36: kby3 = 50
fbx1 = px + 4: fby1 = 48
fbx2 = px + 4: fby2 = 52
For n = 1 To 100
_Limit 20
_Dest drawspace&: Cls
_Dest s&: Cls
If n > 60 Then px = px + 1
If n < 90 Then drawkremulan kx, 60, 180
drawkremulan kx + 20, 70, 180
If n < 95 Then drawkremulan kx + 40, 50, 180
drawplayership px, 50
If n < 20 Then
' blat kbx1 - n, 6, blk$(1), 4, 8
dburst kbx1 - n * 3, kby1 - (n * .8), 2, 4
End If
If n > 23 And n < 44 Then
' blat kbx1 - n, 6, blk$(1), 4, 8
dburst fbx1 + (n - 23) * 3, fby1 + n / 8, 2, 11
End If
If n > 25 And n < 46 Then
' blat kbx1 - n, 6, blk$(1), 4, 8
dburst fbx2 + (n - 25) * 3, fby2 + n / 10, 2, 11
End If
If n > 15 And n < 30 Then
dburst kbx2 - n * 3, kby2 - (n * .8), 2, 4
End If
If n > 12 And n < 27 Then
dburst kbx3 - n * 3, kby3 + (n * .8), 2, 4
End If
If n > 25 And n < 45 Then
dburst kbx3 - n * 3, kby3 + (n * .8), 2, 4
End If
If n > 52 And n < 90 Then
_Dest drawspace&
Select Case Int(Rnd * 8)
Case 0:
Line (px + 1, fby1)-(kbx1, kby1), 11
Line (px + 1, fby2)-(kbx3, kby3), 11
Case 1:
Line (px + 1, fby1)-(kbx1, kby1), 11
Line (px + 1, fby2)-(kbx2, kby2), 11
Case 2:
Line (px + 1, fby2)-(kbx3, kby3), 11
Case 3:
Line (px + 1, fby2)-(kbx2, kby2), 11
Case 4:
Line (px + 1, fby1)-(kbx1, kby1), 3
Case 5:
Line (px + 1, fby1)-(kbx1, kby1), 3
Line (px + 1, fby2)-(kbx3, kby3), 11
Case 6:
Line (px + 1, fby2)-(kbx3, kby3), 3
Line (px + 1, fby2)-(kbx2, kby2), 11
Line (px + 1, fby1)-(kbx1, kby1), 11
Case 7:
Line (px + 1, fby1)-(kbx1, kby1), 11
Line (px + 1, fby2)-(kbx2, kby2), 3
End Select
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
If n > 65 And n < 90 Then
dburst kbx1, kby1, Int(Rnd * 4) + 2, 12
If Int(Rnd * 9) < 7 Then dburst kbx1 + Int(Rnd * 4) + 2, kby1, Int(Rnd * 5), 14
If Int(Rnd * 9) < 7 Then dburst kbx1 + Int(Rnd * 6) + 2, kby1, Int(Rnd * 4), 4
End If
If n > 69 And n < 95 Then
dburst kbx2, kby2, Int(Rnd * 4) + 2, 12
If Int(Rnd * 9) < 7 And n < 93 Then dburst kbx2 + Int(Rnd * 4) + 2, kby2, Int(Rnd * 5), 14
If Int(Rnd * 9) < 7 Then dburst kbx2 + Int(Rnd * 6) + 2, kby2, Int(Rnd * 4), 4
End If
If n > 70 Then
dburst kbx3, kby3, Int(Rnd * 4) + 2, 12
If Int(Rnd * 9) < 7 And n < 98 Then dburst kbx3 + Int(Rnd * 4) + 2, kby3, Int(Rnd * 5), 14
If Int(Rnd * 9) < 7 Then dburst kbx3 + Int(Rnd * 6) + 2, kby3, Int(Rnd * 4), 4
End If
If n > 80 Then kx1 = kx1 + 2
If n > 90 Then kx3 = kb3 + 1
_Dest s&
End If
_Display
Next n
For n = 1 To 30
_Limit 20
_Dest drawspace&: Cls
_Dest s&: Cls
px = px + 2
drawplayership px, 50
If k < 25 Then
dburst kbx2, kby2, Int(Rnd * n) + 2, 12
If n < 23 Then drawkremulan kx + 20, 70, 180
_Dest drawspace&
Select Case Int(Rnd * 8)
Case 0:
Line (px + 1, fby1)-(kbx2, kby2), 3
Line (px + 1, fby2)-(kbx2, kby2), 11
Case 1:
Line (px + 1, fby1)-(kbx2, kby2), 11
Line (px + 1, fby2)-(kbx2, kby2), 3
Case 2:
Line (px + 1, fby1)-(kbx2, kby2), 11
Case 3:
Line (px + 1, fby2)-(kbx2, kby2), 3
End Select
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
End If
_Display
Next n
For n = 1 To 30
_Limit 20
_Dest drawspace&: Cls
_Dest s&: Cls
bat 1, 1, "It would seem that the"
bat 2, 2, " Kremulans decided to .."
If n > 15 Then bat 3, 3, " leave in PIECES"
px = px + 1
drawplayership px, 50
_Display
Next n
'the blockmode subs
bat 1, 11, "press any key"
_Display
A$ = ""
Do
_Limit 60
A$ = InKey$
Loop Until A$ <> ""
System
Sub bstart
For r = 1 To 30
_Limit 60
For b = 1 To 50
blat Int(Rnd * 160) + 1, Int(Rnd * 98) + 1, blk$(Int(Rnd * 4)), Int(Rnd * 16), Int(Rnd * 16)
Next b
Next r
_Delay 0.2
Cls
For r = 1 To 50
For c = 1 To 151
Bgrid(c, r, 1) = 0
Bgrid(c, r, 2) = BSCR_klr
Bgrid(c, r, 2) = BSCR_bkg
Next c
Next r
bfont$ = bfont$ + "€€€€€€€û€€€à€à€”¾”¾”ªÿª„¢„ˆ¢†¹Í²…€€ð€€€œ¢Á€€Á¢œ€ˆªœªˆˆˆ¾ˆˆ"
bfont$ = bfont$ + "€‡†€€ˆˆˆˆˆ€ƒƒ€€‚„ˆ ¾ÅÉѾ€¡ÿ¡ÃÅɱ¢ÉÉɶŒ”¤ÿ„úÉÉÉƾÉÉɦÃÄÈÐà"
bfont$ = bfont$ + "¶ÉÉɶ²ÉÉɾ€€¶€€€¶€€€ˆ”¢€€”””€€¢”ˆ€ ÀÅÈ°¾ÁÝż¿ÈÈÈ¿ÿÉÉɶ¾ÁÁÁ¢"
bfont$ = bfont$ + "ÿÁÁÁ¾ÿÉÉÉÁÿÈÈÈÀ¾ÁÁŦÿˆˆˆÿ€ÁÿÁ€‚ÁþÀÿˆ”¢Áÿÿ ÿÿ ˜„ÿ¾ÁÁÁ¾"
bfont$ = bfont$ + "ÿÄÄĸ¸ÄÄÄÿÿÈÌʱ²ÉÉɦÀÀÿÀÀþþü‚‚üþ†þÁ¶ˆ¶ÁÀ°°ÀÃÅÉÑကÿÁ€"
bfont$ = bfont$ + " ˆ„‚€Áÿ€€„ˆˆ„€Àà €‚•••þ‘‘‘ŽŽ‘‘‘‘Ž‘‘‘þŽ•••Œ€ˆ¿È ˆ•••Ž"
bfont$ = bfont$ + "ÿ€€Þ€€Þ€€ÿ„Š‘‘€€þŸŸŸˆŸŽ‘‘‘Ž’’’ŒŒ’’’Ÿˆˆˆ•••‚"
bfont$ = bfont$ + "€þ‘ž‚Ÿœ‚‚œž†ž‘Š„Š“™……‚œ‘“•™‘€ˆ¶Á€€€÷€€€Á¶ˆ€ˆˆ„ˆˆ„ˆ"
b96$ = b96$ + " !" + Chr$(34) + "#$%&'()*+,-./0123456789:;<=>?"
b96$ = b96$ + "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_"
b96$ = b96$ + "`abcdefghijklmnopqrstuvwxyz{|}~"
End Sub
Sub bat (bcol, brow, B$)
'print block charcters into fixed spots)
bb = 0: br = brow
For bc = 1 To Len(B$)
bb = bb + 1
If bb = 27 Then
bb = 1
br = br + 1
End If
bchar Mid$(B$, bc, 1), (bcol + bb) * 6 - 11, (br * 8) - 7
Next bc
End Sub
Sub blat (bcol, brow, B$, Bklr, Bbkg)
'color print specific blocks
Color Bklr, Bbkg
Locate brow, bcol
Print B$
Color BSCR_klr, BSCR_bkg
End Sub
Sub BSET (bcol, brow, BK, Bklr, Bbkg)
'sets characters and colors on the BGRID
Bgrid(bcol, brow, 1) = BK
Bgrid(bcol, brow, 2) = Bklr
Bgrid(bcol, brow, 3) = Bbkg
End Sub
Sub drawblocks (bc1, bc2, br1, br2)
'show the bgrid
'drawing after row 98 will scroll the screen...ooops
For bc = bc1 To bc2
For br = br1 To br2
blat bc, br, blk$(Bgrid(bc, br, bgblk)), Bgrid(bc, br, bgklr), Bgrid(bc, br, bbkg)
Next br
Next bc
End Sub
Sub bchar (bstr$, bx, by) ' ==== THIS IS a modified MicroFont ROUTINE ====
' -- prints string bstr at position ixx0 and iy0 --
ixx0 = bx
iyy0 = by + 8
Dim ipobstr, ipob96, ipos480, ix0, iy0, ix, iy, imask, ich
ix0 = ixx0 - 1: iy0 = iyy0 + 1 ' byValue
For ipobstr = 1 To Len(bstr$) ' one character at a time
ipob96 = InStr(1, b96$, Mid$(bstr$, ipobstr, 1))
If ipob96 = 0 Then ipob96 = 4 ' invalid character -> #
ipos480 = (ipob96 - 1) * 5 ' index to bfont$
For ix = 0 To 6: imask = 1 ' OxxxxxO 5 columns in character
If 1 <= ix And ix <= 5 Then ich = Asc(Mid$(bfont$, ipos480 + ix, 1))
For iy = 0 To 8 ' OxxxxxxxO 7 rows in character
If ix < 1 Or ix > 5 Or iy < 1 Or iy > 7 Then
' blat ix0 + ix, iy0 - iy, blk$(0), BSCR_klr, BSCR_bkg
Else ' choose FG or BG
If ich And imask Then ' ck bit
blat ix0 + ix, iy0 - iy, blk$(3), BSCR_klr, BSCR_klr
Else
' blat ix0 + ix, iy0 - iy, blk$(0), BSCR_klr, BSCR_bkg
End If
imask = imask + imask ' next bit in column
End If
Next iy
Next ix
ix0 = ix0 + 6 ' next char output
Next ipobstr
' could modify ix here
End Sub
Sub bdraw (BD$)
_Dest drawspace&
If LCase$(BD$) = "CLR" Then
Cls
BD$ = ""
Else
Draw BD$
End If
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
End Sub
Sub bcircle (xx, yy, r, klr)
'draw a circle
_Dest drawspace&
PSet (xx, yy), 0
Draw "c" + Str$(klr)
For d = 0 To 360 Step 1
Draw "ta " + Str$(d) + " r" + Str$(r) + " bl" + Str$(r)
Next d
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
End Sub
Sub barc (xx, yy, r, klr, arc1, arc2)
'draws an arc, will draw an unfilled circle if the arc goes from 0 to 360
_Dest drawspace&
t = Point(xx, yy)
PSet (xx, yy), t
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
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
End Sub
'these subs are used in the blocktrek portion of the demo
' showing how even low-res graphics can be fun
Sub drawplayership (xx, yy)
_Dest drawspace&
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"
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
End Sub
Sub drawkremulan (xx, yy, aa)
_Dest drawspace&
PSet (xx, yy), 0
kk = 6
Color kk
Circle (xx, yy + 2), 2, kk
Draw "ta" + Str$(aa) + "r2l1u3d6u3l10 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)
Draw "ta0"
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
End Sub
Sub dburst (xx, yy, r, klr)
_Dest drawspace&
PSet (xx, yy), klr
For d = 0 To 360 Step (1 + Rnd * 10)
rv = Int(r \ 1.9 + Rnd * (r / 2))
Draw "ta " + Str$(d) + "c" + Str$(klr) + " r" + Str$(rv) + " bl" + Str$(rv)
Next d
_Source drawspace&
For x = 1 To 160
For y = 1 To 98
b = Point(x, y)
If b > 0 Then
_Dest s&
blat x, y, blk$(3), b, b
End If
Next y
Next x
End Sub
|
|
|
|
| Possible bug? Unable to enter a comma in response to INPUT |
|
Posted by: hanness - 06-15-2022, 06:14 AM - Forum: General Discussion
- Replies (4)
|
|
In QB64pe 0.8.2 take a look at this code:
Code: (Select All) a$ = "This is a string, with a comma"
Input b$
Print a$
Print b$
Notice that the first line simply set a string and that the string contains a comma.
The second line is asking for input from a user. Start typing in a string of characters, and somewhere along the line, try to type a comma. The comma will not be accepted.
When it gets to the print statements, it prints the string of text that includes a comma, so clearly a comma is a valid character in a string. Since a comma is a valid character, an INPUT should allow a user to input a comma as part of the string.
|
|
|
|
| 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 (96)
|
 |
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
|
|
|
|
| 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"
|
|
|
|
|
