home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug080.ark / DEDIT.STB < prev    next >
Encoding:
Text File  |  1984-04-29  |  8.6 KB  |  276 lines
  1.  
  2.    10   @"Dictionary 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,Endings,Endings2,Wl
  7.    50   Integer Start,Displacement,Capital,Old
  8.    60   Wl=15
  9.    70   Dim Word$(Wl-1),Word2$(Wl-1),Root$(Wl-1),Suffix$(Wl-1),Data'file$(13)
  10.    80   Dim Suffixes$(20),Command$(10),Command2$(Wl-1),Clear'line$(1)
  11.    90   Dim Words$(Wl*20)
  12.   100   Set 0,-1
  13.   110   Rem On Esc Goto ender
  14.   120   Data'file$="DICTION.DAT"
  15.   130     For I=0 To 6
  16.   140     Read Suffixes$(I*3,(I+1)*3-1)
  17.   150     Next I
  18.   160   Data"es","s","ed","d","ing","ly","y"
  19.   170   Clear'line$=Chr$(126)+Chr$(15)
  20.   180   First=1
  21.   190   Call .List'words (Word$)
  22.   200 *Commands
  23.   210   On Error Stop
  24.   220   Gosub Bottom'lines
  25.   230   @"'F'orward#,'B'ackward#,#,'A'dd,'C'hange#,'D'elete#,'S'uffixes,'M'enu. ";
  26.   240   Input"",Command$(-1);
  27.   250   If Command$="" Then 220
  28.   260   Word$="" : Number=Val(Command$)
  29.   270   If Number>0 Then First=Number : Call .List'words (Word$) : Goto Commands
  30.   280   Number=Val(Command$(1))
  31.   290   If Number=0 And Len(Command$)>1 Then Call .List'words (Command$) : Goto Commands
  32.   300   Call .Capitalize (Command$)
  33.   310   If Pos("ABCDFMS",Command$(0,0),0)=-1 Then 220
  34.   320   If Number<1 Then Number=1
  35.   330   If Command$(0,0)="A" Then Gosub Add'words
  36.   340   If Command$(0,0)="B" Then  Do
  37.   350     If First>0 Then  Do
  38.   360       First=First-(Number)*20 : Call .List'words (Word$)
  39.   370       Enddo
  40.   380     Enddo
  41.   390   If Command$(0,0)="C" Then Call .Get'word (Number) : Gosub Change'word
  42.   400   If Command$(0,0)="D" Then Call .Get'word (Number) : Gosub Delete'word
  43.   410   If Command$(0,0)="F" Then  Do
  44.   420     If First>0 Then  Do
  45.   430       First=First+(Number)*20 : Call .List'words (Word$)
  46.   440       Else
  47.   450       Word$=Words$(19*Wl,20*Wl-1)
  48.   460       Call .List'words (Word$)
  49.   470       Enddo
  50.   480     Enddo
  51.   490   If Command$(0,0)="M" Then Run"SMENUSAV"
  52.   500   If Command$(0,0)="S" Then Call .Get'word (Number) : Gosub Suffixes
  53.   510   Goto Commands
  54.   520 Procedure .Print'word (Num)
  55.   530   Local I,J
  56.   540   @ Using"#####. ",Num;
  57.   550   If Binand(Endings,%4000%)>0 Then Word$(0,0)=Chr$(Asc(Word$(0,0))-32)
  58.   560   @"'";Word$;
  59.   570   J=0
  60.   580     For I=0 To 6
  61.   590     J=J*2+(J=0)
  62.   600     If Binand(Endings,J)>0 Then @"(";Suffixes$(I*3,(I+1)*3-1);")";
  63.   610     Next I
  64.   620   @"'"
  65.   630   Endproc 
  66.   640 Procedure .List'words (Start'word$)
  67.   650   Gosub Screen'erase
  68.   660   Set 3,0
  69.   670   Words$="" : Displacement=0 : Endings=0
  70.   680   On Error Stop
  71.   690   Kopen\1\Data'file$
  72.   700   If Start'word$="" Then  Do
  73.   710     On Error Goto 730
  74.   720     Kgetrec\1,First\Endings
  75.   730     On Error Stop
  76.   740     Else
  77.   750     On Error Goto 780
  78.   760     First=0
  79.   770     Kgetapp\1,Start'word$(-1)\Endings
  80.   780     On Error Stop
  81.   790     Enddo
  82.   800   On Error Goto 820
  83.   810   Kretrieve\1\Word$(-1)
  84.   820   On Error Stop
  85.   830   Words$(0,Wl-1)=Word$(-1)
  86.   840   Call .Print'word (First+(First=0))
  87.   850     Repeat
  88.   860     Displacement=Displacement+1
  89.   870     Word$=""
  90.   880     On Error Goto 930
  91.   890     Kgetfwd\1\Endings
  92.   900     Kretrieve\1\Word$(-1)
  93.   910     Words$(Displacement*Wl,(Displacement+1)*Wl-1)=Word$(-1)
  94.   920     Call .Print'word (Displacement+First+(First=0))
  95.   930     On Error Stop
  96.   940     Until Displacement>=19
  97.   950   On Error Stop
  98.   960   Kclose\1\
  99.   970   If Sys(3)=163 Then @"       **** END ****";
  100.   980   @ : @
  101.   990   Endproc 
  102.  1000 Procedure .Get'word (Number)
  103.  1010   Kopen\1\Data'file$
  104.  1020   On Error Stop
  105.  1030   If Number<21 Then  Do
  106.  1040     Kgetkey\1,Words$((Number-1)*15,Number*15-1)\
  107.  1050     Else
  108.  1060     Kgetrec\1,Number\
  109.  1070     Enddo
  110.  1080   Kretrieve\1\Word$(-1)
  111.  1090   Kclose\1\
  112.  1100   Endproc 
  113.  1110 *Add'words
  114.  1120   Gosub Bottom'lines
  115.  1130   Input"Enter a new word. ",Word$;
  116.  1140   If Word$="" Then Return
  117.  1150   If Word$<"A" Then Goto Add'words
  118.  1160   Call .Lowercase (Word$)
  119.  1170   Gosub Check'word
  120.  1180   Call .List'words (Word$)
  121.  1190   Return
  122.  1200 *Change'word
  123.  1210   Gosub Bottom'lines
  124.  1220   Word2$=Word$
  125.  1230   @"Enter a new spelling for '";Word$;"'. ";
  126.  1240   Input"",Word2$;
  127.  1250   Call .Lowercase (Word2$)
  128.  1260   If Word2$="" Then Return
  129.  1270   If Word2$=Word$ Then Return
  130.  1280   If Word$<"A" Then Goto Change'word
  131.  1290   On Error Stop
  132.  1300   Kopen\1\Data'file$
  133.  1310   Kdel\1,Word$(-1)\
  134.  1320   Word$=Word2$
  135.  1330   Kclose\1\
  136.  1340   Gosub Check'word
  137.  1350   Call .List'words (Word$)
  138.  1360   Return
  139.  1370 *Delete'word
  140.  1380   Gosub Bottom'lines
  141.  1390   @"If you wish to delete '";Word$;"' type Y. ";
  142.  1400   Input"",Command2$;
  143.  1410   Call .Capitalize (Command2$)
  144.  1420   If Command2$<>"Y" Then Return
  145.  1430   Kopen\1\Data'file$
  146.  1440   Kdel\1,Word$(-1)\
  147.  1450   Kclose\1\
  148.  1460   If First>0 Then Word$="" : First=First-1
  149.  1470   Call .List'words (Word$)
  150.  1480   Return
  151.  1490 *Suffixes
  152.  1500   Gosub Bottom'lines
  153.  1510   @"Enter new endings for '";Word$;"'. ";
  154.  1520   Input"",Word2$
  155.  1530   If Word2$="" Then Return
  156.  1540   Call .Lowercase (Word2$)
  157.  1550   Endings=0
  158.  1560     For I=0 To 6
  159.  1570     Suffix$=Suffixes$(I*3,(I+1)*3-1)
  160.  1580     J=Pos(Word2$,Suffix$,0)
  161.  1590     If J>-1 Then  Do
  162.  1600         For K=J To J+Len(Suffix$)-1
  163.  1610         Word2$(K,K)=Chr$(0)
  164.  1620         Next K
  165.  1630       Endings=Binor(Endings,2^I)
  166.  1640       Enddo
  167.  1650     Next I
  168.  1660   If Pos(Word2$,"c",0)>-1 Then Endings=Binor(Endings,%4000%)
  169.  1670   Kopen\1\Data'file$
  170.  1680   Kupdate\1,Word$(-1)\Endings
  171.  1690   Kclose\1\
  172.  1700   If First>1 Then Word$=""
  173.  1710   Call .List'words (Word$)
  174.  1720   Return
  175.  1730 *Screen'erase
  176.  1740   Out 1,126 : Out 1,28 : Return
  177.  1750 *Bottom'lines
  178.  1760   Out 1,126 : Out 1,17 : Out 1,0 : Out 1,21
  179.  1770   Out 1,126 : Out 1,24 : Return
  180.  1780 *Error1
  181.  1790   Close
  182.  1800   Gosub Bottom'lines
  183.  1810   @"Error No. ";Sys(3);" has occured."
  184.  1820   Input"Press RETURN to go on. ",Command2$
  185.  1830   Goto Commands
  186.  1840 Procedure .Capitalize (String$)
  187.  1850   Local I,K
  188.  1860   K=Len(String$)
  189.  1870     For I=0 To K-1
  190.  1880     If String$(I,I)>="a" And String$(I,I)<="z" Then  Do
  191.  1890       String$(I,I)=Chr$(Asc(String$(I,I))-32)
  192.  1900       Enddo
  193.  1910     Next I
  194.  1920   Endproc 
  195.  1930 Procedure .Lowercase (String$)
  196.  1940   Local I,K
  197.  1950   K=Len(String$)
  198.  1960   If String$(0,0)>="A" And String$(0,0)<="Z" Then  Do
  199.  1970     Capital=1
  200.  1980     Else
  201.  1990     Capital=0
  202.  2000     Enddo
  203.  2010     For I=0 To K-1
  204.  2020     If String$(I,I)>="A" And String$(I,I)<="Z" Then  Do
  205.  2030       String$(I,I)=Chr$(Asc(String$(I,I))+32)
  206.  2040       Enddo
  207.  2050     Next I
  208.  2060   Endproc 
  209.  2070 *Check'word
  210.  2080   On Error Stop
  211.  2090   Kopen\1\Data'file$
  212.  2100   Gosub Check'for'old
  213.  2110   If Old=1 Then Goto 2310
  214.  2120   Gosub Check'for'root
  215.  2130   On Error Stop
  216.  2140   If Found>0 Then  Do
  217.  2150     Kgetkey\1,Root$(-1)\Endings
  218.  2160     Endings=Binor(Endings,2^(Found-1))
  219.  2170     If Capital=1 Then Endings=Binor(Endings,%4000%)
  220.  2180     Kupdate\1,Root$(-1)\Endings
  221.  2190     @ Chr$(13);Word$;"-";"new ending added to ";Root$;Clear'line$;
  222.  2200     Word$=Root$
  223.  2210     Else
  224.  2220     Endings=0
  225.  2230     On Error Goto 2290
  226.  2240     If Capital=1 Then Endings=Binor(Endings,%4000%)
  227.  2250     Kadd\1,Word$(-1)\Endings
  228.  2260     On Error Stop
  229.  2270     @ Chr$(13);Word$;"-";"added";Clear'line$;
  230.  2280     Gosub Check'endings
  231.  2290     On Error Stop
  232.  2300     Enddo
  233.  2310   Kclose\1\
  234.  2320   Return
  235.  2330 *Check'for'old
  236.  2340   Old=0
  237.  2350   On Error Goto 2380
  238.  2360   Kgetkey\1,Word$(-1)\
  239.  2370   Old=1
  240.  2380   On Error Stop
  241.  2390   Return
  242.  2400 *Check'endings
  243.  2410     For I=1 To 7
  244.  2420     Suffix$=Word$+Suffixes$((I-1)*3,(I*3)-1)
  245.  2430     On Error Goto 2500
  246.  2440     Kgetkey\1,Suffix$(-1)\Endings2
  247.  2450     If Endings2<>0 Then Goto 2500
  248.  2460     Endings=Binor(Endings,2^(I-1))
  249.  2470     Kdel\1,Suffix$(-1)\
  250.  2480     Kupdate\1,Word$(-1)\Endings
  251.  2490     @ Chr$(13);Suffix$;"-";"deleted";Clear'line$;
  252.  2500     On Error Stop
  253.  2510     Next I
  254.  2520   Return
  255.  2530 *Check'for'root
  256.  2540   Local I,J,K
  257.  2550   I=Len(Word$)
  258.  2560   Found=0 : K=0
  259.  2570     Repeat
  260.  2580     K=K+1
  261.  2590     Suffix$=Suffixes$((K-1)*3,K*3-1)
  262.  2600     J=Len(Suffix$)
  263.  2610     If Word$(I-J,I-1)=Suffix$ Then  Do
  264.  2620       Root$=Word$(0,I-J-1)
  265.  2630       On Error Goto 2660
  266.  2640       Kgetkey\1,Root$(-1)\Endings
  267.  2650       Found=K
  268.  2660       Enddo
  269.  2670     On Error Stop
  270.  2680     Until Found>0 Or K>=7
  271.  2690   Return
  272.  2700 *Ender
  273.  2710   Close
  274.  2720   End
  275.