CLS
PRINT "                 Program name =  SORTBIG.BAS"
PRINT "                  by Bruce the Science Moose"
PRINT "A public domain file sorter by Bruce Ross, PE.  December 1996."
PRINT "    rev June 2, 1997.  "
PRINT
PRINT "SORTS FILES BIGGER THAN 60K USING MULTIPLE PASSES OF DOS  SORT.COM"
PRINT "SORT.COM  IS NOT CASE SENSITIVE !!!!   BOO HISS"
PRINT


SETUP:
ON ERROR GOTO 14300
MAXSIZE& = 64000              ' maximum size SORT.COM can work with
TMPDRV$ = "G:"                ' PATH to temporary files
TEMP1$ = TMPDRV$ + "TEMP1"    ' temporary scratch files
TEMP2$ = TMPDRV$ + "TEMP2"
TEMP3$ = TMPDRV$ + "TEMP3"
TEMP4$ = TMPDRV$ + "TEMP4"
CRLF$ = CHR$(13) + CHR$(10)
PRINT "< > IS THE DEFAULT VALUE AND ENTERED ON  CR."
PRINT
PRINT "PATH TO SCRATCH FILES WHERE THE TEMPORARY FILES ARE TO BE PUT.  <"; TMPDRV$;
INPUT "> "; QTMPDRV$
IF QTMPDRV$ = "" THEN QTMPDRV$ = TMPDRV$
TEMPDRV$ = QTMPDRV$
IF INSTR(TMPDRV$, ":") = 0 THEN BEEP: PRINT "MUST BE A DIR OR PATH WITH A : ": GOTO SETUP

PRINT "FILE TO SORT IS:": Q$ = "": GOSUB 11960: SOURCEFILE$ = Q$

100 : WRONGFILE$ = SOURCEFILE$
     OPEN SOURCEFILE$ FOR INPUT AS #1      ' OPEN FILE
     LOFSOURCE = LOF(1): PRINT "LENGTH OF " + SOURCEFILE$; " ="; LOFSOURCE

PRINT "SORTED FILE IS:": Q$ = "": GOSUB 11960: OUTFILE$ = Q$
      
UPDNQ:
INPUT "SORT WITH LARGEST ON TOP OR BOTTOM T/B <B>"; Q$: Q$ = UCASE$(Q$)
UPDOWN$ = Q$
IF UPDOWN$ = "" THEN UPDOWN$ = "B"
IF UPDOWN$ = "B" THEN UPDOWN$ = "": GOTO SORTCOLQ     ' REGULAR SORT
IF UPDOWN$ = "T" THEN UPDOWN$ = " /R": GOTO SORTCOLQ  ' REVERSE SORT
GOTO UPDNQ

SORTCOLQ:
PRINT "IGNORE ALL TO THE LEFT OF <1> (SORT <1> TO END, INCLUSIVE)."
INPUT " COLUMN NUMBER <1> "; SORTCOL
IF SORTCOL < 1 THEN SORTCOL = 1
IF LOFSOURCE > MAXSIZE& THEN GOTO ITSABIGGIE

SORTIN1PASS:
   CLOSE
   PRINT "SORT <" + SOURCEFILE$ + "> " + OUTFILE$ + " /+" + LTRIM$(STR$(SORTCOL)) + UPDOWN$
   SHELL "SORT <" + SOURCEFILE$ + "> " + OUTFILE$ + " /+" + LTRIM$(STR$(SORTCOL)) + UPDOWN$
   GOTO ENDUP
'---------------------- END SHORT FILE


ITSABIGGIE:
   INPUT " LEFT JUSTIFY THE RECORDS (LINES)?  Y/N <N>"; LJ$: LJ$ = UCASE$(LJ$)
   IF LJ$ = "" THEN LJ$ = "N"
   IF LJ$ = "Y" THEN GOTO BIGGIE1
   IF LJ$ = "N" THEN GOTO BIGGIE1
   BEEP
   GOTO ITSABIGGIE

BIGGIE1:
   INPUT " TRIM OFF RIGHT END SPACES?  Y/N <Y>"; RJ$: RJ$ = UCASE$(RJ$)
   IF LJ$ = "" THEN LJ$ = "Y"
   IF LJ$ = "Y" THEN GOTO BIGGIE2
   IF LJ$ = "N" THEN GOTO BIGGIE2
   BEEP
   GOTO BIGGIE1

BIGGIE2:
   INPUT " REMOVE BLANK LINES?  Y/N <Y>"; BL$: BL$ = UCASE$(BL$)
   IF BL$ = "" THEN BL$ = "Y"
   IF LJ$ = "Y" THEN GOTO BIGGIE3
   IF LJ$ = "N" THEN GOTO BIGGIE3
   BEEP
   GOTO BIGGIE2

BIGGIE3:
   PRINT "MAKING UP WORKING COPY, " + SOURCEFILE$ + " ---> " + TEMP1$
   WRONGFILE$ = TEMP1$
   OPEN TEMP1$ FOR OUTPUT AS #2


BIGGIE4:   ' make edited working copy.  ensures adequate crlf and other edits
  IF EOF(1) THEN GOTO BIGGIE5
  LINE INPUT #1, A$:     '  PRINT "<" + A$ + ">"
  IF LJ$ = "Y" THEN A$ = LTRIM$(A$)
  IF RJ$ = "Y" THEN A$ = RTRIM$(A$)
  IF A$ = "" THEN BEEP: PRINT "blank line removed": GOTO BIGGIE4
  IF INSTR(A$, CHR$(10)) = 0 THEN GOTO BIGGIE4A
  PRINT "LF WITHOUT CR.": PRINT A$
  PRINT LEFT$(A$, INSTR(A$, CHR$(10))): STOP
BIGGIE4A: PRINT #2, A$:  '  PRINT "/" + A$ + "/"
  GOTO BIGGIE4

BIGGIE5:
  PRINT "LENGTH OF ORIGINAL FILE ="; LOFSOURCE
  LOFT1 = LOF(2):
  PRINT "LENGTH OF WORKING FILE ="; LOFT1    ' : STOP
  CLOSE
'           SHELL "COPY " + TEMP1$ + " FOOP": ' STOP
  GOSUB 14200
  IF LOFSOURCE > MAXSIZE& THEN GOTO BIGGIE6  ' still a biggie,  more than one block reqd
   PRINT "SORT <" + TEMP1$ + "> " + OUTFILE$ + " /+" + LTRIM$(STR$(SORTCOL)) + UPDOWN$
   SHELL "SORT <" + TEMP1$ + "> " + OUTFILE$ + " /+" + LTRIM$(STR$(SORTCOL)) + UPDOWN$
   GOTO ENDUP
'-----------------

BIGGIE6:         ' how many blocks?
   BLOCKS = 1
BIGGIE7:
   X& = INT(LOFT1 / BLOCKS)
   IF X& < MAXSIZE& THEN GOTO BIGGIE7A
   BLOCKS = BLOCKS + 1
   GOTO BIGGIE7

BIGGIE7A:   BLOCKSIZE& = X& + 1
BIGGIE7B:   PRINT BLOCKS; BLOCKSIZE&; LOFT1; BLOCKSIZE& * BLOCKS:   '  STOP
  IF LOFT1 > BLOCKSIZE& * BLOCKS THEN BLOCKSIZE& = BLOCKSIZE& + 1: GOTO BIGGIE7B
 
BIGGIE8:
CLOSE :
    FOR N = 1 TO (BLOCKS * 2) * (BLOCKS * 2)
    FOR NN = 1 TO 2
890 : WRONGFILE$ = TEMP2$
    OPEN TEMP2$ FOR OUTPUT AS #2     ' building space
    CLOSE 2                          ' CLEARS TEMP2$
    OPEN TEMP3$ FOR OUTPUT AS #3     ' for sorting file
    CLOSE 3                          ' CLEARS TEMP3$
    LENA = 0
    PRINT "-----------------"; N; NN
    SIZE& = BLOCKSIZE&
    FIRST& = 0:
    IF NN = 1 THEN X& = INT(BLOCKSIZE& / 2): SIZE& = X&: FIRST& = X&                       ' file offset
    CLOSE

900 : WRONGFILE$ = TEMP1$
    OPEN TEMP1$ FOR INPUT AS #1      ' input
    BX& = -SIZE&

910 : WRONGFILE$ = TEMP2$
    OPEN TEMP2$ FOR APPEND AS #2     ' building space

920 : WRONGFILE$ = TEMP3$
    OPEN TEMP3$ FOR APPEND AS #3     ' to make temp3$ ---> sort ---> temp4$
   
    FILEPOS1& = 1                    ' input file postition counter
    filepos3& = 1 + LENA             ' size of block to be sorted
    BX& = BX& + SIZE&

    PRINT "====="
    PRINT "OFFSET ="; FIRST&; " BLOCKSIZE ="; SIZE&; " FILE SIZE ="; LOFT1; " MOVING; "; BX&; BX& + SIZE&
'       STOP
930 :
FINDBLOCK:
    IF EOF(1) THEN LENA = 0: GOTO SORTBLOCK   ' LENA doubles as a residual line flag
932 : LINE INPUT #1, A$: ' PRINT A$
    LENA = LEN(A$) + 2                        ' be sure to count the crlf
940 : PRINT #3, A$: ' PRINT A$
    filepos3& = filepos3& + LENA
    IF filepos3& + LENA > SIZE& THEN GOTO SORTBLOCK
    GOTO FINDBLOCK


SORTBLOCK:
   CLOSE 3:
   CLOSE 2:

   PRINT "SORT <" + TEMP3$ + "> " + TEMP4$ + " /+" + LTRIM$(STR$(SORTCOL)) + UPDOWN$
   SHELL "SORT <" + TEMP3$ + "> " + TEMP4$ + " /+" + LTRIM$(STR$(SORTCOL)) + UPDOWN$

1000 :  PRINT "SORTED.   ATTACHING SORTED TO BUILD FILE"
   WRONGFILE$ = TEMP4$
   OPEN TEMP4$ FOR INPUT AS #4
1100 :  WRONGFILE$ = TEMP2$
   OPEN TEMP2$ FOR APPEND AS #2       ' build sorted files

NEXTFILE4:   ' move temp4 to temp2
   IF EOF(4) THEN GOTO GETREST
   LINE INPUT #4, B$
   PRINT #2, B$
   GOTO NEXTFILE4
 
GETREST:
'      PRINT #2, "-----------------------"
   CLOSE 2
   CLOSE 4:
   KILL TEMP3$
   KILL TEMP4$
1110 : WRONGFILE$ = TEMP3$
   IF LENA = 0 THEN GOTO 1200    ' end of file found
   CLOSE 3
   SIZE& = BLOCKSIZE&
   GOSUB 14200
   GOTO 910   '  residual line is stashed.  Go to Next block

1200 :  PRINT "CLEAN UP FOR NEXT PASS"; NN, M, N:  ' STOP
   CLOSE
   GOSUB 14200
   KILL TEMP1$
   NAME TEMP2$ AS TEMP1$

CHECKFORDUN:
  PRINT "CHECKING INTERMEDIATE SORT TO SEE IF POSSIBLY DONE"
  SORTED = 0    ' FLAG
  GOSUB 14200   ' whadyawant?
1210 : WRONGFILE$ = TEMP1$
  OPEN TEMP1$ FOR INPUT AS #1
  IF EOF(1) THEN GOTO DOONIT
  LINE INPUT #1, S1$: ' get first line
  SECOND$ = RTRIM$(S1$)
1215 :
  LSEC = LEN(SECOND$):
  IF LSEC < SORTCOL THEN SECOND$ = LEFT$(SECOND$ + STRING$(SORTCOL, " "), SORTCOL): GOTO 1215: ' pad short line to sort column length
  SECOND$ = RIGHT$(UCASE$(SECOND$), LSEC - SORTCOL + 1)

CKDUN:  IF EOF(1) THEN GOTO DOONIT
  S1$ = S2$
  FIRST$ = SECOND$          ' OLD BECOMES NEW
  LINE INPUT #1, S2$:       ' READ NEXT TO COMPARE WITH PREVIOUS
  SECOND$ = RTRIM$(S2$)
2516 :
  LSEC = LEN(SECOND$):
  IF LSEC < SORTCOL THEN SECOND$ = LEFT$(SECOND$ + STRING$(SORTCOL, " "), SORTCOL): GOTO 2516: ' pad short line to sort column length
  SECOND$ = RIGHT$(UCASE$(SECOND$), LSEC - SORTCOL + 1)
  IF UPDOWN$ = "" THEN GOTO REGSORT
      PRINT "<"; FIRST$; ">": PRINT "/"; SECOND$; "/": PRINT SORTED; "=r=":
  IF FIRST$ >= SECOND$ THEN GOTO CKDUN: ' reverse sort
  SORTED = 1: GOTO NEXTNN               ' out of order

REGSORT:
  '     PRINT "<"; FIRST$; ">": PRINT "/"; SECOND$; "/":
   '    PRINT ">"; S1$; "<": PRINT "\"; S2$; "\": PRINT SORTED; "=n=":
 
  IF FIRST$ <= SECOND$ THEN GOTO CKDUN: ' regular sort
  SORTED = 1: GOTO NEXTNN                ' out of order

DOONIT:
  CLOSE
  PRINT "------"; M; " ------ M M M M M "
  IF SORTED = 0 THEN GOTO CLEANUP

NEXTNN: GOSUB 14200: NEXT NN
  GOSUB 14200
'  SHELL "list " + TEMP1$
NEXTN: PRINT "====NNNNNNN  "; N; "NNNNNN======": BEEP
NEXT N
PRINT " there is a problem. file not declared as sorted, but probably is":
BEEP: STOP

CLEANUP:
SHELL "COPY " + TEMP1$ + " " + OUTFILE$
KILL TEMP1$
SHELL "DIR"
GOTO ENDUP

END
'---------- END BIGGIE FILE


ENDUP:
   CLOSE
   GOSUB ENDSONG
   BEEP: SOUND 1000, 5: SOUND 2000, 5: SOUND 500, 5
   PRINT SOURCEFILE$; " ----> sort ----> "; OUTFILE$
   INPUT "  WANT TO VIEW SORTED FILE NOW?   Y/N <N>"; Q$:
   Q$ = UCASE$(Q$)
   IF Q$ = "" THEN Q$ = "N"
   IF Q$ = "Y" THEN SHELL "LIST.COM " + OUTFILE$   ' LISTER, must have list.com available

2000 : WRONGFILE$ = TMPDRV$ + "TEMP?"
   SHELL "DEL " + TMPDRV$ + "TEMP?"
   PRINT " END.   GOODBYE"
END

     '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

SWEEPSORT:






END
'=========================================================================


     '        [=-=-=-=-=-= [utility subroutines] =-=-=-=-=-=-=]


      '============ file and set-up subroutines =============
11920 '[------ drive designation for temporary files ------]
      BEEP: PRINT "where to put temporary files? "
      INPUT "<D:\> otherwise ENTER NEW PATH.  ENTER  / or \  for C:\FOO\ "; Q$: Q$ = UCASE$(Q$)
      IF Q$ = "/" THEN Q$ = "C:\FOO\"
      IF Q$ = "\" THEN Q$ = "C:\FOO\"
      TMPDRV$ = "D:\": IF Q$ <> "" THEN TMPDRV$ = Q$
      IF RIGHT$(TMPDRV$, 1) <> "\" THEN PRINT " Is this properly formatted?.  Should end with \": GOTO 11920
11933 OPEN TMPDRV$ + "footmp" FOR OUTPUT AS #1: '  is tmpdrv$ valid?
11934 CLOSE : KILL TMPDRV$ + "FOOTMP"
      RETURN

11960 '[------- file naming -------]
      ' input:  q$ = default name
      ' output: q$ = file name

      PRINT " --  DIR X: for directory. DEL X: for delete "
      A$ = Q$: PRINT "NAME   <"; Q$; ">"; '   print default in <>
     
      INPUT Q$: Q$ = UCASE$(Q$)
      IF Q$ = "" THEN Q$ = A$    ' insert default
      IF Q$ = "DIR" THEN SHELL "DDIR": PRINT : GOTO 11960
      IF Q$ = "DIR " THEN SHELL "DDIR": PRINT : GOTO 11960
      IF INSTR(Q$, "DIR ") > 0 THEN Q$ = RIGHT$(Q$, LEN(Q$) - 4): FILES Q$: PRINT : GOTO 11960
      IF INSTR(Q$, "DEL ") > 0 THEN 12100
      GOTO 12140                 ' to return

12100 QQ$ = RIGHT$(Q$, LEN(Q$) - 4): PRINT "delete "; Q$; : INPUT "   Are you sure? <N>"; Q$
      Q$ = LTRIM$(RTRIM$(Q$)): IF Q$ = "Y" THEN KILL QQ$: PRINT QQ$; " has been deleted"
      PRINT

12140 RETURN                     ' return with file name in Q$

12160 '[-------------- open NEWFILE$ for output ------------]
      IF NEWFILE$ = "" THEN 12360    ' no newfile
      IF NEWFILE$ <> WRKFILE$ THEN 12220
      NEWFILE$ = TMPFILE$:
      PRINT "INPUT AND OUTPUT FILES ARE SPECIFIED TO BE THE SAME NAME."
      PRINT "OUTPUT FILE HAS BEEN RENAMED "; NEWFILE$
12220 PRINT : CLOSE #2
      ON ERROR GOTO 12330            ' if new file does not exist
      OPEN NEWFILE$ FOR INPUT AS #2  ' test for existance of newfile$
12250 PRINT NEWFILE$; "  EXISTS.": BEEP
      INPUT "   OVERWRITE, APPEND, CANCEL NEW FILE NAME   O/A/C <C>"; Q$
12270 CLOSE #2:  FOO$ = NEWFILE$  ' for error trap
      ON ERROR GOTO 14300         ' main error trap
      Q$ = UCASE$(Q$): IF Q$ = "" THEN Q$ = "C"
      IF Q$ = "0" THEN Q$ = "O"
      IF Q$ = "O" THEN OPEN NEWFILE$ FOR OUTPUT AS #2: GOTO 12360
      IF Q$ = "A" THEN OPEN NEWFILE$ FOR APPEND AS #2: GOTO 12360
      IF Q$ = "C" THEN NEWFILE$ = "": GOTO 12160
      BEEP: GOTO 12250
12330 '     error handler,  file does not exist
      Q$ = "O": RESUME 12270      ' default to open

12360 RETURN
'------------------------------------]

14160 '[------ SMALL LETTERS ---> CAPS  FIX-UP  ------]
      Q$ = LTRIM$(UCASE$(Q$))
      GOTO 14221    ' quit questions
 RETURN
      '--------]

14200 '[--------  whadyawant interrupt from kbd. -------]
      IF INKEY$ = "" THEN RETURN
14220 DEF SEG = 0: POKE 1050, PEEK(1052)  ' clear keyboard buffer
      DEF SEG : POKE 106, 0               ' clear basic input buffer
      BEEP: LOCATE 24, 1
      INPUT "whadayawant?  X OR Q to quit.  CR to continue"; Q$: Q$ = UCASE$(Q$)
14221 IF Q$ = "X" THEN CLOSE : SYSTEM
      IF Q$ = "Q" THEN CLOSE : SYSTEM
      IF Q$ <> "" THEN 14220
      RETURN
   '---------------]

14300 ' [------- error handler -------]
     'WRONGFILE = FOO$    ' File where error occured, maybe?
      BEEP: PRINT
      PRINT "Error # "; ERR; "  at or after line "; ERL; ".   Device error # "; ERDEV; "  "; ERDEV$
      PRINT "  Error is -- ";

      IF ERR = 1 THEN PRINT "Next without For coding error"
      IF ERR = 2 THEN PRINT "Coding Syntax error"
      IF ERR = 3 THEN PRINT "Return without Gosub"
      IF ERR = 4 THEN PRINT "Out of DATA"
      IF ERR = 5 THEN PRINT "Illegal function call"
      IF ERR = 6 THEN PRINT "Overflow"
      IF ERR = 7 THEN PRINT "out of memory"
      IF ERR = 8 THEN PRINT "Undefined line number coding error"
      IF ERR = 9 THEN PRINT "SUBSCRIPT OUT OF RANGE "; N
      IF ERR = 10 THEN PRINT "Duplicate definition coding error"
      IF ERR = 11 THEN PRINT "Division by Zero"
      IF ERR = 14 THEN PRINT "Out of string space"
      IF ERR = 15 THEN PRINT "String too long.  255 max"
      IF ERR = 23 THEN PRINT "Line buffer overflow"
      IF ERR = 24 THEN PRINT "Device Time-out"
      IF ERR = 25 THEN PRINT "device fault"
      IF ERR = 27 THEN PRINT "Out of paper"
      IF ERR = 50 THEN PRINT "FIELD overflow."
      IF ERR = 51 THEN PRINT "Internal error"
      IF ERR = 52 THEN 14740 ' " = DISK ERRORS"
      IF ERR = 53 THEN 14740
      IF ERR = 54 THEN 14740
      IF ERR = 55 THEN 14740
      IF ERR = 56 THEN PRINT "Field Statement active"
      IF ERR = 57 THEN PRINT "device I/O error"
      IF ERDEV = 10 THEN PRINT " Printer off line?"
      IF ERR = 58 THEN 14740
      IF ERR = 59 THEN 14740
      IF ERR = 61 THEN 14740
      IF ERR = 62 THEN 14740
      IF ERR = 63 THEN 14740
      IF ERR = 64 THEN GOTO 14740: ' fileerr
      IF ERR = 67 THEN 14740
      IF ERR = 68 THEN PRINT "Device unavailable. Is there a D: directory for the temporary stuff?"
      IF ERR = 69 THEN PRINT "Comm buffer overflow."
      IF ERR = 70 THEN GOTO 14740
      IF ERR = 71 THEN GOTO 14740: ' "Disk ERRORS
      IF ERR = 72 THEN GOTO 14740:
      IF ERR = 73 THEN PRINT "Advanced feature unavailable."
      IF ERR = 74 THEN PRINT "Rename across disks.   see programming manual."
      IF ERR = 75 THEN GOTO 14740:
      IF ERR = 76 THEN GOTO 14740:
      GOTO 15000

14740 'fileerr:
      PRINT "File Related Error # "; ERR; "  at or after line "; ERL; "."
      PRINT "  Error is -- ";
      SHELL "cat"
      PRINT "File Related Error # "; ERR; "  at or after line "; ERL; "."
      PRINT "  Error is -- ";

      IF ERR = 52 THEN PRINT "Bad file name or number."
      IF ERR = 53 THEN PRINT "FILE NOT FOUND. -- "; WRONGFILE$
      IF ERR = 54 THEN PRINT "Bad File Mode."
      IF ERR = 55 THEN PRINT "file already open. -- "; WRONGFILE$
      IF ERR = 58 THEN PRINT "File already exists. -- "; WRONGFILE$
      IF ERR = 59 THEN PRINT "Bad record length."
      IF ERR = 61 THEN PRINT "Disk Full."
      IF ERR = 62 THEN PRINT "Input past end of file."
      IF ERR = 63 THEN PRINT "Bad record number."
      IF ERR = 64 THEN PRINT "Bad file name. Check format."
      IF ERR = 67 THEN PRINT "Too many files."
      IF ERR = 71 THEN PRINT "Disk Not Ready."
      IF ERR = 70 THEN PRINT "Permission denied.   Read only file?  Disk Write protected?": SHELL " attrib " + WRONGFILE$
      IF ERR = 72 THEN PRINT "Disk Media Error."
      IF ERR = 75 THEN PRINT "path / file access error.  Read only file? -- ": SHELL "attrib " + WRONGFILE$
      IF ERR = 76 THEN PRINT "Path  not found."
      PRINT "File troubles usually are path or file name errors."
      PRINT "  Do you need a \ or c:\ in the path?"
      PRINT "  Does the disk directory exist, especially ramdisks.  D:?"
      PRINT "  Is the file on another directory?"
      PRINT "TROUBLE is most likely in NAME or PATH of   "; WRONGFILE$
      GOTO 15000

15000 INPUT "Fix Problem.  Then CR to continue   X or Q to quit. "; Q$:
      Q$ = UCASE$(Q$)
      IF Q$ = "X" THEN SYSTEM
      IF Q$ = "Q" THEN SYSTEM
      RESUME   ' back to line from whence the error occured


ENDSONG:  '[-------- end song --------]
    RANDOMIZE TIMER
    FOR Q = 1 TO 25: SOUND INT(2500 - 200) * RND + 200, 4: NEXT Q
    SOUND 32000, 15
    
     SOUND 2000, 1: SOUND 32000, 2: SOUND 2000, 3: SOUND 32000, 2
     SOUND 2000, 1: SOUND 32000, 2: SOUND 2000, 3: SOUND 32000, 2
     SOUND 2000, 1: SOUND 32000, 2  ' .-.-.
     LOCATE 24, 1: PRINT "--- DONE ---"
     Q& = TIMER + 1:
DOOLAY: IF TIMER < Q& THEN GOTO DOOLAY
     RETURN
     '---------]


15170 '[-----------  clock an calendar -----------](subroutine)
      '   CLOCK AND CALENDAR PROGRAM,     MAY, 1987
      '      BY BRUCE ROSS, SEATTLE, WASHINGTON
      ' NOTES:
      ' J2& = Julian date.   day 1 is Jan 1, 1900
      ' x& names are used to distinguish between variables of calling
      ' program and local variables.  some x& are intrinsically integers.

      ' for any date -- Julian = set Y= year :M= day ' enter at d&=d ---
      ' for reverse Julian, J2& = Julian date        ' enter at m9=0 ---
     
15440 ' [-------- the calendar function --------]
      '         -- day of week fugurer --
      ' day$ (aaa), day (nn), month  (nn), year (19nn)
      ' DATE$                    ' DATE FROM DOS CLOCK
      M = VAL(LEFT$(DATE$, 2))   ' MONTH # FROM DATE$
      D = VAL(MID$(DATE$, 4, 2)) ' DAY # FROM DATE$
      Y = VAL(RIGHT$(DATE$, 4))  ' YEAR# FROM DATE$

15520 'calculate julian date from calendar.    Y, M, D ---> J2
      D& = D: M9 = 0: C9! = .0001:
      IF M < 3 THEN M9 = -1  ' jan-feb
      J1& = D& - 2447095 + INT((1461& * (Y + 4800& + M9) / 4) + C9!)
      J2& = J1& + INT((367 * (M - 2 - 12 * M9) / 12) + C9!)
      J1& = J2& - INT((3 * (Y + 4900& + M9) / 400&) + C9!)
      J2& = J1& '  Julian date.  day 1 is Jan 1, 1900
      W& = INT(J2& - 7 * INT((J1& / 7) + C9!) + 1 + C9!) ' 1-7 day # 1-7
     
15630 ' calculate  calendar date from julian date. j2& ---> y&, m& , dx& .  1/1/1900 = 1
      M9 = 0: C9! = .0001:
      Y& = INT(J2& / 365.25 + C9!): RESTORE 16010: IF Y& / 4 = INT(Y& / 4) THEN M9 = 1: RESTORE 16020 ' leep year
      M& = J2& - INT(Y& * 365.25 + C9!) + M9  ' day into year
      FOR Z = 1 TO 12: READ DX&: M& = M& - DX&: IF M& < 1 THEN M& = M& + DX&: GOTO 15690
      NEXT Z
15690 DX& = M&: M& = Z  ' day and month #
      RESTORE 15980: FOR Z = 1 TO M&: READ MN$: NEXT Z ' Name of month
      RESTORE 15981: FOR Z = 1 TO W&: READ W$: NEXT Z  ' Name of day
      TIHM$ = TIME$: TIHM$ = MID$(TIHM$, 1, INSTR(INSTR(TIHM$, ":") + 1, TIHM$, ":") - 1): ' hour:min
      PRINT MN$; DX&; ","; Y& + 1900; "  "; TIHM$
      RETURN

      '[-------- add time of day to date ----------]
      T$ = TIME$
      GOSUB 15810:                     ' clock and AM-PM
      DANDT$ = W$ + "  " + MN$ + STR$(DX&) + "," + STR$(Y& + 1900) ' date
      DANDT$ = DANDT$ + "  " + T$ + Z$ ' plus time
      PRINT DANDT$                     ' date and time on one line
      PRINT " Julian date ="; J2&
      RETURN                           ' from clock & calendar

15810 ' [------- AM-PM --- clock -------]
      ' 12:00 and 12.01 (night) are AM.  12.00 and 12:01 (noon) are PM
      H = VAL(LEFT$(T$, 2))            ' hour
      MINUTE = VAL(MID$(T$, 4, 2))     ' minute
      HS$ = STR$(H)
      HS$ = RIGHT$(HS$, LEN(HS$) - 1)  ' hour print string
      MIN$ = RIGHT$(T$, 6)             ' minute + second print string
      MIN$ = LEFT$(MIN$, 3)            ' minutes only
      Z$ = "": HS$ = RIGHT$("00" + HS$, 2) ' if am-pm not used
                GOTO 15950             ' bypass am-pm
       Z$ = " AM"
       IF H = 0 THEN HS$ = STR$(12)    ' midnight to 1 am to display as 12 am
       IF H <= 12 THEN 15950
       IF H > 12 THEN HS$ = STR$(H - 12) ' display afternoon as 12 -- 11 pm
15950 T$ = RIGHT$(HS$ + MIN$, 8)       ' time print string
      
15980 DATA "JAN","FEB","MAR","APR","MAY","JUN"
      DATA "JUL","AUG","SEP","OCT","NOV","DEC"
15981 DATA "SUN","MON","TUE","WED","THU","FRI","SAT"
16010 DATA 31,28,31,30,31,30,31,31,30,31,30,31
16020 DATA 31,29,31,30,31,30,31,31,30,31,30,31

      RETURN
      '---------]
      '"""""""""""""""""""""""""""""""""""""""
' END OF CODE