home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
SIMTEL
/
CPMUG
/
CPMUG080.ARK
/
CEDIT.STB
< prev
next >
Wrap
Text File
|
1984-04-29
|
6KB
|
175 lines
10 @"Word Editor"
20 @"By David E. Trachtenbarg"
25 @"Copyright 1981"
30 Rem Wl=Word Length
40 Integer H,I,J,K,Item,Number,First,Found,Wl
50 Integer Start,Displacement
60 Wl=15
70 Dim Word$(Wl-1),Word2$(Wl-1),Data'file$(13)
80 Dim Command$(10),Command2$(Wl-1)
90 Dim Words$(Wl*20)
100 Set 0,-1
110 On Esc Goto Closer
120 Data'file$="CHECK.DAT"
180 Call .List'words (1,Word$)
190 *Commands
200 On Error Stop
210 Gosub Bottom'lines
220 @"'F'orward#,'B'ackward#,#,'C'hange#,'A'dd,'D'elete#,'M'enu. ";
230 Input"",Command$(-1);
240 If Command$="" Then 210
250 Word$="" : Number=Val(Command$)
260 If Number>0 Then First=Number : Call .List'words (First,Word$) : Goto Commands
270 Number=Val(Command$(1))
280 If Number=0 And Len(Command$)>1 Then Call .List'words (1,Command$) : Goto Commands
290 Call .Capitalize (Command$)
300 If Pos("ABCDFM",Command$(0,0),0)=-1 Then 210
310 If Number<1 Then Number=1
320 If Command$(0,0)="A" Then Gosub Add'words
330 If Command$(0,0)="B" Then Do
340 If First>1 Then Do
350 First=First-(Number)*20 : Call .List'words (First,Word$)
360 Else
370 Word2$=Words$(0,Wl-1)
420 Call .List'words (1,Word2$)
430 Enddo
440 Enddo
450 If Command$(0,0)="C" Then Call .Get'word (Number) : Gosub Change'word
460 If Command$(0,0)="D" Then Call .Get'word (Number) : Gosub Delete'word
470 If Command$(0,0)="F" Then Do
480 If First>1 Then Do
490 First=First+(Number)*20 : Call .List'words (First,Word$)
500 Else
510 Word2$=Words$(19*Wl,20*Wl-1)
570 Call .List'words (1,Word2$)
580 Enddo
590 Enddo
600 If Command$(0,0)="M" Then Run"SMENU.SAV"
610 Goto Commands
620 Procedure .Print'word (Num)
630 @ Using"#####. ",Num;
640 @"'";Word$;"'"
660 Endproc
670 Procedure .List'words (Start,Start'word$)
680 Gosub Screen'erase
690 Set 3,0
700 Words$=""
710 Displacement=0
720 On Error Stop
730 Kopen\1\Data'file$
740 If Start'word$="" Then Do
750 First=Start
760 On Error Goto 780
770 Kgetrec\1,Start-1\
780 On Error Stop
790 Else
800 First=1
810 On Error Goto 830
820 Kgetapp\1,Start'word$(-1)\
830 On Error Stop
840 Enddo
850 On Error Goto 870
860 Kretrieve\1\Word$(-1)
870 On Error Stop
880 Words$(Displacement*Wl,(Displacement+1)*Wl-1)=Word$(-1)
890 Call .Print'word (Displacement+Start)
900 Repeat
910 Displacement=Displacement+1
920 Word$=""
930 On Error Goto 980
940 Kgetfwd\1\
950 Kretrieve\1\Word$(-1)
960 Words$(Displacement*Wl,(Displacement+1)*Wl-1)=Word$(-1)
970 Call .Print'word (Displacement+Start)
980 On Error Stop
990 Until Displacement>=19
1000 On Error Stop
1010 Kclose\1\
1020 If Sys(3)=163 Then @" **** END ****";
1040 @ : @
1050 Endproc
1060 Procedure .Get'word (Number)
1070 Kopen\1\Data'file$
1080 On Error Goto Error1
1090 If Number<21 Then Do
1100 Kgetkey\1,Words$((Number-1)*Wl,Number*Wl-1)\
1110 Else
1120 Kgetrec\1,Number-1\
1130 Enddo
1140 Kretrieve\1\Word$(-1)
1150 Kclose\1\
1160 Endproc
1170 *Add'words
1180 Gosub Bottom'lines
1190 Input"Enter a new word. ",Word$;
1200 If Word$="" Then Return
1210 If Word$<"A" Then Goto Add'words
1219 On Error Goto Error1
1220 Kopen\1\Data'file$
1221 Kadd\1,Word$(-1)\
1222 Kclose\1\
1230 Call .List'words (1,Word$)
1240 Return
1250 *Change'word
1260 Gosub Bottom'lines
1270 Word2$=Word$
1280 @"Enter a new spelling for '";Word$;"'. ";
1290 Input"",Word2$;
1300 Call .Lowercase (Word2$)
1310 If Word2$="" Then Return
1320 If Word2$=Word$ Then Return
1330 If Word$<"A" Then Goto Change'word
1340 On Error Goto Error1
1350 Kopen\1\Data'file$
1360 Kdel\1,Word$(-1)\
1370 Kadd\1,Word2$(-1)\
1390 Kclose\1\
1400 Call .List'words (1,Word2$)
1410 Return
1420 *Delete'word
1430 Gosub Bottom'lines
1440 @"If you wish to delete '";Word$;"' type Y. ";
1450 Input"",Command2$;
1460 Call .Capitalize (Command2$)
1470 If Command2$<>"Y" Then Return
1475 On Error Goto Error1
1480 Kopen\1\Data'file$
1490 Kdel\1,Word$(-1)\
1500 Highest=Highest-1
1510 Kclose\1\
1515 If First>1 Then Word$="" : First=First-1
1520 Call .List'words (First,Word$)
1530 Return
1540 *Screen'erase
1550 Out 1,126 : Out 1,28 : Return
1560 *Bottom'lines
1570 Out 1,126 : Out 1,17 : Out 1,0 : Out 1,22
1580 Out 1,126 : Out 1,24 : Return
1590 *Error1
1600 Close
1610 Gosub Bottom'lines
1620 @"Error No. ";Sys(3);" has occured."
1630 Input"Press RETURN to go on. ",Command2$
1640 Goto Commands
1650 Procedure .Capitalize (String$)
1660 Local I,J,K
1670 K=Len(String$)
1680 For I=0 To K-1
1690 J=Asc(String$(I,I))
1700 If J>96 And J<123 Then String$(I,I)=Chr$(J-32)
1710 Next I
1720 Endproc
1730 Procedure .Lowercase (String$)
1740 Local I,J,K
1750 K=Len(String$)
1760 For I=1 To K-1
1770 J=Asc(String$(I,I))
1780 If J>64 And J<91 Then String$(I,I)=Chr$(J+32)
1790 Next I
1800 Endproc
1810 *Closer
1820 Close
1830 End