07-18-2023, 09:29 PM
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.
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 Function
