Power-Programmierung/CD1.mdf/xbase/library/clipper/rlib/rl_pdown.prg

Text File | 1989-02-18 | 15.0 KB | 460 lines

* Function..: PDOWNINIT
* Author....: Richard Low
* Syntax....: PDOWNINIT( row, columns, options, items, starts, prompts,;
*                        promptrow, colors, altkeys, exit )
*
* Notes.....: Mandatory function to initialize PDOWNMENU for operation.
*             Optional parameters are not required, but if you wish to skip
*             an optional parameter, you must pass a dummy value.  The best
*             dummy value to use is a null string '' (set up a memvar named
*             dummy where dummy = '').
*
* Parameters: row       - NUMERIC row for top of Pull Down Menu to appear.
*             columns   - ARRAY of column numbers for each top level option.
*             options   - ARRAY of top level menu option choices.
*             items     - ARRAY of pulled down menu items.
*             starts    - ARRAY of starting element numbers.
*             prompts   - Optional ARRAY corresponding menu item messages.
*             promptrow - Optional NUMERIC row on which these messages appear.
*             colors    - Optional ARRAY of colors to use for the top Bar and
*                         pull down Box menus.
*
*                           color[1] - Option & message displays
*                           color[2] - Menu selection bars
*                           color[3] - Pull-down menu box ACTIVE color
*                           color[4] - Pull-down menu box IN-ACTIVE color
*                           color[5] - Pull-down menu option after selection
*                           color[6] - Menu bar option after selection
*
*             altkeys   - Optional ARRAY of alternate select keys for each menu.
*             exit      - Optional LOGICAL indicating if escape will exit menu.
*
* Returns...: True if initialization sucessful, False if parameters error.
*

FUNCTION PDOWNINIT
PARAMETERS prow, pcols, pmenus, pitems, pstarts, pprompts, promptrow,;
           p_colors, paltkeys, pexit

IF PCOUNT() = 0
   *-- if no parameters, release PUBLIC arrays to reclaim memory
   RELEASE rl_pd, pd_counts, pd_altkeys, pd_bottoms, pd_rights
   RETURN (.T.)
ENDIF

*-- make sure that all the required parameters are the correct type
IF TYPE('prow')   + TYPE('pcols')   + TYPE('pmenus') +;
   TYPE('pitems') + TYPE('pstarts') != 'NAAAA'
   RETURN (.F.)
ENDIF

*-- the number of columns, top level options, starting array element
*-- numbers, and menu item counts must all be the same
IF .NOT. ( LEN(pcols) = LEN(pmenus) .AND. LEN(pcols) = LEN(pstarts) )
   RETURN (.F.)
ENDIF

*-- there must be more than one menu (get real)
IF LEN(pcols) < 2
   RETURN (.F.)
ENDIF


last_menu = LEN(pmenus)
PUBLIC pd_counts[last_menu],  pd_altkeys[last_menu]
PUBLIC pd_bottoms[last_menu], pd_rights[last_menu]


*-- fill in menu item counts based on start numbers
*-- can't start at 1 because of computational algorithm
pd_counts[1] = pstarts[2] - 1
FOR x = 2 TO last_menu - 1
   *-- count of options in this menu equal next start number minus this start
   pd_counts[x] = pstarts[x+1] - pstarts[x]
NEXT x
*-- number of items in last menu is equal to length of array - starting # + 1
pd_counts[ last_menu ] = LEN(pitems) - pstarts[ last_menu ] + 1


*-- copy the altkeys array if it exists
IF TYPE('paltkeys') = 'A'
   ACOPY( paltkeys, pd_altkeys )
ELSE
   *-- otherwise fill it with nulls
   AFILL( pd_altkeys, '' )
ENDIF

AFILL( pd_bottoms, 0 )
AFILL( pd_rights,  0 )


*-- make configuration array public
PUBLIC rl_pd[15]

rl_pd[ 1] = LEN(pmenus)                             && N - number of menus (used for offset)
rl_pd[ 2] = ''                                      && C - main menu direct select keys
rl_pd[ 3] = IF(TYPE('pbox')='C', pbox, '┌─┐│┘─└│')  && C - boxing string

rl_pd[ 4] = SETCOLOR()                              && save incoming color

*-- use <color array> if it is an array AND it has at least 5 elements
IF IF( TYPE('p_colors') = 'A', IF(LEN(p_colors) >= 5, .T., .F.) , .F. )
   rl_pd[ 6] = p_colors[1]              && display color
   rl_pd[ 7] = p_colors[2]              && menu bar color
   rl_pd[ 8] = p_colors[3]              && active pull down menu box color
   rl_pd[ 9] = p_colors[4]              && pull down menu box border after exit
   rl_pd[10] = p_colors[5]              && pull down menu selected option color

   rl_pd[ 5] = p_colors[6]              && top bar menu selected option color
ELSE
   rl_pd[ 6] = rl_pd[4]
   rl_pd[ 7] = GETPARM(2, rl_pd[4])
   rl_pd[ 8] = BRIGHT(rl_pd[4])
   rl_pd[ 9] = rl_pd[4]
   rl_pd[10] = rl_pd[8]

   rl_pd[ 5] = rl_pd[8]
ENDIF


*-- window coordinates and buffer
rl_pd[11] = prow                         && N - <maxtop> (top row for main menu)
rl_pd[12] = pcols[1]                     && N - <maxleft>
rl_pd[13] = 0                            && N - <maxbottom>
rl_pd[14] = 0                            && N - <maxright>
rl_pd[15] = ''                           && C - window to hold screen


*-- display bar menu options and build a list of first letter pick keys
*-- and store coordinates for later fast access, and determine maximum
*-- bottom and right coordinates

xjunk = ''
SETCOLOR(rl_pd[6])
@ prow,0                                  && clear option line in that color

FOR x = 1 TO LEN(pmenus)
   @ prow,pcols[x] SAY pmenus[x]
   xjunk = xjunk + SUBSTR( LTRIM(pmenus[x]),1,1 )                && build list of direct pick keys
   pd_bottoms[x] = prow + pd_counts[x] + 2                       && bottom coordinate for this menu
   pd_rights[x]  = pcols[x] + LEN(pitems[pstarts[x]]) + 1           && right coordinate for this menu
   rl_pd[13] = MAX( rl_pd[13], pd_bottoms[x] )
   rl_pd[14] = MAX( rl_pd[14], pd_rights[x]  )

   *-- fill direct select strings with default first letters for each menu
   yjunk = ''
   FOR y = 1 TO pd_counts[x]
      yjunk = yjunk + SUBSTR(LTRIM(pitems[pstarts[x]+y-1]),1,1)
   NEXT y
   *-- now add to list passed as parameter, if any
   pd_altkeys[x] = yjunk + pd_altkeys[x]

NEXT x

*-- set color back to way it was
SETCOLOR(rl_pd[4])

*-- main menu direct and alternate select keys
rl_pd[2] = xjunk

*-- save screen that was painted with top menu options
rl_pd[15] = SAVESCREEN(rl_pd[11],rl_pd[12],rl_pd[13],rl_pd[14])

RETURN (.T.)





*****************************************************************************
* Function..: PDOWNMENU
* Syntax....: PDOWNMENU( @menu, @item, menus, items, columns, starts;
*                        [, prompts [, exit ] ] )
*
* Notes.....: Pull down menu operation AFTER initialized with PDOWNINIT(...)
*             All but the last two parameters are required!  If the <prompts>
*             are not used, but <exit> is, pass a dummy parameter for <prompts>
*
* Parameters: @menu   - pointer to NUMERIC indicating starting top menu option
*             @item   - pointer to NUMERIC starting menu item (if any) 0 = stay in top
*             menus   - ARRAY of top level menu option choices.
*             items   - ARRAY of pulled down menu items.
*             columns - ARRAY of column numbers for each top level option.
*             starts  - ARRAY of starting element numbers.
*             prompts - Optional ARRAY corresponding menu item messages.
*             exit    - Optional LOGICAL indicating if escape will exit.
*                       Default is True.
*
* Returns...:
*
*
*
*****************************************************************************
FUNCTION PDOWNMENU

PARAMETERS pullmenu, pullitem, pmenus, pitems, pcols, pstarts, pprompts, pexit

PRIVATE fc_incolor, fc_display, fc_menubar, fc_box_on, fc_box_off,;
        fc_selitem, fc_selmenu

*-- verify parameters and types
IF TYPE('pullmenu') + TYPE('pullitem') + TYPE('pmenus') +;
   TYPE('pitems')   + TYPE('pstarts')  + TYPE('pcols')  != 'NNAAAA'
   RETURN 0
ENDIF

prmts_on = IF( TYPE('pprompts') = 'A', .T.,    .F. )      && if prompts being displayed
prmt_row = IF( TYPE('prmtrow')  = 'N', prmtrow, 24 )      && row for prompt messages
pexit    = IF( TYPE('pexit')    = 'L', pexit,  .T. )


*-- retrieve and store colors so they can be used by descriptive names
fc_incolor = rl_pd[ 4]
fc_display = rl_pd[ 6]
fc_menubar = rl_pd[ 7]
fc_box_on  = rl_pd[ 8]
fc_box_off = rl_pd[ 9]
fc_selitem = rl_pd[10]
fc_selmenu = rl_pd[ 5]


*-- first pop the screen that was saved during the initialization
*-- in case the routine that calls PDOWNMENU() messed with the screen
*-- since it was painted with PDOWNINIT()
RESTSCREEN( rl_pd[11], rl_pd[12], rl_pd[13], rl_pd[14], rl_pd[15] )


*-- make sure the menu and item numbers supplied are within array bounds
pullmenu = IF( pullmenu < 1 .OR. pullmenu > LEN(pmenus), 1, pullmenu )


*-- if an option is selected from a pull down, pullitem will = option number
DO WHILE .T.

   *-- if we are to go back into the pulled down menu, do it
   IF pullitem > 0
      pullitem = PULLDOWN_2()
   ELSE
      *-- otherwise, stay in top level menu

      *-- display current selection in reverse video
      SETCOLOR(fc_menubar)
      @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
      SETCOLOR(fc_display)

      *-- wait for a key
      f_lkey = INKEY(0)

      DO CASE

         CASE f_lkey = 4 .OR. f_lkey = 32
            *-- Right Arrow or Space Bar
            @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
            pullmenu = IF( pullmenu = LEN(pmenus), 1, pullmenu + 1 )

         CASE f_lkey = 19 .OR. f_lkey = 8
            *-- Left Arrow or Back Space
            @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
            pullmenu = IF( pullmenu = 1, LEN(pmenus), pullmenu - 1 )

         CASE f_lkey = 1
            *-- Home Key
            @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
            pullmenu = 1

         CASE f_lkey = 6
            *-- End key
            @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
            pullmenu = LEN(pmenus)

         CASE f_lkey = 13
            *-- Enter key
            SETCOLOR(fc_selmenu)
            @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
            *-- go into pull down menu with side stepping
            pullitem = PULLDOWN_2()

         CASE UPPER(CHR(f_lkey)) $ rl_pd[2]
            @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
            x = 1
            pullmenu = 0
            DO WHILE pullmenu = 0
               pullmenu = AT(UPPER(CHR(f_lkey)),SUBSTR(rl_pd[2],x,LEN(pmenus)))
               x = x + LEN(pmenus)
            ENDDO
            SETCOLOR(fc_selmenu)
            @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
            pullitem = PULLDOWN_2()

         CASE f_lkey = 27 .AND. pexit
            *-- Escape allowed to exit
            pullmenu = 0
            EXIT

      ENDCASE
   ENDIF

   *-- if an option was selected, exit
   IF pullitem != 0
      EXIT
   ENDIF

ENDDO

**-- display selected option in bright color
*IF pullmenu > 0 .AND. pullmenu <= LEN(pmenus)
*   SETCOLOR(fc_selitem)
*   @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
*ENDIF

**-- if messages are on, clear the message line
*IF prmts_on
*   @ prmt_row,0
*ENDIF

*-- restore original color
SETCOLOR(fc_incolor)

RETURN IF( pullmenu = 0, 0, pstarts[pullmenu] + pullitem - 1 )



FUNCTION PullDown_2
* Syntax....: PULLDOWN_2()
*
*

*-- this proc displays top menu option in selected color and paints menu
DO pd2_setup

DO WHILE .T.

   *-- display current selection in (selected) video
   SETCOLOR(fc_menubar)
   @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
   SETCOLOR(fc_display)

   *-- if message prompts are on, clear row and display
   IF prmts_on
      @ prmt_row,0
      @ prmt_row,(80-LEN( pprompts[ pstarts[pullmenu]+pullitem-1 ] ))/2 ;
         SAY pprompts[ pstarts[pullmenu]+pullitem-1 ]
   ENDIF

   *-- wait for a key
   f_lkey = INKEY(0)

   DO CASE

      CASE f_lkey = 4 .OR. f_lkey = 32
         *-- Right Arrow or Space Bar
         pullmenu = IF( pullmenu = LEN(pmenus), 1, pullmenu + 1 )
         pullitem = 1
         DO pd2_setup

      CASE f_lkey = 19 .OR. f_lkey = 8
         *-- Left Arrow or Back Space
         pullmenu = IF( pullmenu = 1, LEN(pmenus), pullmenu - 1 )
         pullitem = 1
         DO pd2_setup

      CASE f_lkey = 24
         *-- Down Arrow
         @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
         pullitem = IF( pullitem = pd_counts[pullmenu], 1, pullitem + 1 )

      CASE f_lkey = 5
         *-- Up Arrow or Back Space
         @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
         pullitem = IF( pullitem = 1, pd_counts[pullmenu], pullitem - 1 )

      CASE f_lkey = 1
         *-- Home Key
         @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
         pullitem = 1

      CASE f_lkey = 6
         *-- End key
         @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
         pullitem = pd_counts[pullmenu]

      CASE f_lkey = 13
         *-- Enter key
         EXIT

      CASE UPPER(CHR(f_lkey)) $ pd_altkeys[pullmenu]
         @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
         x = 1
         pullitem = 0
         DO WHILE pullitem = 0
            pullitem = AT(UPPER(CHR(f_lkey)),SUBSTR(pd_altkeys[pullmenu],x,pd_counts[pullmenu]))
            x = x + pd_counts[pullmenu]
         ENDDO
         EXIT

      CASE f_lkey = 27
         *-- Escape request
         pullitem = 0
         EXIT

   ENDCASE
ENDDO


IF pullitem = 0
   *-- restore original screen and color
   RESTSCREEN( rl_pd[11], rl_pd[12], rl_pd[13], rl_pd[14], rl_pd[15] )
ELSE
   *-- display selected option in bright color
   SETCOLOR(fc_selitem)
   @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
   SETCOLOR(fc_box_off)
   @ rl_pd[11]+1, pcols[pullmenu], pd_bottoms[pullmenu], pd_rights[pullmenu] BOX '┌─┐│┘─└│'
ENDIF

*-- if messages are on, clear the message line
SETCOLOR(fc_display)
IF prmts_on
   @ prmt_row,0
ENDIF

RETURN (pullitem)




*******************
PROCEDURE pd2_setup
*******************


*-- restore original screen underneath
RESTSCREEN( rl_pd[11], rl_pd[12], rl_pd[13], rl_pd[14], rl_pd[15] )

*-- display the top bar item in selected color
SETCOLOR(fc_selmenu)
@ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]

*-- now draw the box for the menu using the maximum width of options
SETCOLOR(fc_box_on)
@ rl_pd[11]+1, pcols[pullmenu], pd_bottoms[pullmenu], pd_rights[pullmenu] BOX '╔═╗║╝═╚║'
SETCOLOR(fc_display)

** SCROLL( rl_pd[11]+2, pcols[pullmenu]+1, pd_bottoms[pullmenu]-1, pd_rights[pullmenu]-1, 0)

IF NEXTKEY() = 4 .OR. NEXTKEY() = 19
   *-- if stomping down on arrow keys, skip this stuff
   RETURN
ENDIF


*-- display options
FOR x = 1 TO pd_counts[pullmenu]
   @ rl_pd[11]+1+x,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+x-1 ]
NEXT x

*-- starting choice is always 1, if not already specified
pullitem = IF( pullitem <= 0, 1, pullitem )

RETURN