home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database / CLIPR503.W96 / ARRAY.PR_ / ARRAY.PR
Encoding:
Text File  |  1995-06-20  |  10.7 KB  |  417 lines
  1. /***
  2. *
  3. *  Array.prg
  4. *
  5. *  Sample array handling functions
  6. *
  7. *  Copyright (c) 1990-1995, Computer Associates International Inc.
  8. *  All rights reserved.
  9. *
  10. *  NOTE: Compile with /a /m /n /w
  11. *
  12. */
  13.  
  14. #include "Common.ch"
  15. #include "Inkey.ch"
  16.  
  17.  
  18. // Maintains the current row of ABrowse()
  19. STATIC nRow
  20.  
  21.  
  22. /***
  23. *
  24. *  ABrowse( <aArray> [,<nTop>][,<nLeft>][,<nBottom>][,<nRight>] ) --> xValue
  25. *
  26. *  Browse a 2-dimensional array using a TBrowse object
  27. *
  28. *  Parameters:
  29. *     aArray  - The 2D array to browse
  30. *     nTop    - Optional line on which to display the top margin of the browse
  31. *     nLeft   - Optional column of the left margin of the browse
  32. *     nRight  - Optional column of the right margin of the browse
  33. *     nBottom - Optional line of the bottom margin of the browse
  34. *
  35. *  Returns: The value of the highlighted array element
  36. *
  37. */
  38. FUNCTION ABrowse( aArray, nT, nL, nB, nR )
  39.  
  40.    LOCAL nOldCursor     // Saves current cursor shape
  41.    LOCAL nOldNRow       // Saves current row
  42.    LOCAL xRet           // Return value (user's selection or NIL)
  43.    LOCAL nKey := 0      // Keystroke holder
  44.    LOCAL n              // FOR..NEXT counter variable
  45.    LOCAL o              // TBrowse object
  46.  
  47.    // Preserve cursor setting, turn off cursor
  48.    nOldCursor := SETCURSOR( 0 )
  49.  
  50.    // Preserve static var (just in case), set it to 1
  51.    nOldNRow := nRow
  52.    nRow     := 1
  53.  
  54.  
  55.    // Assign defaults for omitted parameters
  56.    DEFAULT nT TO 0
  57.    DEFAULT nL TO 0
  58.    DEFAULT nB TO MAXROW()
  59.    DEFAULT nR TO MAXCOL()
  60.  
  61.    // Create the TBrowse object
  62.    o := TBrowseNew( nT, nL, nB, nR )
  63.  
  64.    // This skip block just adds to (or subtracts from) nRow
  65.    // (see aSkipTest for explanation of that function)
  66.    o:skipBlock := { |nSkip| nSkip := ASkipTest( aArray, nRow, nSkip ), ;
  67.                             nRow += nSkip,                             ;
  68.                             nSkip                                      ;
  69.                   }
  70.  
  71.    // The go top block sets nRow to 1
  72.    o:goTopBlock := { || nRow := 1 }
  73.  
  74.    // The go bottom block sets nRow to the length of the array
  75.    o:goBottomBlock := { || nRow := LEN( aArray ) }
  76.  
  77.    // Create column blocks and add TBColumn objects to the TBrowse
  78.    // (see ABrowseBlock() below)
  79.    FOR n := 1 TO LEN( aArray[1] )
  80.      o:addColumn( TBColumnNew( "", ABrowseBlock( aArray, n )))
  81.    NEXT
  82.  
  83.    // Main key handler loop
  84.    DO WHILE ( nKey <> K_ESC ) .AND. ( nKey <> K_RETURN )
  85.  
  86.       // Stabilize the browse and wait for a keystroke
  87.       o:forceStable()
  88.       nKey := INKEY( 0 )
  89.  
  90.       // Process the directional keys
  91.       IF o:stable
  92.  
  93.          DO CASE
  94.          CASE ( nKey == K_DOWN )
  95.             o:down()
  96.  
  97.          CASE ( nKey == K_UP )
  98.             o:up()
  99.  
  100.          CASE ( nKey == K_RIGHT )
  101.             o:right()
  102.  
  103.          CASE ( nKey == K_LEFT )
  104.             o:left()
  105.  
  106.          CASE ( nKey == K_PGDN )
  107.             o:right()
  108.             o:down()
  109.  
  110.          CASE ( nKey == K_PGUP )
  111.             o:right()
  112.             o:up()
  113.  
  114.          CASE ( nKey == K_HOME )
  115.             o:left()
  116.             o:up()
  117.  
  118.          CASE ( nKey == K_END )
  119.             o:left()
  120.             o:down()
  121.  
  122.          ENDCASE
  123.  
  124.       ENDIF
  125.  
  126.    ENDDO
  127.  
  128.  
  129.    // Set the return value
  130.    xRet := IF( nKey == K_RETURN, aArray[nRow, o:colPos], NIL )
  131.  
  132.    // Restore the original cursor setting
  133.    SETCURSOR( nOldCursor )
  134.  
  135.    // Restore the static var
  136.    nRow := nOldNRow
  137.  
  138.  
  139.    RETURN (xRet)
  140.  
  141.  
  142.  
  143. /***
  144. *
  145. *  ABrowseBlock( <aArray>, <nIndex> ) --> bColumnBlock
  146. *
  147. *  Create and return a get/set block for <aArray>[nRow, <nIndex>]
  148. *
  149. *  Parameters:
  150. *     aArray - The array for which the code block is to be created
  151. *     nIndex - The index into aArray for the code block creation
  152. *
  153. *  This function works by returning a block that refers
  154. *  to local variables <a> and <x> (the parameters). In
  155. *  version 5.01 these local variables are preserved for
  156. *  use by the block even after the function has returned.
  157. *  The result is that each call to ABrowseBlock() returns
  158. *  a block which has the passed values of <a> and <x> "bound"
  159. *  to it for later use. The block defined here also refers to
  160. *  the static variable nRow, used by ABrowse() to track the
  161. *  array's "current row" while browsing.
  162. *
  163. */
  164. STATIC FUNCTION ABrowseBlock( a, x )
  165.  
  166.    RETURN ( {|p| IF( PCOUNT() == 0, a[nRow, x], a[nRow, x] := p ) } )
  167.  
  168.  
  169.  
  170. /***
  171. *
  172. *  ASkipTest( <aArray>, <nCurrent>, <nSkip> ) --> nSkipsPossible
  173. *
  174. *  Given array <aArray> whose "current" row is <nCurrent>, determine
  175. *  whether it is possible to "skip" forward or backward by
  176. *  <nSkip> rows
  177. *
  178. *  Parameters:
  179. *     aArray   - The array on which to perform the "skip test"
  180. *     nCurrent - The currently selected array element
  181. *     nSkip    - The requested number of rows to skip, negative numbers
  182. *                meaning to "skip" backwards
  183. *
  184. *  Returns the number of skips actually possible
  185. *
  186. */
  187. STATIC FUNCTION ASkipTest( a, nCurrent, nSkip )
  188.  
  189.    IF ( nCurrent + nSkip < 1 )
  190.  
  191.       // Would skip past the top...
  192.       RETURN ( -nCurrent + 1 )
  193.  
  194.    ELSEIF ( nCurrent + nSkip > LEN( a ) )
  195.  
  196.       // Would skip past the bottom...
  197.       RETURN ( LEN(a) - nCurrent )
  198.  
  199.    END
  200.  
  201.    // No problem
  202.    RETURN ( nSkip )
  203.  
  204.  
  205.  
  206. /***
  207. *
  208. *  ABlock( <cName>, <nSubx> ) --> bABlock
  209. *
  210. *  Create a get/set block for the specified array element
  211. *
  212. *  Parameters:
  213. *     cName - The name of the array variable for which the code block is
  214. *             to be created
  215. *     nSubx - The index into the array which determines the array element
  216. *             to use
  217. *
  218. *  NOTE:
  219. *     cName must be the name of a variable that is visible
  220. *     in macros (i.e. not a LOCAL or STATIC variable). Also, the
  221. *     variable must be visible anywhere where the block is to be
  222. *     used.
  223. *
  224. *     ABlock() may be used to make blocks for a nested array
  225. *     by including a subscript expression as part of cName:
  226. *
  227. *       // to make a set/get block for a[i]
  228. *       b := ABlock( "a", i )
  229. *
  230. *       // to make a set/get block for a[i][j]
  231. *       b :=- ABlock( "a[i]", j )
  232. *
  233. *     This function is provided for compatibility with the
  234. *     version 5.00 Array.prg. See the ABrowseBlock() function
  235. *     (above) for a method of "binding" an array to a block
  236. *     without using a macro.
  237. *
  238. */
  239. FUNCTION ABlock( cName, nSubx )
  240.  
  241. LOCAL cAXpr
  242.  
  243.    cAXpr := cName + "[" + LTRIM( STR( nSubx )) + "]"
  244.  
  245.    RETURN &( "{ |p| IF(PCOUNT()==0, " + cAXpr + "," + cAXpr + ":=p) }" )
  246.  
  247.  
  248.  
  249.  
  250. /***
  251. *           Array utility functions
  252. */
  253.  
  254.  
  255. /***
  256. *
  257. *  AMax( <aArray> ) --> nPos
  258. *
  259. *  Search aArray for the position of its highest numerical value
  260. *
  261. *  Parameter:
  262. *     aArray - The array to be "searched" for the highest value
  263. *
  264. *  Returns: The subscript of the array element with the highest value or
  265. *           zero if an error occurred
  266. *
  267. */
  268. FUNCTION AMax( aArray )
  269.  
  270.    LOCAL nLen        // The length of aArray
  271.    LOCAL nPos        // The position of the highest element
  272.    LOCAL nLastExpr   // The value of the last element
  273.    LOCAL nElement    // Loop counter variable
  274.  
  275.    DO CASE
  276.  
  277.    // The argument is not an array
  278.    CASE VALTYPE( aArray ) <> "A"
  279.       nPos := 0
  280.  
  281.    // The array has no elements
  282.    CASE EMPTY( aArray )
  283.       nPos := 0
  284.  
  285.    // If we made it this far, assume the variable's ok
  286.    OTHERWISE
  287.       
  288.       nLen      := LEN( aArray )
  289.       nPos      := 1
  290.       nLastExpr := aArray[nPos]
  291.       FOR nElement := 2 TO nLen
  292.          IF ( aArray[nElement] > nLastExpr )
  293.             
  294.             // Make this element the current maximum and assign it to
  295.             // nLastExpr for future comparisons
  296.             nPos := nElement
  297.             nLastExpr := aArray[nElement]
  298.  
  299.          ENDIF
  300.       NEXT
  301.  
  302.    ENDCASE
  303.  
  304.    RETURN ( nPos )
  305.  
  306.  
  307. /***
  308. *
  309. *  AMin( <aArray> ) --> nPos
  310. *
  311. *  Search aArray for the position of its lowest numerical value
  312. *
  313. *  Parameter:
  314. *     aArray - The array to be "searched" for the minimum value
  315. *
  316. *  Returns: The subscript of the array element with the minimum value or
  317. *           zero if an error occurred
  318. *
  319. */
  320. FUNCTION AMin( aArray )
  321.  
  322.    LOCAL nLen        // The length of aArray
  323.    LOCAL nPos        // The position of the highest element
  324.    LOCAL nLastExpr   // The value of the last element
  325.    LOCAL nElement    // Loop counter variable
  326.  
  327.    DO CASE
  328.  
  329.    // Argument is not an array
  330.    CASE VALTYPE( aArray ) <> "A"
  331.       nPos := 0
  332.  
  333.    // Array is empty
  334.    CASE EMPTY( aArray )
  335.       nPos := 0
  336.  
  337.    // Assume we're ok
  338.    OTHERWISE
  339.       
  340.       nLen      := LEN( aArray )
  341.       nPos      := 1
  342.       nLastExpr := aArray[nPos]
  343.       FOR nElement := 2 TO nLen
  344.          
  345.          // If this element is less than previous elements, assign it as
  346.          // the current minimum
  347.          IF aArray[nElement] < nLastExpr
  348.             nPos := nElement
  349.             nLastExpr := aArray[nElement]
  350.          ENDIF
  351.  
  352.       NEXT
  353.  
  354.    ENDCASE
  355.  
  356.    RETURN ( nPos )
  357.  
  358.  
  359. /***
  360. *
  361. *  AComp( <aArray>, <bComp> [, <nStart>] [, <nStop>] ) --> xElementValue
  362. *
  363. *  Compare all elements of aArray using the bComp block from nStart to
  364. *  nStop (if specified, otherwise entire array) and return the result.
  365. *
  366. *  Parameters:
  367. *     aArray - Array to be compared
  368. *     bComp  - Code block containing the comparison expression
  369. *     nStart - Optional starting element to compare
  370. *     nStop  - Optional ending element to compare
  371. *
  372. *  NOTE: Several sample blocks are provided in Array.ch.
  373. *
  374. */
  375. FUNCTION AComp( aArray, bComp, nStart, nStop )
  376.    
  377.    LOCAL xVal := aArray[1]    // Value of the element matching the condition
  378.  
  379.    AEVAL(                                                               ;
  380.           aArray,                                                       ;
  381.           {|x| xVal := IF( EVAL( bComp, x, xVal ), x, xVal ) },         ;
  382.           nStart,                                                       ;
  383.           nStop                                                         ;
  384.         )
  385.  
  386.    RETURN( xVal )
  387.  
  388.  
  389. /***
  390. *
  391. *  Dimensions( <aArray> ) --> aDims
  392. *
  393. *  Calculate the dimensions of a multi-dimensional array
  394. *
  395. *  Parameter:
  396. *     aArray - Array to be calculated
  397. *
  398. *  Returns: An array of numeric values describing the dimensions of aArray
  399. *
  400. *  NOTE: Assumes aArray has uniform dimensions (i.e. is not a ragged array)
  401. *
  402. */
  403. FUNCTION Dimensions( aArray )
  404.    
  405.    LOCAL aDims := {}    // Array to contain the dimensions
  406.  
  407.    // We keep "traversing" the array until the first element is NOT an array
  408.    DO WHILE ( VALTYPE( aArray ) == "A" )
  409.       
  410.       // Add the size of this dimension to aDims and use this array's first
  411.       // element as the array for the next iteration of the loop
  412.       AADD( aDims, LEN(aArray) )
  413.       aArray := aArray[1]
  414.  
  415.    ENDDO
  416.  
  417.    RETURN ( aDims )