+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: A dice parser (/showthread.php?tid=1851)
A dice parser - James D Jarvis - 07-18-2023
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
'*******************************************************
'setting up sample rolls to demonstarte routines
Dim r$(12)
r$(1) = "1d6"
r$(2) = "2d6"
r$(3) = "1s8"
r$(4) = "1e8"
r$(5) = "2t10"
r$(6) = "1d6+1d3"
r$(7) = "1d12+1s4"
r$(8) = "-2t100"
r$(9) = "1d4+1d6+1d8"
r$(10) = "1s20+1f5"
r$(11) = "1d10000/1s4"
r$(12) = "1t200-1s200"
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 FunctionRE: A dice parser - SMcNeill - 07-18-2023
https://qb64phoenix.com/forum/showthread.php?tid=250&pid=1028#pid1028 -- There's my dice rolling routine. It works with any sort of requirements which you'd ever need for any type of table-top RPG you'll ever encounter.
RE: A dice parser - OldMoses - 07-18-2023
I stripped this little tidbit out of my Runequest character generator. Change the R$ to whatever quantity, type of dice, and modifier that you need.
Code: (Select All)
RANDOMIZE TIMER
R$ = "2d6"
Build_Dice R$, a%
PRINT a%
END
FUNCTION DiceRoll% (quan AS INTEGER, dice AS INTEGER, plus AS INTEGER)
'Rolls any number of dice of any number of sides and adds modifiers
'syntax usage: DiceRoll% (number of dice rolled, number of sides, any modifier)
DIM t%, x%
t% = plus ' add modifier
FOR x% = 1 TO quan ' roll die <quan>tity of times
t% = t% + INT(RND * dice) + 1 ' total up results
NEXT x%
DiceRoll% = t%
END FUNCTION 'DiceRoll%
SUB Build_Dice (roll AS STRING, result AS INTEGER)
'Parse a dice roll string and roll it, return in result
roll = UCASE$(roll)
dpos% = INSTR(roll, "D")
qn% = -VAL(MID$(roll, 1, dpos% - 1)) * (dpos% > 1) - (dpos% = 1)
p% = INSTR(roll, "+")
n% = INSTR(roll, "-")
IF p% <> 0 THEN md% = VAL(MID$(roll, p%)): dc% = VAL(MID$(roll, dpos% + 1, p% - dpos% + 1))
IF n% <> 0 THEN md% = VAL(MID$(roll, n%)): dc% = VAL(MID$(roll, dpos% + 1, n% - dpos% + 1))
IF p% = 0 AND n% = 0 THEN md% = 0: dc% = VAL(MID$(roll, dpos% + 1))
result = DiceRoll%(qn%, dc%, md%)
END SUB 'Build_Dice