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 / SPELL.STB < prev    next >
Text File  |  1984-04-29  |  6KB  |  166 lines
  1.  
  2.    20   Gosub Screen'erase
  3.    30   @"Spelling Program"
  4.    40   @"By David E. Trachtenbarg"
  5.    50   @"Copyright 1981"
  6.    60   Integer I,J,Sector,Record,Finish,Start'word,End'word,Endings
  7.    70   Integer Bitmask(15),In'dictionary,To'check
  8.    80   Sector=128
  9.    90   Dim Eof$(1),String$(10),Text'file$(13),Root$(14),Word'check$(15)
  10.   100   Dim Dictionary$(13),Check'words$(13),Text$(Sector*2)
  11.   110   Dim Command$(10),Suffixes$(20),Suffix$(2)
  12.   120   Dim Uppercase$(25),Lowercase$(25),Numbers$(11),Letters$(63)
  13.   130   Uppercase$="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  14.   140   Lowercase$="abcdefghijklmnopqrstuvwxyz"
  15.   150   Numbers$="0123456789'@"
  16.   160   Letters$=Uppercase$+Lowercase$+Numbers$
  17.   170   Eof$=Chr$(26)+Chr$(27)
  18.   180   Dictionary$="DICTION.DAT"
  19.   190   Check'words$="CHECK.DAT"
  20.   200     For I=0 To 6
  21.   210     Read Suffixes$(I*3,(I+1)*3-1)
  22.   220     Next I
  23.   230   Data"es","s","ed","d","ing","ly","y"
  24.   240   Set 0,-1
  25.   250   Gosub Set'masks
  26.   260   Gosub Enter'text'file
  27.   270   Gosub Set'record
  28.   280   On Esc Goto Ender
  29.   290   On Error Goto 350
  30.   300   Open\1,Sector,1\Text'file$
  31.   310   Kopen\2\Dictionary$
  32.   320   Kopen\3\Check'words$
  33.   330   Gosub Get'file
  34.   340   Gosub Count
  35.   350   Close
  36.   360   Gosub Print'results
  37.   390   Goto 260
  38.   400 *Screen'erase
  39.   410   Out 1,126 : Out 1,28 : Return
  40.   420 *Enter'text'file
  41.   430     Repeat
  42.   440     Set 3,0
  43.   450     @ : @"Press RETURN to go to the menu."
  44.   470     Input"To check a text file, enter its name. ",Text'file$
  45.   480     If Text'file$="" Then Run"SMENU.SAV"
  46.   490     On Error Goto 520
  47.   500     Open\1\Text'file$
  48.   510     Close\1\
  49.   520     If Sys(3)>0 Then  Do
  50.   530       @ : @"Error ";Sys(3);" has occured."
  51.   540       If Sys(3)=128 Or Sys(3)=134 Then @"File does not exist on disk."
  52.   550       If Sys(3)=129 Then @"Please enter a filename."
  53.   560       If Sys(3)=131 Then Close\1\ : @"File not ready.  Please try again."
  54.   570       Enddo
  55.   580     Until Sys(3)=0
  56.   590   On Error Stop
  57.   600   Return
  58.   610 *Set'record
  59.   620   @ : @"Press RETURN to start with record 0"
  60.   630   Input"Or type a record number to start at: ",String$
  61.   640   If String$="" Then Record=-1 : Return
  62.   650   Record=Val(String$)-1
  63.   660   If Record<-1 Then Record=-1
  64.   670   Return
  65.   680 *Get'file
  66.   690   Text$(0,Sector-1)=Text$(Sector,Sector*2-1)
  67.   700   Record=Record+1
  68.   710   Get\1,Record\Text$(Sector,Sector*2-1)
  69.   720   Finish=Pos(Text$,Eof$(0,0),0)
  70.   730   If Finish=-1 Then Finish=Sector*2
  71.   740   I=Sector
  72.   750   Start'word=Start'word-Sector
  73.   760   Return
  74.   770 *Count
  75.   780   I=Sector
  76.   790     While Pos(Letters$,Text$(I,I),0)=-1 And I<=Finish
  77.   800     I=I+1
  78.   810     If I=Sector*2 Then Gosub Get'file
  79.   820     Endwhile
  80.   830     Repeat
  81.   840     Start'word=I
  82.   850     End'word=-2
  83.   860       While End'word=-2 And I<Finish
  84.   870       If Pos(Letters$,Text$(I,I),0)=-1 Then End'word=I-1
  85.   880       If End'word=-2 Then I=I+1
  86.   890       If I=Sector*2 Then Gosub Get'file
  87.   900       Endwhile
  88.   910     If I<Finish Then Gosub Spelling
  89.   920       While Pos(Letters$,Text$(I,I),0)=-1 And I<Finish
  90.   930       I=I+1
  91.   940       If I=Sector*2 Then Gosub Get'file
  92.   950       Endwhile
  93.   960     Until I>=Finish
  94.   970   Return
  95.   980 *Spelling
  96.   990   Word'check$=Text$(Start'word,End'word)
  97.  1000   If Len(Word'check$)<4 Then Return
  98.  1010   If Asc(Word'check$(0,0))<65 Then Return
  99.  1020   Gosub Lower
  100.  1030   If Pos(Word'check$,"'",0)>-1 Then  Do
  101.  1040     Local K
  102.  1050     K=Pos(Word'check$,"'",0)
  103.  1060     If Word'check$(K+1,K+1)=Chr$(0) Then Word'check$(K,K)=Chr$(0)
  104.  1070     If Word'check$(K+1,K+1)="s" Then Word'check$(K,K)=Chr$(0) : Word'check$(K+1,K+1)=Chr$(0)
  105.  1080     Enddo
  106.  1090   If Len(Word'check$)>15 Then Goto 1210
  107.  1100   On Error Goto 1140
  108.  1110   Kgetkey\2,Word'check$(0,14)\
  109.  1120   In'dictionary=In'dictionary+1
  110.  1130   @ Word'check$;" OK" : Return
  111.  1140   On Error Stop
  112.  1150   Call .Check'for'root (Word'check$)
  113.  1160   On Error Stop
  114.  1170   If Found>0 Then @ Word'check$;" OK" : In'dictionary=In'dictionary+1 : Return
  115.  1180   @ Word'check$;" CHECK";
  116.  1190   To'check=To'check+1
  117.  1200   @ Using" ###.##%",(100.0*To'check)/(To'check+In'dictionary)
  118.  1210   On Error Goto 1230
  119.  1220   Kadd\3,Word'check$(0,14)\
  120.  1230   On Error Goto 350
  121.  1240   Return
  122.  1250 *Lower
  123.  1260   Local I
  124.  1270     For I=0 To Len(Word'check$)-1
  125.  1280     If Word'check$(I,I)>"@" And Word'check$(I,I)<"]" Then Word'check$(I,I)=Chr$(Asc(Word'check$(I,I))+32)
  126.  1290     Next I
  127.  1300   Return
  128.  1310 Procedure .Check'for'root (Word$)
  129.  1320   Local I,J,K
  130.  1330   I=Len(Word$)
  131.  1340   Found=0 : K=0
  132.  1350     Repeat
  133.  1360     K=K+1
  134.  1370     Suffix$=Suffixes$((K-1)*3,K*3-1)
  135.  1380     J=Len(Suffix$)
  136.  1390     If Word$(I-J,I-1)=Suffix$ Then  Do
  137.  1400       Root$=Word$(0,I-J-1)
  138.  1410       On Error Goto 1440
  139.  1420       Kgetkey\2,Root$(-1)\Endings
  140.  1430       If Binand(Endings,Bitmask(K-1))>0 Then Found=K
  141.  1440       Enddo
  142.  1450     On Error Stop
  143.  1460     Until Found>0 Or K>=7
  144.  1470   Endproc 
  145.  1480 *Print'results
  146.  1485   @ : @"File examined = ";Text'file$
  147.  1490   @"Number of words examined = ";In'dictionary+To'check
  148.  1500   @"Percent in dictionary = ";
  149.  1505   Print Using"###.##%",(100.0*In'dictionary)/(In'dictionary+To'check)
  150.  1510   @
  151.  1520   Return
  152.  1530 *Ender
  153.  1540   Close
  154.  1550   @ : @"Ended at record ";Record : @
  155.  1555   Gosub Print'results
  156.  1560   End
  157.  1570 *Set'masks
  158.  1580   Local I,J
  159.  1590   Bitmask(0)=1 : J=1
  160.  1600     For I=1 To 14
  161.  1610     J=J*2
  162.  1620     Bitmask(I)=J
  163.  1630     Next I
  164.  1640   Return
  165.