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 >
Text File  |  1984-04-29  |  6KB  |  175 lines
  1.  
  2.    10   @"Word Editor"
  3.    20   @"By David E. Trachtenbarg"
  4.    25   @"Copyright 1981"
  5.    30   Rem Wl=Word Length
  6.    40   Integer H,I,J,K,Item,Number,First,Found,Wl
  7.    50   Integer Start,Displacement
  8.    60   Wl=15
  9.    70   Dim Word$(Wl-1),Word2$(Wl-1),Data'file$(13)
  10.    80   Dim Command$(10),Command2$(Wl-1)
  11.    90   Dim Words$(Wl*20)
  12.   100   Set 0,-1
  13.   110   On Esc Goto Closer
  14.   120   Data'file$="CHECK.DAT"
  15.   180   Call .List'words (1,Word$)
  16.   190 *Commands
  17.   200   On Error Stop
  18.   210   Gosub Bottom'lines
  19.   220   @"'F'orward#,'B'ackward#,#,'C'hange#,'A'dd,'D'elete#,'M'enu. ";
  20.   230   Input"",Command$(-1);
  21.   240   If Command$="" Then 210
  22.   250   Word$="" : Number=Val(Command$)
  23.   260   If Number>0 Then First=Number : Call .List'words (First,Word$) : Goto Commands
  24.   270   Number=Val(Command$(1))
  25.   280   If Number=0 And Len(Command$)>1 Then Call .List'words (1,Command$) : Goto Commands
  26.   290   Call .Capitalize (Command$)
  27.   300   If Pos("ABCDFM",Command$(0,0),0)=-1 Then 210
  28.   310   If Number<1 Then Number=1
  29.   320   If Command$(0,0)="A" Then Gosub Add'words
  30.   330   If Command$(0,0)="B" Then  Do
  31.   340     If First>1 Then  Do
  32.   350       First=First-(Number)*20 : Call .List'words (First,Word$)
  33.   360       Else
  34.   370       Word2$=Words$(0,Wl-1)
  35.   420       Call .List'words (1,Word2$)
  36.   430       Enddo
  37.   440     Enddo
  38.   450   If Command$(0,0)="C" Then Call .Get'word (Number) : Gosub Change'word
  39.   460   If Command$(0,0)="D" Then Call .Get'word (Number) : Gosub Delete'word
  40.   470   If Command$(0,0)="F" Then  Do
  41.   480     If First>1 Then  Do
  42.   490       First=First+(Number)*20 : Call .List'words (First,Word$)
  43.   500       Else
  44.   510       Word2$=Words$(19*Wl,20*Wl-1)
  45.   570       Call .List'words (1,Word2$)
  46.   580       Enddo
  47.   590     Enddo
  48.   600   If Command$(0,0)="M" Then Run"SMENU.SAV"
  49.   610   Goto Commands
  50.   620 Procedure .Print'word (Num)
  51.   630   @ Using"#####. ",Num;
  52.   640   @"'";Word$;"'"
  53.   660   Endproc 
  54.   670 Procedure .List'words (Start,Start'word$)
  55.   680   Gosub Screen'erase
  56.   690   Set 3,0
  57.   700   Words$=""
  58.   710   Displacement=0
  59.   720   On Error Stop
  60.   730   Kopen\1\Data'file$
  61.   740   If Start'word$="" Then  Do
  62.   750     First=Start
  63.   760     On Error Goto 780
  64.   770     Kgetrec\1,Start-1\
  65.   780     On Error Stop
  66.   790     Else
  67.   800     First=1
  68.   810     On Error Goto 830
  69.   820     Kgetapp\1,Start'word$(-1)\
  70.   830     On Error Stop
  71.   840     Enddo
  72.   850   On Error Goto 870
  73.   860   Kretrieve\1\Word$(-1)
  74.   870   On Error Stop
  75.   880   Words$(Displacement*Wl,(Displacement+1)*Wl-1)=Word$(-1)
  76.   890   Call .Print'word (Displacement+Start)
  77.   900     Repeat
  78.   910     Displacement=Displacement+1
  79.   920     Word$=""
  80.   930     On Error Goto 980
  81.   940     Kgetfwd\1\
  82.   950     Kretrieve\1\Word$(-1)
  83.   960     Words$(Displacement*Wl,(Displacement+1)*Wl-1)=Word$(-1)
  84.   970     Call .Print'word (Displacement+Start)
  85.   980     On Error Stop
  86.   990     Until Displacement>=19
  87.  1000   On Error Stop
  88.  1010   Kclose\1\
  89.  1020   If Sys(3)=163 Then @"       **** END ****";
  90.  1040   @ : @
  91.  1050   Endproc 
  92.  1060 Procedure .Get'word (Number)
  93.  1070   Kopen\1\Data'file$
  94.  1080   On Error Goto Error1
  95.  1090   If Number<21 Then  Do
  96.  1100     Kgetkey\1,Words$((Number-1)*Wl,Number*Wl-1)\
  97.  1110     Else
  98.  1120     Kgetrec\1,Number-1\
  99.  1130     Enddo
  100.  1140   Kretrieve\1\Word$(-1)
  101.  1150   Kclose\1\
  102.  1160   Endproc 
  103.  1170 *Add'words
  104.  1180   Gosub Bottom'lines
  105.  1190   Input"Enter a new word. ",Word$;
  106.  1200   If Word$="" Then Return
  107.  1210   If Word$<"A" Then Goto Add'words
  108.  1219   On Error Goto Error1
  109.  1220   Kopen\1\Data'file$
  110.  1221   Kadd\1,Word$(-1)\
  111.  1222   Kclose\1\
  112.  1230   Call .List'words (1,Word$)
  113.  1240   Return
  114.  1250 *Change'word
  115.  1260   Gosub Bottom'lines
  116.  1270   Word2$=Word$
  117.  1280   @"Enter a new spelling for '";Word$;"'. ";
  118.  1290   Input"",Word2$;
  119.  1300   Call .Lowercase (Word2$)
  120.  1310   If Word2$="" Then Return
  121.  1320   If Word2$=Word$ Then Return
  122.  1330   If Word$<"A" Then Goto Change'word
  123.  1340   On Error Goto Error1
  124.  1350   Kopen\1\Data'file$
  125.  1360   Kdel\1,Word$(-1)\
  126.  1370   Kadd\1,Word2$(-1)\
  127.  1390   Kclose\1\
  128.  1400   Call .List'words (1,Word2$)
  129.  1410   Return
  130.  1420 *Delete'word
  131.  1430   Gosub Bottom'lines
  132.  1440   @"If you wish to delete '";Word$;"' type Y. ";
  133.  1450   Input"",Command2$;
  134.  1460   Call .Capitalize (Command2$)
  135.  1470   If Command2$<>"Y" Then Return
  136.  1475   On Error Goto Error1
  137.  1480   Kopen\1\Data'file$
  138.  1490   Kdel\1,Word$(-1)\
  139.  1500   Highest=Highest-1
  140.  1510   Kclose\1\
  141.  1515   If First>1 Then Word$="" : First=First-1
  142.  1520   Call .List'words (First,Word$)
  143.  1530   Return
  144.  1540 *Screen'erase
  145.  1550   Out 1,126 : Out 1,28 : Return
  146.  1560 *Bottom'lines
  147.  1570   Out 1,126 : Out 1,17 : Out 1,0 : Out 1,22
  148.  1580   Out 1,126 : Out 1,24 : Return
  149.  1590 *Error1
  150.  1600   Close
  151.  1610   Gosub Bottom'lines
  152.  1620   @"Error No. ";Sys(3);" has occured."
  153.  1630   Input"Press RETURN to go on. ",Command2$
  154.  1640   Goto Commands
  155.  1650 Procedure .Capitalize (String$)
  156.  1660   Local I,J,K
  157.  1670   K=Len(String$)
  158.  1680     For I=0 To K-1
  159.  1690     J=Asc(String$(I,I))
  160.  1700     If J>96 And J<123 Then String$(I,I)=Chr$(J-32)
  161.  1710     Next I
  162.  1720   Endproc 
  163.  1730 Procedure .Lowercase (String$)
  164.  1740   Local I,J,K
  165.  1750   K=Len(String$)
  166.  1760     For I=1 To K-1
  167.  1770     J=Asc(String$(I,I))
  168.  1780     If J>64 And J<91 Then String$(I,I)=Chr$(J+32)
  169.  1790     Next I
  170.  1800   Endproc 
  171.  1810 *Closer
  172.  1820   Close
  173.  1830   End
  174.