REM file: Zsort.bas - Public Domain DOS Utility
REM Version 1.0a created 06/08/1995
REM Version 1.1a created 08/07/1995

REM Compiling with Microsoft BASIC Professional Development System 7.1:
REM    BC ZSORT/FS/X/O;
REM    LINK ZSORT,,,QBX/E;

' default integer variables
DEFINT A-Z
REM $DYNAMIC

' define boolean values
CONST True = -1
CONST False = NOT True
CONST TrueD = -1#
CONST FalseD = NOT TrueD
CONST NUL = ""

' define color values
CONST Black = 0
CONST Cyan = 11
CONST Green = 10
CONST Plain = 7
CONST Red = 12
CONST White = 15
CONST Yellow = 14

' declare include files
REM $INCLUDE: 'qbx.bi'

' declare functions
DECLARE FUNCTION ParseLine (S$)

' declare registers
COMMON SHARED InregsX AS RegtypeX, OutregsX AS RegtypeX

' declare work variables
COMMON SHARED Reverse.Sort AS INTEGER, Sort.Column AS INTEGER
COMMON SHARED Lines.Counted AS INTEGER, Max.Lines AS INTEGER
COMMON SHARED Ignore.Case AS INTEGER, Continuous.List AS INTEGER
COMMON SHARED Strip.Blanks AS INTEGER, Sort.Swaps AS SINGLE

' declare sort array
COMMON SHARED Sort.Array() AS STRING

' declare command line work variables
COMMON SHARED Command.Line AS STRING

' redimension sort array
REDIM Sort.Array(1 TO 128) AS STRING

' reset count variables
Max.Lines = 128

' increase stack size
STACK 3072

' declare standard error trap
ON ERROR GOTO Error.Routine

' command line parser
FUNCTION ParseLine (X$)
 Imbedded = INSTR(Command.Line, X$)
 IF Imbedded THEN
    Command.Line = LEFT$(Command.Line, Imbedded - 1) + MID$(Command.Line, Imbedded + LEN(X$))
    ParseLine = True
 ELSE
    ParseLine = False
 END IF
END FUNCTION 

' check command line
SELECT CASE COMMAND$
CASE "/?"
   GOTO Boot.Usage
END SELECT

' store and parse command line
Command.Line = RTRIM$(COMMAND$)
Command.Line = LTRIM$(Command.Line)
IF Command.Line = NUL THEN
   Command.Line = UCASE$(ENVIRON$("ZSORT"))
END IF

' check command line switches
Continuous.List = ParseLine ("/C")
Ignore.Case = ParseLine ("/I")
Reverse.Sort = ParseLine ("/R")
Strip.Blanks = ParseLine ("/T")

' get sort column
Imbedded = INSTR(Command.Line, "+")
IF Imbedded THEN
   Sort.Column = INT(VAL(MID$(Command.Line, Imbedded + 1)))
ELSE
   Sort.Column = 1
END IF

' search through all redirected input
Lines.Counted = 1

' loop while reading input
DO

   ' check direct console input
   InregsX.AX = &H600
   InregsX.DX = &H0FF
   CALL InterruptX(&H21, InregsX, OutregsX)

   ' check zero flag
   IF (OutregsX.Flags AND &H40) = &H40 THEN
      EXIT DO
   END IF

   ' store character
   Char$ = CHR$(OutregsX.AX AND &HFF)

   ' determine character type
   SELECT CASE ASC(Char$)
   CASE 13
   CASE 10
      IF Strip.Blanks THEN
         IF Sort.Array(Lines.Counted) = NUL THEN
	    Lines.Counted = Lines.Counted - 1
	 END IF
      END IF
      Lines.Counted = Lines.Counted + 1
      IF Lines.Counted > Max.Lines THEN
         Max.Lines = Max.Lines + 16
	 REDIM PRESERVE Sort.Array(1 TO Max.Lines) AS STRING
      END IF
   CASE ELSE
      Sort.Array(Lines.Counted) = Sort.Array(Lines.Counted) + Char$
   END SELECT
LOOP

' shell sort
Sort.Swaps = False
Num = Lines.Counted
Span = INT(Num / 2)
DO WHILE Span > False
   FOR Start = Span TO Num - 1
      FOR Element = (Start - Span + 1) TO 1 STEP -Span
         Sort.Column1$ = MID$(Sort.Array(Element), Sort.Column)
         Sort.Column2$ = MID$(Sort.Array(Element + Span), Sort.Column)
	 IF Ignore.Case THEN
	    Sort.Column1$ = UCASE$(Sort.Column1$)
	    Sort.Column2$ = UCASE$(Sort.Column2$)
	 END IF
	 IF Reverse.Sort THEN
	    IF Sort.Column2$ <= Sort.Column1$ THEN
	       EXIT FOR
	    END IF
	 ELSE
	    IF Sort.Column1$ <= Sort.Column2$ THEN
	       EXIT FOR
	    END IF
	 END IF
         SWAP Sort.Array(Element), Sort.Array(Element + Span)
	 Sort.Swaps = Sort.Swaps + 1
      NEXT
   NEXT
   Span = INT(Span / 2)
LOOP

' output array
COLOR Yellow, Black
FOR Array.Line = 1 TO Lines.Counted
   PRINT Sort.Array(Array.Line)
NEXT

End.Copy:

IF Continuous.List = False THEN
   COLOR Yellow, Black
   PRINT "Lines counted"; Lines.Counted; "Sort swaps made"; Sort.Swaps
   Prompt$ = "Press <enter> to exit to DOS:"
   CALL MorePrompt(Prompt$, CHR$(13), Outpt$)
END IF
COLOR Plain, Black
END

Boot.Usage:
 ' make header
 COLOR White, Black
 PRINT "Zsort v1.1a: File sort utility; "
 COLOR Yellow, Black
 PRINT "Usage:"
 PRINT "   Zsort [/cirt][+n]"
 PRINT "Where:"
 PRINT "   /c  continuous list"
 PRINT "   /i  ignore case"
 PRINT "   /r  reverse order"
 PRINT "   /t  strip blank lines"
 PRINT "   +n  sort at column n"
 COLOR Plain, Black
 END

Boot.Error:
 COLOR White, Black
 PRINT "Command line error. Type Zsort /? for help."
 COLOR Plain, Black
 END

' critical error trap
Error.Routine:
 Data.Error = ERR
 SELECT CASE Data.Error
 CASE 9
    PRINT "Subscript out of range."
    END
 CASE 14
    PRINT "Out of string space."
    END
 CASE 53
    Temp.Outpt$ = "File not found."
 CASE 61
    Temp.Outpt$ = "Disk full."
 CASE 70
    Temp.Outpt$ = "Permission denied."
 CASE 71
    Temp.Outpt$ = "Disk not ready."
 CASE ELSE
    Temp.Outpt$ = "Untrapped error" + STR$(Data.Error) + "."
 END SELECT
 COLOR White, Black
 PRINT Temp.Outpt$
 Prompt$ = "Press R to retry, Q to quit, C to continue:"
 CALL MorePrompt(Prompt$, "rqc", Outpt$)
 SELECT CASE Outpt$
 CASE "r"
    RESUME
 CASE "q"
    Error.Level = True
    RESUME End.Copy
 CASE "c"
    OutregsX.Flags = &H1
    RESUME NEXT
 END SELECT
 END 0

SUB MorePrompt (Input.String$, Input.Mask$, Output.String$)
 COLOR White, Black
 PRINT Input.String$ + " ";
 Input.Char$ = NUL
 DO
    LOCATE , , 1
    Input.Char$ = INKEY$
    IF LEN(Input.Char$) THEN
       Input.Char$ = LCASE$(Input.Char$)
       IF INSTR(Input.Mask$, Input.Char$) THEN
	  PRINT Input.Char$
	  Output.String$ = Input.Char$
	  EXIT DO
       END IF
    END IF
 LOOP
END SUB
