'===========================================================================
' Subject: XMS SORTING INTERFACE             Date: 08-06-97 (18:26)       
' Author:  Vincent D. Voois                  Code: QB, PDS                
' Origin:  vv@musician.org                 Packet: LIBRARY.ABC
'===========================================================================
  ' XMS-sorting interface by Vincent Voois
  ' This little program demonstrates sorting of various textlines from a
  ' texfile loaded into XMS memory.
  ' Note that you need the object file which handles the XMSroutines of Robin
  ' Duffy (Sequential Software Inc.) somewhere on the MEMORY.ABC Packet
  '
 
  DEFINT A-Z

  DECLARE FUNCTION GetXMS% (Handle%) 'Duffy's part of his XMS routine
  DECLARE FUNCTION GetReeks$ (Nummer&) 'Interface between XMS and Basic memory.
  DECLARE FUNCTION WhichXError% () 'Duffy's part of his XMS routine
  DECLARE FUNCTION XMSError% () 'Duffy's part of his XMS routine

  DECLARE SUB FreeHandles () 'Clearing all possible XMS-handles
  DECLARE SUB PutReeks (Variabele$, Nummer&) 'Interface between XMS and Basic memory.
  DECLARE SUB HuthSort () ' Mike Huth's SortAlgorithm
  DECLARE SUB Switch (A&, B&) 'Interface between XMS and Basic memory.
 
  TYPE StackType
    low AS LONG 'These were integers in original, i allways use long just in
                'in doubtfull case.
    hi AS LONG  'at least you can sort a few million elements now :)
  END TYPE


  TYPE Buffer
    FileLine AS STRING * 128 'Set line read limit to 128 chars, increase this
  END TYPE                   'whenever your linelengths are bigger.
                             'Do know, that enlarging the stringsize will slow
  CLEAR                      'up the sortroutine and you risk clogging up stack
                             'space even with Huth's sort-algorithm!
                             'Stackclogging danger may arise above 1024 bytes.

  DIM SHARED File(1) AS Buffer 'This is the interface variable between XMS&Bas
 
  DIM SHARED FileHandle% 'This is an XMS handle associated with file-routines
 
  DIM SHARED FileLines& 'These are the total of lines inside the loaded file
 
  DIM SHARED Leng% 'This is the length of the longest line inside the file.
                   'This one may not exceed 128, else increase the FileLine
                   'length
  CLS

  CALL InitXMS(Status%, MemSize&)

  FreeHandles 'Clear all (possible) open handles:
              'when interrupting testprocedures, you're memory can get clogged
              'up with previous test-data,closing XMS-handle pointers is must!

  ' Open file, count the lines included and measure the linelengths

  PRINT "Checking input data..."

  OPEN "text.tst" FOR INPUT AS #1 'or Any file with some textlines in it

  DO WHILE NOT EOF(1)
    LINE INPUT #1, A$

    FileLines& = FileLines& + 1

    IF LEN(A$) > Leng% THEN
      Leng% = LEN(A$)
    END IF

  LOOP

  Leng% = Leng% + 1

  CLOSE

  'The memory to allocate will be all filelines multiplied by the longest line
  'it's length, devided by 1024 and added 1K for insurance.
 
  TotalFileSize% = ((FileLines& * Leng%) \ 1024) + 1

  'Calculate statistics
 
  MustMem& = TotalFileSize%
 
  MustMem& = MustMem& * 1024
 
  PRINT "Allocating memory:"; MustMem&; "Bytes"

  'Fill Filehandle
 
  FileHandle% = GetXMS(TotalFileSize%)

  ' Open up file again and fill up XMS memory with the contents, do check on
  ' errors during xms-transfers

  OPEN "text.tst" FOR INPUT AS #1

  DO WHILE NOT EOF(1)
    LINE INPUT #1, In$

    LineNumber& = LineNumber& + 1
   
    PutReeks In$, LineNumber&

    Xerror% = WhichXError

    IF XMSError THEN
      FreeHandles

      PRINT LineNumber&

      PRINT "Error closing..."; Xerror%

      CLOSE

      END
    END IF

  LOOP

  'Sorting the stuphz in XMS through basic...

  PRINT "Sorting "; FileLines&; "Elements...."

  HuthSort
 
  ' And show the sorted stuphz
 
  FOR i& = 1 TO LineNumber&
    PRINT ">"; GetReeks$(i&); "<"

    IF NonStop% = 0 THEN

      DO
        T$ = INKEY$
      LOOP UNTIL T$ <> ""

      IF T$ = "n" THEN
        NonStop% = 1
      END IF

      IF T$ = CHR$(27) THEN
        FreeHandles

        PRINT "Aborting..."

        END
      END IF

    END IF

  NEXT i&

  FreeHandles

SUB FreeHandles
 
  ' This routine is clearing various XMS handles, i just did it to be capable
  ' to interrupt basic routines while testing them without clogging up memory
  ' with reults of previous tests.

  CALL FreeXMS(10)
  CALL FreeXMS(9)
  CALL FreeXMS(8)
  CALL FreeXMS(7)
  CALL FreeXMS(6)
  CALL FreeXMS(5)
  CALL FreeXMS(4)
  CALL FreeXMS(3)
  CALL FreeXMS(2)
  CALL FreeXMS(FileHandle%)
  
END SUB

FUNCTION GetReeks$ (Nummer&)
 
  ' This routine substitutes the [Array()] handlers of Quickbasic
  ' It get's an element out of XMS-memory and then stores it into a string
  ' value.

  File(1).FileLine = STRING$(Leng%, " ")
 
  CALL XGetElement(FileHandle%, File(1), Leng%, Nummer&)
 
  GetReeks$ = RTRIM$(File(1).FileLine)
 
END FUNCTION

SUB HuthSort

DIM Compare$


DIM aStack(1 TO 1024) AS StackType

  StackPtr = 1
 
  aStack(StackPtr).low = 1
 
  aStack(StackPtr).hi = FileLines&
 
  StackPtr = StackPtr + 1
 
  DO
    StackPtr = StackPtr - 1
   
    low& = aStack(StackPtr).low
   
    hi& = aStack(StackPtr).hi
   
    DO
      i& = low&
     
      j& = hi&
     
      Mid& = (low& + hi&) \ 2
     
      'Want to see searching results? unremark below lines.
     
      'LOCATE 5, 1
     
      'PRINT "mid:"; Mid&
      'PRINT "I:"; i&
      'PRINT "J:"; j&
     
      Compare$ = GetReeks$(Mid&)
     
      DO
       
        DO WHILE GetReeks$(i&) < Compare$
          i& = i& + 1
        LOOP
       
        DO WHILE GetReeks$(j&) > Compare$
          j& = j& - 1
        LOOP
       
        IF i& <= j& THEN
          Switch i&, j&
         
          i& = i& + 1
         
          j& = j& - 1
        END IF

      LOOP WHILE i& <= j&
     
      IF j& - low& < hi& - i& THEN
       
        IF i& < hi& THEN
         
          aStack(StackPtr).low = i&
         
          aStack(StackPtr).hi = hi&
         
          StackPtr = StackPtr + 1
        END IF
       
        hi& = j&
      ELSE
       
        IF low& < j& THEN
          aStack(StackPtr).low = low&
         
          aStack(StackPtr).hi = j&
         
          StackPtr = StackPtr + 1
        END IF
       
        low& = i&
      END IF
   
    LOOP WHILE low& < hi&
 
  LOOP WHILE StackPtr <> 1
END SUB

SUB PutReeks (Variabele$, Nummer&)

  ' This routine substitutes the [Array()] handlers of Quickbasic
  ' It set's an element into XMS-memory with a basic-string value.
  ' You can change this to your needs to let it insert other values than
  ' stringvalues.
 
  File(1).FileLine = STRING$(Leng%, " ")

  File(1).FileLine = Variabele$
 
  CALL XSetElement(FileHandle%, File(1), Leng%, Nummer&)
 
END SUB

SUB Switch (A&, B&)
 
  'This routine is the substitute of Basic's [SWAP] function.
  'It does the same with arrays and strings in XMS as Swap does in Basic.
  'You only work with the corresponding arrayelements this time.

  B$ = GetReeks$(B&)
 
  A$ = GetReeks$(A&)
 
  'I tried 'PutReeks GetReeks$(B&), A&' but that was not a wise decision i
  'made, it took me one day to find THAT bug that doubled up the lines.
  'I think that passing a Functionstring to a Subroutine causes trouble in
  'the first place. just don't adapt a trick like that avoid long debugging.

  PutReeks B$, A&
 
  PutReeks A$, B&

END SUB