home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
xbase
/
library
/
dbase
/
duflp
/
frpg.prg
< prev
next >
Wrap
Text File
|
1992-06-25
|
19KB
|
462 lines
*-------------------------------------------------------------------------------
*-- Program...: FRPG.PRG
*-- Programmer: Ken Mayer (KENMAYER)
*-- Date......: 06/25/1992
*-- Notes.....: These are Fantasy Role-Playing Game routines. For examples of
*-- the use of these routines, in much detail, I have a gaming
*-- system (constantly being modified) that uses these routines
*-- extensively. It's a fantasy system, based in 'Middle Earth'.
*-- It includes: Character Generation (updating, printing, deleting);
*-- Random Encounters (Wilderness and City); and Random Treasure
*-- Generation. If interested, contact me. Information is in
*-- README.TXT. This system is not yet ready for 'public
*-- consumption', but sometime early 1992 ... (RSN <G>)
*-------------------------------------------------------------------------------
PROCEDURE SetRand
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 02/18/1992
*-- Notes.......: A small procedure used to set a random number table. Used with
*-- DICE(), etc. below, it can be quite handy. NOTE: You should
*-- use EITHER this routine, OR RAND(-1) (built in to dBASE).
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Do SetRand
*-- Example.....: Do SetRand
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
private x,nSeed
nSeed = (val(substr(time(),1,2)) + val(substr(time(),4,2))+;
val(substr(time(),7,2))) * val(substr(time(),7,2))
x=int(rand(nSeed) * 6) + 1
RETURN
*-- EoP: SetRand
FUNCTION Dice
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 02/13/1992
*-- Notes.......: A small function used to determine a random number from
*-- 1 to x. Used for gaming purposes.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/23/1991 - original function.
*-- 02/13/1992 -- Ken Mayer -- discovered after playing with this
*-- that there are some problems with resetting the random table
*-- each time. This has been removed. It also means that a
*-- couple of routines that used to be based on this can use
*-- it better (see: MULTDICE() below ...)
*-- Calls.......: None
*-- Called by...: Any
*-- MULTDICE() Function in FRPG.PRG
*-- Usage.......: Dice(<nSides>)
*-- Example.....: nVal = Dice(4)
*-- Returns.....: Random # between 1 and <nSides>
*-- Parameters..: nSides = # of sides of die to be cast ... (RPG dice
*-- include 4, 6 (standard), 8, 10, 12, 20, 100 ...
*-------------------------------------------------------------------------------
parameters nSides
*-- return a random number from 0 to nSides -1 and add 1 to it ...
RETURN int(rand() * nSides) + 1
*-- EoF: Dice()
FUNCTION MultDice
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 02/13/1992
*-- Notes.......: Function like above, used to determine a random #,
*-- but for multiple dice, of x# of sides.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 06/12/1991 - original function.
*-- 02/13/1992 -- cleaned up to call DICE() above for each
*-- iteration, rather than calling once and then redoing the
*-- randomizer logic ... I was setting the random table
*-- in the DICE() function, but decided it was more trouble
*-- than it was worth ... resetting it too fast (i.e., in a loop)
*-- and I was getting the exact same number 2 to 4 times in a
*-- row ... not worth it. SO, I don't anymore.
*-- Calls.......: DICE() Function in FRPG.PRG
*-- Called by...: Any
*-- Usage.......: MultDice(<nNum>,<nSides>)
*-- Example.....: nVal = MultDice(3,6)
*-- Returns.....: Random value of 1 to x (x being number of sides),
*-- for each iteration (nNum), totalled. For example,
*-- value returned would be the total of 3 six-sided die
*-- rolled, the number would be anywhere from 3 to 18.
*-- Parameters..: nNum = Number of dice to be "rolled"
*-- nSides = # of sides to the dice (see Dice() above)
*-------------------------------------------------------------------------------
parameters nNum,nSides
private nCount,nTotal
nCount = 0 && set counter
nTotal = 0 && set total
do while nCount < nNum && loop for number of dice
nCount = nCount + 1 && increment counter
nTotal = nTotal + dice(nSides) && add to total
enddo
RETURN nTotal
*-- EoF: MultDice()
FUNCTION ValiDice
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 06/08/1992
*-- Notes.......: Used to ask user for input of a number within a range
*-- based on gaming dice. Programmer supplies # of dice,
*-- and number of sides to function, it returns the input
*-- from the user (and only allows valid input).
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/09/1991 - original function.
*-- 02/13/1992 -- modified to handle user pressing <Esc>.
*-- 06/08/1992 -- explicit color handling
*-- Calls.......: SHADOW Procedure in PROC.PRG
*-- CENTER Procedure in PROC.PRG
*-- COLORBRK() Function in PROC.PRG
*-- RECOLOR Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: ValiDice(<nNum>,<nDice>,"<cMessage>","<cColor>")
*-- Example.....: replace STRENGTH with ValiDice(3,6,"Strength",;
*-- "rg+/gb,w/n,rg+/gb") && 3 6-sided
*-- Returns.....: Valid user input
*-- Parameters..: nNum = Number of dice
*-- nSides = Number of sides
*-- cMessage = Message for line 0
*-- cColor = Colors for window
*-------------------------------------------------------------------------------
PARAMETERS nNum, nDice, cMessage, cColor
private nUpper,nUser, cTempCol,cCurColor
save screen to sDice
*-- save colors
cCurColor = set("ATTRIBUTES")
*-- set colors
cTempCol = colorbrk(cColor,1)
set color of normal to &cTempCol
set color of message to &cTempCol
cTempCol = colorbrk(cColor,2)
set color of highlight to &cTempCol
cTempCol = colorbrk(cColor,3)
set color of box to &cTempCol
define window wDice from 8,20 to 14,60 double
do shadow with 8,20,14,60
activate window wDice
nUpper = nNum * nDice && upper limit
do center with 0,40,"","&cMessage"
do center with 1,40,"","Enter a value from "+ltrim(str(nNum))+" to "+;
ltrim(str(nUpper))
do center with 2,40,"","("+ltrim(str(nNum))+"d"+ltrim(str(nDice))+")"
nUser = 0
do while .t.
@4,18 get nUser picture "999" valid required nUser => nNum .and.;
nUser =< nUpper;
error chr(7)+"Enter a valid number!"
read
if lastkey() = 27
?? chr(7)
else
exit
endif
enddo
deactivate window wDice
release window wDice
restore screen from sDice
release screen sDice
*-- restore colors
do ReColor with cCurColor
RETURN nUser
*-- EoF: ValiDice()
FUNCTION DiceChoose
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 06/08/1992
*-- Notes.......: This is another FRPG routine -- It is used to give the
*-- user a choice of three die roles. The computer will
*-- randomly generate a die roll three times so the user
*-- has a choice.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/09/1991 - original function
*-- 02/13/1992 -- Modified to only require use of MULTDICE(),
*-- not a call to DICE() AND MULTDICE() ... also modified to
*-- deal with user pressing <Esc> (it beeps at 'em).
*-- 06/08/1992 -- Explicit color handling
*-- Calls.......: MULTDICE() Function in FRPG.PRG
*-- SHADOW Procedure in PROC.PRG
*-- CENTER Procedure in PROC.PRG
*-- COLORBRK() Function in PROC.PRG
*-- RECOLOR Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: DiceChoose(<nNum>,<nSides>,"<nMessage>","<cColor>")
*-- Example.....: replace STRENGTH with DiceChoose(3,6,;
*-- "To determine your character's Strength",;
*-- "rg+/gb,w+/n,rg+/gb")
*-- Returns.....: The value of one of the choices displayed for the user,
*-- which will be a value from nNum to nNum*nSides + nNum+nPlus.
*-- Parameters..: nNum = number of dice to be rolled
*-- nSides = number of sides for each dice
*-- cMessage = Message to be displayed at line 0 (max 40 Char)
*-- cColor = Colors for the window
*-------------------------------------------------------------------------------
PARAMETERS nNum, nSides, cMessage, cColor
private nVal1,nVal2,nVal3,nUser,cTempCol,cCurColor
*-- save colors
cCurColor = set("ATTRIBUTES")
*-- set colors
cTempCol = colorbrk(cColor,1)
set color of normal to &cTempCol
set color of message to &cTempCol
cTempCol = colorbrk(cColor,2)
set color of highlight to &cTempCol
cTempCol = colorbrk(cColor,3)
set color of box to &cTempCol
*-- here we determine the three values for the user (roll the dice) --
nVal1 = multdice(nSides,nNum)
nVal2 = multdice(nSides,nNum)
nVal3 = multdice(nSides,nNum)
*-- now we have the three values we need, define windows/menu ...
define window wDice from 8,20 to 17,60 double
save screen to sDice
define menu mDice && as it says, define the menu
define pad pChoice1 of mDice prompt ltrim(str(nVal1)) at 3,18
define pad pChoice2 of mDice prompt ltrim(str(nVal2)) at 4,18
define pad pChoice3 of mDice prompt ltrim(str(nVal3)) at 5,18
on selection pad pChoice1 of mDice deactivate menu
on selection pad pChoice2 of mDice deactivate menu
on selection pad pChoice3 of mDice deactivate menu
*-- activate it all for user ...
do shadow with 8,20,17,60 && display shadow
activate window wDice && startup the window
*-- display info in Window
do center with 0,40,"","&cMessage"
do center with 1,40,"","Choose a value from below:"
@3,15 say "1)"
@4,15 say "2)"
@5,15 say "3)"
do center with 7,40,"","Use Arrow keys, <Enter> to choose"
do while .t.
activate menu mDice && startup menu
if lastkey() = 27
?? chr(7)
else
exit
endif
enddo
do case && determine value to be returned
case pad() = "PCHOICE1"
nUser = nVal1
case pad() = "PCHOICE2"
nUser = nVal2
case pad() = "PCHOICE3"
nUser = nVal3
endcase
*-- cleanup
release menu mDice
deactivate window wDice
release window wDice
restore screen from sDice
release screen sDice
on escape
*-- restore colors
do recolor with cCurColor
RETURN nUser
*-- EoF: DiceChoose()
FUNCTION ParseDice
*-------------------------------------------------------------------------------
*-- Programmer...: Ken Mayer (KENMAYER)
*-- Date.........: 02/13/1992
*-- Notes........: This is another gaming function ...
*-- It's purpose is to read a string in the format xdy+z or
*-- some variation, and calculate the value ...
*-- x = # of dice,
*-- d = a part of the standard gaming syntax (i.e., 3d6),
*-- y = # of sides of dice,
*-- + = a modifier (could be a minus also ...)
*-- z = number to modify each die rolled
*-- (3d6+1 = a value from 6 to 21 (figure if you add 1 to each
*-- die rolled, minimum value will be 6 (3+3), maximum will
*-- be 21 (18+3))).)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 08/29/1991 - original function.
*-- 02/13/1992 -- minor -- changed randomizer call to DICE()
*-- Calls.......: ALLTRIM() Function in PROC.PRG
*-- DICE() Function in FRPG.PRG
*-- Called by...: Any
*-- Usage.......: ParseDice("<cDice>")
*-- Example.....: ? ParseDice("5d6-3")
*-- Returns.....: Random number from x (modified by z) to y (modified by z)
*-- Parameters..: cDice = Standard gaming format value to be parsed and
*-- calculated.
*-------------------------------------------------------------------------------
parameter cDice && value to parse and return a # from ...
private nCount,cDice,nPos,nNumDice,nMod,nDice,nPos2,nReturn
cDice = upper(alltrim(cDice)) && trim out ALL extra spaces on left and right,
&& and convert to all caps (for check for
&& letter 'D')
if at("D",cDice) > 0 && if the letter 'D' is in there ...
*-- get the VALUE of the "substring" of cDice, starting at
*-- character 1, going to the letter D and backing up 1.
*-- this will be useful in case we have 10dy ... otherwise,
*-- we _could_ assume only one character, but assumptions are
*-- bad ...
nPos = at("D",cDice)
nNumDice = val(substr(cDice,1,nPos-1))
nPos = nPos + 1 && move to character beyond letter 'D'
if at("+",cDice) > 0 && if we have a + modifier
nPos2 = at("+",cDice)
nDice = val(substr(cDice,nPos,nPos2-1))
nMod = val(substr(cDice,nPos2+1,len(cDice)-nPos2))
else
if at("-",cDice) > 0 && if we have a - modifier
nPos2 = at("-",cDice)
nDice = val(substr(cDice,nPos,nPos2-1))
nMod = val(substr(cDice,nPos2+1,len(cDice)-nPos2))
else && no modifier
nDice = val(substr(cDice,nPos,len(cDice)-nPos+1))
endif && check for - sign
endif && check for + sign
*-- roll the nDice sided "dice" nNumDice number of times ...
nCount = 0
nReturn = 0
do while nCount < nNumDice
nCount = nCount + 1
nReturn = nReturn + dice(nDice)
enddo
*-- Modifiers -- add or subtract appropriate value
if at("+",cDice) > 0 && if there's a + sign,
nReturn = nReturn + (nNumDice * nMod)
endif
if at("-",cDice) > 0 && it's a minus sign
nReturn = nReturn - (nNumDice * nMod)
endif
else && there's no letter 'D', so we simply have a number to return
&& this is under the assumption that the value passed is either
&& a random one, or (in this case) it's a set value ... for
&& example, in some cases in my gaming system, HitPoints for a
&& critter may be a set value, in others it may be a random one.
&& this routine handles both ...
nReturn = val(cDice)
endif
RETURN nReturn
*-- EoF: ParseDice()
PROCEDURE PopDice
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 06/08/1992
*-- Notes.......: Used in my FRPG system as a Gamemaster's aid ... I can simply
*-- press <Alt>D and have the system popup a window over whatever
*-- I'm doing, ask for a "dice string" as in PARSEDICE(), and have
*-- it return a value. That way I'm not stuck digging for the
*-- dice in the middle of a situation that calls for a quick roll.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 06/08/1992 -- Explicit color handling ...
*-- Calls.......: SHADOW Procedure in PROC.PRG
*-- CENTER Procedure in PROC.PRG
*-- PARSEDICE() Function in FRPG.PRG
*-- COLORBRK() Function in PROC.PRG
*-- RECOLOR Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Do PopDice with <cColor>
*-- Example.....: ON KEY LABEL ALT-D DO POPDICE WITH "RG+/GB,W+/N,RG+/GB"
*-- Returns.....: None
*-- Parameters..: cColor = window colors ...
*-------------------------------------------------------------------------------
parameters cColor
private cDice,cCursor, cCurColor, cTempCol
*-- setup
cCursor = set("CURSOR")
set cursor off
save screen to sPop && save the screen
*-- save colors
cCurColor = set("ATTRIBUTES")
*-- set colors
cTempCol = colorbrk(cColor,1)
set color of normal to &cTempCol
set color of message to &cTempCol
cTempCol = colorbrk(cColor,2)
set color of highlight to &cTempCol
cTempCol = colorbrk(cColor,3)
set color of box to &cTempCol
define window wPop from 7,20 to 15,60 double
do shadow with 7,20,15,60
activate window wPop
do center with 0,40,"","PopDice (c) 1992"
*-- loop until user pressed such keys as <Enter> or <Esc> ...
do while .t.
store space(10) to cDice && blank out field
@2,2 say "Enter dice description: " get cDice;
message "Examples: 6 (1d6), d6, 3d6, 3d6+1, 3d6-1 ..."
set cursor on
read
set cursor off
if len(trim(cDice)) = 0 && len ... = 0, time to close down ...
exit
endif
if at("D",upper(cDice)) = 0 && parsedice() requires xD at front ...
cDice = "1d"+cDice
endif
if upper(left(cDice,1)) = "D" && must be at least 1 ...
cDice = "1" + cDice
endif
@4,7 say " Dice Rolled: "+cDice && display what's being done
@5,0 clear && clear out messages, etc.
do center with 6,40,"rg+/r",". . . Calculating . . ."
*-- do it ... and display it
@5,7 say "Value returned: "+ltrim(str(parsedice(cDice)))
@6,0 clear
enddo
*-- cleanup
deactivate window wPop
release window wPop
restore screen from sPop
release screen sPop
set cursor &cCursor
*-- restore colors
do recolor with cCurColor
RETURN
*-- EoP: PopDice
*-------------------------------------------------------------------------------
*-- EoP: FRPG.PRG
*-------------------------------------------------------------------------------