A dice parser to return a score from a string that describes a dice roll.
roll("2d6") would return a score from 2 to 12
These routines are part of a Role Playing Game related program and mat be useful to others.
This sample program demonstrates 12 different string and the results generated.
Code: (Select All)
'dice parser july 2023
'by James D. Jarvis
'a simpe dice parser for an RPG game that will evalute a string and generate the roll described
' d = dice,standard equal distribution range
' s = short dice, trends to generate low value in range
' f = fat dice, trends to generate median value in range
' t = tall dice, trend to generate higher values in range
' e = exploding die
'******************************************************
'Include these in nay program using the routines here
'$dynamic
Randomize Timer
Dim Shared de$(0) 'dice experssion
Dim Shared drf$(0) 'dice function
Dim Shared dn
Dim Shared ds
'*******************************************************
Do
For x = 1 To 12
rr = roll(r$(x))
Print r$(x); "= "; rr
Next x
Print
Print "Press any key for more rolls, <esc> to exit"
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
Cls
Loop Until kk$ = Chr$(27)
'roll dice
Function rolld (num, sides)
score = 0
For n = 1 To num
score = score + Int(1 + Rnd * sides)
Next n
rolld = score
End Function
'roll short dice
Function rolls (num, sides)
score = 0
For n = 1 To num
A = Int(1 + Rnd * sides)
B = Int(1 + Rnd * sides)
C = Int(1 + Rnd * sides)
add = A
If add > B Then add = B
If add > C Then add = C
score = score + add
Next n
rolls = score
End Function
'roll tall dice
Function rollt (num, sides)
score = 0
For n = 1 To num
A = Int(1 + Rnd * sides)
B = Int(1 + Rnd * sides)
C = Int(1 + Rnd * sides)
add = A
If B > add Then add = B
If C > add Then add = C
score = score + add
Next n
rollt = score
End Function
'roll fat dice
Function rollf (num, sides)
score = 0
For n = 1 To num * 3
score = score + Int(1 + Rnd * sides)
Next n
rollf = Int(score / 3)
End Function
'roll exploding die
Function rolle (num, sides)
score = 0
b = 0
For n = 1 To num
a = Int(1 + Rnd * sides)
score = score + a
If a = sides Then
Do
b = Int(1 + Rnd * sides)
score = score + b
Loop Until b < sides
End If
Next n
rolle = score
End Function
'break out the individual rolls
Sub find_rolls (idd$)
c = 0
w$ = ""
xc = 0
dd$ = idd$ + "#" 'okay I'm lazy i added a termination symbol to the string
last$ = "+"
Do
c = c + 1
A$ = Mid$(dd$, c, 1)
Select Case A$
Case "+", "-", "/", "*", "#"
xc = xc + 1
ReDim _Preserve de$(xc)
ReDim _Preserve drf$(xc)
de$(xc) = w$
drf$(xc) = last$
w$ = ""
last$ = A$
Case Else
w$ = w$ + A$
End Select
Loop Until c >= Len(dd$)
End Sub
'the main fuction that is called to return a rolled value from the described dice roll
Function roll (idd$)
find_rolls idd$
dn = UBound(de$)
Dim ss(dn)
score = 0
For n = 1 To dn
dit$ = doroll$(de$(n))
Select Case doroll$(de$(n))
Case "d"
ss(n) = rolld(finddn(de$(n), dit$), findds(de$(n), dit$))
Case "s"
ss(n) = rolls(finddn(de$(n), dit$), findds(de$(n), dit$))
Case "t"
ss(n) = rollt(finddn(de$(n), dit$), findds(de$(n), dit$))
Case "f"
ss(n) = rollf(finddn(de$(n), dit$), findds(de$(n), dit$))
Case "e"
ss(n) = rolle(finddn(de$(n), dit$), findds(de$(n), dit$))
Case "V"
ss(n) = Val(de$(n))
End Select
Select Case drf$(n)
Case "+"
score = score + ss(n)
Case "-"
score = score - ss(n)
Case "/" 'divides the previolsy generated score
score = score / ss(n)
Case "*" 'multiplies the previolsy generated score
score = score * ss(n)
End Select
Next n
roll = score
End Function
Function doroll$ (dd$)
c = 1
Dim a$(6)
a$(1) = "d": a$(2) = "s": a$(3) = "f": a$(4) = "t": a$(5) = "e": a$(6) = "V"
d$ = "V"
Do
If InStr(dd$, a$(c)) > 0 Then
d$ = a$(c)
c = 6
End If
c = c + 1
Loop Until c > 6
doroll$ = d$
End Function
Function finddn (dd$, r$)
rp = InStr(dd$, r$)
a = Val(Left$(dd$, rp - 1))
finddn = a
End Function
Function findds (dd$, r$)
rp = InStr(dd$, r$)
a = Val(Right$(dd$, Len(dd$) - rp))
findds = a
End Function
Here's yet another silly game that I remembered from one of David L. Heiserman's books. But it's "customized" to my taste and knowledge of BASIC programming LOL. In this game you play a stunt paratrooper jumping out of a plane trying to evade buildings. The game should be straightforward, giving instructions on the screen. Either you jump or you don't, and if you jump don't go "splat" into a building and don't go off a side of the screen! The plane does a "loop" back to the beginning so it could wrap around the screen but the stunt paratrooper can't!
There is a peculiar RANDOMIZE statement, allowing a player to "practice" this program.
I should allocate some time for sound effects for this program. The original program had a quirk about the protagonist but didn't care how he/she was called. In fact I programmed another quirk before deciding to submit this, heh heh.
Code: (Select All)
'by mnrvovrfc 17-July-2023
option _explicit
dim nm$(1 to 7), histogram(1 to 80) as integer
dim as integer i, j, h, v, w, z, numtiles, numthalf, thresh
dim as integer x, y, px, py, fuel, recede, planecolor
dim ke$, handl$, jumped as _bit, die as integer
print "Welcome to Stunt Paratrooper!"
print: print "Please choose who do you want to be. Press any number key from [1] to [7]."
for i = 1 to 7
print "("; _trim$(str$(i)); ") "; nm$(i)
next
do
do : ke$ = inkey$ : loop while ke$ = ""
if ke$ = chr$(27) then end
v = val(ke$)
loop until v > 0 and v < 8
handl$ = nm$(v)
v = ubound(nm$) - v + 4
for i = 1 to numthalf
j = Random1(80)
histogram(j) = histogram(j) + 1
next
h = 0
for i = 1 to 80
if histogram(i) > h then h = histogram(i)
next
for i = 1 to numthalf
do
j = Random1(80)
loop until abs(histogram(j) - h) <= thresh
histogram(j) = histogram(j) + 1
next
h = 0
for i = 1 to 80
if histogram(i) > h then
h = histogram(i)
w = i
end if
if histogram(i) = 0 then histogram(i) = 1
next
if w = 80 then
z = 80
w = 78
else
z = w + 2
end if
histogram(w + 1) = 0
color 6
locate 25, 1 : print string$(79, 46);
locate 24, 1 : print string$(80, 46);
color 8
for i = 1 to 80
y = 24
for j = histogram(i) to 1 step -1
locate y, i
print chr$(177);
y = y - 1
if y < 10 then exit for
next
next
color 4
locate 1, 1 : print handl$;
color 3
print " you have to hit the grass between those buildings! Good luck!"
color 5
locate 2, 1 : print "Press [ESC] to quit. Press spacebar to jump out of plane."
fuel = 6
recede = fuel - 1
jumped = 0
x = 1
y = 5
planecolor = 7
do : ke$ = inkey$ : loop until ke$ = ""
do
color planecolor
locate y, x : print "|_^";
for i = 1 to 10
_delay 0.05
ke$ = inkey$
if ke$ <> "" then
if ke$ = chr$(27) then system
if ke$ = chr$(32) then
jumped = 1
exit for
end if
end if
next
locate y, x : print space$(3);
x = x + 1
if x > 78 then
x = 1
if y < 8 then y = y + 1
fuel = fuel - 1
if fuel < 1 then exit do
if fuel < 3 then
color 4
locate 1, 1 : print space$(80);
locate 1, 1 : print handl$; " you need to jump now, I'm running out of fuel!"
end if
end if
if fuel < 3 then
if planecolor = 7 then planecolor = 8 else planecolor = 7
end if
loop until jumped
if jumped then
color 4
locate 1, 1 : print space$(80);
locate 2, 1 : print space$(80);
locate 1, 1
if fuel = recede then
print "BE CAREFUL "; handl$; "!!!"
else
print handl$; " has jumped!"
end if
px = x + 1
py = y
do while v
py = py + 1
if fuel = recede then
px = px - 1
if px < 1 then
die = 2
exit do
end if
else
px = px + 1
if px > 80 then
die = 2
exit do
end if
end if
color 12
locate py, px : print chr$(2);
x = x + 1
if x > 78 then x = 1
color 7
locate y, x : print "|_^";
v = v - 1
_delay 0.5
locate py, px : print " ";
locate y, x : print space$(3);
loop
if die = 0 then
do
'this should not need screen bounds checking
py = py + 1
h = screen(py, px)
if h = 46 then die = 0 : exit do
if h = 177 then die = 1 : exit do
color 12
locate py, px : print chr$(2);
x = x + 1
if x > 78 then x = 1
color 7
locate y, x : print "|_^";
_delay 0.5
locate py, px : print " ";
locate y, x : print space$(3);
loop
end if
color 5
locate 2, 1
select case die
case 0
print "GOOD JOB "; handl$; "!!! You have landed on the grass."
case 1
print "You crashed into a building! OUCH!!!"
case 2
print "Sorry but you went out of bounds which is not the purpose of this game. "
end select
end
else
color 4
locate 1, 1 : print space$(80);
locate 1, 1 : print "Sorry but you have lost.";
color 7
do until y > 23
locate y, x : print space$(3);
y = y + 1
locate y, x : print "|_^";
_delay 0.25
loop
color 4
for i = 1 to 10
locate y, x : print "#*#";
_delay 0.125
locate y, x
if i > 7 then
print ".+.";
else
print "*#*";
end if
_delay 0.125
next
locate y, x : print space$(3);
_delay 1
end if
system
FUNCTION Random1& (maxvaluu&)
DIM sg AS INTEGER
sg% = SGN(maxvaluu&)
IF sg% = 0 THEN
Random1& = 0
ELSE
IF sg% = -1 THEN maxvaluu& = maxvaluu& * -1
Random1& = INT(RND * maxvaluu& + 1) * sg%
END IF
END FUNCTION
Actually there are no pointers in Basic like in C, but maybe they can be imitated. I've tried this now with VarPtr, Peek and Poke, and I didn't find any error in my exercise to achieve this. I don't see any at the moment either. Access to the memory address is basically like in C, and I can also change the content.
Pointers are a powerful, but also dangerous, tool in C! One could definitely good use them in Basic too. I think so.
I would be grateful to anyone who is interested and takes a look at the program if they could point out whether and if so, where I made a mistake in my thinking.
The explanations/comments are of course in German, so I can understand what's going on.
Code: (Select All)
'Zeigerbeispiel in Basic - 16. Juli 2023
'Mit VarPtr und Peek und Poke ist es moeglich Zeiger in
'Basic nachzuahmen.
$Console:Only
Option _Explicit
Dim As Long zahl1, zahl2, wert, wert2
Dim As Long speicherAdresse, speicherAdresse2
Locate 2, 3
Input "Zahl 1: ", zahl1
Locate 3, 3
Input "Zahl 2: ", zahl2
Locate 5, 3
Print Using "Zeige Zahl 1: ### -- Zahl 2: ### "; zahl1, zahl2
'Adresse der Zahl im Speicher ermitteln
speicherAdresse = VarPtr(zahl1)
'Inhalt der Speicheradresse
Locate 11, 3
Print "Inhalt der 2ten Speicheradresse: ", wert2
Locate 12, 3
Print "Jetzt auf die Adresse von Zahl 2 zugreifen, um den Inhalt zu aendern."
'Der 2ten Variablen den Wert von wert2 von der
'ersten Speicheradresse zuweisen
Locate 14, 3
wert2 = Peek(speicherAdresse)
Print "2te Variable hat jetzt den selben Wert wie Zahl 1: ", wert2
I'm attempting to recreate the look and feel of the original BattleStar Galactica lasers that the Colonial Vipers (red lasers) and the Cylon Raiders (white/blue lasers) produced. Below you can see a montage of screen shots showing the various lasers in action. There's also a link to a short 4 minute clip of the show showing the two ships shooting at each other.
I've tried to recreate this effect a number of different ways using image files, rotozoom and_PUTIMAGE, shading using alpha blends, and other various things that always look like crap. I'm horrible when it comes to custom graphics.
So here's the challenge if you choose to accept it: Create this laser effect on a 2D screen where the laser can be pointed and shot in any one of 360 degrees. I've posted an early attempt of my code to give you and idea of what to shoot for. I'm working on a game based on the old BG series and I really want to get the lasers looking as authentic as possible.
TYPE TYPE_LINE
Start AS TYPE_VECTOR ' start coordinate of laser beam line
Finish AS TYPE_VECTOR ' end coordinate of laser beam line 'Center AS TYPE_VECTOR ' center coordinate of laser beam line END TYPE
Index = -1' reset index counter DO' begin free index search
Index = Index + 1' increment index counter IF Laser(Index).Active = 0THENEXIT DO' is this index free? LOOP UNTIL Index = UBOUND(Laser) ' leave when all indexes checked IF Laser(Index).Active THEN' were all indexes checked?
Index = Index + 1' yes, no free indexes, increment index REDIM_PRESERVE Laser(Index) AS TYPE_LASER ' create a new index in array END IF
Degree = FIX_DEGREE(Degree)
Laser(Index).Active = -1
Laser(Index).Origin = Origin
Laser(Index).Vector = Vec(Degree)
Laser(Index).Degree = Degree
LINE (Laser(Index).Tail.Start.x, Laser(Index).Tail.Start.y)-(Laser(Index).Tail.Finish.x, Laser(Index).Tail.Finish.y), Laser(Index).LaserColor LINE -(Laser(Index).Head.Finish.x, Laser(Index).Head.Finish.y), Laser(Index).LaserColor LINE -(Laser(Index).Head.Start.x, Laser(Index).Head.Start.y), Laser(Index).LaserColor LINE -(Laser(Index).Tail.Start.x, Laser(Index).Tail.Start.y), Laser(Index).LaserColor
LINE (Laser(Index).Tail.Start.x, Laser(Index).Tail.Start.y)-(Laser(Index).Tail.Finish.x, Laser(Index).Tail.Finish.y), Laser(Index).GlowColor LINE -(Laser(Index).Head.Finish.x, Laser(Index).Head.Finish.y), Laser(Index).GlowColor LINE -(Laser(Index).Head.Start.x, Laser(Index).Head.Start.y), Laser(Index).GlowColor LINE -(Laser(Index).Tail.Start.x, Laser(Index).Tail.Start.y), Laser(Index).GlowColor
Deg = Degree ' get passed in degree value IF Deg < 0OR Degree > 359THEN' degree out of range?
Deg = Deg MOD360' yes, get remainder of modulus 360 IF Deg < 0THEN Deg = Deg + 360' add 360 if less than 0 END IF FIX_DEGREE = Deg ' return degree
UNSCRAMBLEPIC.BAS is a relaxing picture puzzle for all ages. A picture is shown, then broken up into pieces which are randomly rotated in different positions. Your goal is to rotate each piece back into the correct direction so they will show the correct picture again. This program uses a built-in image, but you could supply your own image instead (look in the code for that place).
Use the mouse and click on the pieces to rotate them. Left click will turns them clockwise, right click turns them counter clockwise. If you get stuck, you can press SPACE to briefly show the solved picture. The included picture is shown below (picture was made in a QB64 program).
Posted by: Dav - 07-14-2023, 03:24 AM - Forum: Games
- Replies (14)
UNSCRAMBLEPIC.BAS is a relaxing picture puzzle for all ages. A picture is shown, then broken up into pieces which are randomly rotated in different positions. Your goal is to rotate each piece back into the correct direction so they will show the correct picture again. This program uses a built-in image, but you could supply your own image instead (look in the code for that place).
Use the mouse and click on the pieces to rotate them. Left click will turns them clockwise, right click turns them counter clockwise. If you get stuck, you can press SPACE to briefly show the solved picture. The included picture is shown below (picture was made in a QB64 program).
I use a small gradient ball SUB in various programs. It had a flaw however - large balls with dark color values would have think back edges. Made a new version to fix that. Just thought I'd share it here. If you have one too, please share it - I'd love to see what other people are using. And if you see a way to improve mine please post it. Thanks!
- Dav
Code: (Select All)
'================
'GRADIENTBALL.BAS
'================
'Simple SUB that draw gradient balls.
'Coded by Dav, JULY/2023
SUB ball (x, y, size, r, g, b)
'This SUB draws a gradient ball with given color.
'see current display status
displayStatus%% = _AUTODISPLAY
'turn off screen updates while we draw
_DISPLAY
reg = .4
'if size is larger than value colors given,
'adjust the reg value to step down at a slower rate.
'This prevents thick black rim around larger balls
'that have a too low a given color value.
IF size > r AND size > g AND size > b THEN
IF r > g AND r > b THEN reg = r / size * .4
IF g > r AND g > b THEN reg = g / size * .4
IF b > r AND b > g THEN reg = b / size * .4
END IF
'now draw the ball using CIRCLE.
'Using smaller STEP value than 1 prevents gaps.
FOR s = 0 TO size STEP .4
CIRCLE (x, y), s, _RGB(r, g, b)
r = r - reg: g = g - reg: b = b - reg
NEXT
'show the ball
_DISPLAY
'If autodislay was previously on, turn it back on
IF displayStatus%% = -1 THEN _AUTODISPLAY
"
![[Image: Zeiger-in-Basic2023-07-16.jpg]](https://i.ibb.co/2c9RvCT/Zeiger-in-Basic2023-07-16.jpg)
