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
/
DEDIT.STB
< prev
next >
Wrap
Text File
|
1984-04-29
|
9KB
|
276 lines
10 @"Dictionary Editor"
20 @"By David E. Trachtenbarg"
25 @"Copyright 1981"
30 Rem Wl=Word Length
40 Integer H,I,J,K,Item,Number,First,Found,Endings,Endings2,Wl
50 Integer Start,Displacement,Capital,Old
60 Wl=15
70 Dim Word$(Wl-1),Word2$(Wl-1),Root$(Wl-1),Suffix$(Wl-1),Data'file$(13)
80 Dim Suffixes$(20),Command$(10),Command2$(Wl-1),Clear'line$(1)
90 Dim Words$(Wl*20)
100 Set 0,-1
110 Rem On Esc Goto ender
120 Data'file$="DICTION.DAT"
130 For I=0 To 6
140 Read Suffixes$(I*3,(I+1)*3-1)
150 Next I
160 Data"es","s","ed","d","ing","ly","y"
170 Clear'line$=Chr$(126)+Chr$(15)
180 First=1
190 Call .List'words (Word$)
200 *Commands
210 On Error Stop
220 Gosub Bottom'lines
230 @"'F'orward#,'B'ackward#,#,'A'dd,'C'hange#,'D'elete#,'S'uffixes,'M'enu. ";
240 Input"",Command$(-1);
250 If Command$="" Then 220
260 Word$="" : Number=Val(Command$)
270 If Number>0 Then First=Number : Call .List'words (Word$) : Goto Commands
280 Number=Val(Command$(1))
290 If Number=0 And Len(Command$)>1 Then Call .List'words (Command$) : Goto Commands
300 Call .Capitalize (Command$)
310 If Pos("ABCDFMS",Command$(0,0),0)=-1 Then 220
320 If Number<1 Then Number=1
330 If Command$(0,0)="A" Then Gosub Add'words
340 If Command$(0,0)="B" Then Do
350 If First>0 Then Do
360 First=First-(Number)*20 : Call .List'words (Word$)
370 Enddo
380 Enddo
390 If Command$(0,0)="C" Then Call .Get'word (Number) : Gosub Change'word
400 If Command$(0,0)="D" Then Call .Get'word (Number) : Gosub Delete'word
410 If Command$(0,0)="F" Then Do
420 If First>0 Then Do
430 First=First+(Number)*20 : Call .List'words (Word$)
440 Else
450 Word$=Words$(19*Wl,20*Wl-1)
460 Call .List'words (Word$)
470 Enddo
480 Enddo
490 If Command$(0,0)="M" Then Run"SMENUSAV"
500 If Command$(0,0)="S" Then Call .Get'word (Number) : Gosub Suffixes
510 Goto Commands
520 Procedure .Print'word (Num)
530 Local I,J
540 @ Using"#####. ",Num;
550 If Binand(Endings,%4000%)>0 Then Word$(0,0)=Chr$(Asc(Word$(0,0))-32)
560 @"'";Word$;
570 J=0
580 For I=0 To 6
590 J=J*2+(J=0)
600 If Binand(Endings,J)>0 Then @"(";Suffixes$(I*3,(I+1)*3-1);")";
610 Next I
620 @"'"
630 Endproc
640 Procedure .List'words (Start'word$)
650 Gosub Screen'erase
660 Set 3,0
670 Words$="" : Displacement=0 : Endings=0
680 On Error Stop
690 Kopen\1\Data'file$
700 If Start'word$="" Then Do
710 On Error Goto 730
720 Kgetrec\1,First\Endings
730 On Error Stop
740 Else
750 On Error Goto 780
760 First=0
770 Kgetapp\1,Start'word$(-1)\Endings
780 On Error Stop
790 Enddo
800 On Error Goto 820
810 Kretrieve\1\Word$(-1)
820 On Error Stop
830 Words$(0,Wl-1)=Word$(-1)
840 Call .Print'word (First+(First=0))
850 Repeat
860 Displacement=Displacement+1
870 Word$=""
880 On Error Goto 930
890 Kgetfwd\1\Endings
900 Kretrieve\1\Word$(-1)
910 Words$(Displacement*Wl,(Displacement+1)*Wl-1)=Word$(-1)
920 Call .Print'word (Displacement+First+(First=0))
930 On Error Stop
940 Until Displacement>=19
950 On Error Stop
960 Kclose\1\
970 If Sys(3)=163 Then @" **** END ****";
980 @ : @
990 Endproc
1000 Procedure .Get'word (Number)
1010 Kopen\1\Data'file$
1020 On Error Stop
1030 If Number<21 Then Do
1040 Kgetkey\1,Words$((Number-1)*15,Number*15-1)\
1050 Else
1060 Kgetrec\1,Number\
1070 Enddo
1080 Kretrieve\1\Word$(-1)
1090 Kclose\1\
1100 Endproc
1110 *Add'words
1120 Gosub Bottom'lines
1130 Input"Enter a new word. ",Word$;
1140 If Word$="" Then Return
1150 If Word$<"A" Then Goto Add'words
1160 Call .Lowercase (Word$)
1170 Gosub Check'word
1180 Call .List'words (Word$)
1190 Return
1200 *Change'word
1210 Gosub Bottom'lines
1220 Word2$=Word$
1230 @"Enter a new spelling for '";Word$;"'. ";
1240 Input"",Word2$;
1250 Call .Lowercase (Word2$)
1260 If Word2$="" Then Return
1270 If Word2$=Word$ Then Return
1280 If Word$<"A" Then Goto Change'word
1290 On Error Stop
1300 Kopen\1\Data'file$
1310 Kdel\1,Word$(-1)\
1320 Word$=Word2$
1330 Kclose\1\
1340 Gosub Check'word
1350 Call .List'words (Word$)
1360 Return
1370 *Delete'word
1380 Gosub Bottom'lines
1390 @"If you wish to delete '";Word$;"' type Y. ";
1400 Input"",Command2$;
1410 Call .Capitalize (Command2$)
1420 If Command2$<>"Y" Then Return
1430 Kopen\1\Data'file$
1440 Kdel\1,Word$(-1)\
1450 Kclose\1\
1460 If First>0 Then Word$="" : First=First-1
1470 Call .List'words (Word$)
1480 Return
1490 *Suffixes
1500 Gosub Bottom'lines
1510 @"Enter new endings for '";Word$;"'. ";
1520 Input"",Word2$
1530 If Word2$="" Then Return
1540 Call .Lowercase (Word2$)
1550 Endings=0
1560 For I=0 To 6
1570 Suffix$=Suffixes$(I*3,(I+1)*3-1)
1580 J=Pos(Word2$,Suffix$,0)
1590 If J>-1 Then Do
1600 For K=J To J+Len(Suffix$)-1
1610 Word2$(K,K)=Chr$(0)
1620 Next K
1630 Endings=Binor(Endings,2^I)
1640 Enddo
1650 Next I
1660 If Pos(Word2$,"c",0)>-1 Then Endings=Binor(Endings,%4000%)
1670 Kopen\1\Data'file$
1680 Kupdate\1,Word$(-1)\Endings
1690 Kclose\1\
1700 If First>1 Then Word$=""
1710 Call .List'words (Word$)
1720 Return
1730 *Screen'erase
1740 Out 1,126 : Out 1,28 : Return
1750 *Bottom'lines
1760 Out 1,126 : Out 1,17 : Out 1,0 : Out 1,21
1770 Out 1,126 : Out 1,24 : Return
1780 *Error1
1790 Close
1800 Gosub Bottom'lines
1810 @"Error No. ";Sys(3);" has occured."
1820 Input"Press RETURN to go on. ",Command2$
1830 Goto Commands
1840 Procedure .Capitalize (String$)
1850 Local I,K
1860 K=Len(String$)
1870 For I=0 To K-1
1880 If String$(I,I)>="a" And String$(I,I)<="z" Then Do
1890 String$(I,I)=Chr$(Asc(String$(I,I))-32)
1900 Enddo
1910 Next I
1920 Endproc
1930 Procedure .Lowercase (String$)
1940 Local I,K
1950 K=Len(String$)
1960 If String$(0,0)>="A" And String$(0,0)<="Z" Then Do
1970 Capital=1
1980 Else
1990 Capital=0
2000 Enddo
2010 For I=0 To K-1
2020 If String$(I,I)>="A" And String$(I,I)<="Z" Then Do
2030 String$(I,I)=Chr$(Asc(String$(I,I))+32)
2040 Enddo
2050 Next I
2060 Endproc
2070 *Check'word
2080 On Error Stop
2090 Kopen\1\Data'file$
2100 Gosub Check'for'old
2110 If Old=1 Then Goto 2310
2120 Gosub Check'for'root
2130 On Error Stop
2140 If Found>0 Then Do
2150 Kgetkey\1,Root$(-1)\Endings
2160 Endings=Binor(Endings,2^(Found-1))
2170 If Capital=1 Then Endings=Binor(Endings,%4000%)
2180 Kupdate\1,Root$(-1)\Endings
2190 @ Chr$(13);Word$;"-";"new ending added to ";Root$;Clear'line$;
2200 Word$=Root$
2210 Else
2220 Endings=0
2230 On Error Goto 2290
2240 If Capital=1 Then Endings=Binor(Endings,%4000%)
2250 Kadd\1,Word$(-1)\Endings
2260 On Error Stop
2270 @ Chr$(13);Word$;"-";"added";Clear'line$;
2280 Gosub Check'endings
2290 On Error Stop
2300 Enddo
2310 Kclose\1\
2320 Return
2330 *Check'for'old
2340 Old=0
2350 On Error Goto 2380
2360 Kgetkey\1,Word$(-1)\
2370 Old=1
2380 On Error Stop
2390 Return
2400 *Check'endings
2410 For I=1 To 7
2420 Suffix$=Word$+Suffixes$((I-1)*3,(I*3)-1)
2430 On Error Goto 2500
2440 Kgetkey\1,Suffix$(-1)\Endings2
2450 If Endings2<>0 Then Goto 2500
2460 Endings=Binor(Endings,2^(I-1))
2470 Kdel\1,Suffix$(-1)\
2480 Kupdate\1,Word$(-1)\Endings
2490 @ Chr$(13);Suffix$;"-";"deleted";Clear'line$;
2500 On Error Stop
2510 Next I
2520 Return
2530 *Check'for'root
2540 Local I,J,K
2550 I=Len(Word$)
2560 Found=0 : K=0
2570 Repeat
2580 K=K+1
2590 Suffix$=Suffixes$((K-1)*3,K*3-1)
2600 J=Len(Suffix$)
2610 If Word$(I-J,I-1)=Suffix$ Then Do
2620 Root$=Word$(0,I-J-1)
2630 On Error Goto 2660
2640 Kgetkey\1,Root$(-1)\Endings
2650 Found=K
2660 Enddo
2670 On Error Stop
2680 Until Found>0 Or K>=7
2690 Return
2700 *Ender
2710 Close
2720 End