home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / frpg.prg < prev    next >
Text File  |  1992-06-25  |  19KB  |  462 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: FRPG.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are Fantasy Role-Playing Game routines. For examples of 
  6. *--             the use of these routines, in much detail, I have a gaming
  7. *--             system (constantly being modified) that uses these routines 
  8. *--             extensively. It's a fantasy system, based in 'Middle Earth'. 
  9. *--             It includes: Character Generation (updating, printing, deleting);
  10. *--             Random Encounters (Wilderness and City); and Random Treasure 
  11. *--             Generation. If interested, contact me. Information is in 
  12. *--             README.TXT. This system is not yet ready for 'public
  13. *--             consumption', but sometime early 1992 ... (RSN  <G>)
  14. *-------------------------------------------------------------------------------
  15.  
  16. PROCEDURE SetRand
  17. *-------------------------------------------------------------------------------
  18. *-- Programmer..: Ken Mayer (KENMAYER)
  19. *-- Date........: 02/18/1992
  20. *-- Notes.......: A small procedure used to set a random number table. Used with
  21. *--               DICE(), etc. below, it can be quite handy. NOTE: You should
  22. *--               use EITHER this routine, OR  RAND(-1) (built in to dBASE).
  23. *-- Written for.: dBASE IV, 1.1
  24. *-- Rev. History: None
  25. *-- Calls.......: None
  26. *-- Called by...: Any
  27. *-- Usage.......: Do SetRand
  28. *-- Example.....: Do SetRand
  29. *-- Returns.....: None
  30. *-- Parameters..: None
  31. *-------------------------------------------------------------------------------
  32.  
  33.     private x,nSeed
  34.     nSeed = (val(substr(time(),1,2)) + val(substr(time(),4,2))+;
  35.                val(substr(time(),7,2))) * val(substr(time(),7,2))
  36.     x=int(rand(nSeed) * 6) + 1
  37.  
  38. RETURN
  39. *-- EoP: SetRand
  40.  
  41. FUNCTION Dice
  42. *-------------------------------------------------------------------------------
  43. *-- Programmer..: Ken Mayer (KENMAYER)
  44. *-- Date........: 02/13/1992
  45. *-- Notes.......: A small function used to determine a random number from
  46. *--               1 to x. Used for gaming purposes.
  47. *-- Written for.: dBASE IV, 1.1
  48. *-- Rev. History: 05/23/1991 - original function.
  49. *--               02/13/1992 -- Ken Mayer -- discovered after playing with this
  50. *--                that there are some problems with resetting the random table
  51. *--                each time. This has been removed. It also means that a 
  52. *--                couple of routines that used to be based on this can use
  53. *--                it better (see: MULTDICE() below ...)
  54. *-- Calls.......: None
  55. *-- Called by...: Any
  56. *--               MULTDICE()       Function in FRPG.PRG
  57. *-- Usage.......: Dice(<nSides>)
  58. *-- Example.....: nVal = Dice(4)
  59. *-- Returns.....: Random # between 1 and <nSides>
  60. *-- Parameters..: nSides = # of sides of die to be cast ... (RPG dice
  61. *--                        include 4, 6 (standard), 8, 10, 12, 20, 100 ...
  62. *-------------------------------------------------------------------------------
  63.  
  64.     parameters nSides
  65.  
  66.    *-- return a random number from 0 to nSides -1 and add 1 to it ...
  67. RETURN int(rand() * nSides) + 1
  68. *-- EoF: Dice()
  69.  
  70. FUNCTION MultDice
  71. *-------------------------------------------------------------------------------
  72. *-- Programmer..: Ken Mayer (KENMAYER)
  73. *-- Date........: 02/13/1992
  74. *-- Notes.......: Function like above, used to determine a random #,
  75. *--               but for multiple dice, of x# of sides.
  76. *-- Written for.: dBASE IV, 1.1
  77. *-- Rev. History: 06/12/1991 - original function.
  78. *--               02/13/1992 -- cleaned up to call DICE() above for each
  79. *--                iteration, rather than calling once and then redoing the
  80. *--                randomizer logic ... I was setting the random table
  81. *--                in the DICE() function, but decided it was more trouble
  82. *--                than it was worth ... resetting it too fast (i.e., in a loop)
  83. *--                and I was getting the exact same number 2 to 4 times in a
  84. *--                row ... not worth it. SO, I don't anymore.
  85. *-- Calls.......: DICE()               Function in FRPG.PRG
  86. *-- Called by...: Any
  87. *-- Usage.......: MultDice(<nNum>,<nSides>)
  88. *-- Example.....: nVal = MultDice(3,6)
  89. *-- Returns.....: Random value of 1 to x (x being number of sides), 
  90. *--               for each iteration (nNum), totalled. For example,
  91. *--               value returned would be the total of 3 six-sided die
  92. *--               rolled, the number would be anywhere from 3 to 18.
  93. *-- Parameters..: nNum   = Number of dice to be "rolled"
  94. *--               nSides = # of sides to the dice (see Dice() above)
  95. *-------------------------------------------------------------------------------
  96.  
  97.     parameters nNum,nSides
  98.     private nCount,nTotal
  99.     
  100.     nCount = 0                             && set counter
  101.     nTotal = 0                             && set total
  102.     do while nCount < nNum                 && loop for number of dice 
  103.         nCount = nCount + 1                 && increment counter
  104.         nTotal = nTotal + dice(nSides)      && add to total
  105.     enddo
  106.     
  107. RETURN nTotal
  108. *-- EoF: MultDice()
  109.  
  110. FUNCTION ValiDice
  111. *-------------------------------------------------------------------------------
  112. *-- Programmer..: Ken Mayer (KENMAYER)
  113. *-- Date........: 06/08/1992
  114. *-- Notes.......: Used to ask user for input of a number within a range
  115. *--               based on gaming dice. Programmer supplies # of dice,
  116. *--               and number of sides to function, it returns the input
  117. *--               from the user (and only allows valid input).
  118. *-- Written for.: dBASE IV, 1.1
  119. *-- Rev. History: 07/09/1991 - original function.
  120. *--               02/13/1992 -- modified to handle user pressing <Esc>.
  121. *--               06/08/1992 -- explicit color handling
  122. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  123. *--               CENTER               Procedure in PROC.PRG
  124. *--               COLORBRK()           Function in PROC.PRG
  125. *--               RECOLOR              Function in PROC.PRG
  126. *-- Called by...: Any
  127. *-- Usage.......: ValiDice(<nNum>,<nDice>,"<cMessage>","<cColor>")
  128. *-- Example.....: replace STRENGTH with ValiDice(3,6,"Strength",;
  129. *--                                       "rg+/gb,w/n,rg+/gb")  && 3 6-sided
  130. *-- Returns.....: Valid user input
  131. *-- Parameters..: nNum     = Number of dice
  132. *--               nSides   = Number of sides
  133. *--               cMessage = Message for line 0
  134. *--               cColor   = Colors for window
  135. *-------------------------------------------------------------------------------
  136.  
  137.     PARAMETERS nNum, nDice, cMessage, cColor
  138.     private nUpper,nUser, cTempCol,cCurColor
  139.     
  140.     save screen to sDice
  141.     *-- save colors
  142.     cCurColor = set("ATTRIBUTES")
  143.     *-- set colors
  144.     cTempCol = colorbrk(cColor,1)
  145.     set color of normal to &cTempCol
  146.     set color of message to &cTempCol
  147.     cTempCol = colorbrk(cColor,2)
  148.     set color of highlight to &cTempCol
  149.     cTempCol = colorbrk(cColor,3)
  150.     set color of box to &cTempCol
  151.     
  152.     define window wDice from 8,20 to 14,60 double 
  153.     do shadow with 8,20,14,60
  154.     activate window wDice
  155.     
  156.     nUpper = nNum * nDice    && upper limit
  157.     do center with 0,40,"","&cMessage"
  158.     do center with 1,40,"","Enter a value from "+ltrim(str(nNum))+" to "+;
  159.                             ltrim(str(nUpper))
  160.     do center with 2,40,"","("+ltrim(str(nNum))+"d"+ltrim(str(nDice))+")"
  161.     nUser = 0
  162.     do while .t.
  163.         @4,18 get nUser picture "999" valid required nUser => nNum .and.;
  164.                                                  nUser =< nUpper;
  165.                              error chr(7)+"Enter a valid number!"
  166.         read 
  167.         if lastkey() = 27
  168.             ?? chr(7)
  169.         else
  170.             exit
  171.         endif
  172.     enddo
  173.  
  174.     deactivate window wDice
  175.     release window wDice
  176.     restore screen from sDice
  177.     release screen sDice
  178.     *-- restore colors
  179.     do ReColor with cCurColor
  180.     
  181. RETURN nUser
  182. *-- EoF: ValiDice()
  183.  
  184. FUNCTION DiceChoose
  185. *-------------------------------------------------------------------------------
  186. *-- Programmer..: Ken Mayer (KENMAYER)
  187. *-- Date........: 06/08/1992
  188. *-- Notes.......: This is another FRPG routine -- It is used to give the
  189. *--               user a choice of three die roles. The computer will
  190. *--               randomly generate a die roll three times so the user
  191. *--               has a choice. 
  192. *-- Written for.: dBASE IV, 1.1
  193. *-- Rev. History: 07/09/1991 - original function
  194. *--               02/13/1992 -- Modified to only require use of MULTDICE(),
  195. *--               not a call to DICE() AND MULTDICE() ... also modified to
  196. *--               deal with user pressing <Esc> (it beeps at 'em).
  197. *--               06/08/1992 -- Explicit color handling
  198. *-- Calls.......: MULTDICE()           Function in FRPG.PRG
  199. *--               SHADOW               Procedure in PROC.PRG
  200. *--               CENTER               Procedure in PROC.PRG
  201. *--               COLORBRK()           Function in PROC.PRG
  202. *--               RECOLOR              Procedure in PROC.PRG
  203. *-- Called by...: Any
  204. *-- Usage.......: DiceChoose(<nNum>,<nSides>,"<nMessage>","<cColor>")
  205. *-- Example.....: replace STRENGTH with DiceChoose(3,6,;
  206. *--                                 "To determine your character's Strength",;
  207. *--                                 "rg+/gb,w+/n,rg+/gb")
  208. *-- Returns.....: The value of one of the choices displayed for the user,
  209. *--               which will be a value from nNum to nNum*nSides + nNum+nPlus.
  210. *-- Parameters..: nNum     = number of dice to be rolled
  211. *--               nSides   = number of sides for each dice
  212. *--               cMessage = Message to be displayed at line 0 (max 40 Char)
  213. *--               cColor   = Colors for the window
  214. *-------------------------------------------------------------------------------
  215.  
  216.     PARAMETERS nNum, nSides, cMessage, cColor
  217.     private nVal1,nVal2,nVal3,nUser,cTempCol,cCurColor
  218.     
  219.     *-- save colors
  220.     cCurColor = set("ATTRIBUTES")
  221.     *-- set colors
  222.     cTempCol = colorbrk(cColor,1)
  223.     set color of normal to &cTempCol
  224.     set color of message to &cTempCol
  225.     cTempCol = colorbrk(cColor,2)
  226.     set color of highlight to &cTempCol
  227.     cTempCol = colorbrk(cColor,3)
  228.     set color of box to &cTempCol
  229.     
  230.     *-- here we determine the three values for the user (roll the dice) --
  231.     nVal1 = multdice(nSides,nNum)
  232.     nVal2 = multdice(nSides,nNum)
  233.     nVal3 = multdice(nSides,nNum)
  234.     
  235.     *-- now we have the three values we need, define windows/menu ...
  236.     define window wDice from 8,20 to 17,60 double 
  237.     save screen to sDice
  238.     define menu mDice                      && as it says, define the menu
  239.     define pad  pChoice1 of mDice prompt ltrim(str(nVal1)) at 3,18
  240.     define pad  pChoice2 of mDice prompt ltrim(str(nVal2)) at 4,18
  241.     define pad  pChoice3 of mDice prompt ltrim(str(nVal3)) at 5,18
  242.     on selection pad pChoice1 of mDice deactivate menu
  243.     on selection pad pChoice2 of mDice deactivate menu
  244.     on selection pad pChoice3 of mDice deactivate menu
  245.     
  246.     *-- activate it all for user ...
  247.     do shadow with 8,20,17,60              && display shadow
  248.     activate window wDice                  && startup the window
  249.     *-- display info in Window
  250.     do center with 0,40,"","&cMessage"
  251.     do center with 1,40,"","Choose a value from below:"
  252.     @3,15 say "1)"
  253.     @4,15 say "2)"
  254.     @5,15 say "3)"
  255.     do center with 7,40,"","Use Arrow keys, <Enter> to choose"
  256.     do while .t.
  257.         activate menu mDice                    && startup menu
  258.         if lastkey() = 27
  259.             ?? chr(7)
  260.         else
  261.             exit
  262.         endif
  263.     enddo
  264.     do case                                && determine value to be returned
  265.         case pad() = "PCHOICE1"
  266.             nUser = nVal1
  267.         case pad() = "PCHOICE2"
  268.             nUser = nVal2
  269.         case pad() = "PCHOICE3"
  270.             nUser = nVal3
  271.     endcase
  272.     
  273.     *-- cleanup
  274.     release menu mDice
  275.     deactivate window wDice
  276.     release window wDice
  277.     restore screen from sDice
  278.     release screen sDice
  279.     on escape
  280.     
  281.     *-- restore colors
  282.     do recolor with cCurColor
  283.     
  284. RETURN nUser
  285. *-- EoF: DiceChoose()
  286.  
  287. FUNCTION ParseDice
  288. *-------------------------------------------------------------------------------
  289. *-- Programmer...: Ken Mayer (KENMAYER)
  290. *-- Date.........: 02/13/1992
  291. *-- Notes........: This is another gaming function ...
  292. *--                It's purpose is to read a string in the format  xdy+z  or 
  293. *--                some variation, and calculate the value ... 
  294. *--                x = # of dice, 
  295. *--                d = a part of the standard gaming syntax (i.e., 3d6),
  296. *--                y = # of sides of dice,
  297. *--                + = a modifier (could be a minus also ...)
  298. *--                z = number to modify each die rolled
  299. *--                (3d6+1 = a value from 6 to 21 (figure if you add 1 to each 
  300. *--                 die rolled, minimum value will be 6 (3+3), maximum will 
  301. *--                 be 21 (18+3))).)
  302. *-- Written for.: dBASE IV, 1.1
  303. *-- Rev. History: 08/29/1991 - original function.
  304. *--               02/13/1992 -- minor -- changed randomizer call to DICE()
  305. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  306. *--               DICE()               Function in FRPG.PRG
  307. *-- Called by...: Any
  308. *-- Usage.......: ParseDice("<cDice>")
  309. *-- Example.....: ? ParseDice("5d6-3")
  310. *-- Returns.....: Random number from x (modified by z) to y (modified by z)
  311. *-- Parameters..: cDice = Standard gaming format value to be parsed and
  312. *--               calculated.
  313. *-------------------------------------------------------------------------------
  314.  
  315.     parameter cDice    && value to parse and return a # from ...
  316.     private nCount,cDice,nPos,nNumDice,nMod,nDice,nPos2,nReturn
  317.     
  318.     cDice = upper(alltrim(cDice)) && trim out ALL extra spaces on left and right,
  319.                                   && and convert to all caps (for check for 
  320.                                   && letter 'D')
  321.     
  322.     if at("D",cDice) > 0          && if the letter 'D' is in there ...
  323.         *-- get the VALUE of the "substring" of cDice, starting at
  324.         *-- character 1, going to the letter D and backing up 1.
  325.         *-- this will be useful in case we have 10dy ... otherwise,
  326.         *-- we _could_ assume only one character, but assumptions are
  327.         *-- bad ...
  328.         nPos = at("D",cDice)
  329.         nNumDice = val(substr(cDice,1,nPos-1))
  330.         nPos = nPos + 1  && move to character beyond letter 'D'
  331.         if at("+",cDice) > 0   && if we have a + modifier
  332.            nPos2 = at("+",cDice)
  333.             nDice = val(substr(cDice,nPos,nPos2-1))
  334.             nMod = val(substr(cDice,nPos2+1,len(cDice)-nPos2))
  335.         else
  336.             if at("-",cDice) > 0 && if we have a - modifier
  337.                 nPos2 = at("-",cDice)
  338.                 nDice = val(substr(cDice,nPos,nPos2-1))
  339.                 nMod = val(substr(cDice,nPos2+1,len(cDice)-nPos2))
  340.             else  && no modifier
  341.                 nDice = val(substr(cDice,nPos,len(cDice)-nPos+1))
  342.             endif  && check for - sign
  343.         endif  && check for + sign
  344.         
  345.         *-- roll the nDice sided "dice" nNumDice number of times ...
  346.         nCount = 0
  347.         nReturn = 0
  348.         do while nCount < nNumDice
  349.             nCount = nCount + 1
  350.             nReturn = nReturn + dice(nDice)
  351.         enddo
  352.         
  353.         *-- Modifiers -- add or subtract appropriate value
  354.         if at("+",cDice) > 0  && if there's a + sign,
  355.             nReturn = nReturn + (nNumDice * nMod)
  356.         endif
  357.         if at("-",cDice) > 0  && it's a minus sign
  358.             nReturn = nReturn - (nNumDice * nMod)
  359.         endif
  360.         
  361.     else   && there's no letter 'D', so we simply have a number to return
  362.            && this is under the assumption that the value passed is either
  363.            && a random one, or (in this case) it's a set value ... for
  364.            && example, in some cases in my gaming system, HitPoints for a
  365.            && critter may be a set value, in others it may be a random one.
  366.            && this routine handles both ...
  367.     
  368.         nReturn = val(cDice)
  369.         
  370.     endif
  371.  
  372. RETURN nReturn
  373. *-- EoF: ParseDice()
  374.  
  375. PROCEDURE PopDice
  376. *-------------------------------------------------------------------------------
  377. *-- Programmer..: Ken Mayer (KENMAYER)
  378. *-- Date........: 06/08/1992
  379. *-- Notes.......: Used in my FRPG system as a Gamemaster's aid ... I can simply
  380. *--               press <Alt>D and have the system popup a window over whatever
  381. *--               I'm doing, ask for a "dice string" as in PARSEDICE(), and have
  382. *--               it return a value. That way I'm not stuck digging for the
  383. *--               dice in the middle of a situation that calls for a quick roll.
  384. *-- Written for.: dBASE IV, 1.1
  385. *-- Rev. History: 06/08/1992 -- Explicit color handling ...
  386. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  387. *--               CENTER               Procedure in PROC.PRG
  388. *--               PARSEDICE()          Function in FRPG.PRG
  389. *--               COLORBRK()           Function in PROC.PRG
  390. *--               RECOLOR              Procedure in PROC.PRG
  391. *-- Called by...: Any
  392. *-- Usage.......: Do PopDice with <cColor>
  393. *-- Example.....: ON KEY LABEL ALT-D DO POPDICE WITH "RG+/GB,W+/N,RG+/GB"
  394. *-- Returns.....: None
  395. *-- Parameters..: cColor = window colors ...
  396. *-------------------------------------------------------------------------------
  397.     parameters cColor
  398.     private cDice,cCursor, cCurColor, cTempCol
  399.  
  400.     *-- setup
  401.     cCursor = set("CURSOR")
  402.     set cursor off
  403.     save screen to sPop  && save the screen
  404.     
  405.     *-- save colors
  406.     cCurColor = set("ATTRIBUTES")
  407.     *-- set colors
  408.     cTempCol = colorbrk(cColor,1)
  409.     set color of normal to &cTempCol
  410.     set color of message to &cTempCol
  411.     cTempCol = colorbrk(cColor,2)
  412.     set color of highlight to &cTempCol
  413.     cTempCol = colorbrk(cColor,3)
  414.     set color of box to &cTempCol
  415.     
  416.     define window wPop from 7,20 to 15,60 double
  417.     do shadow with 7,20,15,60
  418.     activate window wPop
  419.     do center with 0,40,"","PopDice (c) 1992"
  420.     
  421.     *-- loop until user pressed such keys as <Enter> or <Esc> ...
  422.     do while .t.
  423.         store space(10) to cDice  && blank out field
  424.         @2,2 say "Enter dice description: " get cDice;
  425.             message "Examples: 6 (1d6), d6, 3d6, 3d6+1, 3d6-1 ..."
  426.         set cursor on
  427.         read
  428.         set cursor off
  429.         if len(trim(cDice)) = 0        && len ... = 0, time to close down ...
  430.             exit
  431.         endif
  432.         if at("D",upper(cDice)) = 0    && parsedice() requires xD at front ...
  433.             cDice = "1d"+cDice
  434.         endif
  435.         if upper(left(cDice,1)) = "D"  && must be at least 1 ...
  436.             cDice = "1" + cDice
  437.         endif
  438.         @4,7 say "   Dice Rolled: "+cDice   && display what's being done
  439.         @5,0 clear                     && clear out messages, etc.
  440.         do center with 6,40,"rg+/r",". . . Calculating . . ."
  441.         *-- do it ... and display it
  442.         @5,7 say "Value returned: "+ltrim(str(parsedice(cDice)))
  443.         @6,0 clear
  444.     
  445.     enddo
  446.     
  447.     *-- cleanup
  448.     deactivate window wPop
  449.     release window wPop
  450.     restore screen from sPop
  451.     release screen sPop
  452.     set cursor &cCursor
  453.     *-- restore colors
  454.     do recolor with cCurColor
  455.     
  456. RETURN
  457. *-- EoP: PopDice
  458.  
  459. *-------------------------------------------------------------------------------
  460. *-- EoP: FRPG.PRG
  461. *-------------------------------------------------------------------------------
  462.