home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug080.ark / TARNSFER.STB < prev    next >
Encoding:
Text File  |  1984-04-29  |  2.5 KB  |  89 lines
  1.  
  2.    10   Rem Copyright 1981 by David E. Trachtenbarg
  3.    20   Dim Check'file$(13),Dictionary$(13),Word$(14),Root$(14),Suffix$(14)
  4.    30   Dim Suffixes$(20)
  5.    40   Integer I,Old,Found,Endings,Endings2
  6.    50     For I=0 To 6
  7.    60     Read Suffixes$(I*3,(I+1)*3-1)
  8.    70     Next I
  9.    80   Data"es","s","ed","d","ing","ly","y"
  10.    90   Dictionary$="DICTION.DAT"
  11.   100   Check'file$="CHECK.DAT"
  12.   110   On Esc Goto Ender
  13.   120 *Transfer
  14.   130   Kopen\1\Check'file$
  15.   140   Kopen\2\Dictionary$
  16.   150   Endings=0
  17.   160   On Error Goto 440
  18.   170   Kgetfwd\1\
  19.   180   Kretrieve\1\Word$(-1)
  20.   190   Kdel\1,Word$(-1)\
  21.   191   Gosub Check'for'old
  22.   192   If Old=1 Then 430
  23.   200   On Error Stop
  24.   210   Gosub Check'for'root
  25.   220   On Error Stop
  26.   230   If Found>0 Then  Do
  27.   235     On Error Goto 285
  28.   240     Kgetkey\2,Root$(-1)\Endings
  29.   250     Endings=Binor(Endings,2^(Found-1))
  30.   260     Kupdate\2,Root$(-1)\Endings
  31.   270     @ Word$;Tab(20);"new ending added to ";Root$
  32.   280     Word$=Root$
  33.   285     On Error Stop
  34.   290     Else
  35.   320     If Word$(0,0)>="A" And Word$(0,0)<="Z" Then  Do
  36.   330       Endings=Binor(Endings,2^14)
  37.   340       Word$(0,0)=Chr$(Asc(Word$(0,0))+32)
  38.   360       Enddo
  39.   365     Kadd\2,Word$(-1)\Endings
  40.   380     @ Word$;Tab(20);"added"
  41.   390     Gosub Check'endings
  42.   400     On Error Stop
  43.   410     Enddo
  44.   430   Goto 150
  45.   440   Close
  46.   450   Run"Menu.sav"
  47.   451 *Check'for'old
  48.   452   Old=0
  49.   453   On Error Goto 458
  50.   454   Kgetkey\2,Word$(-1)\
  51.   455   Old=1
  52.   456   @ Word$;Tab(20);"already in dictionary"
  53.   458   On Error Stop
  54.   459   Return
  55.   460 *Check'endings
  56.   470     For I=1 To 7
  57.   480     Suffix$=Word$+Suffixes$((I-1)*3,(I*3)-1)
  58.   490     On Error Goto 560
  59.   500     Kgetkey\2,Suffix$(-1)\Endings2
  60.   510     If Endings2<>0 Then Goto 560
  61.   520     Endings=Binor(Endings,2^(I-1))
  62.   530     Kdel\2,Suffix$(-1)\
  63.   540     Kupdate\2,Word$(-1)\Endings
  64.   550     @ Suffix$;Tab(20);"deleted"
  65.   560     On Error Stop
  66.   570     Next I
  67.   580   Return
  68.   590 *Check'for'root
  69.   600   Local I,J,K
  70.   610   I=Len(Word$)
  71.   620   Found=0 : K=0
  72.   630     Repeat
  73.   640     K=K+1
  74.   650     Suffix$=Suffixes$((K-1)*3,K*3-1)
  75.   660     J=Len(Suffix$)
  76.   670     If Word$(I-J,I-1)=Suffix$ Then  Do
  77.   680       Root$=Word$(0,I-J-1)
  78.   690       On Error Goto 720
  79.   700       Kgetkey\2,Root$(-1)\Endings
  80.   710       Found=K
  81.   720       Enddo
  82.   730     On Error Stop
  83.   740     Until Found>0 Or K>=7
  84.   750   Return
  85.   760 *Ender
  86.   770   Close
  87.   780   End
  88.