home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
litebar.zip
/
LITE5.PRG
next >
Wrap
Text File
|
1991-08-12
|
25KB
|
759 lines
*-------------------------------------------------------------------------------
*-- Program...: LITE5.PRG
*-- Programmer: Ken Mayer
*-- Date......: 7/17/91
*-- Notes.....: The dBASE Menus are fine to a point, but there are times when
*-- you may need a LOT of menu pads. This program is designed to
*-- allow up to 60 menu items, although you can, if you desire,
*-- set up some options as headers (these will not be chooseable
*-- by the user), and you can set up conditions where an option
*-- may be skipped. This routine is the original program, created
*-- for my fantasy gaming procedures. It allows a user to choose
*-- an item once (for you gamers, this is part of a character
*-- generation routine -- when creating a character, the character
*-- may improve certain skills once only ... (that's for the
*-- creation ... in the update routines that option will be removed)
*-- -- the user knows he's chosen that item before because the
*-- color changes ...
*-- Original concept by FELIXR, but I ran with it and programmed
*-- it up ... As a programmer, the following procedures will need
*-- to be modified:
*-- REFRESH -- description of each litebar
*-- LOADARRAY -- load the arrays ... there are some items
*-- that will need changing
*-- DOCHOICE -- this is where the user choice is made ...
*-- VALID -- validation of litebars ...
*-- Other items needing changing are noted in comments.
*-------------------------------------------------------------------------------
cTalk = set("TALK")
set talk off
cStatus = set("STATUS")
set stat off && just making sure
cEscape = set("ESCAPE")
set escape off && for use with INKEY()
cCursor = set("CURSOR")
set cursor off
set procedure to proc && contains a few routines like YESNO ...
clear && clear screen completely for this ...
?scrnhead("rg+/gb","Character Skills")
public literow,litecol,choice,lastcol,lastrow,gl_error && global memvars
*-- literow = row position
*-- litecol = column -- used together to hold real positions
*-- choice = user entry (up, down, right, left, <Enter>, <Esc>
*-- lastcol = last column -- entered in REFRESH routine
*-- lastrow = last row -- ditto
ln_max = 60 && max entries
choice = 0 && init choice so it's numeric ...
public skill,lite_bar,pos1,pos2,skil_flag,skip,heading && arrays
declare skill[ln_max],pos1[15],pos2[4],lite_bar[15,4],skil_flag[15,4]
declare skip[15,4],heading[15,4]
*-- skill[x] = value we're obtaining from user ...
*-- pos1[x] = position of choices on screen ... rows
*-- pos2[y] = same ... columns
*-- lite_bar[x,y] = choices displayed on screen ...
*-- skil_flag[x,y]= flag for each choice ... once chosen can't choose again
*-- skip[x,y] = flag to determine if we should skip an option ...
*-- heading[x,y] = if it's a heading, we need to display in specific colors
*--------------------------------------------------------------------------
* START processing here
*--------------------------------------------------------------------------
do load_array && procedure below to load values into arrays
*-- PROGRAMMER -- Make sure these are correct --*
literow = 2 && starting coordinates
litecol = 1 && ditto
do scrnpnt && paint the screen the first time .. the rest is handled
&& when the cursor is moved ...
*--------------------------------------------------------------------------
* find out how many changes the user can make in beginning skills ...
*--------------------------------------------------------------------------
if yesno(.t.,"Number of Changes Allowed","Do you want to roll the dice?","",;
"rg+/gb,n/w,rg+/gb")
ln_roll = validice(1,6,"Number of Changes","rg+/gb,n/g,rg+/gb")
else
ln_roll = dice(6)
endif && yesno ...
ln_numskills = ln_roll + 2
*--------------------------------------------------------------------------
* loop until the user has done them all ...
*--------------------------------------------------------------------------
do while ln_numskills > 0 && loop until user has modified all skills
@1,60 say "Skills left: "+ltrim(str(ln_numskills)) color rg+/gb
choice = 0 && default it to 0, just to be safe ....
choice = inkey(0)
*-- inkey() returns: 4 = right arrow
*-- 19 = left arrow
*-- 5 = up arrow
*-- 24 = down arrow
*-- 13 = <Enter>/Carriage Return
*-- 27 = <Esc>
*-- 2 = <End>
*-- 27 = <Home>
*
do case
case choice = 4 .or. choice = 19
do movecol
case choice = 5 .or. choice = 24
do moverow
case choice = 2 .or. choice = 26
do HomeEnd
case choice = 13
do DoChoice
if .not. gl_error && check to see if user chose wrong item
ln_numskills = ln_numskills - 1 && decrement counter
endif
endcase
enddo && loop and main procedure ...
*--------------------------------------------------------------------------
*-- CLEANUP
*--------------------------------------------------------------------------
release literow,litecol,choice,lastcol,lastrow
release pos1,pos2,lite_bar,skip,heading
release skill,skil_flag && these last two may need to be kept for my own
&& production version ... and NOT released ...
set status &cStatus && reset these if needed ...
set talk &cTalk
set escape &cEscape
set cursor &cCursor
do Save_Array && save the data in the SKILL[] array ...
RETURN && to calling program
*--------------------------------------------------------------------------
* procedures here
*--------------------------------------------------------------------------
PROCEDURE Load_Array
*-- This will be replaced in my gaming programs to replace the
*-- contents of the SKILL[] array with fields from the database
*-- also load skil_name[] array from database ... (same way)
ln_count = 0 && initialize "skill" array
ln_num = int(rand(-1) * 20) + 1
do while ln_count < ln_max
ln_count = ln_count + 1
skill[ln_count] = int(rand() * 20) + 1 && random number from 1 to 20
enddo
*-- don't touch --*
ln_cnt1 = 0 && initialize the lightbar array ...
do while ln_cnt1 < 15
ln_cnt1 = ln_cnt1 + 1
ln_cnt2 = 0
do while ln_cnt2 < 4
ln_cnt2 = ln_cnt2 + 1
lite_bar[ln_cnt1,ln_cnt2] = space(1) && init to a single space
&& character in it...
store .f. to skip[ln_cnt1,ln_cnt2] && init to NO skip, but change
&& below as needed ...
enddo
enddo
do Refresh && this is used to setup the litebars ... and can be called
&& as a separate procedure from anywhere ...
*-- this shouldn't need to be changed ...
*-- start at row six, allowing room at top of window/screen for headings
row1 = 6
row2 = 7
row3 = 8
row4 = 9
row5 = 10
row6 = 11
row7 = 12
row8 = 13
row9 = 14
row10 = 15
row11 = 16
row12 = 17
row13 = 18
row14 = 19
row15 = 20
*-- set for four columns, up to 20 characters each -- column four should
*-- be kept down to 15 ... actually all of them should.
col1 = 5
col2 = 25
col3 = 45
col4 = 65
*-- positions -- POS1 array is the row
pos1[1] = row1
pos1[2] = row2
pos1[3] = row3
pos1[4] = row4
pos1[5] = row5
pos1[6] = row6
pos1[7] = row7
pos1[8] = row8
pos1[9] = row9
pos1[10] = row10
pos1[11] = row11
pos1[12] = row12
pos1[13] = row13
pos1[14] = row14
pos1[15] = row15
*-- positions -- POS2 array is the column
pos2[1] = col1
pos2[2] = col2
pos2[3] = col3
pos2[4] = col4
RETURN
*-- EoP: Load_Array
*--------------------------------------------------------------------------
PROCEDURE Save_Array
*-- procedure to save the contents of the SKILL[] array back to the
*-- database, otherwise all of this is pointless ...
RETURN
*-- EoP: Save_Array
*--------------------------------------------------------------------------
PROCEDURE Refresh
*-- PROGRAMMER CHANGES --*
*-- this routine simply refreshes/defines the bars for the litebar
*-- headings should define both SKIP and HEADING arrays as true for
*-- those entries, otherwise the program will allow them as "valid"
*-- choices. If you want to set up conditionals, this is the place
*-- to do it. You can do such things as:
*-- IF <condition>
*-- STORE .t. TO SKIP[x,y]
*-- ELSE
*-- STORE .f. TO SKIP[x,y]
*-- ENDIF
*-- this would replace the WHEN clause of the dbase popup BARs.
lite_bar[1,1] = "HEADING 1"
store .t. to skip[1,1] && don't allow as valid choice
store .t. to heading[1,1] && for color display
lite_bar[2,1] = "Choice 1: "+ltrim(str(skill[1]))
lite_bar[3,1] = "Choice 2: "+ltrim(str(skill[2]))
*-- 4,1 = nothing -- blank
lite_bar[5,1] = "HEADING 2"
store .t. to skip[5,1]
store .t. to heading[5,1]
lite_bar[6,1] = "Choice 3: "+ltrim(str(skill[3]))
lite_bar[7,1] = "Choice 4: "+ltrim(str(skill[4]))
*-- column 2
lite_bar[1,2] = "HEADING 3"
store .t. to skip[1,2]
store .t. to heading[1,2]
lite_bar[2,2] = "Choice 5: "+ltrim(str(skill[5]))
lite_bar[3,2] = "Choice 6: "+ltrim(str(skill[6]))
lite_bar[4,2] = "Choice 7: "+ltrim(str(skill[7]))
store .t. to skip[4,2]
*-- 5,2 = nothing
lite_bar[6,2] = "HEADING 4"
store .t. to skip[6,2]
store .t. to heading[6,2]
lite_bar[7,2] = "Choice 8: "+ltrim(str(skill[8]))
*-- column 3
lite_bar[1,3] = "HEADING 5"
store .t. to skip[1,3]
store .t. to heading[1,3]
lite_bar[2,3] = "Choice 9: "+ltrim(str(skill[9]))
lite_bar[3,3] = "Choice 10: "+ltrim(str(skill[10]))
lite_bar[4,3] = "Choice 11: "+ltrim(str(skill[11]))
lite_bar[5,3] = "Choice 12: "+ltrim(str(skill[12]))
*-- It is vital that these two items are set properly. If you have
*-- four columns, change lastcol to 4, and so on ...
lastcol = 3
lastrow = 7
RETURN
*-- EoP: Refresh
*--------------------------------------------------------------------------
PROCEDURE ScrnPnt && procedure to paint the screen
*-- this procedure will probably only be called once - at the beginning
*-- of the program. There should be no need for programmer modifications.
ln_cnt = 0
do while ln_cnt < 15
ln_cnt = ln_cnt + 1
ln_cnt2 = 0
do while ln_cnt2 < 4
ln_cnt2 = ln_cnt2 + 1
if len(trim(lite_bar[ln_cnt,ln_cnt2])) > 0
if heading[ln_cnt,ln_cnt2]
@pos1[ln_cnt],pos2[ln_cnt2] say lite_bar[ln_cnt,ln_cnt2];
color rg+/gb && it's a heading
else
if skip[ln_cnt,ln_cnt2] && it's not a heading, must not be
&& allowed!
@pos1[ln_cnt],pos2[ln_cnt2] say lite_bar[ln_cnt,ln_cnt2];
color r/n && color says it's not allowed!
else && normal item ...
@pos1[ln_cnt],pos2[ln_cnt2] say lite_bar[ln_cnt,ln_cnt2]
endif && skip ...
endif && heading ...
endif && len(trim...
enddo && while ln_cnt2 ...
enddo && while ln_cnt ...
@pos1[2],pos2[1] say lite_bar[2,1] color n/g
&& display first bar higlighted
do center with 23,80,"rg+/r","Press: "+chr(24)+chr(25)+chr(26)+chr(27)+;
", <Home>, <End> to move, <Enter> to choose"
RETURN
*-- EoP: ScrnPnt
*--------------------------------------------------------------------------
PROCEDURE MoveRow && up/down arrows pressed
*-- NO CHANGES NEEDED (in the next three procedures ... --*
*-- this procedure handles up and down movement. It is designed to first,
*-- redisplay the current litebar area in "normal" color (default is
*-- whatever your screen/window NORMAL color is set to). Next, it looks
*-- at the keystroke, and moves the pointer to the next item. We check
*-- to see if that's valid (using VALID() below), and if it is, we are
*-- done. If it's not valid, we move in the direction (up/down) again,
*-- and check for valid, looping until we either find a valid option, or,
*-- if none of the options in that column are valid, we move to the
*-- next column. (Tricky, eh?) Once we have a valid position, we
*-- display it highlighted, and return ...
if valid()
@pos1[literow],pos2[litecol] clear to pos1[literow],pos2[litecol]+19
if skil_flag[literow,litecol] && if it's .t., display as RED on Black
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol] color r/n
else && otherwise, display as normal ...
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol]
endif
endif && valid()
do case
*-- uparrow first
case choice = 5
if literow = 1 && if first row
literow = lastrow && wrap it around ...
else
literow = literow - 1 && decrement (move to next row)
endif
ln_count = 1 && set counter to 1
do while .not. valid() && function below to determine if lite_bar
&& is valid
ln_count = ln_count + 1 && if we're here, we're moving again
if ln_count = lastrow && we've wrapped around
choice = 4 && stick a right arrow in here ...
do movecol && procedure to move cursor by col!
exit && we're done here ...
endif && ln_count = lastrow
if literow = 1 && check for first row
literow = lastrow && wrap around
else
literow = literow - 1 && decrement (move to next)
endif
enddo
*-- down arrow next
case choice = 24
if literow = lastrow && if last row
literow = 1 && wrap it around ...
else
literow = literow + 1 && increment (move to next row)
endif
ln_count = 1 && set counter to 1
do while .not. valid() && function below to determine if lite_bar
&& is valid
ln_count = ln_count + 1 && if we're here, we're moving again
if ln_count = lastrow && we've wrapped around
choice = 19 && stick a left arrow in here ...
do movecol && procedure to move cursor by col!
exit && we're done here ...
endif && ln_count = lastrow
if literow = lastrow && check for last row
literow = 1 && wrap around
else
literow = literow + 1 && increment (move to next)
endif
enddo
endcase
@pos1[literow],pos2[litecol] clear to pos1[literow],pos2[litecol]+19
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol] color n/g
&& display in hilight colors ...
RETURN
*-- EoP: MoveRow
*--------------------------------------------------------------------------
PROCEDURE MoveCol && left/right arrows pressed
*-- See comments in MoveRow for an explanation of this.
if valid()
@pos1[literow],pos2[litecol] clear to pos1[literow],pos2[litecol]+19
if skil_flag[literow,litecol] && if it's .t., display as RED on Black
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol] color r/n
else && otherwise, display as normal ...
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol]
endif
endif
do case
case choice = 4
** right arrow
if litecol = lastcol && if last column
litecol = 1 && wrap it around ...
else
litecol = litecol + 1 && increment (move to next column)
endif
ln_count = 1 && set counter to 1
do while .not. valid() && function below to determine if lite_bar
&& is valid
ln_count = ln_count + 1 && if we're here, we're moving again
if ln_count = lastcol && we've wrapped around
choice = 24 && stick a down arrow in here ...
do moverow && procedure to move cursor by rows!
exit && we're done here ...
endif && ln_count = lastcol
if litecol = lastcol && check for last column
litecol = 1 && wrap around
else
litecol = litecol + 1 && increment (move to next)
endif
enddo
*-- left arrow next
case choice = 19
if litecol = 1 && if FIRST column
litecol = lastcol && wrap it around ...
else
litecol = litecol - 1 && decrement (move to next column)
endif
ln_count = 1 && set counter to 1
do while .not. valid() && function below to determine if lite_bar
&& is valid
ln_count = ln_count + 1 && if we're here, we're moving again
if ln_count = lastcol && we've wrapped around
choice = 5 && stick an up arrow in here ...
do moverow && procedure to move cursor by rows!
exit && we're done here ...
endif && ln_count = lastcol
if litecol = 1 && check for last column
litecol = lastcol && wrap around
else
litecol = litecol - 1 && decrement (move to next)
endif
enddo
endcase
@pos1[literow],pos2[litecol] clear to pos1[literow],pos2[litecol]+19
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol] color n/g
RETURN
*-- EoP: MoveCol
*--------------------------------------------------------------------------
PROCEDURE HomeEnd && user pressed <Home> or <End>
*-- Very much the same logic as MoveRow and MoveCol, but the
*-- cursor is moved to the first position (<Home>) or last (<End>) and
*-- validations is checked in those columns (moving to another column
*-- if really necessary).
if valid()
@pos1[literow],pos2[litecol] clear to pos1[literow],pos2[litecol]+19
if skil_flag[literow,litecol] && if it's .t., display as RED on Black
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol] color r/n
else && otherwise, display as normal ...
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol]
endif
endif && valid()
do case
*-- For HOME, we need to go to first position, and move down the column,
*-- as if we were doing the routine in MOVEROW ... for END we do the
*-- same, but go to last position, and work UP the column, looking for
*-- valid ...
case choice = 26
*-- <Home> key
litecol = 1 && move pointer to "Home" position
literow = 1
ln_count = 1 && set counter to 1
do while .not. valid() && function below to determine if lite_bar
&& is valid
ln_count = ln_count + 1 && if we're here, we're moving again
if ln_count = lastrow && we've wrapped around
choice = 4 && stick a right arrow in here ...
do movecol && procedure to move cursor by rows!
exit && we're done here ...
endif && ln_count = lastrow
if literow = lastrow && check for last column
literow = 1 && wrap around
else
literow = literow + 1 && increment (move to next)
endif
enddo
case choice = 2
*-- <End> key
literow = lastrow && move cursor to last item
litecol = lastcol
ln_count = 1 && set counter to 1
do while .not. valid() && function below to determine if lite_bar
&& is valid
ln_count = ln_count + 1 && if we're here, we're moving again
if ln_count = lastrow && we've wrapped around
choice = 19 && stick a left arrow in here ...
do movecol && procedure to move cursor by col!
exit && we're done here ...
endif && ln_count = lastrow
if literow = 1 && check for first row
literow = lastrow && wrap around
else
literow = literow - 1 && increment (move to next)
endif
enddo
endcase
@pos1[literow],pos2[litecol] clear to pos1[literow],pos2[litecol]+19
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol] color n/g
&& display in hilight colors ...
RETURN
*-- EoP: HomeEnd
*--------------------------------------------------------------------------
PROCEDURE DoChoice && Determine what user has chosen to do, and do it.
*-- PROGRAMMER CHANGES --*
*-- This is where we go when the user has pressed <Enter>. It means
*-- they want to choose the highlighted option. The current structure
*-- below looks at the column, and then the row we are pointing to
*-- to decide what to do. Such options as DO program can be placed
*-- in the approprate cases ...
*-- For this version, we set a value (skill number), and then use that
*-- in the SKILL[] Array.
*-- can this be done more efficiently? I can't think of a better
*-- way ... >sigh<.
do case
case litecol = 1
do case
case literow = 1
case literow = 2
sk_num = 1
case literow = 3
sk_num = 2
case literow = 4
case literow = 5
case literow = 6
sk_num = 3
case literow = 7
sk_num = 4
case literow = 8
case literow = 9
case literow = 10
case literow = 11
case literow = 12
case literow = 13
case literow = 14
case literow = 15
endcase
case litecol = 2
do case
case literow = 1
case literow = 2
sk_num = 5
case literow = 3
sk_num = 6
case literow = 4
sk_num = 7
case literow = 5
case literow = 6
case literow = 7
sk_num = 8
case literow = 8
case literow = 9
case literow = 10
case literow = 11
case literow = 12
case literow = 13
case literow = 14
case literow = 15
endcase
case litecol = 3
do case
case literow = 1
case literow = 2
sk_num = 9
case literow = 3
sk_num = 10
case literow = 4
sk_num = 11
case literow = 5
sk_num = 12
case literow = 6
case literow = 7
case literow = 8
case literow = 9
case literow = 10
case literow = 11
case literow = 12
case literow = 13
case literow = 14
case literow = 15
endcase
case litecol = 4
do case
case literow = 1
case literow = 2
case literow = 3
case literow = 4
case literow = 5
case literow = 6
case literow = 7
case literow = 8
case literow = 9
case literow = 10
case literow = 11
case literow = 12
case literow = 13
case literow = 14
case literow = 15
endcase
endcase
lc_skilname = substr(lite_bar[literow,litecol],1,;
at(":",lite_bar[literow,litecol])-1) && get the skill name from the
&& litebar ...
gl_error = .f.
if yesno(.t.,"&lc_skilname","Do you really want to modify",;
"&lc_skilname?","rg+/gb,n/g,rg+/gb")
if yesno(.t.,"&lc_skilname","Do you want to roll the dice?","",;
"rg+/gb,n/g,rg+/gb")
set cursor on
ln_roll = int(ValiDice(1,100,"","rg+/b,n/g,rg+/n") / 2)
&& get valid value from user and then cut it in half ...
set cursor off
else
ln_roll = int(Dice(100) / 2) && roll it and cut value in half ...
endif
skill[sk_num] = skill[sk_num] + ln_roll && add this to it ...
store .t. to skil_flag[literow,litecol] && don't allow this choice again ...
store .t. to skip[literow,litecol] && SKIP this one next time around ...
do refresh && update the lite_bar array ...
@pos1[literow],pos2[litecol] clear to pos1[literow],pos2[litecol]+19
@pos1[literow],pos2[litecol] say lite_bar[literow,litecol] color r/n
&& display option red on black ... so user KNOWS he's done it before.
else && user didn't want this 'un after all
gl_error = .t.
endif && check to see if user wanted this one ...
RETURN
*--------------------------------------------------------------------------
FUNCTION Valid && used to determine if the current litebar choice is valid
if len(trim(lite_bar[literow,litecol])) > 0 .and. .not. skip[literow,litecol]
store .t. to lValid
else
store .f. to lValid
endif
RETURN lValid
*--------------------------------------------------------------------------
* end of program: LITE4.prg
*--------------------------------------------------------------------------