A dice parser

[James D Jarvis]

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 Function