home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
progmisc
/
dblib201.zip
/
ARRAY.PRG
next >
Wrap
Text File
|
1993-03-29
|
32KB
|
834 lines
*-------------------------------------------------------------------------------
*-- Program...: ARRAY.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 03/29/1993
*-- Notes.....: These routines deal with filling arrays, sorting arrays,
*-- and so on ... See README.TXT for details on using this file.
*-------------------------------------------------------------------------------
FUNCTION Afill
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/22/1992
*-- Notes.......: Creates if needed, and fills a row or column of, an array,
*-- with sequential numeric elements starting with nFirst,
*-- increasing by nStep.
*-- Useful for testing routines that require an array ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 -- Original Release
*-- 04/22/1992 - Jay Parsons - calling syntax changed
*-- Calls.......: AMASK() Functon in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: AFill("<cArrayskel>",<nCount>,<nFirstVal>,<nStep>)
*-- Example.....: lX = AFill("aTest",20,1,10)
*-- Returns.....: .T. (and an array filled with values as in "notes" above)
*-- Parameters..: cArrayskel = Name of array and optional row/column info
*-- nCount = number of elements to fill
*-- nFirstVal = starting value in array
*-- nStep = number to increment by
*-- Side effects: Creates as public, if needed, and fills array. Will destroy
*-- existing array of the same name if its dimensions are
*-- inadequate for the data to be filled in.
*-------------------------------------------------------------------------------
parameters cArrayskel, nCount, nFirstval, nStep
private nAt, cArray, cMask, cElem, nRows, nCols, nFill
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nAt" )
if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
nRows = val( substr( cMask, at( "[", cMask ) + 1 ) )
nCols = nCount
else
nRows = nCount
nCols = val( substr( cMask, at( ",", cMask ) + 1 ) )
endif
nAt = nCount
cElem = cArray + cMask
if type( cElem ) = "U"
release &cArray
public &cArray
if nCols > 0
declare &cArray[ nRows, nCols ]
else
declare &cArray[ nRows ]
endif
endif
nFill = nFirstval
nAt = 0
do while nAt < nCount
nAt = nAt + 1
cElem = cArray + cMask
store nFill to &cElem
nFill = nFill + nStep
enddo
RETURN .T.
*-- EoF: Afill()
FUNCTION Amask
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/21/1992
*-- Notes.......: Returns a "mask" specifying the desired row or column of
*-- an array.
*-- Written for.: dBASE IV
*-- Rev. History: 04/21/1992 -- Original Release
*-- Calls : None
*-- Called by...: Any
*-- Usage.......: Amask( <cArrayskel>, <cVar> )
*-- Example.....: ? Amask( "Myarray [ , 1 ]", "nAt" )
*-- Returns : a character value including a passed character string,
*-- which may be used by the calling function to locate array
*-- elements
*-- Parameters..: cArrayskel, a character string including the name of the
*-- array and, if the row or column to be used is not the
*-- first row (or only row if array is one-dimensional),
*-- a bracketed expression with a number indicating the row,
*- or column if the number is preceded by a comma, to be used.
*-- cVar, name of the memvar to be used by calling function.
*-------------------------------------------------------------------------------
parameters cArrayskel, cVar
private nAt, cWhich, cMask, cV
nAt = at( "[", cArrayskel )
cWhich = "0 ]"
cV = trim( ltrim( cVar ) )
if nAt > 0
cWhich = substr( cArrayskel, nAt + 1 )
else
cWhich = "1 ]"
endif
if .not. "," $ cArrayskel
cMask = "[ " + cV + " ]"
else
if val( cWhich ) > 0
cMask = "["+ ltrim( str( val( cWhich ) ) ) + "," + cV + "]"
else
cWhich = substr( cWhich, at( ",", cWhich ) + 1 )
cMask = "[" + cV+ ","+ ltrim( str( val( cWhich ) ) ) + "]"
endif
endif
RETURN cMask
*-- EoF: Amask()
FUNCTION Amean
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/13/1992
*-- Notes.......: Mean of non-blank numeric or date values in specified row
*-- : or column of a specified array. If the first value is a
*-- : date, averages only dates. If first value is numeric or
*-- : float, averages only numerics and floats. Exits returning
*-- : .F. if first value is character or logical, if specified
*-- : row or column does not exist or if there are no
*-- : averageable values.
*-- Written for.: dBASE IV Version 1.5.
*-- Rev. History: Original function written 1990
*-- : Adapted to Version 1.5 4/13/1992
*-- Calls : AMASK() Function in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: Amean( <cArrayskel> )
*-- Example.....: ? Amean( "Myarray [ , 1 ]" )
*-- Returns : a numeric, float or date value, the mean or average, or .F.
*-- : If any of the averaged items are floats, the result will be.
*-- Parameters..: cArrayskel, a character string including the name of the
*-- : array and, if the row or column to be averaged is not the
*-- : first row, a bracketed expression with a number indicating
*-- : the row, or column if the number is preceded by a comma,
*-- : to be averaged.
*-------------------------------------------------------------------------------
parameters cArrayskel
private nAt,cArray,cMask,cElem,nTot,nCount,xNext,cOktype
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nAt" )
store 0 to nTot, nCount, nAt
do while .t.
nAt = nAt + 1
cElem = cArray + cMask
xNext = type( cElem )
do case
case xNext = "U"
exit
case nAt = 1
if xNext $ "CL"
exit
else
cOktype = iif( xNext = "D", "D", "NF" )
endif
case .not. xNext $ cOktype
loop
endcase
xNext = &cElem
if isblank( xNext )
loop
endif
if cOktype = "D"
xNext = xNext - {01/01/01}
endif
nTot = nTot + xNext
nCount = nCount + 1
enddo
RETURN iif( nCount = 0, .F., nTot / nCount ;
+ iif( cOktype = "D", {01/01/01}, 0 ) )
*-- EoF: Amean()
FUNCTION Amax
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/13/1992
*-- Notes.......: Finds maximum non-blank numeric, date or character value in
*-- : specified row or column of a specified array. If the first
*-- : value is character or date, considers only that type.
*-- : If first value is numeric or float, considers only numerics
*-- : and floats. Exits returning .F. if first value is logical,
*-- : if specified row or column does not exist or if there are no
* : numeric, date or character values in the row or column.
*-- Written for.: dBASE IV Version 1.5.
*-- Rev. History: Original function written 1990
*-- : Adapted to Version 1.5 4/13/1992
*-- Calls : AMASK() Function in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: Amax( <cArrayskel> )
*-- Example.....: ? Amax( "Myarray [ , 1 ]" )
*-- Returns : a char, numeric, float or date value, the maximum, or .F.
*-- : If any of the numeric items are floats, the result will be.
*-- Parameters..: cArrayskel, a character string including the name of the
*-- : array and, if the row or column to be used is not the
*-- : first row, a bracketed expression with a number indicating
*-- : the row, or column if the number is preceded by a comma,
*-- : to be used.
*-------------------------------------------------------------------------------
parameters cArrayskel
private nAt,cArray,cMask,cElem,xMax,xNext,cOktype
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nAt" )
store 0 to nAt
do while .T.
nAt = nAt + 1
cElem = cArray + cMask
xNext = type( cElem )
do case
case xNext = "U"
exit
case nAt = 1
if xNext ="L"
exit
else
cOktype = iif( xNext $ "CD", xNext, "NF" )
endif
case .not. xNext $ cOktype
loop
endcase
xNext = &cElem
if cOktype # "C" .and. isblank( xNext )
loop
endif
if nAt = 1
xMax = xNext
else
xMax = max( xMax, xNext )
endif
enddo
RETURN iif( type( "xMax" ) = "U", .F., xMax )
*-- EoF: Amax()
FUNCTION Amin
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/13/1992
*-- Notes.......: Finds minimum non-blank numeric, date or character value in
*-- : specified row or column of a specified array. If the first
*-- : value is character or date, considers only that type.
*-- : If first value is numeric or float, considers only numerics
*-- : and floats. Exits returning .F. if first value is logical,
*-- : if specified row or column does not exist or if there are no
* : numeric, date or character values in the row or column.
*-- Written for.: dBASE IV Version 1.5.
*-- Rev. History: Original function written 1990
*-- : Adapted to Version 1.5 4/13/1992
*-- Calls : AMASK() Function in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: Amin( <cArrayskel> )
*-- Example.....: ? Amin( "Myarray [ , 1 ]" )
*-- Returns : a char, numeric, float or date value, the minimum, or .F.
*-- : If any of the numeric items are floats, the result will be.
*-- Parameters..: cArrayskel, a character string including the name of the
*-- : array and, if the row or column to be used is not the
*-- : first row, a bracketed expression with a number indicating
*-- : the row, or column if the number is preceded by a comma,
*-- : to be used.
*-------------------------------------------------------------------------------
parameters cArrayskel
private nAt,cArray,cMask,cElem,xMin,xNext,cOktype
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nAt" )
store 0 to nAt
do while .T.
nAt = nAt + 1
cElem = cArray + cMask
xNext = type( cElem )
do case
case xNext = "U"
exit
case nAt = 1
if xNext ="L"
exit
else
cOktype = iif( xNext $ "CD", xNext, "NF" )
endif
case .not. xNext $ cOktype
loop
endcase
xNext = &cElem
if cOktype # "C" .and. isblank( xNext )
loop
endif
if nAt = 1
xMin = xNext
else
xMin = min( xMin, xNext )
endif
enddo
RETURN iif( type( "xMin" ) = "U", .F., xMin )
*-- EoF: Amin()
FUNCTION Avar
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/13/1992
*-- Notes.......: Finds population variance of non-blank numeric or date values
*-- : in specified row or column of a specified array. If first
*-- : value is date, considers only that type.
*-- : If first value is numeric or float, considers only numerics
*-- : and floats. Exits returning .F. if first value is character
*-- : or logical, if specified row or column does not exist or if
*-- : there are no numeric or date values in the row or column.
*-- :
*-- : To adapt this to find the sample variance, substitute
*-- : "( nCount - 1 )" for the final "nCount" in the last line.
*-- Written for.: dBASE IV Version 1.5.
*-- Rev. History: Original function written 1990
*-- : Adapted to Version 1.5 4/13/1992
*-- Calls : AMASK() Function in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: Avar( <cArrayskel> )
*-- Example.....: ? Avar( "Myarray [ , 1 ]" )
*-- Returns : a numeric, or float value, the variance, or .F.
*-- : If any of the numeric items are floats, the result will be.
*-- Parameters..: cArrayskel, a character string including the name of the
*-- : array and, if the row or column to be used is not the
*-- : first row, a bracketed expression with a number indicating
*-- : the row, or column if the number is preceded by a comma,
*-- : to be used.
*-------------------------------------------------------------------------------
parameters cArrayskel
private nAt,cArray,cMask,cElem,nCount,nTot,nTotsq,xNext,cOktype
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nAt" )
store 0 to nTot, nTotsq, nCount, nAt
do while .t.
nAt = nAt + 1
cElem = cArray + cMask
xNext = type( cElem )
do case
case xNext = "U"
exit
case nAt = 1
if xNext $ "CL"
exit
else
cOktype = iif( xNext = "D", "D", "NF" )
endif
case .not. xNext $ cOktype
loop
endcase
xNext = &cElem
if isblank( xNext )
loop
endif
if cOktype = "D"
xNext = xNext - {01/01/01}
endif
nTot = nTot + xNext
nTotsq = nTotsq + xNext * xNext
nCount = nCount + 1
enddo
RETURN iif( nCount = 0, .F., ( nTotsq - nTot * nTot / nCount ) / nCount )
*-- EoF: Avar()
FUNCTION Aseek
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/21/1992
*-- Notes.......: Binary search of an array for an element of which the
*-- value is Finditem (could be character, numeric or date,
*-- but of course types of all elements must match). Works
*-- only if array is sorted ascending. Element found is
*-- not necessarily the first that matches the value sought.
*-- To use with array sorted descending, change ">" to "<"
*-- in the remarked line.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 - original function.
*-- 04/21/1992 - Jay Parsons - calling syntax changed
*-- Calls.......: AMASK() Function in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: Aseek(<cArrayskel>,<xFindItem> )
*-- Example.....: nIndex = Aseek("MyArray [ ,2 ], {01/15/89} )
*-- Returns.....: numeric ( index to place in array where item exists, or 0 )
*-- Parameters..: cArrayskel = name of array and optional row/column info
*-- xFindItem = Item to look for in array
*-- Must be same TYPE as item in array looked for.
*-- Numerics are NOT the same as floats for this one.
*-------------------------------------------------------------------------------
parameters cArrayskel, xFinditem
private cArray, cMask, cElem, nHi, nLo, nTrial, cOktype
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nTrial" )
cOktype = type( "xFinditem" )
nLo = 1
nHi = 1170
do while .t.
if nHi < nLo
nTrial = 0
exit
else
nTrial = int( ( nHi + nLo ) / 2 )
endif
cElem = cArray + cMask
xNext = type( cElem )
do case
case xNext = "U"
nHi = nTrial - 1
case .not. xNext $ cOktype
nTrial = 0
exit
otherwise
xNext = &cElem
do case
case xNext = xFinditem
exit
case xNext > xFinditem && see notes
nHi = nTrial - 1
otherwise
nLo = nTrial + 1
endcase
endcase
enddo
RETURN nTrial
*-- EoF: Aseek
FUNCTION Ashuffle
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Random shuffle of elements of an array
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: Amask() Function in ARRAY.PRG
*-- Arrayrows() Function in ARRAY.PRG
*-- Arraycols() Function in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: AShuffle( "<cArrayskel>" )
*-- Example.....: lX = AShuffle( "aTest[ ,2]" )
*-- Returns.....: .T.
*-- Parameters..: cArrayskel = Name of array, optional row/column designator
*-- Side effects: Rearranges elements of the array
*-- Reseeds random number generator and uses some random numbers
*-------------------------------------------------------------------------------
parameters cArrayskel
private cArray, cMask, cElem, cElem, nAt, nRand, nLeft, x1, x2
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nAt" )
if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
nLeft = Arraycols( cArray )
else
nLeft = Arrayrows( cArray )
endif
nRand = rand( -1 )
do while nLeft > 1
nAt = nLeft
cElem = cArray + cMask
x1 = &cElem
nAt = int( rand() * nLeft ) + 1
cElem = cArray + cMask
x2 = &cElem
store x1 to &cElem
nAt = nLeft
cElem = cArray + cMask
store x2 to &cElem
nLeft = nLeft - 1
enddo
RETURN .T.
*-- EoF: Ashuffle()
FUNCTION Abubble
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/21/1992
*-- Notes.......: Bubble sort. This is a slow algorithm, made slower by
*-- passing the array name as a parameter instead of copying
*-- the array to one of predefined name. Its primary use is in
*-- selecting a few of the highest or lowest values from a longer
*-- list. The argument "nPasses" gives the number of values
*-- guaranteed to be in their correct places, in this case the
*-- lowest values, at the head of the list. Values at other
*-- places in the list may not have been sorted.
*-- Note: To place the highest values at the head of
*-- the list, change > to < in the remarked line.
*-- What use is it? Well, a golf handicap is based on
*-- the lowest 10 score differentials of the last 20.
*-- This is the easy way to select them. Other applications
*-- include selecting a few invidividuals from a large number
*-- of candidates based on some numeric expression.
*-- Written for.: dBASE IV, 1.1, 1.5
*-- Rev. History: 04/21/1992 -- Original Release
*-- Calls.......: AMASK() Function in ARRAY.PRG
*-- Arraycols() Function in ARRAY.PRG
*-- Arrayrows() Function in ARRAY.PRG
*-- Called by...: Any
*-- Usage.......: BubbleSort("<cArrayskel>" [,<nPass>] )
*-- Example.....: lX = BubbleSort("Test [1,]",10)
*-- Returns.....: .T.
*-- Parameters..: cArrayskel = Name of array, optional row/column designator
*-- nPasses = number of passes. If you want a complete sort,
*-- set this value to the same as length of array,
*-- or omit it in 1.5.
*-- Side effects: Rearranges elements of the array
*-------------------------------------------------------------------------------
parameters cArrayskel, nPasses
private nJ, nAt, cArray, cMask, cElem, x1, x2, nP, nPasses, lSwitch, nOld, nNew
cArray = cArrayskel
if "[" $ cArray
cArray = left( cArray, at( "[", cArray ) - 1 )
endif
cArray = trim( ltrim( cArray ) )
cMask = Amask( cArrayskel, "nAt" )
if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
nJ = Arraycols( cArray )
else
nJ = Arrayrows( cArray )
endif
if val( substr( version(), 9, 5 ) ) < 1.5 .or. pcount() > 1
nP = min( nPasses, nJ )
else
nP = nJ
endif
nPass = 1
do while nPass <= nP
lSwitch = .F.
nOld = nJ
do while .t.
cElem = cArray + cMask
nAt = nOld
x1 = &cElem
do while .t.
nNew = nOld - 1
if nNew < nPass
exit
endif
nAt = nNew
cElem = cArray + cMask
x2 = &cElem
if x1 < x2 && see notes
lSwitch = .T.
nAt = nOld
cElem = cArray + cMask
store x2 to &cElem
nOld = nNew
else
exit
endif
enddo
nAt = nOld
cElem = cArray + cMask
store x1 to &cElem
nOld = nNew
if nOld <= nPass
exit
endif
enddo
if .not. lSwitch
exit
endif
nPass = nPass + 1
enddo
RETURN .T.
*-- EoF: Abubble()
FUNCTION ArrayRows
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 03/24/1993
*-- Notes.......: Number of Rows in an array
*-- Written for.: dBASE IV, 1.1 to 2.0
*-- Rev. History: 03/01/1992 -- Original
*-- 03/24/1993 -- Modified to allow up to 65,535 elements
*-- per dimension, as allowed by version 2.0.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ArrayRows("<aArray>")
*-- Example.....: n = ArrayRows("aTest")
*-- Returns.....: numeric
*-- Parameters..: aArray = Name of array
*-------------------------------------------------------------------------------
parameters aArray
private nHi, nLo, nTrial, nDims
nLo = 1
nHi = iif( val( substr( version(), 11, 3 ) ) < 2, 1170, 65535 )
if type( "&aArray[ 1, 1 ]" ) = "U"
nDims = 1
else
nDims = 2
endif
do while .T.
nTrial = int( ( nHi + nLo ) / 2 )
if nHi < nLo
exit
endif
if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ;
nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U"
nHi = nTrial - 1
else
nLo = nTrial + 1
endif
enddo
RETURN nTrial
*-- EoF: ArrayRows()
FUNCTION ArrayCols
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 03/24/1993
*-- Notes.......: Number of Columns in an array
*-- Written for.: dBASE IV, 1.1 to 2.0
*-- Rev. History: 03/01/1992 Original function
*-- 03/24/1993 Modified to allow up to 65,535 elements per
*-- dimension, as allowed by dBASE IV Version 2.0
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ArrayCols("<aArray>")
*-- Example.....: n = ArrayCols("aTest")
*-- Returns.....: numeric
*-- Parameters..: aArray = Name of array
*-------------------------------------------------------------------------------
parameters aArray
private nHi, nLo, nTrial
nLo = 1
nHi = iif( val( substr( version(), 11, 3 ) ) < 2, 1170, 65535 )
if type( "&aArray[ 1, 1 ]" ) = "U"
RETURN 0
endif
do while .t.
nTrial = int( ( nHi + nLo ) / 2 )
if nHi < nLo
exit
endif
if type( "&aArray[ 1, nTrial ]" ) = "U"
nHi = nTrial - 1
else
nLo = nTrial + 1
endif
enddo
RETURN nTrial
*-- EoF: ArrayCol()
FUNCTION ShellSort
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Sort aMyarray[] elements 1 to Number, ascending
*-- Note: change < to > in the remarked line for
*-- a descending sort.
*-- This routine depends on the elements being copied
*-- into the array "aMyarray" before the sort. It could,
*-- like the other array functions, accept the name of
*-- the array as a parameter and use it as a macro within,
*-- but performance will be very slow in that case.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ShellSort(<nNumber>)
*-- Example.....: lX = ShellSort(532)
*-- Returns.....: .T.
*-- Parameters..: nNumber = Size of array (# of elements)
*-------------------------------------------------------------------------------
parameters nNumber
private nInterval, nPlace, nI, nJ, xTemp
nInterval = nNumber
do while nInterval > 0
nInterval = int( nInterval / 2 )
nPlace = 1
do while .T.
nI = nPlace
nJ = nI + nInterval
if nJ > nNumber
exit
endif
xTemp = aMyarray[ nJ, 1 ]
do while xTemp < aMyarray[ nI, 1 ] && see note
aMyarray[ nJ,1 ] = aMyarray[ nI, 1 ]
nJ = nI
nI = nI - nInterval
if nI < 1
exit
endif
enddo
aMyarray[ nJ, 1 ] = xTemp
nPlace = nPlace + 1
enddo
enddo
RETURN .T.
*-- EoF: ShellSort()
FUNCTION Arec2Arr
*-------------------------------------------------------------------------------
*-- Programmer..: Bowen Moursund (CIS: 76566,1405)
*-- Date........: 05/01/1992
*-- Notes.......: Creates a public array, aRecord[n], initialized to the
*-- record format of the currently selected DBF, either blank or
*-- filled with the values of the current record. Memo fields
*-- cannot be copied to an array.
*-- Written for.: dBASE IV v1.5
*-- Rev. History: 05/01/1992
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Arec2Arr(<lBlank>)
*-- Example.....: lSuccess = Arec2Arr(.T.)
*-- Returns.....: .T. if succesful, .F. if not.
*-- Parameters..: lBlank = whether or not to create an empty array.
*-- .T. = blank
*-- .F. = current record values
*-- Side effects: Creates a public array, aRecord[n]. It will destroy
*-- an existing array of that name.
*-------------------------------------------------------------------------------
parameters lBlank
private lSuccess,lDbf,cFieldName,nFieldNumb,nNumFields
lSuccess = .f.
lDbf = ( "" # dbf() )
if ((lDbf .and. lBlank) .or. (.not. lBlank .and. lDbf .and. .not. eof()))
release aRecord
nNumFields = fldcount()
public array aRecord[nNumFields]
if lBlank
goto bottom
skip && phantom record
nFieldNumb=1
do while nFieldNumb <= nNumFields
cFieldName = field(nFieldNumb)
aRecord[nFieldNumb] = &cFieldName.
nFieldNumb = nFieldNumb + 1
enddo
else
copy to array aRecord next 1
endif
lSuccess = .t.
endif
RETURN lSuccess
*-- EoF: Arec2Arr()
FUNCTION aPullSort
*-------------------------------------------------------------------------------
*-- Programmer..: Kelvin Smith (KELVIN)
*-- Date........: 05/07/1992
*-- Notes.......: Sort aMyarray[] elements 1 to Number, ascending
*-- Note: change > to < in the remarked line for
*-- a descending sort.
*-- This sorting algorithm, while not as fast as a shell
*-- sort, is fairly simple to understand and considerably
*-- faster than the infamous bubble sort. Each iteration
*-- pulls the next item in order to the front of the unsorted
*-- portion of the list.
*-- This routine depends on the elements being copied
*-- into the array "aMyarray" before the sort. It could,
*-- like the other array functions, accept the name of
*-- the array as a parameter and use it as a macro within,
*-- but performance will be very slow in that case.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 05/07/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: APullSort(<nNumber>)
*-- Example.....: lX = APullSort(532)
*-- Returns.....: .T.
*-- Parameters..: nNumber = Size of array (# of elements)
*-------------------------------------------------------------------------------
parameters nNumber
private nI, nJ, nSwap, xTemp
nI = 1
do while nI < nNumber && Through the list
nSwap = nI
nJ = nI + 1
do while nJ <= nNumber && From nI to end of list
if aMyarray[nSwap] > aMyarray[nJ] && see note
nSwap = nJ && Item at nJ is smaller
endif
nJ = nJ + 1
enddo
if nSwap <> nI && Found a smaller one
xTemp = aMyarray[nSwap] && Swap it
aMyarray[nSwap] = aMyarray[nI]
aMyarray[nI] = xTemp
endif
nI = nI + 1
enddo
RETURN .T.
*-- EoF: APullSort()
*-------------------------------------------------------------------------------
*-- EoP: ARRAY.PRG
*-------------------------------------------------------------------------------