home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / nfsrc21.zip / CLRSEL.PRG < prev    next >
Text File  |  1991-08-17  |  25KB  |  792 lines
  1. /*
  2.  * File......: ClrSel.PRG
  3.  * Author....: Dave Adams
  4.  * CIS ID....: 72037,2654
  5.  * Date......: $Date:   17 Aug 1991 15:05:22  $
  6.  * Revision..: $Revision:   1.2  $
  7.  * Log file..: $Logfile:   E:/nanfor/src/clrsel.prv  $
  8.  * 
  9.  * This is an original work by Dave Adams and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   E:/nanfor/src/clrsel.prv  $
  16.  * 
  17.  *    Rev 1.2   17 Aug 1991 15:05:22   GLENN
  18.  * Don Caton made corrected some spelling errors in the doc
  19.  * 
  20.  *    Rev 1.1   15 Aug 1991 23:03:50   GLENN
  21.  * Forest Belt proofread/edited/cleaned up doc
  22.  * 
  23.  *    Rev 1.0   13 Jun 1991 15:21:46   GLENN
  24.  * Initial revision.
  25.  *
  26.  */
  27.  
  28.  
  29.  
  30. /*  $DOC$
  31.  *  $FUNCNAME$
  32.  *     FT_ClrSel()
  33.  *  $CATEGORY$
  34.  *     Menus/Prompts
  35.  *  $ONELINER$
  36.  *     User Selectable Colour Routine
  37.  *  $SYNTAX$
  38.  *     FT_ClrSel( <aClrData>, [ <lClrMode> ], [ <cTestChr> ]  -> aClrData
  39.  *  $ARGUMENTS$
  40.  *
  41.  *     <aClrData> is an array of subarrays, with each subarray containing
  42.  *        information about the colour settings.
  43.  *
  44.  *        The subarray has the following structure:
  45.  *
  46.  *         [1]  cName    is the name of this colour setting i.e. "Pick List"
  47.  *                 Maximum length is 20 bytes
  48.  *
  49.  *         [2]  cClrStr  is the current colour string
  50.  *                 Default is "W/N,N/W,N/N,N/N,N/W"
  51.  *
  52.  *                 If Setting type is "M" (Menu) the colours are...
  53.  *                    1.  Prompt Colour
  54.  *                    2.  Message Colour
  55.  *                    3.  HotKey Colour
  56.  *                    4.  LightBar Colour
  57.  *                    5.  LightBar HotKey Colour
  58.  *
  59.  *                 Note: While there are many ways to code the individual
  60.  *                    colour combinations,  they should be in the same
  61.  *                    format that gets returned from SETCOLOR(), so
  62.  *                    the defaults can be found in the colour palette.
  63.  *
  64.  *                    foreground [+] / background [*]
  65.  *                    i.e. "GR+/BG*, N/W*, N+/N, , W/N"
  66.  *
  67.  *         [3]  cType  is the type of colour setting
  68.  *                 Default is "W" (Window)
  69.  *
  70.  *                    T = Title     Only 1 colour element
  71.  *                    D = Desktop   Background colour and character
  72.  *                    M = Menu      For FT_Menuto() style menus
  73.  *                    W = Window    Windows with radio buttons
  74.  *                    G = Get       For use with @ SAY...
  75.  *                    B = Browse    For tBrowse() and *dbEdit()
  76.  *                    A = aChoice   Pick-lists etc...
  77.  *
  78.  *                 W/G/B/A are functionally the same but will provide
  79.  *                 a more appropriate test display.
  80.  *
  81.  *         [4]  cFillChar  is the character (for desktop background only)
  82.  *                 Default is CHR(177) "▒▒▒▒▒▒▒▒▒▒▒▒▒▒"
  83.  *
  84.  *
  85.  *     <lClrMode>   .T.  use colour palette
  86.  *                 .F.  use monochrome palette
  87.  *
  88.  *                 Default is the ISCOLOR() setting
  89.  *
  90.  *     <cTestChr>  2 Byte character string for colour test display
  91.  *
  92.  *                 Default is the CHR(254)+CHR(254)  "■■"
  93.  *
  94.  *  $RETURNS$
  95.  *     An array identical to the one passed, with new selected colours
  96.  *  $DESCRIPTION$
  97.  *       This function allows users to select their own colour combinations
  98.  *     for all the different types of screen I/O in a typical application.
  99.  *     This facilitates an easy implementation of Ted Means' replacement
  100.  *     of the  @..PROMPT/MENU TO found in the NanForum Toolkit.  If you are
  101.  *     not using FT_MENUTO(), you can specify "A" for setting type and have
  102.  *     a normal colour string returned.
  103.  *  $EXAMPLES$
  104.  *     LOCAL aClrs   := {}
  105.  *     LOCAL lColour := ISCOLOR()
  106.  *     LOCAL cChr    := CHR(254) + CHR(254)
  107.  *     
  108.  *     SET SCOREBOARD Off
  109.  *     SETBLINK( .F. )       // Allow bright backgrounds
  110.  *   
  111.  *     *.... a typical application might have the following different settings
  112.  *     *     normally these would be stored in a .dbf/.dbv
  113.  *     aClrs := {;
  114.  *        { "Desktop",        "N/BG",                         "D", "▒" }, ;
  115.  *        { "Title",          "N/W",                          "T"      }, ;
  116.  *        { "Top Menu",       "N/BG,N/W,W+/BG,W+/N,GR+/N",    "M"      }, ;
  117.  *        { "Sub Menu",       "W+/N*,GR+/N*,GR+/N*,W+/R,G+/R","M"      }, ;
  118.  *        { "Standard Gets",  "W/B,  W+/N,,, W/N",            "G"      }, ;
  119.  *        { "Nested Gets",    "N/BG, W+/N,,, W/N",            "G"      }, ;
  120.  *        { "Help",           "N/G,  W+/N,,, W/N",            "W"      }, ;
  121.  *        { "Error Messages", "W+/R*,N/GR*,,,N/R*",           "W"      }, ;
  122.  *        { "Database Query", "N/BG, N/GR*,,,N+/BG",          "B"      }, ;
  123.  *        { "Pick List",      "N/GR*,W+/B,,, BG/GR*",         "A"      }  ;
  124.  *              }
  125.  *   
  126.  *    aClrs := FT_ClrSel( aClrs, lColour, cChr )
  127.  *  $END$
  128.  */
  129.  
  130. /*
  131.  * File Contents
  132.  * 
  133.  *   FT_ClrSel( aClrs, lColour, cChr )         user selectable colour routine
  134.  *   _ftHiLite( nRow, nCol, cStr, nLen )       re-hilite an achoice prompt
  135.  *   _ftColours( aOpt, aClrPal, lColour )      control colour selection
  136.  *   _ftShowIt( aOpt )                         show a sample of the colours
  137.  *   _ftClrSel( aClrPal, cClr, nElem, aOpt)    pick a colour
  138.  *   _ftClrPut( cClrStr, nElem, cClr )         place a clr element into str
  139.  *   _ftDeskChar( aOpt )                       select desktop char
  140.  *   _ftChr2Arr( cString, cDelim )             parse string into array
  141.  *   _ftArr2Chr( aArray, cDelim )              create string from array
  142.  *   _ftShowPal( aClrPal, cChr )               paint palette on screen
  143.  *   _ftInitPal( aClrTab )                     create the palette
  144.  *   _ftIdentArr( aArray1, aArray2 )           compare array contents
  145.  *
  146.  */
  147.  
  148. /*
  149.  * Commentary
  150.  *
  151.  *  Thanks to Brian Loesgen for offering ideas and helping to tweak
  152.  *  the code.
  153.  *
  154.  *
  155.  */
  156.  
  157. *------------------------------------------------
  158. // Pre-processor stuff
  159.  
  160. #include "box.ch"
  161. #include "setcurs.ch"
  162. #include "inkey.ch"
  163.  
  164. #define C_NAME   1
  165. #define C_CLR    2
  166. #define C_TYPE   3
  167. #define C_CHAR   4
  168.  
  169. #translate Single( <t>, <l>, <b>, <r> ) =>;
  170.            @ <t>, <l>, <b>, <r> BOX B_SINGLE
  171.  
  172. #translate Double( <t>, <l>, <b>, <r> ) =>;
  173.            @ <t>, <l>, <b>, <r> BOX B_DOUBLE
  174.  
  175. #translate ClearS( <t>, <l>, <b>, <r> ) =>;
  176.            @ <t>, <l> CLEAR TO <b>, <r>
  177.  
  178. #translate BkGrnd( <t>, <l>, <b>, <r>, <c> ) =>;
  179.            DispBox( <t>, <l>, <b>, <r>, REPLICATE(<c>,9) )
  180.  
  181. #command DEFAULT <p> TO <val> [, <pn> TO <valn> ]  =>;
  182.          <p> := IIF( <p> == Nil, <val>, <p> );     ;
  183.          [ <pn> := IIF( <pn> == Nil, <valn>, <pn> ) ]
  184.  
  185. *------------------------------------------------
  186. //  Demo of FT_ClrSel()
  187.  
  188. /*
  189.  *     To run the sample program:
  190.  *
  191.  *     Compile :   Clipper ClrSel /n /m /w /dFT_TEST
  192.  *     Link    :   Rtlink FILE ClrSel LIB NanFor [/PLL:Fullbase]
  193.  *                                         .OR.  [/PLL:Base50]
  194.  *
  195.  *     ClrSel MONO      To force monochrome mode
  196.  *     ClrSel NOSNOW    To prevent CGA snowstorms
  197.  *     ClrSel EGA       43 line mode
  198.  *     ClrSel VGA       50 line mode
  199.  *
  200.  */
  201.  
  202. #IFDEF FT_TEST
  203.  
  204.   FUNCTION Main( cVidMode )
  205.  
  206.   LOCAL nRowDos := ROW()
  207.   LOCAL nColDos := COL()
  208.   LOCAL lBlink  := SETBLINK( .F. )  // make sure it starts out .F.
  209.   LOCAL aEnvDos := FT_SaveSets()
  210.   LOCAL cScrDos := SAVESCREEN( 00, 00, MAXROW(), MAXCOL() )
  211.   LOCAL lColour := .F.
  212.   LOCAL aClrs   := {}
  213.   
  214.   DEFAULT cVidMode TO ""
  215.   NOSNOW( ( "NOSNOW" $ UPPER( cVidMode ) ) )
  216.   IF "VGA" $ UPPER( cVidMode )
  217.      SETMODE( 50, 80 )
  218.   ENDIF
  219.   IF "EGA" $ UPPER( cVidMode )
  220.      SETMODE( 43, 80 )
  221.   ENDIF
  222.   lColour := IF( "MONO" $ UPPER( cVidMode ), .F., ISCOLOR() )
  223.  
  224.   SET SCOREBOARD Off
  225.   SETCURSOR( SC_NONE )
  226.   lBlink := SETBLINK( .F. )
  227.  
  228.   *.... a typical application might have the following different settings
  229.   *     normally these would be stored in a .dbf/.dbv
  230.   aClrs := {;
  231.      { "Desktop",        "N/BG",                         "D", "▒" }, ;
  232.      { "Title",          "N/W",                          "T"      }, ;
  233.      { "Top Menu",       "N/BG,N/W,W+/BG,W+/N,GR+/N",    "M"      }, ;
  234.      { "Sub Menu",       "W+/N*,GR+/N*,GR+/N*,W+/R,G+/R","M"      }, ;
  235.      { "Standard Gets",  "W/B,  W+/N,,, W/N",            "G"      }, ;
  236.      { "Nested Gets",    "N/BG, W+/N,,, W/N",            "G"      }, ;
  237.      { "Help",           "N/G,  W+/N,,, W/N",            "W"      }, ;
  238.      { "Error Messages", "W+/R*,N/GR*,,,N/R*",           "W"      }, ;
  239.      { "Database Query", "N/BG, N/GR*,,,N+/BG",          "B"      }, ;
  240.      { "Pick List",      "N/GR*,W+/B,,, BG/GR*",         "A"      }  ;
  241.            }
  242.  
  243.   aClrs := FT_ClrSel( aClrs, lColour )
  244.  
  245.   *.... restore the DOS environment
  246.   FT_RestSets( aEnvDos )
  247.   RESTSCREEN( 00, 00, MAXROW(), MAXCOL(), cScrDos )
  248.   SETPOS( nRowDos, nColDos )
  249.   SETBLINK( .F. )  // doesn't appear to be reset from FT_RestSets
  250.  
  251.   RETURN Nil
  252.  
  253. #ENDIF
  254.  
  255. *------------------------------------------------
  256. FUNCTION FT_ClrSel( aClrs, lColour, cChr )
  257. // Colour selection routine
  258. // Return -> the same array that was passed but with modified colours
  259.  
  260. LOCAL aClrOld := aClone( aClrs )
  261. LOCAL aOptions
  262. LOCAL nF, nB, nT, nL, nR
  263. LOCAL nChoice := 1
  264. LOCAL nLen    := 0
  265. LOCAL aPrompt := {}
  266. LOCAL aClrPal := {}
  267. LOCAL aClrTab := { "N","B","G","BG","R","RB","GR","W" }
  268. LOCAL aClrBW  := { "N","B","W" }
  269. LOCAL nRowSav := ROW()
  270. LOCAL nColSav := COL()
  271. LOCAL aEnvSav := FT_SaveSets()
  272. LOCAL cScrSav := SAVESCREEN( 00, 00, MAXROW(), MAXCOL() )
  273.  
  274. DEFAULT lColour TO ISCOLOR()
  275. DEFAULT cChr TO chr(254)+chr(254)
  276. cChr := PadR( cChr, 2 )
  277.  
  278. SETCURSOR( SC_NONE )
  279. SETCOLOR( IIF( lColour, "GR+/N,,N/N", "W+/N,,N/N" ) )
  280. CLS
  281.  
  282. *.... initialize the colour palette
  283. aClrPal := _ftInitPal( IIF( lColour, aClrTab, aClrBW ) )
  284.  
  285. *.... paint the colours on the screen
  286. _ftShowPal( aClrPal, cChr )
  287.  
  288. *.... Determine length of longest name and make sure not greater than 20
  289. aEval( aClrs, { |aOpt| nLen := MAX( nLen, LEN( aOpt[C_NAME] ) ) } )
  290. nLen := MIN( MAX( nLen, 1 ), 20 ) + 2
  291.  
  292. *.... prepare an array for use with aChoice(); truncate names at 20 chrs.
  293. aPrompt := ARRAY( LEN( aClrs ) )
  294. aEval( aClrs,;
  295.        { |aOpt,nE| aPrompt[nE] := " "+ SUBS(aOpt[C_NAME], 1, nLen-2) +" " };
  296.      )
  297.  
  298. *.... determine co-ordinates for the achoice window
  299. nT := MAX( INT( (18-LEN(aPrompt)) /2 )-1, 1 )
  300. nB := MIN( nT + LEN(aPrompt) + 1, 17 )
  301. nL := MAX( INT( (27-nLen) /2 )-2, 1 )
  302. nR := MIN( nL + nLen + 3, 26 )
  303.  
  304. *.... set up the window for aChoice
  305. SETCOLOR( IIF( lColour, "N/W,W+/R", "N/W,W+/N" ) )
  306. ClearS( nT, nL,   nB, nR )
  307.  
  308. *.... prompt for colour setting and modify
  309. DO WHILE nChoice <> 0
  310.   Double( nT, nL+1, nB, nR-1 )
  311.   nChoice := aChoice( nt+1, nL+2, nB-1, nR-2, aPrompt, , , nChoice )
  312.   IF nChoice <> 0
  313.     _ftHiLite( ROW(), nL+2, aPrompt[ nChoice ], nLen )
  314.     Single( nT, nL+1, nB, nR-1 )
  315.     aClrs[ nChoice ] := _ftColours( aClrs[ nChoice ], aClrPal, lColour )
  316.   ENDIF
  317. ENDDO
  318.  
  319. aOptions := { "Save New Colours", "Restore Original" }
  320. IF ! _ftIdentArr( aClrs, aClrOld )
  321.   nChoice := ALERT( "Colors have been modified...", aOptions )
  322. ELSE
  323.   nChoice := 1
  324. ENDIF
  325.  
  326. FT_RestSets( aEnvSav )
  327. RESTSCREEN( 00, 00, MAXROW(), MAXCOL(), cScrSav )
  328. SETPOS( nRowSav, nColSav )
  329.  
  330. RETURN IIF( nChoice == 1, aClrs, aClrOld )
  331.  
  332. *------------------------------------------------
  333. STATIC FUNCTION _ftHiLite( nRow, nCol, cStr, nLen )
  334. // Highlight the current selected aChoice element
  335. // Return -> Nil
  336.  
  337. LOCAL cClr := SETCOLOR()
  338. LOCAL aClr := _ftChr2Arr( cClr )
  339.  
  340. SETCOLOR( aClr[ 2 ] )                  // enhanced colour
  341. @ nRow, nCol SAY PadR( cStr, nLen )
  342. SETCOLOR( cClr )
  343.  
  344. RETURN Nil
  345.  
  346. *------------------------------------------------
  347. STATIC FUNCTION _ftColours( aOpt, aClrPal, lColour )
  348. // Colour selection for specific type of colour setting
  349. // Return -> aOpt with modified colour strings
  350.  
  351. LOCAL nF, nB, nT, nL, nR
  352. LOCAL nX      := 0
  353. LOCAL aClrs   := {}
  354. LOCAL cClr    := ""
  355. LOCAL nChoice := 1
  356. LOCAL aPrompt := {}
  357. LOCAL nLen    := 0
  358. LOCAL cColour := SETCOLOR()
  359. LOCAL cScrSav := SAVESCREEN( 18, 00, MAXROW(), MAXCOL() )
  360.  
  361. aSize( aOpt, 4 )                            // check incoming parameters
  362. DEFAULT aOpt[ C_CHAR ] TO ""
  363. DEFAULT aOpt[ C_TYPE ] TO "W"
  364. aOpt[ C_CLR ]  := UPPER( aOpt[ C_CLR ] )    // need upper case
  365. aOpt[ C_TYPE ] := UPPER( aOpt[ C_TYPE ] )
  366.  
  367. DEFAULT lColour TO ISCOLOR()
  368.  
  369. *.... display appropriate prompts based on type of colour setting
  370. nChoice := 1
  371. DO CASE
  372.    CASE aOpt[ C_TYPE ] == "D"
  373.      aPrompt := { " Color ", " Character " }
  374.    CASE aOpt[ C_TYPE ] == "M"
  375.      aPrompt := { " Prompt ", " Message ", " HotKey ",;
  376.                   " LightBar ", " LightBar HotKey " }
  377.    CASE aOpt[ C_TYPE ] == "A" .OR.  aOpt[ C_TYPE ] == "B"
  378.      aPrompt := { " Standard ", " Selected ", " Border ", " Unavailable " }
  379.    OTHERWISE
  380.      aPrompt := { " Standard ", " Selected ", " Border ", " Unselected " }
  381. ENDCASE
  382.  
  383. IF aOpt[ C_TYPE ] <> "T"  // no prompt for titles
  384.   *.... we need to know top,left,bottom,right for the prompt window
  385.   aEval( aPrompt, { |cPrompt| nLen := MAX( nLen, LEN( cPrompt ) ) } )
  386.   nLen := MAX( nLen, LEN( aOpt[ C_NAME ] ) + 2 )
  387.   nT := IIF( aOpt[ C_TYPE ] == "M", 18, 19 )
  388.   nB := nT + LEN(aPrompt) + 1
  389.   nL := MAX( INT( (27-nLen) /2 )-2, 1 )
  390.   nR := MIN( nL + nLen + 3, 26 )
  391.  
  392.   *.... set up the window for prompt
  393.   SETCOLOR( "N/W" )
  394.   ClearS( nT, nL, nB, nR )
  395. ENDIF
  396.  
  397. DO WHILE .T.
  398.  
  399.   *.... show sample window
  400.   _ftShowIt( aOpt )
  401.  
  402.   IF aOpt[ C_TYPE ] <> "T"  // no prompt for titles
  403.     SETCOLOR( IIF( lColour, "N/W,W+/R,,,N/W", "N/W,W+/N,,,N/W" ) )
  404.     Double( nT, nL+1, nB, nR-1 )
  405.     @ nT, nL+2 SAY PadC( " "+ aOpt[C_NAME] +" ", nR -nL -3, "═" )
  406.     FOR nX := 1 TO LEN( aPrompt )
  407.       @ nX+nT, nL+2 PROMPT PadR( aPrompt[nX], nR -nL -3 )
  408.     NEXT
  409.     MENU TO nChoice
  410.  
  411.     DO CASE
  412.        CASE nChoice == 0
  413.          EXIT
  414.        CASE nChoice == 2 .AND. aOpt[ C_TYPE ] == "D"
  415.          *....  desktop character
  416.          aOpt := _ftDeskChar( aOpt )
  417.          LOOP
  418.        CASE nChoice == 4 .AND. aOpt[ C_TYPE ] <> "M"
  419.          nChoice := 5      // 4th color param is unused
  420.     ENDCASE
  421.   ENDIF
  422.  
  423.   *.... get the specific colour combination
  424.   aClrs := _ftChr2Arr( aOpt[ C_CLR ] )   // place color string in an array
  425.   aSize( aClrs, 5 )                      // make sure there are 5 settings
  426.   *.... empty elements are made Nil so they can be defaulted
  427.   aEval( aClrs, { |v,e| aClrs[e] := IIF( EMPTY(v), Nil, ALLTRIM(v) ) } )
  428.   DEFAULT aClrs[1] TO "W/N"
  429.   DEFAULT aClrs[2] TO "N/W"   // place default colours into
  430.   DEFAULT aClrs[3] TO "N/N"   // elements which are empty
  431.   DEFAULT aClrs[4] TO "N/N"
  432.   DEFAULT aClrs[5] TO "N/W"
  433.   cClr := aClrs[ nChoice ]    // selected colour
  434.  
  435.   *.... allow change to specific part of colour string
  436.   IF aOpt[ C_TYPE ] <> "T"
  437.     Single( nT, nL+1, nB, nR-1 )
  438.     @ nT, nL+2 SAY PadC( " "+ aOpt[C_NAME] +" ", nR -nL -3, "─" )
  439.   ENDIF
  440.   cClr := _ftClrSel( aClrPal, cClr, nChoice, aOpt )  //  selection routine
  441.   aClrs[ nChoice ] := cClr               // put colour back in array
  442.   aOpt[ C_CLR ] := _ftArr2Chr( aClrs )   // convert array to colour string
  443.  
  444.   IF aOpt[ C_TYPE ] == "T"
  445.     EXIT
  446.   ENDIF
  447.  
  448. ENDDO
  449.  
  450. *.... restore the lower 1/2 of screen, and colour
  451. RESTSCREEN( 18, 00, MAXROW(), MAXCOL(), cScrSav )
  452. SETCOLOR( cColour )
  453.  
  454. RETURN aOpt
  455.  
  456. *------------------------------------------------
  457. STATIC FUNCTION _ftShowIt( aOpt )
  458. // Show an example of the colour setting
  459. // Return -> Nil
  460.  
  461. LOCAL aClr := _ftChr2Arr( aOpt[ C_CLR ] )
  462.  
  463. IF aOpt[ C_TYPE ] <> "M"     // no borders in menu colour selection
  464.   SETCOLOR( aOpt[ C_CLR ] )  // this will set the border on VGA
  465. ENDIF
  466.  
  467. DispBegin()
  468. DO CASE
  469.  
  470.    CASE aOpt[ C_TYPE ] == "D"    // Desktop Background
  471.      SETCOLOR( aClr[1] )
  472.      BkGrnd( 19, 43, 22, 64, aOpt[ C_CHAR ] )
  473.  
  474.    CASE aOpt[ C_TYPE ] == "T"    // Title
  475.      SETCOLOR( aClr[1] )
  476.      @ 20,08 SAY PadC( "This is an example of how the text shall look", 63 )
  477.  
  478.    CASE aOpt[ C_TYPE ] == "M"    // Menus
  479.      SETCOLOR( "W/N" )
  480.      BkGrnd( 19, 41, 23, 66, CHR(177) )
  481.      SETCOLOR( aClr[1] )
  482.      Single( 19, 43, 22, 60 )
  483.      @ 18,41 SAY "   Report  Inquiry  Quit  "
  484.      @ 21,44 SAY    " eXit           "
  485.      SETCOLOR( aClr[4] )
  486.      @ 18,43 SAY    " Report "
  487.      @ 20,44 SAY    " Product List   "
  488.      SETCOLOR( aClr[3] )
  489.      @ 18,52 SAY            "I"
  490.      @ 18,61 SAY                     "Q"
  491.      @ 21,46 SAY      "X"
  492.      SETCOLOR( aClr[5] )
  493.      @ 18,44 SAY     "R"
  494.      @ 20,45 SAY     "P"
  495.      SETCOLOR( aClr[2] )
  496.      @ 24,41 SAY PadC( "Inventory Report", 26 )
  497.  
  498.    CASE aOpt[ C_TYPE ] == "G"    // Get windows
  499.      SETCOLOR( aClr[1] )
  500.      ClearS( 19, 41, 24, 66 )
  501.      Single( 19, 42, 24, 65 )
  502.      @ 20,43 SAY  "    Invoice Entry    "
  503.      @ 21,42 SAY "├──────────────────────┤"
  504.      @ 22,43 SAY  "   Amount            "
  505.      @ 23,43 SAY  "   Date              "
  506.      SETCOLOR( aClr[2] )
  507.      @ 22,53 SAY             "  199.95"
  508.      SETCOLOR( aClr[5] )
  509.      @ 23,53 SAY             "09/15/91"
  510.  
  511.    CASE aOpt[ C_TYPE ] == "W"    // Alert windows
  512.      SETCOLOR( aClr[1] )
  513.      ClearS( 18, 40, 24, 66 )
  514.      Single( 18, 41, 24, 65 )
  515.      @ 19,42 SAY  "                       "
  516.      @ 20,42 SAY  "     Test Message      "
  517.      @ 21,42 SAY  "                       "
  518.      @ 22,41 SAY "├───────────────────────┤"
  519.      SETCOLOR( aClr[2] )
  520.      @ 23,44 SAY  " Accept "
  521.      SETCOLOR( aClr[5] )
  522.      @ 23,55 SAY             " Reject "
  523.  
  524.    CASE aOpt[ C_TYPE ] == "B"    // browse windows
  525.      SETCOLOR( aClr[1] )
  526.      ClearS( 18, 37, 24, 70 )
  527.      Single( 18, 38, 24, 69 )
  528.      @ 19,39 SAY  " Cust   Name           Amount "
  529.      @ 20,38 SAY "╞══════╤══════════════╤════════╡"
  530.      @ 21,39 SAY  "  312 │ Rick Shaw    │ 143.25 "
  531.      @ 23,39 SAY  "      │              │        "
  532.      @ 24,38 SAY "╘══════╧══════════════╧════════╛"
  533.      SETCOLOR( aClr[2] )
  534.      @ 22,39 SAY  " 1005 │ Harry Pitts  │  78.95 "
  535.      SETCOLOR( aClr[5] )
  536.      @ 23,39 SAY  " 3162 "
  537.      @ 23,46 SAY         " Barb Wire    "
  538.      @ 23,61 SAY                        " 345.06 "
  539.  
  540.    CASE aOpt[ C_TYPE ] == "A"    // achoice type window
  541.      SETCOLOR( aClr[1] )
  542.      ClearS( 18, 42, 24, 64 )
  543.      Single( 18, 43, 24, 63 )
  544.      @ 19,44 SAY  " Daily Reports     "
  545.      @ 21,44 SAY  " Quarterly Reports "
  546.      @ 23,44 SAY  " Exit ...   <Esc>  "
  547.      SETCOLOR( aClr[2] )
  548.      @ 20,44 SAY  " Monthend Reports  "
  549.      SETCOLOR( aClr[5] )
  550.      @ 22,44 SAY  " Yearend Reports   "
  551.  
  552. ENDCASE
  553. DispEnd()
  554.  
  555. RETURN Nil
  556.  
  557. *------------------------------------------------
  558. STATIC FUNCTION _ftClrSel( aClrPal, cClr, nElem, aOpt )
  559. // select the colour combination from aClrPal and place in cClr
  560. // cClr is the current colour being modified
  561. // Return -> selected colour combination
  562.  
  563. LOCAL nR     := 1
  564. LOCAL nC     := 1
  565. LOCAL lFound := .F.
  566. LOCAL nKey   := 0
  567. LOCAL nDim   := LEN( aClrPal )
  568. LOCAL nTop    := 0
  569. LOCAL nLeft   := 28
  570. LOCAL nBottom := nTop  + nDim + 1
  571. LOCAL nRight  := nLeft + ( nDim * 3 ) + 2
  572.  
  573. SETCOLOR( "GR+/N" )
  574. Double( nTop, nLeft, nBottom, nRight )
  575.  
  576. SETCOLOR ( "W+/N" )
  577.  
  578. *.... find the starting row and column for the current colour
  579. FOR nR := 1 TO nDim
  580.   FOR nC := 1 TO nDim
  581.     IF aClrPal[ nR, nC ] == ALLTRIM( cClr )
  582.       lFound := .T. ;  EXIT
  583.     ENDIF
  584.   NEXT
  585.   IF lFound ;  EXIT ;  ENDIF
  586. NEXT
  587.  
  588. IF ! lFound
  589.   nR := 1                         // black background
  590.   nC := IIF( nDim == 5, 3, 8 )    // white foreground
  591. ENDIF
  592.  
  593. DO WHILE .T.
  594.  
  595.   *.... make sure array boundary not exceeded
  596.   nR := IIF( nR > nDim, 1, IIF( nR == 0, nDim, nR ) )
  597.   nC := IIF( nC > nDim, 1, IIF( nC == 0, nDim, nC ) )
  598.  
  599.   *.... place selected colour in the appropriate spot in clr string
  600.   aOpt[ C_CLR ] := _ftClrPut( aOpt[ C_CLR ], nElem, aClrPal[ nR, nC ] )
  601.  
  602.   *.... show sample window
  603.   _ftShowIt( aOpt )
  604.  
  605.   *.... highlight the colour palette element
  606.   SETCOLOR ( "W+/N" )
  607.   @ nR, nC*3+26 SAY ""
  608.   @ nR, nC*3+29 SAY ""
  609.   nKey := INKEY(0)
  610.   @ nR, nC*3+26 SAY " "
  611.   @ nR, nC*3+29 SAY " "
  612.  
  613.   *.... check key movement and modify co-ordinates
  614.   DO CASE
  615.      CASE nKey == K_ESC   ;  EXIT
  616.      CASE nKey == K_ENTER ;  cClr := aClrPal[ nR, nC ] ;  EXIT
  617.      CASE nKey == K_UP    ;  --nR
  618.      CASE nKey == K_DOWN  ;  ++nR
  619.      CASE nKey == K_LEFT  ;  --nC
  620.      CASE nKey == K_RIGHT ;  ++nC
  621.   ENDCASE
  622.  
  623. ENDDO
  624.  
  625. SETCOLOR( "GR+/N" )
  626. Single( nTop, nLeft, nBottom, nRight )
  627.  
  628. RETURN cClr
  629.  
  630. *------------------------------------------------
  631. STATIC FUNCTION _ftClrPut( cClrStr, nElem, cClr )
  632. // Place a colour setting in the colour string
  633. // Return -> modified colour string
  634.  
  635. LOCAL aClr := _ftChr2Arr( cClrStr )
  636.  
  637. aClr[ nElem ] := cClr
  638.  
  639. RETURN _ftArr2Chr( aClr )
  640.  
  641. *------------------------------------------------
  642. STATIC FUNCTION _ftDeskChar( aOpt )
  643. // Select the character to be used for the desktop background
  644. // Return -> same array with new character
  645.  
  646. LOCAL aChar := { CHR(32), CHR(176), CHR(177), CHR(178) }
  647. LOCAL cChar := aOpt[ C_CHAR ]
  648. LOCAL cClr  := aOpt[ C_CLR ]
  649. LOCAL nElem := aScan( aChar, cChar )
  650. LOCAL n, nKey
  651.  
  652. IF nElem == 0            // this allows another character to be selected
  653.   aAdd( aChar, cChar )   // but there is the possibility that it will
  654.   nElem := 5             // not be available if they ever select another
  655. ENDIF                    // char and store it. It's up to you to put it in
  656.  
  657. *.... draw the choices on the screen
  658. SETCOLOR ( cClr )
  659. FOR n := 1 TO LEN( aChar )
  660.   @ n+18, 29 SAY REPL( aChar[n], 10 )
  661. NEXT
  662.  
  663. n := nElem + 18
  664. DO WHILE .T.
  665.   *.... make sure boundary not exeeded
  666.   n := IIF( n > Len(aChar)+18, 19, IIF( n < 19, Len(aChar)+18, n ) )
  667.  
  668.   *.... show sample window
  669.   aOpt[ C_CHAR ] := aChar[ n-18 ] // place in array
  670.   _ftShowIt( aOpt )
  671.  
  672.   SETCOLOR ( "W+/N" )
  673.   @ n, 28 SAY ""
  674.   @ n, 39 SAY ""
  675.   nKey := INKEY(0)
  676.   @ n, 28 SAY " "
  677.   @ n, 39 SAY " "
  678.  
  679.   *.... check key movement and modify co-ordinates
  680.   DO CASE
  681.      CASE nKey == K_ESC   ;  aOpt[ C_CHAR ] := cChar ;  EXIT
  682.      CASE nKey == K_ENTER ;  EXIT
  683.      CASE nKey == K_UP    ;  --n
  684.      CASE nKey == K_DOWN  ;  ++n
  685.   ENDCASE
  686.  
  687. ENDDO
  688.  
  689. SETCOLOR ( "W+/N" )
  690. ClearS( 18, 28, 23, 39 )
  691.  
  692. RETURN aOpt
  693.  
  694. *------------------------------------------------
  695. STATIC FUNCTION _ftChr2Arr( cString, cDelim )
  696. // Convert a chr string to an array
  697. // Return -> array
  698.  
  699. LOCAL n, aArray := {}
  700.  
  701. DEFAULT cDelim  TO ","
  702. DEFAULT cString TO ""  // this should really be passed
  703. cString += cDelim
  704.  
  705. DO WHILE .T.
  706.   IF EMPTY( cString ) ;  EXIT ;  ENDIF
  707.   n := AT( cDelim, cString )
  708.   AADD( aArray, IIF( n == 1, "", LEFT( cString, n - 1 ) ) )
  709.   cString := SUBS( cString, n + 1 )
  710. ENDDO
  711.  
  712. RETURN aArray
  713.  
  714. *------------------------------------------------
  715. STATIC FUNCTION _ftArr2Chr( aArray, cDelim )
  716. // convert an array to a chr string
  717. // Return -> string
  718.  
  719. LOCAL cString := ""
  720.  
  721. DEFAULT aArray TO {}
  722. DEFAULT cDelim TO ","
  723.  
  724. AEVAL( aArray, { |v,e| cString += IIF( e == 1, v, cDelim + v ) } )
  725.  
  726. RETURN cString
  727.  
  728. *------------------------------------------------
  729. STATIC FUNCTION _ftShowPal( aClrPal, cChr )
  730. // Paint the palette on the screen
  731. // Return -> Nil
  732.  
  733. LOCAL nF,nB
  734. LOCAL nTop    := 0
  735. LOCAL nLeft   := 28
  736. LOCAL nBottom := nTop  + LEN( aClrPal ) + 1
  737. LOCAL nRight  := nLeft + ( LEN( aClrPal )*3 ) + 2
  738.  
  739. *.... Buffer the screen output
  740. DispBegin()
  741. Single( nTop, nLeft, nBottom, nRight )
  742. FOR nF := 1 TO LEN( aClrPal )
  743.   FOR nB := 1 TO  LEN( aClrPal[ nF ] )
  744.     SETCOLOR( aClrPal[ nF, nB ] )
  745.     @ nF, nB*3+27 SAY cChr
  746.   NEXT
  747. NEXT
  748. DispEnd()
  749.  
  750. RETURN Nil
  751.  
  752. *------------------------------------------------
  753. STATIC FUNCTION _ftInitPal( aClrTab )
  754. // Initialise the colour palette based on the passed colour table aClrTab
  755. // Load the palette with colours
  756. // Return -> Colour pallette array
  757.  
  758. LOCAL nF,nB
  759. LOCAL nDim    := LEN( aClrTab )
  760. LOCAL aClrPal := ARRAY( nDim*2, nDim*2 )
  761.  
  762. FOR nF := 1 TO nDim*2
  763.   FOR nB := 1 TO nDim*2
  764.     aClrPal[ nF, nB ] :=;
  765.       IIF( nF <= nDim, aClrTab[ nF ], aClrTab[ nF-nDim ] +"+" ) +"/"+;
  766.       IIF( nB <= nDim, aClrTab[ nB ], aClrTab[ nB-nDim ] +"*" )
  767.   NEXT
  768. NEXT
  769.  
  770. RETURN aClrPal
  771.  
  772. *------------------------------------------------
  773. STATIC FUNCTION _ftIdentArr( aArr1, aArr2 )
  774. // Compares the contents of 2 arrays
  775. // Return -> logical
  776.  
  777. LOCAL lIdentical := LEN(aArr1) == LEN(aArr2)
  778. LOCAL n := 1
  779.  
  780. DO WHILE lIdentical .AND. n <= LEN(aArr1)
  781.   IF VALTYPE( aArr1[n] ) == VALTYPE( aArr2[n] )
  782.     lIdentical := IIF( VALTYPE( aArr1[n] ) == "A",     ;
  783.                        _ftIdentArr( aArr1[n], aArr2[n] ), ;
  784.                        aArr1[n] == aArr2[n] )
  785.   ELSE
  786.     lIdentical := .f.
  787.   ENDIF
  788.   n++
  789. ENDDO
  790.  
  791. RETURN lIdentical
  792.