home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a009 / 6.ddi / SAMPLE.LIF / ARRAY.PRG < prev    next >
Encoding:
Text File  |  1991-04-14  |  7.9 KB  |  332 lines
  1. /***
  2. *  Array.prg
  3. *  Sample array handling functions.
  4. *  Copyright (c) 1990-1991 Nantucket Corp.  All rights reserved.
  5. *
  6. *  NOTE: compile with /n/w/a/m
  7. */
  8.  
  9. #include "Inkey.ch"
  10.  
  11.  
  12. // This static maintains the "current row" for ABrowse()
  13. static nRow
  14.  
  15.  
  16. /***
  17. *  ABrowse( <aArray>, <nTop>, <nLeft>, <nBottom>, <nRight> ) --> value
  18. *
  19. *  Browse a 2-dimensional array using TBrowse object and
  20. *  return the value of the highlighted array element.
  21. *
  22. *  Authors: Jake Jacob & Fleming Ho
  23. */
  24.  
  25. FUNCTION ABrowse( aArray, nT, nL, nB, nR )
  26.  
  27.    LOCAL n, xRet, nOldNRow, nOldCursor  // Various
  28.    LOCAL o                              // TBrowse object
  29.    LOCAL nKey := 0                      // Keystroke holder
  30.  
  31.  
  32.    // Preserve cursor setting, turn off cursor
  33.    nOldCursor := SetCursor( 0 )
  34.  
  35.    // Preserve static var (just in case), set it to 1
  36.    nOldNRow := nRow
  37.    nRow := 1
  38.  
  39.  
  40.    // Handle omitted parameters
  41.    nT := IF( nT == NIL, 0, nT )
  42.    nL := IF( nL == NIL, 0, nL )
  43.    nB := IF( nB == NIL, MAXROW(), nB )
  44.    nR := IF( nR == NIL, MAXCOL(), nR )
  45.  
  46.  
  47.    // Create the TBrowse object
  48.    o := TBrowseNew( nT, nL, nB, nR )
  49.  
  50.    // The "skip" block just adds to (or subtracts from) nRow
  51.    // (see ASkipTest() below)
  52.    o:SkipBlock := { |nSkip|                                             ;
  53.                              nSkip := ASkipTest(aArray, nRow, nSkip),   ;
  54.                              nRow += nSkip,                             ;
  55.                              nSkip                                      ;
  56.                   }
  57.  
  58.    // The "go top" block sets nRow to 1
  59.    o:GoTopBlock := { || nRow := 1 }
  60.  
  61.    // The "go bottom" block sets nRow to the length of the array
  62.    o:GoBottomBlock := { || nRow := LEN(aArray) }
  63.  
  64.    // Create column blocks and add TBColumn objects to the TBrowse
  65.    // (see ABrowseBlock() below)
  66.    FOR n = 1 TO LEN( aArray[1] )
  67.       o:AddColumn( TBColumnNew("", ABrowseBlock(aArray, n)) )
  68.    NEXT
  69.  
  70.  
  71.    // Start the event handler loop
  72.    DO WHILE nKey <> K_ESC .AND. nKey <> K_RETURN
  73.  
  74.       // Stabilize
  75.       nKey := 0
  76.       DO WHILE .NOT. o:Stabilize()
  77.          nKey := INKEY()
  78.          IF nKey <> 0
  79.             EXIT
  80.          ENDIF
  81.       ENDDO
  82.  
  83.       IF nKey == 0
  84.          nKey := INKEY(0)
  85.       ENDIF
  86.  
  87.       // Process the directional keys
  88.       IF o:Stable
  89.  
  90.          DO CASE
  91.          CASE ( nKey == K_DOWN )
  92.             o:Down()
  93.  
  94.          CASE ( nKey == K_UP )
  95.             o:Up()
  96.  
  97.          CASE ( nKey == K_RIGHT )
  98.             o:Right()
  99.  
  100.          CASE ( nKey == K_LEFT )
  101.             o:Left()
  102.  
  103.          CASE ( nKey == K_PGDN )
  104.             o:Right()
  105.             o:Down()
  106.  
  107.          CASE ( nKey == K_PGUP )
  108.             o:Right()
  109.             o:Up()
  110.  
  111.          CASE ( nKey == K_HOME )
  112.             o:Left()
  113.             o:Up()
  114.  
  115.          CASE ( nKey == K_END )
  116.             o:Left()
  117.             o:Down()
  118.  
  119.          ENDCASE
  120.  
  121.       ENDIF
  122.  
  123.    ENDDO
  124.  
  125.  
  126.    // Set return value
  127.    xRet := IF( nKey == K_RETURN, aArray[nRow, o:ColPos], NIL )
  128.  
  129.    // Restore cursor setting
  130.    SetCursor( nOldCursor )
  131.  
  132.    // Restore static var
  133.    nRow := nOldNRow
  134.  
  135.  
  136.    RETURN (xRet)
  137.  
  138.  
  139. /***
  140. *  ABrowseBlock( <a>, <x> ) -> bColumnBlock
  141. *  Service function for ABrowse().
  142. *
  143. *  Return a set/get block for  <a>[nRow, <x>]
  144. *
  145. *  This function works by returning a block that refers
  146. *  to local variables <a> and <x> (the parameters). In
  147. *  version 5.01 these local variables are preserved for
  148. *  use by the block even after the function has returned.
  149. *  The result is that each call to ABrowseBlock() returns
  150. *  a block which has the passed values of <a> and <x> "bound"
  151. *  to it for later use. The block defined here also refers to
  152. *  the static variable nRow, used by ABrowse() to track the
  153. *  array's "current row" while browsing.
  154. */
  155.  
  156. STATIC FUNCTION ABrowseBlock(a, x)
  157.  
  158.    RETURN ( {|p| IF(PCOUNT() == 0, a[nRow, x], a[nRow, x] := p)} )
  159.  
  160.  
  161. /***
  162. *  ASkipTest( <a>, <nCurrent>, <nSkip> ) -> nSkipsPossible
  163. *  Service function for ABrowse().
  164. *
  165. *  Given array <a> whose "current" row is <nCurrent>, determine
  166. *  whether it is possible to "skip" forward or backward by
  167. *  <nSkip> rows. Return the number of skips actually possible.
  168. */
  169.  
  170. STATIC FUNCTION ASkipTest(a, nCurrent, nSkip)
  171.  
  172.    IF ( nCurrent + nSkip < 1 )
  173.       // Would skip past the top...
  174.       RETURN ( -nCurrent + 1 )
  175.  
  176.    ELSEIF ( nCurrent + nSkip > LEN(a) )
  177.       // Would skip past the bottom...
  178.       RETURN ( LEN(a) - nCurrent )
  179.  
  180.    END
  181.  
  182.    // No problem
  183.    RETURN (nSkip)
  184.  
  185.  
  186.  
  187.  
  188. /***
  189. *  ABlock( <cName>, <nSubx> ) -> bABlock
  190. *
  191. *  Given the name of a variable containing an array, and a
  192. *  subscript value, create a set/get block for the specified
  193. *  array element.
  194. *
  195. *  NOTE: cName must be the name of a variable that is visible
  196. *  in macros (i.e. not a LOCAL or STATIC variable). Also, the
  197. *  variable must be visible anywhere where the block is to be
  198. *  used.
  199. *
  200. *  NOTE: ABlock() may be used to make blocks for a nested array
  201. *  by including a subscript expression as part of cName:
  202. *
  203. *      // to make a set/get block for a[i]
  204. *      b := ABlock( "a", i )
  205. *
  206. *      // to make a set/get block for a[i][j]
  207. *      b :=- ABlock( "a[i]", j )
  208. *
  209. *  NOTE: this function is provided for compatibility with the
  210. *  version 5.00 Array.prg. See the ABrowseBlock() function
  211. *  (above) for a method of "binding" an array to a block
  212. *  without using a macro.
  213. *
  214. */
  215.  
  216. FUNCTION ABlock( cName, nSubx )
  217.  
  218. LOCAL cAXpr
  219.  
  220.    cAXpr := cName + "[" + LTRIM(STR(nSubx)) + "]"
  221.  
  222.    RETURN &( "{ |p| IF(PCOUNT()==0, " + cAXpr + "," + cAXpr + ":=p) }" )
  223.  
  224.  
  225. /***
  226. *  AMax( <aArray> ) --> nPos
  227. *  Return the subscript of the array element with the highest value.
  228. */
  229.  
  230. FUNCTION AMax( aArray )
  231.  
  232.    LOCAL nLen, nPos, expLast, nElement
  233.  
  234.  
  235.    DO CASE
  236.  
  237.    // Invalid argument
  238.    CASE VALTYPE( aArray ) <> "A"
  239.       RETURN NIL
  240.  
  241.    // Empty argument
  242.    CASE EMPTY( aArray )
  243.       RETURN 0
  244.  
  245.    OTHERWISE
  246.       nLen := LEN( aArray )
  247.       nPos := 1
  248.       expLast := aArray[1]
  249.       FOR nElement := 2 TO nLen
  250.          IF aArray[nElement] > expLast
  251.             nPos := nElement
  252.             expLast := aArray[nElement]
  253.          ENDIF
  254.       NEXT
  255.  
  256.    ENDCASE
  257.  
  258.    RETURN nPos
  259.  
  260.  
  261. /***
  262. *  AMin( <aArray> ) --> nPos
  263. *  Return the subscript of the array element with the lowest value.
  264. */
  265.  
  266. FUNCTION AMin( aArray )
  267.  
  268.    LOCAL nLen, nPos, expLast, nElement
  269.  
  270.  
  271.    DO CASE
  272.  
  273.    // Invalid argument
  274.    CASE VALTYPE( aArray ) <> "A"
  275.       RETURN NIL
  276.  
  277.    // Empty argument
  278.    CASE EMPTY( aArray )
  279.       RETURN 0
  280.  
  281.    OTHERWISE
  282.       nLen := LEN( aArray )
  283.       nPos := 1
  284.       expLast := aArray[1]
  285.       FOR nElement := 2 TO nLen
  286.          IF aArray[nElement] < expLast
  287.             nPos := nElement
  288.             expLast := aArray[nElement]
  289.          ENDIF
  290.       NEXT
  291.  
  292.    ENDCASE
  293.  
  294.    RETURN nPos
  295.  
  296.  
  297. /***
  298. *  AComp( <aArray>, <bComp>, [<nStart>], [<nStop>] ) --> valueElement
  299. *  Compares all elements of aArray using the bComp block from nStart to
  300. *  nStop (if specified, otherwise entire array) and returns the result.
  301. *  Several sample blocks are provided in Array.ch.
  302. */
  303. FUNCTION AComp( aArray, bComp, nStart, nStop )
  304.    LOCAL value := aArray[1]
  305.  
  306.    AEVAL(                                                               ;
  307.           aArray,                                                       ;
  308.           {|x| value := IF( EVAL(bComp, x, value), x, value )},         ;
  309.           nStart,                                                       ;
  310.           nStop                                                         ;
  311.         )
  312.  
  313.    RETURN( value )
  314.  
  315.  
  316. /***
  317. *  Dimensions( <aArray> ) --> aDims
  318. *  Return an array of numeric values describing the dimensions of a
  319. *  nested or multi-dimensional array, assuming the array has uniform
  320. *  dimensions.
  321. */
  322.  
  323. FUNCTION Dimensions( aArray )
  324.    LOCAL aDims := {}
  325.  
  326.    DO WHILE ( VALTYPE(aArray) == "A" )
  327.       AADD( aDims, LEN(aArray) )
  328.       aArray := aArray[1]
  329.    ENDDO
  330.  
  331.    RETURN (aDims)
  332.