Compress or expand an ascii bas file utility - FreeWare, listed 07-22-2004

   10 ' compexpa.bas - FreeWare 2004
   20 GOTO 150 ' begin
   30 SAVE "compexpa":LIST-120
   40 GOTO 180 ' center text
   50 GOTO 290 ' reject duplicates
   60 GOTO 360 ' reject non-ascii files
   70 GOTO 420 ' remove excess spaces
   80 GOTO 580 ' make line numbers to five digits
   90 GOTO 590 ' 0000
  100 GOTO 1580 ' expand start
  110 GOTO 1610 ' expand 2
  120 GOTO 1630 ' expand 3
  130 GOTO 2640 ' get key input

  140 ' Begin
  150 DEFINT B-K,S-Z:DEFSTR Q:Q=MKI$(0)
  160 DIM LIN$(1500),REFERENCE(1200):GOTO 640

  170 ' Center text on screen
  180 PRINT TAB(40-LEN(CENTER$)/2)CENTER$:RETURN

  190 ' Handle errors in program
  200 IF ERR=53 THEN RESUME 240
  210 COLOR 7,0,0
  220 CLS:CENTER$="Critical error * * * program terminated":LOCATE 14,1:GOSUB 40
  230 LOCATE 24,1:PRINT ERR,ERL:END
  240 CLS:CENTER$=FILE$+" Program not found":LOCATE 14,1:COLOR 12:GOSUB 40
  250 PRINT:PRINT:COLOR 14
  260 IF CHOICE=1 THEN 940
  270 IF CHOICE=2 THEN 1670

  280 ' Reject duplicate file names for input and output files
  290 BEEP
  300 CLS:CENTER$="Original file and new file cannot have same name"
  310 COLOR 31:GOSUB 40:CENTER$="Press any key to continue"
  320 LOCATE 20,1:COLOR 14:GOSUB 40
  330 GOSUB 130
  340 CLS:LOCATE 14,1:RETURN

  350 ' Reject files not saved in ascii format
  360 CLOSE:BEEP:CLS:COLOR 31
  370 CENTER$="**** "+FILE$+" Is not an ascii file ****":GOSUB 40:COLOR 14
  380 CENTER$="Press any key to continue":LOCATE 20,1:GOSUB 40
  390 GOSUB 130
  400 LOCATE 14,1:RETURN

  410 ' Remove excess spaces
  420 START=INSTR(C$," ")+1
  430 SPACE=INSTR(START,C$," "):IF SPACE=NO THEN 560
  440 STARTQUOTE=INSTR(START,C$,EQ$):IF STARTQUOTE=0 THEN 480
  450 ENDQUOTE=INSTR(STARTQUOTE+1,C$,EQ$):IF ENDQUOTE=0 THEN 560
  460 IF SPACE<STARTQUOTE THEN 480
  470 IF SPACE<ENDQUOTE THEN START=ENDQUOTE+1:GOTO 430
  480 BEFORE$=MID$(C$,SPACE-1,1):IF INSTR("+-=></:; ",BEFORE$)=0 THEN 510
  490 C$=MID$(C$,1,SPACE-1)+MID$(C$,SPACE+1,LEN(C$)):GONE=GONE+1
  500 IF SPACE-1<START THEN START=SPACE-1
  510 SPACE=INSTR(START,C$," "):IF SPACE=NO THEN 560
  520 AFTER$=MID$(C$,SPACE+1,1):IF INSTR("+-=></:; ",AFTER$)=0 THEN 540
  530 C$=MID$(C$,1,SPACE-1)+MID$(C$,SPACE+1,LEN(C$)):GONE=GONE+1
  540 IF GONE<>0 THEN START=SPACE+1-GONE:GONE=0:GOTO 430
  550 START=SPACE+1:GOTO 430
  560 RETURN

  570 ' Standardize line numbers to five digits
  580 SPACE=INSTR(LIN$(I)," "):NUM$=LEFT$(LIN$(I),SPACE-1)
  590 NUM$="0000"+NUM$
  600 Z=INSTR(NUM$," "):IF Z<>0 THEN MID$(NUM$,Z,1)="0":GOTO 600
  610 NUM$=RIGHT$(NUM$,5):IF SHORT=1 THEN SHORT=0:RETURN
  620 LIN$(I)=NUM$+" "+MID$(LIN$(I),SPACE+1,LEN(LIN$(I))):RETURN

  630 ' Initialize screen format and layout
  640 ON ERROR GOTO 200 ' "             É               Í         »
  650 YES=1:NO=0:EQ$=CHR$(34):TOP$=CHR$(201)+STRING$(78,205)+CHR$(187)
  660 BOTTOM$=CHR$(200)+STRING$(78,205)+CHR$(188):SIDE$=CHR$(186)
  670 COLOR 3,1,1:KEY OFF ' È      Í         ¼               º
  680 CLS:LOCATE 4,1:CENTER$="COMPEXPA.BAS - FreeWare 2004":COLOR 12:GOSUB 40
  690 CENTER$="An expanding / compressing utility":COLOR 14:GOSUB 40
  700 CENTER$="for basic programs saved in ascii format"
  710 COLOR 12:GOSUB 40:COLOR 11:LOCATE 2,1
  720 PRINT TOP$
  730 FOR I=3 TO 7:LOCATE I,1:PRINT SIDE$;:LOCATE I,80:PRINT SIDE$;:NEXT
  740 PRINT BOTTOM$:COLOR 14
  750 PRINT TAB(20)"Do you wish to      1) expand a program":PRINT
  760 PRINT TAB(20)"Do you wish to      2) compress a program":PRINT
  770 PRINT TAB(20)"Do you wish to      3) return to basic prompt":PRINT
  780 PRINT TAB(20)"Do you wish to      4) return to dos prompt"
  790 GOSUB 130
  800 EN=VAL(Q):CHOICE=EN:IF EN<0 OR EN>4 THEN 790
  810 IF EN=4 THEN COLOR 7,8,0:CLS:SYSTEM
  820 IF EN<>3 THEN 860
  830 COLOR 7,8,0
  840 KEY 5,"compexpa.bas":KEY 6,CHR$(34)+",a":KEY ON:CLS:END

  850 ' Expand a program
  860 IF EN=2 THEN 1660 ELSE CLS
  870 CENTER$="MAKE SURE you have done these 2 steps:":COLOR 12:GOSUB 40:PRINT
  880 CENTER$="1. Bas listing has been renumbered 50,,50":COLOR 14:GOSUB 40
  890 CENTER$="2. Program has been saved in ASCII format":GOSUB 40:PRINT
  900 CENTER$="Press any key to expand, or q/Q to quit":COLOR 15:GOSUB 40
  910 GOSUB 130
  920 IF ASC(Q)=113 OR ASC(Q)=81 THEN 830 ' q Q
  930 CLS:FILES "*.bas"
  940 INPUT "Enter name of program you wish to have expanded";FILE$
  950 PRINT:IF FILE$="" THEN SCREEN 0,0,0:CLS:END
  960 COLOR 11:INPUT "Enter name of new file to hold expanded program";NEWFILE$
  970 IF FILE$<>NEWFILE$ THEN 1000
  980 GOSUB 50 ' reject duplicate file names
  990 GOTO 940
 1000 CLS:LOCATE 14,1:COLOR 14:PS=INT(LEN(FILE$)+13)/2:LOCATE 14,40-PS
 1010 PRINT "Now loading: ";:COLOR 11:PRINT FILE$:OPEN"I",1,FILE$
 1020 FOR I=1 TO 5000:IF EOF(1) THEN 1080
 1030  NL=NL+1:LOCATE 16,40:PRINT I:LINE INPUT #1,LIN$(I)
 1040  IF ASC(LIN$(I))<=58 THEN 1070
 1050  GOSUB 60 ' reject non-ascii files
 1060  GOTO 940
 1070 NEXT
 1080 CLOSE:CLS
 1090 CENTER$="Standardizing line numbers to five digits":LOCATE 14,1:GOSUB 40
 1100 CENTER$="Please wait":LOCATE 16,1:GOSUB 40

 1110 ' Standardize line numbers to five digits
 1120 FOR I=1 TO NL:GOSUB 80:NEXT

 1130 ' Expand lines of selected program
 1140 SL=NL:INC=1:CLS:LOCATE 14,6:PRINT "Now processing line number: ":COLOR 14
 1150 FOR I=1 TO NL:LL=VAL(LIN$(I)):LOCATE 14,45:COLOR 14
 1160  PRINT LL
 1170  STARTQUOTE=INSTR(LIN$(I),EQ$):ENDQUOTE=INSTR(STARTQUOTE+1,LIN$(I),EQ$)
 1180  IF STARTQUOTE<>0 AND ENDQUOTE=0 THEN 1330
 1190  J=INSTR(LIN$(I),CHR$(58)):IF STARTQUOTE=0 THEN 1220      '58 = :
 1200  IF J<STARTQUOTE THEN 1220
 1210  IF J<ENDQUOTE THEN J=INSTR(ENDQUOTE+1,LIN$(I),CHR$(58))  ':
 1220  IF J=0 AND CH=0 THEN 1330
 1230  F=INSTR(LIN$(I),CHR$(73)+CHR$(70)+CHR$(32))              '73 70 =IF
 1240  IF F<>0 AND F<J AND CH=0 THEN 1330
 1250  IF F<>0 AND F<J AND CH<>0 THEN GOSUB 120:GOTO 1320
 1260  IF J=0 AND CH=0 THEN 1330
 1270  IF J=0 AND CH<>0 THEN GOSUB 110:GOTO 1320
 1280  IF J<>0 THEN GOSUB 100
 1290  IF J=0 AND CH<>0 THEN 1320
 1300  LIN$(I)=MID$(LIN$(I),J+1,LEN(LIN$(I))):IF J=0 AND CH<>0 THEN 1320
 1310  GOTO 1170
 1320  IF CH<>0 THEN LIN$(I)=FIRST$
 1330  CH=0
 1340 NEXT:N=SL

 1350 ' Sort program lines
 1360 CLS:CENTER$="Rearranging program lines":LOCATE 14,1:GOSUB 40
 1370 SORT0=N:SORT1=SORT0
 1380 SORT1=SORT1\2:IF SORT1=0 THEN 1450
 1390 SORT2=SORT0-SORT1
 1400 FOR SORT3=1 TO SORT2:SORT4=SORT3
 1410  SORT5=SORT4+SORT1:IF LIN$(SORT4)<=LIN$(SORT5) THEN 1430
 1420  SWAP LIN$(SORT4),LIN$(SORT5):SORT4=SORT4-SORT1:IF SORT4>0 THEN 1410
 1430 NEXT:GOTO 1380

 1440 ' Save expanded file
 1450 CLS:LOCATE 14,1:PS=INT(LEN(NEWFILE$)+12)/2:LOCATE 14,40-PS
 1460 PRINT "Now saving: ";:COLOR 11:PRINT NEWFILE$:OPEN"O",1,NEWFILE$
 1470 FOR I=1 TO SL:PRINT #1,LIN$(I):NEXT:CLOSE
 1480 CLS:CENTER$="Do you want to load "+NEWFILE$+"?":LOCATE 14,1:GOSUB 40
 1490 GOSUB 130
 1500 IF ASC(Q)=121 OR ASC(Q)=89 THEN 1530 ' y Y
 1510 IF ASC(Q)=110 OR ASC(Q)=78 THEN RUN  ' n N
 1520 GOTO 1490
 1530 COLOR 7,0,0:CLS:LOCATE 14,1
 1540 CENTER$="At basic prompt, type "+EQ$+"renum "+EQ$:GOSUB 40:LOCATE 20,1
 1550 LOAD NEWFILE$
 1560 END

 1570 ' Code to expand program
 1580 CH=CH+1:IF CH=1 THEN LL$=(MID$(LIN$(I),1,J-1)):FIRST$=LL$:RETURN
 1590 LL=LL+INC:NUM$=STR$(LL):SHORT=1:GOSUB 90 ' standardize line numbers
 1600 LL$=NUM$+" "+MID$(LIN$(I),1,J-1):SL=SL+1:LIN$(SL)=LL$:RETURN
 1610 CH=CH+1:LL=LL+INC:NUM$=STR$(LL):SHORT=1:GOSUB 90
 1620 LL$=NUM$+" "+LIN$(I):SL=SL+1:LIN$(SL)=LL$:RETURN
 1630 LL=LL+INC:NUM$=STR$(LL):SHORT=1:GOSUB 90
 1640 LL$=NUM$+" "+LIN$(I):SL=SL+1:LIN$(SL)=LL$:RETURN

 1650 ' Code to compress program lines
 1660 CLS:FILES "*.bas"
 1670 LINE INPUT "Enter name of the program to be compressed : ";FILE$
 1680 PRINT:IF FILE$="" THEN SCREEN 0,0,0:CLS:END
 1690 COLOR 11
 1700 LINE INPUT "Enter name for the final compressed program : ";NEWFILE$
 1710 IF FILE$<>NEWFILE$ THEN 1740
 1720 GOSUB 50 ' reject duplicate file names
 1730 GOTO 1670
 1740 CLS:LOCATE 14,1
 1750 CENTER$="Do you wish to delete unnecessary spaces ?":GOSUB 40
 1760 GOSUB 130
 1770 IF ASC(Q)=121 OR ASC(Q)=89 THEN DOSPACE=YES ELSE DOSPACE=NO
 1780 PRINT:CENTER$="Do you wish to delete remark statements ?":GOSUB 40
 1790 GOSUB 130
 1800 IF ASC(Q)=121 OR ASC(Q)=89 THEN DOREMARK=YES ELSE DOREMARK=NO
 1810 CLS:LOCATE 14,1:CENTER$="Making list of reserved lines":GOSUB 40
 1820 CENTER$="Please wait":LOCATE 16,1:GOSUB 40:OPEN "I",1,FILE$
 1830 IF EOF(1) THEN 2120
 1840 LINE INPUT #1,A$:IF ASC(A$)<=58 THEN 1870
 1850 GOSUB 60 ' reject non-ascii files
 1860 GOTO 1670
 1870 START1=1:START2=1:START3=1:START4=1:START5=1:START6=1
 1880 STANDARD=4
 1890 FOUND=INSTR(START1,A$,"THEN")
 1900 IF FOUND THEN START1=FOUND+STANDARD:GOTO 2020
 1910 FOUND=INSTR(START2,A$,"GOTO")
 1920 IF FOUND THEN START2=FOUND+STANDARD:GOTO 2020
 1930 FOUND=INSTR(START3,A$,"ELSE")
 1940 IF FOUND THEN START3=FOUND+STANDARD:GOTO 2020
 1950 FOUND=INSTR(START4,A$,"GOSUB")
 1960 IF FOUND THEN STANDARD=5:START4=FOUND+STANDARD:GOTO 2020
 1970 FOUND=INSTR(START5,A$,"RESUME")
 1980 IF FOUND THEN STANDARD=6:START5=FOUND+STANDARD:GOTO 2020
 1990 FOUND=INSTR(START6,A$,"RUN")
 2000 IF FOUND THEN STANDARD=3:START6=FOUND+STANDARD:GOTO 2020
 2010 GOTO 1830
 2020 THISREF=VAL(MID$(A$,FOUND+STANDARD)):IF THISREF=0 THEN 1880
 2030 FOR CHECK=1 TO TOTALREF
 2040  IF REFERENCE(CHECK)<>THISREF THEN NEXT CHECK ELSE 2060
 2050 TOTALREF=TOTALREF+1:REFERENCE(TOTALREF)=THISREF
 2060 FOUND=FOUND+STANDARD:STANDARD=1
 2070 FOUND1=INSTR(FOUND,A$,",")
 2080 FOUND2=INSTR(FOUND,A$,":")
 2090 IF FOUND1=0 THEN 2110
 2100 IF (FOUND2=0 OR FOUND1<FOUND2) THEN FOUND=FOUND1:GOTO 2020
 2110 GOTO 1880
 2120 CLOSE

 2130 ' Sort reserved line numbers
 2140 CLS:CENTER$="Sorting reserved line numbers":LOCATE 14,1:GOSUB 40
 2150 SORT0=TOTALREF:SORT1=SORT0
 2160 SORT1=SORT1\2:IF SORT1=0 THEN 2240
 2170 SORT2=SORT0-SORT1
 2180 FOR SORT3=1 TO SORT2:SORT4=SORT3
 2190  SORT5=SORT4+SORT1:IF REFERENCE(SORT4)>REFERENCE(SORT5) THEN 2220
 2200  SWAP REFERENCE(SORT4),REFERENCE(SORT5):SORT4=SORT4-SORT1
 2210  IF SORT4>0 THEN 2190
 2220 NEXT:GOTO 2160

 2230 ' Prepare compressed file
 2240 OPEN "I",1,FILE$:OPEN "O",2,NEWFILE$:CLS
 2250 IF EOF(1) THEN 2540
 2260 LINE INPUT #1,A$:IF DOREMARK=NO THEN 2370
 2270 IF INSTR(A$," REM ") THEN 2250
 2280 FIRSTSPACE=INSTR(A$," "):IF MID$(A$,FIRSTSPACE+1,1)="'" THEN 2250
 2290 SPOT=1
 2300 STARTQUOTE=INSTR(SPOT,A$,EQ$):IF STARTQUOTE=0 THEN 2320
 2310 ENDQUOTE=INSTR(STARTQUOTE+1,A$,EQ$):IF ENDQUOTE=0 THEN 2370
 2320 AP=INSTR(SPOT,A$,"'")
 2330 IF AP=0 THEN 2370
 2340 IF STARTQUOTE=0 THEN 2360
 2350 IF STARTQUOTE<AP AND ENDQUOTE>AP THEN SPOT=ENDQUOTE+1:GOTO 2300
 2360 A$=MID$(A$,1,AP-1)
 2370 FOR CHECK=INSTR(A$," ") TO LEN(A$)-1
 2380  IF MID$(A$,CHECK+1,1)=" " THEN NEXT CHECK
 2390 CUT=CHECK:LN=VAL(A$):LOCATE 14,21:COLOR 11
 2400 PRINT "Now processing line number: ";:COLOR 12:PRINT LN
 2410 IF C$="" THEN C$=A$:GOTO 2250
 2420 IF TOTALREF=0 THEN 2450
 2430 IF LN=REFERENCE(TOTALREF) THEN TOTALREF=TOTALREF-1:GOTO 2520
 2440 IF LN>REFERENCE(TOTALREF) THEN TOTALREF=TOTALREF-1:GOTO 2420
 2450 IF INSTR(C$,"RETURN") OR INSTR(C$,"DATA") THEN 2520
 2460 IF INSTR(C$,"IF ") OR INSTR(C$,"REM ") OR INSTR(C$,"'") THEN 2520

 2470 ' Length of compressed line < 80 to 255 (Set at 130)
 2480 V$=RIGHT$(A$,LEN(A$)-CUT)
 2490 IF LEN(C$)+LEN(V$)<100 THEN C$=C$+":"+V$ ELSE GOTO 2520
 2500 GOTO 2250

 2510 ' Write to diskfile
 2520 IF DOSPACE=YES THEN GOSUB 70 ' remove excess spaces
 2530 PRINT #2,C$:C$=A$:GOTO 2250
 2540 IF DOSPACE=YES THEN GOSUB 70
 2550 PRINT #2,C$:CLOSE
 2560 CLS:CENTER$="Do you want to load "+NEWFILE$+"?":LOCATE 14,1:GOSUB 40
 2570 GOSUB 130
 2580 IF ASC(Q)=121 OR ASC(Q)=89 THEN 2590 ELSE RUN
 2590 COLOR 7,0,0:CLS:LOCATE 14,1
 2600 CENTER$="At basic prompt, type "+EQ$+"renum "+EQ$:GOSUB 40:LOCATE 20,1
 2610 LOAD NEWFILE$
 2620 END

 2630 ' get key
 2640 LSET Q=MKI$(0)
 2650 WHILE CVI(Q)=0:MID$(Q,1)=INKEY$:WEND
 2660 RETURN

 2670 ' MAKEOVER.BAS - compexpa.bas by Eric F. Tchong - September 3, 1996
 2680 ' Written by Robert W. Gipson       
 2690 ' 2549 Dixie Highway, Lakeside Park, KY 41017
 2700 ' Thanks Robert for such a fine utility - FREEWARE 2004