Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : LITBAR.ZIP
Filename : LITE5.PRG
*-- 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,
*-- 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 =
*-- 27 =
*-- 2 =
*-- 27 =
*
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
*-- 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)+;
",
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
*-- Very much the same logic as MoveRow and MoveCol, but the
*-- cursor is moved to the first position (
*-- 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
*--
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
*--
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
*-- 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
*--------------------------------------------------------------------------
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/