CP/M/CPM_CDROM.iso/simtel/cpmug/cpmug080.ark/CEDIT.STB

Text File | 1984-04-29 | 5.5 KB | 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