100 ' CoCo Usenet Transfer Utility
110 ' CUTS-format encoder/decoder for Color Computer 3 by Tim Koonce
120 ' Released into Public Domain  23 March, 1988
140 '
150 ' Updated for faster decoding - October 2, 1988
160 ' Faster decoding with dir updates for .BIN - October 29, 1988
180 ' Updated for faster encoding - December 26, 1988 - James Connolly
190 '
200 ' The purpose of this program is to translate ascii and binary files
210 ' to/from a format which has been designed for easy transferral over
220 ' electronic mail networks.
230 '
510 WIDTH80:RGB:VERIFY ON:CLS3:PALETTE8,63:PALETTE2,8:POKE65497,0
540 PCLEAR1:CLEAR 300,&H7AFF
600 GOSUB 5000:GOSUB 6000:PRINT"Type RUN again":DEL600
610 DEFUSR1=&H7F00
620 DEFUSR2=&H7FC8
630 DEFUSR3=&H7D35
640 DEFUSR4=&H7D50
650 POKE65496,0
1000 CLEAR 3000
1010 DIM CD$(255) : AC$="!"+CHR$(34)+"#$%&'("
1020 MT$="JanFebMarAprMayJunJulAugSepOctNovDec"
1030 PRINT:PRINT:PRINT:PRINT" CUTS3 Encoder/Decoder"
1040 PRINT:PRINT"Written by: Tim Koonce         April 1988"
1050 PRINT"Updated by: James Connolly  December 1988":PRINT
1060 PRINT"1)Encode a file into CUTS format"
1070 PRINT"2)Decode a CUTS file"
1080 PRINT"3)Print directory"
1090 PRINT"4)End this program"
1100 PRINT:PRINT"Select 1,2,3, or 4.":PRINT
1110 A$=INKEY$:IF A$="" THEN 1110
1120 IF A$="4" THEN END
1130 ON VAL(A$) GOSUB 3000,4000,2000
1140 GOTO 1110
2000 '
2010 'Print a directory
2030 PRINT"Drive for directory?"
2040 A$=INKEY$:IF INSTR("0123",A$)=0 OR A$="" THEN 2040
2050 DIR VAL(A$) : PRINT"Free space: "FREE(VAL(A$))
2060 PRINT"Press any key to continue"
2070 A$=INKEY$:IF A$<>"" THEN 2070
2080 A$=INKEY$:IF A$="" THEN 2080
2090 RUN
3000 '
3010 'Encode a file
3030 PRINT"Filename of file to encode :":LINEINPUT F$
3040 PRINT"What type of file is this?"
3050 PRINT" 1) ASCII text"
3060 PRINT" 2) RSDOS machine language program"
3070 PRINT" 3) OS9 module"
3080 PRINT" 4) Other BINary file"
3090 A$=INKEY$:IF INSTR("1234",A$)=0 OR A$=""  THEN 3090
3100 TY$=MID$("ASCRSDOS9BIN",VAL(A$)*3-2,3)
3110 PRINT"Filename of CUTS output file :";:LINEINPUT OF$
3120 FF$=OF$ : EX$=".CUT" : GOSUB 4760 : OF$=FF$
3130 '
3140 'Encode a file
3160 GOSUB 3830
3170 EXEC &H7C67 ' initialize the .0001.D string
3180 OPEN"R",1,F$,1 : II=1 : FIELD #1,1 AS CH$ : IL=LOF(1)
3190 OPEN"O",2,OF$
3200 '
3210 'Output comments
3230 PRINT"Type in comments to be inserted at beginning of file "
3240 PRINT"A blank line ends comments."
3250 PRINT" :> ";:LINEINPUT A$
3260 IF A$<>"" THEN PRINT#2,A$ : GOTO 3250
3270 '
3280 ' Construct 'I' packet
3300 INPUT"Last two digits of Year ";YR
3310 INPUT"Number of current Month ";MN
3320 INPUT"Day of Month ";DY
3330 A$=".0000.I.A"+STRING$(69,".")
3340 MID$(A$,11,2)=RIGHT$("0"+RIGHT$(STR$(YR),LEN(STR$(YR))-1),2)
3350 MID$(A$,13,2)=RIGHT$("0"+RIGHT$(STR$(MN),LEN(STR$(MN))-1),2)
3360 MID$(A$,15,2)=RIGHT$("0"+RIGHT$(STR$(DY),LEN(STR$(DY))-1),2)
3370 MID$(A$,18,3)=TY$
3380 IF INSTR(F$,":")>0 THEN F1$=LEFT$(F$,INSTR(F$,":")-1) ELSE F1$=F$
3390 MID$(A$,22,LEN(F1$)+2)=CHR$(34)+F1$+CHR$(34)
3400 GOSUB 3760:L0$=A$+CS$
3410 PRINT#2,L0$ : PRINT LEFT$(L0$,5);
3420 '
3430 'Now encode rest of file
3450 A$=STRING$(255,0)
3460 IF IL<105 THEN GOTO 3580
3470 CLOSE #1
3480 OPEN"R",1,F$,105 : FIELD #1,105 AS CH$
3490 FOR II = 1 TO INT(IL/105)
3500 GET #1,II
3510 IF USR3(VARPTR(A$)) THEN PRINT"Encoding error - pass a 255 byte variable"
3520 L=USR4(VARPTR(CH$)) : PRINT IL-II*105;
3530 PRINT#2,LEFT$(A$,L);
3540 NEXT II
3550 CLOSE #1
3560 IF IL/105 = INT(IL/105) THEN GOTO 3660
3570 OPEN"R",1,F$,1 : FIELD #1,1 AS CH$
3580 B$=""
3590 FOR II=INT(IL/105)*105+1 TO IL
3600 GET #1,II : B$=B$+CH$
3610 NEXT II
3620 CLOSE #1
3630 IF USR3(VARPTR(A$)) THEN PRINT"Encoding error - pass a 255 byte variable"
3640 L=USR4(VARPTR(B$))
3650 PRINT#2,LEFT$(A$,L);
3660 B$=""
3670 IF USR3(VARPTR(A$)) THEN PRINT"Encoding error - pass a 255 byte variable"
3680 L=USR4(VARPTR(B$))
3690 PRINT#2,LEFT$(A$,L);
3700 '
3710 ' Now repeat first line
3730 PRINT#2,L0$ : PRINT LEFT$(L0$,5)
3740 CLOSE
3750 RUN
3760 '
3770 'Calculate checksum of A$ and return as CS$
3790 CS=0
3800 FOR I=1 TO LEN(A$) : CS=CS+ASC(MID$(A$,I)) : NEXT I
3810 CS$=CHR$( (CS AND 31) + 48 )
3820 RETURN
3830 '
3840 ' Generate coding array
3860 FOR I=0 TO 7 : FOR J=0 TO 31
3870 CD$(I*32+J)=CHR$(I+&H21)+CHR$(&H30+J)
3880 NEXT J,I
3890 FOR I=&H2A TO &H5A : CD$(I)=CHR$(I) : NEXT I
3900 FOR I=&H61 TO &H7A : CD$(I)=CHR$(I) : NEXT I
3910 CD$(32)=CHR$(32)
3920 RETURN
4000 '
4010 ' Decode a file
4030 PRINT"Name of CUTS-encoded file to decode :":LINEINPUTF$
4040 FF$=F$:EX$=".CUT":GOSUB 4760: OPEN"I",1,FF$
4050 N0$=".0000." : L0$="" : F0=0
4060 LN=0 ' Start with Line 0
4070 LN$="."+RIGHT$("000"+MID$(STR$(LN),2),4)+"."
4080 IF EOF(1) THEN PRINT:PRINT"Warning: Unexpected end of file":CLOSE:RUN
4090 LINEINPUT#1,A$ : A$=LEFT$(A$,79)
4100 IF A$=L0$ AND F0 THEN PRINT:PRINT"Finished decoding":CLOSE:RUN
4110 IF LEFT$(A$,6)<>LN$ THEN PRINT A$:GOTO4080 ELSE PRINT LEFT$(LN$,5);
4120 IF LN=0 THEN F0=-1 : L0$=A$
4130 IF LEN(A$)>=79 THEN 4180
4140 PRINT:PRINT"Warning: Line"LN" is too short.":PRINT
4150 INPUT"Do you wish to continue (Y/N)";II$
4160 IF INSTR("Yy",LEFT$(II$,1)) THEN 4170 ELSE CLOSE: RUN
4170 A$=A$+STRING$(79-LEN(A$),".")
4180 C1$=MID$(A$,79,1)
4190 'A$=LEFT$(A$,78) : GOSUB 10000
4200 IF USR2(VARPTR(A$)) THEN 4240
4210 PRINT:PRINT"Warning: Line"LN" has a bad checksum.":PRINT
4220 INPUT"Do you wish to continue (Y/N)";II$
4230 IF INSTR("Yy",LEFT$(II$,1)) THEN 4240 ELSE CLOSE : RUN
4240 PK$=MID$(A$,7) 'Separate Packet
4250 IF LEFT$(PK$,1)="I" THEN GOSUB 4320 : LN=LN+1 : GOTO 4070
4260 IF LEFT$(PK$,1)="D" THEN 4290
4270 PRINT"Unrecognized Packet Type "LEFT$(PK$,1)" in Line"LN
4280 LN=LN+1 : GOTO 4070
4290 PK$=MID$(PK$,2)
4300 IF LEN(PK$)>0 THEN GOSUB 4500
4310 LN=LN+1 : GOTO 4070
4320 '
4330 ' Handle "I" packets
4350 PRINT:PRINT"File encoded by CUTS version "MID$(PK$,3,1)
4360 PRINT"Encoded on: "MID$(PK$,9,2)" ";
4370 PRINT MID$(MT$,VAL(MID$(PK$,7,2))*3-2,3)" "MID$(PK$,5,2)
4380 TY$=MID$(PK$,12,3)
4390 PRINT"Filetype :"TY$
4400 F$=MID$(PK$,17) : F$=LEFT$(F$,INSTR(F$,CHR$(34))-1)
4410 PRINT"Stored Filename is :"F$
4420 PRINT"Filename to store file under"
4430 PRINT" (<ENTER> for same filename):"
4440 LINEINPUT F1$ : IF F1$<>"" THEN F$=F1$
4450 FF$=F$ : EX$="." : GOSUB 4760 : F$=FF$
4460 PRINT"Saving decoded CUTS file to "F$
4470 IF TY$="BIN" OR TY$="OS9" OR TY$="RSD" THEN SAVEM F$,0,0,0
4480 OPEN"O",2,F$
4490 RETURN
4500 '
4510 ' Decode sequence in PK$ and output to file #2.
4530 LP=USR1(VARPTR(PK$)) 'length of decoded string, A$ now decoded
4540 IF LP=0 THEN RETURN
4550 IF (LP AND 255)=0 THEN CLOSE 2:GOTO 4590
4560 PRINT#2,PK$;
4570 IF LP>255 THEN CLOSE 2:GOTO 4590
4580 RETURN
4585 '
4590 ' fix directory entry if binary file
4600 IF TY$="ASC" THEN RETURN
4610 X=INSTR(F$,"/")
4620 IF X>0 THEN MID$(F$,X,1)="."
4630 X=INSTR(F$,".")
4640 IF X=0 THEN E$="DAT":X=9 ELSE E$=LEFT$(MID$(F$+"   ",X+1),3)
4650 IF X=1 THEN F$=" "+F$:X=2
4660 F$=LEFT$(LEFT$(F$,X-1)+"        ",8)+E$
4670 FOR X=3 TO 11
4680 DSKI$ PEEK(235),17,X,A$,E$
4690 P1=INSTR(A$,F$):P2=INSTR(E$,F$)
4700 IF P1>0 THEN MID$(A$,P1+11,2)=CHR$(2)+CHR$(0):GOTO 4740
4710 IF P2>0 THEN MID$(E$,P2+11,2)=CHR$(2)+CHR$(0):GOTO 4740
4720 NEXT X
4730 RETURN
4740 DSKO$ PEEK(235),17,X,A$,E$
4750 RETURN
4760 '
4770 ' Add extension to filename
4790 IF INSTR(FF$,".")<>0 OR INSTR(FF$,"/")<>0 THEN 4820
4800 IF INSTR(FF$,":")=0 THEN FF$=FF$+EX$ : GOTO 4820
4810 FF$=LEFT$(FF$,INSTR(FF$,":")-1)+EX$+MID$(FF$,INSTR(FF$,":"))
4820 RETURN
5000 FOR X = &H7F00 TO &H7FF0
5010 READ A$: POKE X,VAL("&H"+A$):NEXT X
5020 RETURN
5025 '
5030 ' Data for USR1&USR2 (for decoding D-Packet)
5040 DATA BD,B3,ED,34,06,1F,01
5050 DATA E6,00,AE,02,1F,12,4F
5060 DATA 34,02,34,04,6D,E4,27
5070 DATA 1E,E6,80,6A,E4,C1,20
5080 DATA 27,10,C1,2A,25,2B,C1
5090 DATA 5A,23,08,C1,61,25,50
5100 DATA C1,7A,22,4C,E7,A0,6C
5110 DATA 61,20,DE,35,04,35,04
5120 DATA 35,20,E7,20,4F,7E,B4
5130 DATA F4,35,04,35,04,35,20
5140 DATA E7,20,86,01,7E,B4,F4
5150 DATA C1,21,25,29,C1,29,22
5160 DATA 25,6D,E4,27,DB,A6,80
5170 DATA 6A,E4,81,2E,27,DF,81
5180 DATA 30,25,16,81,4F,22,12
5190 DATA C0,21,58,58,58,58,58
5200 DATA 80,30,34,02,EB,E4,35
5210 DATA 02,20,B4,4F,0F,6F,34
5220 DATA 02,86,22,AD,9F,A0,02
5230 DATA 1F,98,AD,9F,A0,02,35
5240 DATA 02,AD,9F,A0,02,86,22
5250 DATA AD,9F,A0,02,34,20,31
5260 DATA 8C,0F,A6,A0,27,06,AD
5270 DATA 9F,A0,02,20,F6,35,20
5280 DATA 16,FF,67,20,55,6E,72
5290 DATA 65,63,6F,67,6E,69,7A
5300 DATA 65,64,20,63,6F,64,65
5310 DATA 20,73,65,71,75,65,6E
5320 DATA 63,65,0D,00,BD,B3,ED
5330 DATA 1F,01,E6,00,C1,4F,25
5340 DATA 19,C6,4E,E7,00,AE,02
5350 DATA 4F,AB,80,5A,26,FB,84
5360 DATA 1F,8B,30,A1,84,26,05
5370 DATA CC,FF,FF,20,02,4F,5F
5380 DATA 7E,B4,F4
6000 FOR X = &H7C58 TO &H7E10
6010 READ A$: POKE X,VAL("&H"+A$):NEXT X
6020 RETURN
6030 ' Data for USR3&USR4 for encoding
6040 DATA A6,80,A7,A0,5A,26,F9
6050 DATA 39,2E,30,30,30,31,2E
6060 DATA 44,30,8C,F6,31,8C,9B
6070 DATA C6,07,8D,E7,86,0D,A7
6080 DATA 8C,E1,A7,8C,8E,30,8C
6090 DATA 93,AF,8C,81,39,34,36
6100 DATA AE,8D,FF,7C,AC,8D,FF
6110 DATA 76,25,3C,30,01,1F,10
6120 DATA AE,8D,FF,6C,34,10,30
6130 DATA 8D,FF,75,AC,E4,26,06
6140 DATA 30,8D,FF,66,AF,E4,A3
6150 DATA E4,35,10,10,AE,8D,FF
6160 DATA 57,34,04,8D,A7,35,04
6170 DATA EB,8D,FF,4F,E7,8D,FF
6180 DATA 4B,10,AF,8D,FF,44,30
6190 DATA 8D,FF,4B,AF,8D,FF,38
6200 DATA 35,B6,34,16,30,8D,FF
6210 DATA 38,CC,00,4E,AB,80,5A
6220 DATA 26,FB,84,1F,8B,30,A7
6230 DATA 84,35,96,34,16,30,8D
6240 DATA FF,26,C6,04,A6,84,4C
6250 DATA A7,84,81,39,23,0F,86
6260 DATA 30,A7,84,30,1F,5A,26
6270 DATA EE,86,31,A7,8D,FF,0C
6280 DATA 35,96,AE,8D,FE,FA,34
6290 DATA 10,30,8D,FF,4A,1F,10
6300 DATA A3,E4,32,62,C1,01,26
6310 DATA 02,C6,47,5A,E7,8D,FD
6320 DATA E3,30,8D,FD,E0,86,23
6330 DATA A7,80,C6,FE,86,2E,A7
6340 DATA 80,5A,26,FB,6F,8D,FE
6350 DATA D5,16,00,32,BD,B3,ED
6360 DATA 1F,01,A6,84,4C,10,26
6370 DATA 00,CA,AE,02,AF,8D,FE
6380 DATA BD,6F,8D,FE,BB,4F,5F
6390 DATA 7E,B4,F4,BD,B3,ED,1F
6400 DATA 01,E6,84,AE,02,31,8D
6410 DATA FD,A3,E7,A0,5D,10,27
6420 DATA FF,9E,17,FE,F1,31,8D
6430 DATA FD,96,AE,8D,FE,91,6D
6440 DATA 8D,FD,8D,10,27,00,7B
6450 DATA 4F,E6,A0,C1,23,26,0D
6460 DATA 6D,8D,FE,85,26,07,1F
6470 DATA 98,C6,2E,16,00,21,C1
6480 DATA 20,27,1D,C1,2A,25,04
6490 DATA C1,5A,23,15,C1,61,25
6500 DATA 04,C1,7A,23,0D,1F,98
6510 DATA 44,44,44,44,44,8B,21
6520 DATA C4,1F,CB,30,4D,27,19
6530 DATA 34,10,30,8D,FE,A0,AC
6540 DATA E4,35,10,26,0B,31,3F
6550 DATA 4F,C6,23,6C,8D,FD,3C
6560 DATA 20,02,A7,80,6A,8D,FD
6570 DATA 34,E7,80,34,10,30,8D
6580 DATA FE,82,AC,E4,35,10,10
6590 DATA 26,FF,93,30,01,AF,8D
6600 DATA FE,20,17,FE,E5,17,FE
6610 DATA 98,17,FE,F5,AE,8D,FE
6620 DATA 11,16,FF,7D,34,10,30
6630 DATA 1F,AF,8D,FE,08,17,FE
6640 DATA 83,35,10,AF,8D,FD,FD
6650 DATA 4F,E6,8D,FD,FE,7E,B4
6660 DATA F4,CC,FF,FF,7E,B4,F4
6670 END