home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / array.prg next >
Text File  |  1992-07-07  |  31KB  |  834 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: ARRAY.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 07/07/1992
  5. *-- Notes.....: These routines deal with filling arrays, sorting arrays, 
  6. *--             and so on ... See README.TXT for details on using this file.
  7. *-------------------------------------------------------------------------------
  8.  
  9. FUNCTION Afill
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Jay Parsons (JPARSONS)
  12. *-- Date........: 04/22/1992
  13. *-- Notes.......: Creates if needed, and fills a row or column of, an array,
  14. *--               with sequential numeric elements starting with nFirst,
  15. *--               increasing by nStep.
  16. *--               Useful for testing routines that require an array ...
  17. *-- Written for.: dBASE IV, 1.1
  18. *-- Rev. History: Original function 03/01/1992.
  19. *--               04/22/92 - Jay Parsons - calling syntax changed
  20. *-- Calls.......: AMASK()              Functon in ARRAY.PRG
  21. *-- Called by...: Any
  22. *-- Usage.......: AFill("<cArrayskel>",<nCount>,<nFirstVal>,<nStep>)
  23. *-- Example.....: lX = AFill("aTest",20,1,10)
  24. *-- Returns.....: .T. (and an array filled with values as in "notes" above)
  25. *-- Parameters..: cArrayskel  = Name of array and optional row/column info
  26. *--               nCount      = number of elements to fill
  27. *--               nFirstVal   = starting value in array
  28. *--               nStep       = number to increment by
  29. *-- Side effects: Creates as public, if needed, and fills array.  Will destroy
  30. *--               existing array of the same name if its dimensions are
  31. *--               inadequate for the data to be filled in.
  32. *-------------------------------------------------------------------------------
  33.  
  34.    parameters cArrayskel, nCount, nFirstval, nStep
  35.    private nAt, cArray, cMask, cElem, nRows, nCols, nFill
  36.    cArray = cArrayskel
  37.    if "[" $ cArray
  38.       cArray = left( cArray, at( "[", cArray ) - 1 )
  39.    endif
  40.    cArray = trim( ltrim( cArray ) )
  41.    cMask = Amask( cArrayskel, "nAt" )
  42.    if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
  43.       nRows = val( substr( cMask, at( "[", cMask ) + 1 ) )
  44.       nCols = nCount
  45.    else
  46.       nRows = nCount
  47.       nCols = val( substr( cMask, at( ",", cMask ) + 1 ) )
  48.    endif
  49.    nAt = nCount
  50.    cElem = cArray + cMask
  51.    if type( cElem ) = "U"
  52.       release &cArray
  53.       public &cArray
  54.       if nCols > 0
  55.          declare &cArray[ nRows, nCols ]
  56.       else
  57.          declare &cArray[ nRows ]
  58.       endif
  59.    endif
  60.    nFill = nFirstval
  61.    nAt = 0
  62.    do while nAt < nCount
  63.       nAt = nAt + 1
  64.       cElem = cArray + cMask
  65.       store nFill to &cElem
  66.       nFill = nFill + nStep
  67.    enddo
  68.     
  69. RETURN .T.
  70. *-- EoF: Afill()
  71.  
  72. FUNCTION Amask
  73. *-------------------------------------------------------------------------------
  74. *-- Programmer..: Jay Parsons (Jparsons)
  75. *-- Date........: 04/21/1992
  76. *-- Notes.......: Returns a "mask" specifying the desired row or column of
  77. *--               an array.
  78. *-- Written for.: dBASE IV
  79. *-- Rev. History: None
  80. *-- Calls       : None
  81. *-- Called by...: Any
  82. *-- Usage.......: Amask( <cArrayskel>, <cVar> )
  83. *-- Example.....: ? Amask( "Myarray [ , 1 ]", "nAt" )
  84. *-- Returns     : a character value including a passed character string,
  85. *--               which may be used by the calling function to locate array
  86. *--               elements
  87. *-- Parameters..: cArrayskel, a character string including the name of the
  88. *--               array and, if the row or column to be used is not the
  89. *--               first row (or only row if array is one-dimensional),
  90. *--               a bracketed expression with a number indicating the row,
  91. *-                or column if the number is preceded by a comma, to be used.
  92. *--               cVar, name of the memvar to be used by calling function.
  93. *-------------------------------------------------------------------------------
  94.  
  95.    parameters cArrayskel, cVar
  96.    private nAt, cWhich, cMask, cV
  97.    nAt = at( "[", cArrayskel )
  98.    cWhich = "0 ]"
  99.    cV = trim( ltrim( cVar ) )
  100.    if nAt > 0
  101.       cWhich = substr( cArrayskel, nAt + 1 )
  102.    else
  103.       cWhich = "1 ]"
  104.    endif
  105.    if .not. "," $ cArrayskel
  106.       cMask = "[ " + cV + " ]"
  107.    else
  108.       if val( cWhich ) > 0
  109.          cMask = "["+ ltrim( str( val( cWhich ) ) ) + "," + cV + "]"
  110.       else
  111.          cWhich = substr( cWhich, at( ",", cWhich ) + 1 )
  112.          cMask = "[" + cV+ ","+ ltrim( str( val( cWhich ) ) ) + "]"
  113.       endif
  114.    endif
  115.  
  116. RETURN cMask
  117. *-- EoF: Amask()
  118.  
  119. FUNCTION Amean
  120. *-------------------------------------------------------------------------------
  121. *-- Programmer..: Jay Parsons (Jparsons)
  122. *-- Date........: 04/13/1992
  123. *-- Notes.......: Mean of non-blank numeric or date values in specified row
  124. *--             : or column of a specified array.  If the first value is a
  125. *--             : date, averages only dates.  If first value is numeric or
  126. *--             : float, averages only numerics and floats.  Exits returning
  127. *--             : .F. if first value is character or logical, if specified
  128. *--             : row or column does not exist or if there are no
  129. *--             : averageable values.
  130. *--             :
  131. *-- Written for.: dBASE IV Version 1.5.
  132. *-- Rev. History: Original function written 1990
  133. *--             : Adapted to Version 1.5 4/13/1992
  134. *-- Calls       : AMASK()              Function in ARRAY.PRG
  135. *-- Called by...: Any
  136. *-- Usage.......: Amean( <cArrayskel> )
  137. *-- Example.....: ? Amean( "Myarray [ , 1 ]" )
  138. *-- Returns     : a numeric, float or date value, the mean or average, or .F.
  139. *--             : If any of the averaged items are floats, the result will be.
  140. *-- Parameters..: cArrayskel, a character string including the name of the
  141. *--             : array and, if the row or column to be averaged is not the
  142. *--             : first row, a bracketed expression with a number indicating
  143. *--             : the row, or column if the number is preceded by a comma,
  144. *--             : to be averaged.
  145. *-------------------------------------------------------------------------------
  146.  
  147.    parameters cArrayskel
  148.    private nAt,cArray,cMask,cElem,nTot,nCount,xNext,cOktype
  149.    cArray = cArrayskel
  150.    if "[" $ cArray
  151.       cArray = left( cArray, at( "[", cArray ) - 1 )
  152.    endif
  153.    cArray = trim( ltrim( cArray ) )
  154.    cMask = Amask( cArrayskel, "nAt" )
  155.    store 0 to nTot, nCount, nAt
  156.    do while .t.
  157.       nAt = nAt + 1
  158.       cElem = cArray + cMask
  159.       xNext = type( cElem )
  160.       do case
  161.          case xNext = "U"
  162.             exit
  163.          case nAt = 1
  164.             if xNext $ "CL"
  165.                exit
  166.             else
  167.                cOktype = iif( xNext = "D", "D", "NF" )
  168.             endif
  169.          case .not. xNext $ cOktype
  170.             loop
  171.       endcase
  172.       xNext = &cElem
  173.       if isblank( xNext )
  174.          loop
  175.       endif
  176.       if cOktype = "D"
  177.          xNext = xNext - {01/01/01}
  178.       endif
  179.       nTot = nTot + xNext
  180.       nCount = nCount + 1
  181.    enddo
  182.  
  183. RETURN iif( nCount = 0, .F., nTot / nCount ;
  184.      + iif( cOktype = "D", {01/01/01}, 0 ) )
  185. *-- EoF: Amean()
  186.  
  187. FUNCTION Amax
  188. *-------------------------------------------------------------------------------
  189. *-- Programmer..: Jay Parsons (Jparsons)
  190. *-- Date........: 04/13/1992
  191. *-- Notes.......: Finds maximum non-blank numeric, date or character value in
  192. *--             : specified row or column of a specified array.  If the first
  193. *--             : value is character or date, considers only that type.
  194. *--             : If first value is numeric or float, considers only numerics
  195. *--             : and floats.  Exits returning .F. if first value is logical,
  196. *--             : if specified row or column does not exist or if there are no
  197. *               : numeric, date or character values in the row or column.
  198. *--             :
  199. *-- Written for.: dBASE IV Version 1.5.
  200. *-- Rev. History: Original function written 1990
  201. *--             : Adapted to Version 1.5 4/13/1992
  202. *-- Calls       : AMASK()              Function in ARRAY.PRG
  203. *-- Called by...: Any
  204. *-- Usage.......: Amax( <cArrayskel> )
  205. *-- Example.....: ? Amax( "Myarray [ , 1 ]" )
  206. *-- Returns     : a char, numeric, float or date value, the maximum, or .F.
  207. *--             : If any of the numeric items are floats, the result will be.
  208. *-- Parameters..: cArrayskel, a character string including the name of the
  209. *--             : array and, if the row or column to be used is not the
  210. *--             : first row, a bracketed expression with a number indicating
  211. *--             : the row, or column if the number is preceded by a comma,
  212. *--             : to be used.
  213. *-------------------------------------------------------------------------------
  214.  
  215.    parameters cArrayskel
  216.    private nAt,cArray,cMask,cElem,xMax,xNext,cOktype
  217.    cArray = cArrayskel
  218.    if "[" $ cArray
  219.       cArray = left( cArray, at( "[", cArray ) - 1 )
  220.    endif
  221.    cArray = trim( ltrim( cArray ) )
  222.    cMask = Amask( cArrayskel, "nAt" )
  223.    store 0 to nAt
  224.    do while .T.
  225.       nAt = nAt + 1
  226.       cElem = cArray + cMask
  227.       xNext = type( cElem )
  228.       do case
  229.          case xNext = "U"
  230.             exit
  231.          case nAt = 1
  232.             if xNext ="L"
  233.                exit
  234.             else
  235.                cOktype = iif( xNext $ "CD", xNext, "NF" )
  236.             endif
  237.          case .not. xNext $ cOktype
  238.             loop
  239.       endcase
  240.       xNext = &cElem
  241.       if cOktype # "C" .and. isblank( xNext )
  242.          loop
  243.       endif
  244.       if nAt = 1
  245.          xMax = xNext
  246.       else
  247.          xMax = max( xMax, xNext )
  248.       endif
  249.    enddo
  250.  
  251. RETURN iif( type( "xMax" ) = "U", .F., xMax )
  252. *-- EoF: Amax()
  253.  
  254. FUNCTION Amin
  255. *-------------------------------------------------------------------------------
  256. *-- Programmer..: Jay Parsons (Jparsons)
  257. *-- Date........: 04/13/1992
  258. *-- Notes.......: Finds minimum non-blank numeric, date or character value in
  259. *--             : specified row or column of a specified array.  If the first
  260. *--             : value is character or date, considers only that type.
  261. *--             : If first value is numeric or float, considers only numerics
  262. *--             : and floats.  Exits returning .F. if first value is logical,
  263. *--             : if specified row or column does not exist or if there are no
  264. *               : numeric, date or character values in the row or column.
  265. *--             :
  266. *-- Written for.: dBASE IV Version 1.5.
  267. *-- Rev. History: Original function written 1990
  268. *--             : Adapted to Version 1.5 4/13/1992
  269. *-- Calls       : AMASK()                 Function in ARRAY.PRG
  270. *-- Called by...: Any
  271. *-- Usage.......: Amin( <cArrayskel> )
  272. *-- Example.....: ? Amin( "Myarray [ , 1 ]" )
  273. *-- Returns     : a char, numeric, float or date value, the minimum, or .F.
  274. *--             : If any of the numeric items are floats, the result will be.
  275. *-- Parameters..: cArrayskel, a character string including the name of the
  276. *--             : array and, if the row or column to be used is not the
  277. *--             : first row, a bracketed expression with a number indicating
  278. *--             : the row, or column if the number is preceded by a comma,
  279. *--             : to be used.
  280. *-------------------------------------------------------------------------------
  281.  
  282.    parameters cArrayskel
  283.    private nAt,cArray,cMask,cElem,xMin,xNext,cOktype
  284.    cArray = cArrayskel
  285.    if "[" $ cArray
  286.       cArray = left( cArray, at( "[", cArray ) - 1 )
  287.    endif
  288.    cArray = trim( ltrim( cArray ) )
  289.    cMask = Amask( cArrayskel, "nAt" )
  290.    store 0 to nAt
  291.    do while .T.
  292.       nAt = nAt + 1
  293.       cElem = cArray + cMask
  294.       xNext = type( cElem )
  295.       do case
  296.          case xNext = "U"
  297.             exit
  298.          case nAt = 1
  299.             if xNext ="L"
  300.                exit
  301.             else
  302.                cOktype = iif( xNext $ "CD", xNext, "NF" )
  303.             endif
  304.          case .not. xNext $ cOktype
  305.             loop
  306.       endcase
  307.       xNext = &cElem
  308.       if cOktype # "C" .and. isblank( xNext )
  309.          loop
  310.       endif
  311.       if nAt = 1
  312.          xMin = xNext
  313.       else
  314.          xMin = min( xMin, xNext )
  315.       endif
  316.    enddo
  317.  
  318. RETURN iif( type( "xMin" ) = "U", .F., xMin )
  319. *-- EoF: Amin()
  320.  
  321. FUNCTION Avar
  322. *-------------------------------------------------------------------------------
  323. *-- Programmer..: Jay Parsons (Jparsons)
  324. *-- Date........: 04/13/1992
  325. *-- Notes.......: Finds population variance of non-blank numeric or date values
  326. *--             : in specified row or column of a specified array.  If first
  327. *--             : value is date, considers only that type.
  328. *--             : If first value is numeric or float, considers only numerics
  329. *--             : and floats.  Exits returning .F. if first value is character
  330. *--             : or logical, if specified row or column does not exist or if
  331. *--             : there are no numeric or date values in the row or column.
  332. *--             :
  333. *--             : To adapt this to find the sample variance, substitute
  334. *--             : "( nCount - 1 )" for the final "nCount" in the last line.
  335. *--             :
  336. *-- Written for.: dBASE IV Version 1.5.
  337. *-- Rev. History: Original function written 1990
  338. *--             : Adapted to Version 1.5 4/13/1992
  339. *-- Calls       : AMASK()                 Function in ARRAY.PRG
  340. *-- Called by...: Any
  341. *-- Usage.......: Avar( <cArrayskel> )
  342. *-- Example.....: ? Avar( "Myarray [ , 1 ]" )
  343. *-- Returns     : a numeric, or float value, the variance, or .F.
  344. *--             : If any of the numeric items are floats, the result will be.
  345. *-- Parameters..: cArrayskel, a character string including the name of the
  346. *--             : array and, if the row or column to be used is not the
  347. *--             : first row, a bracketed expression with a number indicating
  348. *--             : the row, or column if the number is preceded by a comma,
  349. *--             : to be used.
  350. *-------------------------------------------------------------------------------
  351.  
  352.    parameters cArrayskel
  353.    private nAt,cArray,cMask,cElem,nCount,nTot,nTotsq,xNext,cOktype
  354.    cArray = cArrayskel
  355.    if "[" $ cArray
  356.       cArray = left( cArray, at( "[", cArray ) - 1 )
  357.    endif
  358.    cArray = trim( ltrim( cArray ) )
  359.    cMask = Amask( cArrayskel, "nAt" )
  360.    store 0 to nTot, nTotsq, nCount, nAt
  361.    do while .t.
  362.       nAt = nAt + 1
  363.       cElem = cArray + cMask
  364.       xNext = type( cElem )
  365.       do case
  366.          case xNext = "U"
  367.             exit
  368.          case nAt = 1
  369.             if xNext $ "CL"
  370.                exit
  371.             else
  372.                cOktype = iif( xNext = "D", "D", "NF" )
  373.             endif
  374.          case .not. xNext $ cOktype
  375.             loop
  376.       endcase
  377.       xNext = &cElem
  378.       if isblank( xNext )
  379.          loop
  380.       endif
  381.       if cOktype = "D"
  382.          xNext = xNext - {01/01/01}
  383.       endif
  384.       nTot = nTot + xNext
  385.       nTotsq = nTotsq + xNext * xNext
  386.       nCount = nCount + 1
  387.    enddo
  388.  
  389. RETURN iif( nCount = 0, .F., ( nTotsq - nTot * nTot / nCount ) / nCount )
  390. *-- EoF: Avar()
  391.  
  392. FUNCTION Aseek
  393. *-------------------------------------------------------------------------------
  394. *-- Programmer..: Jay Parsons (JPARSONS)
  395. *-- Date........: 04/21/1992
  396. *-- Notes.......: Binary search of an array for an element of which the
  397. *--               value is Finditem (could be character, numeric or date,
  398. *--               but of course types of all elements must match).  Works
  399. *--               only if array is sorted ascending.  Element found is
  400. *--               not necessarily the first that matches the value sought.
  401. *--               To use with array sorted descending, change ">" to "<"
  402. *--               in the remarked line.
  403. *-- Written for.: dBASE IV, 1.1
  404. *-- Rev. History: 03/01/1992 - original function.
  405. *--               04/21/1992 - Jay Parsons - calling syntax changed
  406. *-- Calls.......: AMASK()           Function in ARRAY.PRG
  407. *-- Called by...: Any
  408. *-- Usage.......: Aseek(<cArrayskel>,<xFindItem> )
  409. *-- Example.....: nIndex = Aseek("MyArray [ ,2 ], {01/15/89} )
  410. *-- Returns.....: numeric ( index to place in array where item exists, or 0 )
  411. *-- Parameters..: cArrayskel = name of array and optional row/column info
  412. *--               xFindItem  = Item to look for in array
  413. *--                            Must be same TYPE as item in array looked for.
  414. *--                            Numerics are NOT the same as floats for this one.
  415. *-------------------------------------------------------------------------------
  416.  
  417.    parameters cArrayskel, xFinditem
  418.    private cArray, cMask, cElem, nHi, nLo, nTrial, cOktype
  419.    cArray = cArrayskel
  420.    if "[" $ cArray
  421.       cArray = left( cArray, at( "[", cArray ) - 1 )
  422.    endif
  423.    cArray = trim( ltrim( cArray ) )
  424.    cMask = Amask( cArrayskel, "nTrial" )
  425.    cOktype = type( "xFinditem" )
  426.    nLo = 1
  427.    nHi = 1170
  428.    do while .t.
  429.       if nHi < nLo
  430.          nTrial = 0
  431.          exit
  432.       else
  433.          nTrial = int( ( nHi + nLo ) / 2 )
  434.       endif
  435.       cElem = cArray + cMask
  436.       xNext = type( cElem )
  437.       do case
  438.          case xNext = "U"
  439.             nHi = nTrial - 1
  440.          case .not. xNext $ cOktype
  441.             nTrial = 0
  442.             exit
  443.          otherwise
  444.             xNext = &cElem
  445.             do case
  446.                case xNext = xFinditem
  447.                   exit
  448.                case xNext > xFinditem   && see notes
  449.                   nHi = nTrial - 1
  450.                otherwise
  451.                   nLo = nTrial + 1
  452.             endcase
  453.       endcase
  454.    enddo
  455.  
  456. RETURN nTrial
  457. *-- EoF: Aseek
  458.  
  459. FUNCTION Ashuffle
  460. *-------------------------------------------------------------------------------
  461. *-- Programmer..: Jay Parsons (JPARSONS)
  462. *-- Date........: 03/01/1992
  463. *-- Notes.......: Random shuffle of elements of an array
  464. *-- Written for.: dBASE IV, 1.1
  465. *-- Rev. History: None
  466. *-- Calls.......: Amask()           Function in ARRAY.PRG
  467. *--               Arrayrows()       Function in ARRAY.PRG
  468. *--               Arraycols()       Function in ARRAY.PRG
  469. *-- Called by...: Any
  470. *-- Usage.......: AShuffle( "<cArrayskel>" )
  471. *-- Example.....: lX = AShuffle( "aTest[ ,2]" )
  472. *-- Returns.....: .T.
  473. *-- Parameters..: cArrayskel = Name of array, optional row/column designator
  474. *-- Side effects: Rearranges elements of the array
  475. *--               Reseeds random number generator and uses some random numbers
  476. *-------------------------------------------------------------------------------
  477.  
  478.    parameters cArrayskel
  479.    private cArray, cMask, cElem, cElem, nAt, nRand, nLeft, x1, x2
  480.    cArray = cArrayskel
  481.    if "[" $ cArray
  482.       cArray = left( cArray, at( "[", cArray ) - 1 )
  483.    endif
  484.    cArray = trim( ltrim( cArray ) )
  485.    cMask = Amask( cArrayskel, "nAt" )
  486.    if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
  487.       nLeft = Arraycols( cArray )
  488.    else
  489.       nLeft = Arrayrows( cArray )
  490.    endif
  491.    nRand =  rand( -1 )
  492.    do while nLeft > 1
  493.       nAt = nLeft
  494.       cElem = cArray + cMask
  495.       x1 = &cElem
  496.       nAt = int( rand() * nLeft ) + 1
  497.       cElem = cArray + cMask
  498.       x2 = &cElem
  499.       store x1 to &cElem
  500.       nAt = nLeft
  501.       cElem = cArray + cMask
  502.       store x2 to &cElem
  503.       nLeft = nLeft - 1
  504.    enddo
  505.  
  506. RETURN .T.
  507. *-- EoF: Ashuffle()
  508.  
  509. FUNCTION Abubble
  510. *-------------------------------------------------------------------------------
  511. *-- Programmer..: Jay Parsons (JPARSONS)
  512. *-- Date........: 04/21/1992
  513. *-- Notes.......: Bubble sort.  This is a slow algorithm, made slower by 
  514. *--               passing the array name as a parameter instead of copying 
  515. *--               the array to one of predefined name.  Its primary use is in 
  516. *--               selecting a few of the highest or lowest values from a longer
  517. *--               list.  The argument "nPasses" gives the number of values
  518. *--               guaranteed to be in their correct places, in this case the 
  519. *--               lowest values, at the head of the list. Values at other
  520. *--               places in the list may not have been sorted.
  521. *--               Note: To place the highest values at the head of
  522. *--               the list, change > to < in the remarked line.
  523. *--               What use is it?  Well, a golf handicap is based on
  524. *--               the lowest 10 score differentials of the last 20.
  525. *--               This is the easy way to select them.  Other applications
  526. *--               include selecting a few invidividuals from a large number
  527. *--               of candidates based on some numeric expression.
  528. *-- Written for.: dBASE IV, 1.1, 1.5
  529. *-- Rev. History: None
  530. *-- Calls.......: AMASK()           Function in ARRAY.PRG
  531. *--               Arraycols()       Function in ARRAY.PRG
  532. *--               Arrayrows()       Function in ARRAY.PRG
  533. *-- Called by...: Any
  534. *-- Usage.......: BubbleSort("<cArrayskel>" [,<nPass>] )
  535. *-- Example.....: lX = BubbleSort("Test [1,]",10)
  536. *-- Returns.....: .T.
  537. *-- Parameters..: cArrayskel = Name of array, optional row/column designator
  538. *--               nPasses    = number of passes. If you want a complete sort,
  539. *--                            set this value to the same as length of array,
  540. *--                            or omit it in 1.5.
  541. *-- Side effects: Rearranges elements of the array
  542. *-------------------------------------------------------------------------------
  543.  
  544.    parameters cArrayskel, nPasses
  545.    private nJ, nAt, cArray, cMask, cElem, x1, x2, nP, nPasses, lSwitch, nOld, nNew
  546.    cArray = cArrayskel
  547.    if "[" $ cArray
  548.       cArray = left( cArray, at( "[", cArray ) - 1 )
  549.    endif
  550.    cArray = trim( ltrim( cArray ) )
  551.    cMask = Amask( cArrayskel, "nAt" )
  552.    if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
  553.       nJ = Arraycols( cArray )
  554.    else
  555.       nJ = Arrayrows( cArray )
  556.    endif
  557.    if val( substr( version(), 9, 5 ) ) < 1.5 .or. pcount() > 1
  558.       nP = min( nPasses, nJ )
  559.    else
  560.       nP = nJ
  561.    endif
  562.    nPass = 1
  563.    do while nPass <= nP
  564.       lSwitch = .F.
  565.       nOld = nJ
  566.       do while .t.
  567.          cElem = cArray + cMask
  568.          nAt = nOld
  569.          x1 = &cElem
  570.          do while .t.
  571.             nNew = nOld - 1
  572.             if nNew < nPass
  573.                exit
  574.             endif
  575.             nAt = nNew
  576.             cElem = cArray + cMask
  577.             x2 = &cElem
  578.             if x1 < x2        && see notes
  579.                lSwitch = .T.
  580.                nAt = nOld
  581.                cElem = cArray + cMask
  582.                store x2 to &cElem
  583.                nOld = nNew
  584.             else
  585.                exit
  586.             endif
  587.          enddo
  588.          nAt = nOld
  589.          cElem = cArray + cMask
  590.          store x1 to &cElem
  591.          nOld = nNew
  592.          if nOld <= nPass
  593.             exit
  594.          endif
  595.       enddo
  596.       if .not. lSwitch
  597.          exit
  598.       endif
  599.       nPass = nPass + 1
  600.    enddo
  601.     
  602. RETURN .T.
  603. *-- EoF: Abubble()
  604.  
  605. FUNCTION ArrayRows
  606. *-------------------------------------------------------------------------------
  607. *-- Programmer..: Jay Parsons (JPARSONS)
  608. *-- Date........: 03/01/1992
  609. *-- Notes.......: Number of Rows in an array
  610. *-- Written for.: dBASE IV, 1.1
  611. *-- Rev. History: None
  612. *-- Calls.......: None
  613. *-- Called by...: Any
  614. *-- Usage.......: ArrayRows("<aArray>")
  615. *-- Example.....: n = ArrayRows("aTest")
  616. *-- Returns.....: numeric
  617. *-- Parameters..: aArray      = Name of array 
  618. *-------------------------------------------------------------------------------
  619.  
  620.     parameters aArray
  621.     private nHi, nLo, nTrial, nDims
  622.     nLo = 1
  623.     nHi = 1170
  624.     if type( "&aArray[ 1, 1 ]" ) = "U"
  625.       nDims = 1
  626.     else
  627.      nDims = 2
  628.     endif
  629.     do while .T.
  630.      nTrial = int( ( nHi + nLo ) / 2 )
  631.       if nHi < nLo
  632.         exit
  633.       endif
  634.      if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ;
  635.        nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U"
  636.         nHi = nTrial - 1
  637.       else
  638.         nLo = nTrial + 1
  639.       endif
  640.     enddo
  641.     
  642. RETURN nTrial
  643. *-- EoF: ArrayRows()
  644.  
  645. FUNCTION ArrayCols
  646. *-------------------------------------------------------------------------------
  647. *-- Programmer..: Jay Parsons (JPARSONS)
  648. *-- Date........: 03/01/1992
  649. *-- Notes.......: Number of Columns in an array
  650. *-- Written for.: dBASE IV, 1.1
  651. *-- Rev. History: None
  652. *-- Calls.......: None
  653. *-- Called by...: Any
  654. *-- Usage.......: ArrayCols("<aArray>")
  655. *-- Example.....: n = ArrayCols("aTest")
  656. *-- Returns.....: numeric
  657. *-- Parameters..: aArray      = Name of array 
  658. *-------------------------------------------------------------------------------
  659.  
  660.     parameters aArray
  661.    private nHi, nLo, nTrial
  662.     nLo = 1
  663.     nHi = 1170
  664.     if type( "&aArray[ 1, 1 ]" ) = "U"
  665.       RETURN 0
  666.     endif
  667.     do while .t.
  668.       nTrial = int( ( nHi + nLo ) / 2 )
  669.       if nHi < nLo
  670.          exit
  671.       endif
  672.       if type( "&aArray[ 1, nTrial ]" ) = "U"
  673.         nHi = nTrial - 1
  674.       else
  675.         nLo = nTrial + 1
  676.       endif
  677.     enddo
  678.  
  679. RETURN nTrial
  680. *-- EoF: ArrayCol()
  681.                                    
  682. FUNCTION ShellSort
  683. *-------------------------------------------------------------------------------
  684. *-- Programmer..: Jay Parsons (JPARSONS)
  685. *-- Date........: 03/01/1992
  686. *-- Notes.......: Sort aMyarray[] elements 1 to Number, ascending
  687. *--               Note: change < to > in the remarked line for
  688. *--               a descending sort.
  689. *--               This routine depends on the elements being copied
  690. *--               into the array "aMyarray" before the sort.  It could,
  691. *--               like the other array functions, accept the name of
  692. *--               the array as a parameter and use it as a macro within,
  693. *--               but performance will be very slow in that case.
  694. *-- Written for.: dBASE IV, 1.1
  695. *-- Rev. History: None
  696. *-- Calls.......: None
  697. *-- Called by...: Any
  698. *-- Usage.......: ShellSort(<nNumber>)
  699. *-- Example.....: lX = ShellSort(532)
  700. *-- Returns.....: .T.
  701. *-- Parameters..: nNumber    = Size of array (# of elements)
  702. *-------------------------------------------------------------------------------
  703.  
  704.     parameters nNumber
  705.     private nInterval, nPlace, nI, nJ, xTemp
  706.     nInterval = nNumber
  707.     do while nInterval > 0
  708.       nInterval = int( nInterval / 2 )
  709.       nPlace = 1
  710.       do while .T.
  711.         nI = nPlace
  712.         nJ = nI + nInterval
  713.         if nJ > nNumber
  714.           exit
  715.         endif
  716.         xTemp = aMyarray[ nJ, 1 ]
  717.         do while xTemp < aMyarray[ nI, 1 ]  && see note
  718.           aMyarray[ nJ,1 ] = aMyarray[ nI, 1 ]
  719.           nJ = nI
  720.           nI = nI - nInterval
  721.           if nI < 1
  722.             exit
  723.           endif
  724.         enddo
  725.         aMyarray[ nJ, 1 ] = xTemp
  726.         nPlace = nPlace + 1
  727.       enddo
  728.     enddo
  729.  
  730. RETURN .T.
  731. *-- EoF: ShellSort()
  732.  
  733. FUNCTION Arec2Arr
  734. *-------------------------------------------------------------------------------
  735. *-- Programmer..: Bowen Moursund (BOWEN)
  736. *-- Date........: 05/01/1992
  737. *-- Notes.......: Creates a public array, aRecord[n], initialized to the
  738. *--               record format of the currently selected DBF, either blank or
  739. *--               filled with the values of the current record. Memo fields
  740. *--               cannot be copied to an array.
  741. *-- Written for.: dBASE IV v1.5
  742. *-- Rev. History: None
  743. *-- Calls.......: None
  744. *-- Called by...: Any
  745. *-- Usage.......: Arec2Arr(<lBlank>)
  746. *-- Example.....: lSuccess = Arec2Arr(.T.)
  747. *-- Returns.....: .T. if succesful, .F. if not.
  748. *-- Parameters..: lBlank = whether or not to create an empty array.
  749. *--                        .T. = blank
  750. *--                        .F. = current record values
  751. *-- Side effects: Creates a public array, aRecord[n]. It will destroy
  752. *--               an existing array of that name.
  753. *-------------------------------------------------------------------------------
  754.  
  755.     parameters lBlank
  756.     private lSuccess,lDbf,cFieldName,nFieldNumb,nNumFields
  757.     lSuccess = .f.
  758.     lDbf = ( "" # dbf() )
  759.     if ((lDbf .and. lBlank) .or. (.not. lBlank .and. lDbf .and. .not. eof()))
  760.         release aRecord
  761.         nNumFields = fldcount()
  762.         public array aRecord[nNumFields]
  763.         if lBlank
  764.             goto bottom
  765.             skip         && phantom record
  766.             nFieldNumb=1
  767.             do while nFieldNumb <= nNumFields
  768.                 cFieldName = field(nFieldNumb)
  769.                 aRecord[nFieldNumb] = &cFieldName.
  770.                 nFieldNumb = nFieldNumb + 1
  771.             enddo
  772.         else
  773.             copy to array aRecord next 1
  774.         endif
  775.         lSuccess = .t.
  776.     endif
  777.  
  778. RETURN lSuccess
  779. *-- EoF: Arec2Arr()
  780.  
  781. FUNCTION aPullSort
  782. *-------------------------------------------------------------------------------
  783. *-- Programmer..: Kelvin Smith (KELVIN)
  784. *-- Date........: 05/07/1992
  785. *-- Notes.......: Sort aMyarray[] elements 1 to Number, ascending
  786. *--                 Note: change > to < in the remarked line for
  787. *--               a descending sort.
  788. *--               This sorting algorithm, while not as fast as a shell
  789. *--               sort, is fairly simple to understand and considerably
  790. *--               faster than the infamous bubble sort.  Each iteration
  791. *--               pulls the next item in order to the front of the unsorted
  792. *--               portion of the list.
  793. *--                 This routine depends on the elements being copied
  794. *--               into the array "aMyarray" before the sort.  It could,
  795. *--               like the other array functions, accept the name of
  796. *--               the array as a parameter and use it as a macro within,
  797. *--               but performance will be very slow in that case.
  798. *-- Written for.: dBASE IV, 1.5
  799. *-- Rev. History: None
  800. *-- Calls.......: None
  801. *-- Called by...: Any
  802. *-- Usage.......: APullSort(<nNumber>)
  803. *-- Example.....: lX = APullSort(532)
  804. *-- Returns.....: .T.
  805. *-- Parameters..: nNumber    = Size of array (# of elements)
  806. *-------------------------------------------------------------------------------
  807.  
  808.     parameters nNumber
  809.     private nI, nJ, nSwap, xTemp
  810.     nI = 1
  811.     do while nI < nNumber                   && Through the list
  812.        nSwap = nI
  813.        nJ = nI + 1
  814.        do while nJ <= nNumber               && From nI to end of list
  815.           if aMyarray[nSwap] > aMyarray[nJ]    && see note
  816.              nSwap = nJ                     && Item at nJ is smaller
  817.           endif
  818.           nJ = nJ + 1
  819.        enddo
  820.        if nSwap <> nI                       && Found a smaller one
  821.           xTemp = aMyarray[nSwap]           && Swap it
  822.           aMyarray[nSwap] = aMyarray[nI]
  823.           aMyarray[nI] = xTemp
  824.        endif
  825.        nI = nI + 1
  826.     enddo
  827.  
  828. RETURN .T.
  829. *-- EoF: APullSort()
  830.  
  831. *-------------------------------------------------------------------------------
  832. *-- EoP: ARRAY.PRG
  833. *-------------------------------------------------------------------------------
  834.