*посчитать частоту повторения слов в файле

VoidVolker

Дано имя файла.
Необходимо посчитать количество уникальных лексем в файле,
затем вывести собранную информацию в удобном виде.

\ посчитать количество уникальных лексем в заданном файле, вывести результат в stdout 
: lexfreq ( / filename --> )
            ;

ТЗ подправлено mOleg

горький

Не удержался и написал программу, которая решает сразу две задачи: первоначальную и изменённую.
Программа написана для SPF и работает с бинарным деревом.

Код:

0
CELL -- T.WORD
CELL -- T.COUNT
CELL -- T.LEFT
CELL -- T.RIGHT
CONSTANT /TNODE

VARIABLE TREE

( NODEALLOC создает новый узел дерева a1,
  возвращает адрес нового узла - a2)

: NODEALLOC ( a1 -- a2 )
/TNODE ALLOCATE THROW >R R@ SWAP ! R> ;

( STRALLOC копирует строку a1 u1
  в строку со счетчиком a2 )

: STRALLOC ( a1 u1 -- a2 )
DUP 1+ ALLOCATE THROW
>R DUP R@ C! R@ 1+ SWAP CMOVE R> ;

( NEWNODE создает новый узел дерева a2
  и копирует туда слово a1 u1, если оно
  ненулевой длины)

: NEWNODE ( a1 u1 a2 -- )
OVER
IF NODEALLOC >R
STRALLOC R@ T.WORD !
1 R@ T.COUNT !
0 R@ T.LEFT !
0 R> T.RIGHT !
ELSE DROP 2DROP
THEN
;

( ADDWORD вставляет новое слово a1 u1
  в дерево a2 или добавляет 1 к счетчику
  уже имеющегося в дереве a2 слова)

: ADDWORD ( a1 u1 a2 -- )
DUP @ 0= IF NEWNODE EXIT THEN
@ >R 2DUP R@ T.WORD @ COUNT COMPARE DUP 0= 
IF 2DROP DROP 1 R> T.COUNT +! EXIT THEN
-1 = IF R> T.LEFT RECURSE
ELSE R> T.RIGHT RECURSE THEN
;

( _TPRINT печатает счетчик и слово
  из текущего узла дерева а)

: _TPRINT ( a --)
DUP T.COUNT @ . @ COUNT TYPE CR
;

( TPRINT печатает счетчики и слова 
  из дерева a )

: TPRINT ( a --)
@ ?DUP IF
DUP T.LEFT RECURSE
DUP _TPRINT
T.RIGHT RECURSE
THEN
;

( _NODECOUNT считает количество
  узлов дерева a)

VARIABLE #NODE

: _NODECOUNT ( a --)
@ ?DUP IF
1 #NODE +!
DUP T.LEFT RECURSE
T.RIGHT RECURSE
THEN
;

( NODECOUNT возвращает количество
  узлов дерева a)

: NODECOUNT ( a -- n)
0 #NODE !
_NODECOUNT
#NODE @
;

( SPLIT делит строку a1 u1 по подстроке a2 u2
на строки a3 u3 и a4 u4 и возвращает
флаг успешности -1,
в случае отсутствия в строке a1 u1
подстроки a2 u2 возвращает неизмененную
строку a1 u1 и флаг успешности 0)

: SPLIT
( a1 u1 a2 u2 -- a3 u3 a4 u4 -1 | a1 u1 0 )
DUP >R 2OVER DROP >R
SEARCH IF
SWAP R@ OVER R> -
2SWAP R@ + SWAP R> -
-1 EXIT THEN
2R> 2DROP 0 ;

( TRAILING убирает пробелы из начала строки)

: TRAILING ( a1 u1 -- a2 u2)
BEGIN
OVER C@ BL =
WHILE
1 -1 D+
REPEAT
;

( ADDWORDS добавляет слова из строки a u
в дерево TREE)

: ADDWORDS ( a u --)
BEGIN 
TRAILING S"  " SPLIT
WHILE
2SWAP TREE ADDWORD 
REPEAT
TREE ADDWORD
;

( ADDFILE добавляет слова из файла 
с дескриптором fd в дерево TREE) 

: ADDFILE ( fd --)
BEGIN
DUP PAD 1022 ROT READ-LINE THROW
WHILE
PAD SWAP ADDWORDS
REPEAT
DROP
;

: lexfreq ( a u --)
R/O OPEN-FILE THROW
ADDFILE
CLOSE-FILE THROW
TREE TPRINT
." Unique lexems: " TREE NODECOUNT . CR
;

chess

Отдыхая от отпуска.

Код:

\ читать файл в первый буфер
\ и выделить второй буфер для координат лексем( a u ) из первого буфера
: file->heap \ af uf -- ab1 ub1 ab2
  R/O OPEN-FILE THROW f) f !      \ открыть файл
  f @ FILE-SIZE THROW DROP s) s ! \ определить его размер
  memd( ALLOCATE THROW )          \ определить процедуру выделения памяти в хипе
  s @ memd s @ bf) bf 2!          \ выделить первый буфер - под файл
  bf 2@ f @ READ-FILE THROW DROP  \ скопировать файл в первый буфер
  f @ CLOSE-FILE THROW bf 2@      \ закрыть файл
  s @ CELLS memd  ;               \ выделить второй буфер для координат лексем

\ дать область поиска второй лексемы и координаты первой лексемы
: get-lex \ a u -- a u al ul 1 | 0
  OVER + ae) ae ! DUP ab) ab ! at) at ! fle) fle 0!
  BEGIN at @ C@ BL > IF at @ abl) abl ! 1 fle ! THEN
        at 1+! at @ ae @ > fle @ OR UNTIL fle @
  IF fle 0! BEGIN at @ C@ BL 1+ < IF at @ ael) ael ! 1 fle ! THEN
                   at 1+! at @ ae @ > fle @ OR UNTIL fle @
     IF ael @ ae @ ael @ - abl @ ael @ abl @ - TRUE ELSE FALSE THEN
  ELSE FALSE THEN ;

\ сбросить координаты лексем во второй буфер
: aulex->buf \ ab1 ub1 ab2 -- cn ab2
  ab) ab ! dp) dp 0! cl) cl 0!
  BEGIN get-lex IF ab @ dp @ + 2! 8 dp +! cl 1+! ELSE cl @ ab @ EXIT THEN AGAIN ;

\ число экземпляров каждой уникальной лексемы и число уникальных лексем
: lexfreq    ( af uf -- )
  file->heap ( af uf -- ab1 ub1 ab2  ) ROT 2DUP buf) buf 2! -ROT
  aulex->buf ( ab1 ub1 ab2 -- cn ab2 )
  a) a ! cn) cn ! o) c1) 0 c1 ! c2) 0 c2 ! all) all 0!
  BEGIN a @ c1 @ 8 * + 2@ 2DUP D0= 0=
   IF o 2! cn @ c1 @ DO a @ I 8 * + 2@ 2DUP D0=
                        IF 2DROP ELSE o 2@ COMPARE 0=
                           IF c2 1+! 0. a @ I 8 * + 2! THEN THEN
                     LOOP c2 @ . o 2@ TYPE CR  all 1+!
   ELSE 2DROP THEN 0 c2 ! c1 1+! c1 @ cn @ >
  UNTIL CR all @ . ." уникальных лексем " CR
  buf 2@ FREE THROW FREE THROW ;  \ освободить память в хипе

\ EOF

' ANSI>OEM TO ANSI><OEM STARTLOG

S" g:\SPF-419\devel\~chess\MUSOR\q3.f"  lexfreq

лог

Код:

\
форт
:
Q3
n
--
n'
DUP
2-
2*
1-
*
24
/
;
SEE
ассм
q3
$
-2
B=aA
C=B
1C<<
C--
*C
*B
18
B=#
CDQ
/B
S1
100
1
DO
I
.
LOOP

уникальных лексем

Ok
ПС. Использовал механизм лок. слов.

mOleg

ну вот и я решил побаловаться.
Правда, в первую очередь код иллюстрирует идею (использовать стандартный словарь для подсчета слов)

source file: lx.fts
\ 16.07.2010 ~mOleg
\ Сopyright [C] 2009 mOleg mOlegg@ya.ru
\ решение задачки viewtopic.php?f=19&t=2602 для конкурса

         vocs/ vocab.fts

\ Дано имя файла.
\ Необходимо посчитать количество уникальных лексем в файле,
\ затем вывести собранную информацию в удобном виде.

VOCABULARY STAT

\ создать в текущем словаре лексему, которая при каждом вызове
\ будет себя увеличивать на 1
: lex ( asc # --> )
      CREATED 1 ,
      DOES> 1 SWAP +! ;

\ если имя уже есть в текущем словаре, выполнить его, иначе создать новое имя
: ?lex ( asc # --> )
       DDUP WHO STAT SEARCH-NAME
       *IF LINK>C EXECUTE DDROP ;THEN
       DROP lex ;CREATE ;

\ выполнить действие ?lex над каждым словом во входном потоке
: (stat) ( --> )
         ALSO STAT DEFINITIONS
           BEGIN NextWord *WHILE ?lex REPEAT DDROP
         RECENT ;

\ посчитать количество уникальных лексем в заданном файле
: lexfreq ( / filename --> )
          ParseFileName FileSource ['] (stat) EvalSrcWith  ;

\ отобразить статистику по словам
: ~~ ( --> )
     WHO STAT <: CR DUP LINK>C CFL + @ . ." \t" ID. ;> WITH-VOC ;

использовать вместе с форком так
lexfreq "file.name"

потом
~~

можно и из командной строки:
fork lx.fts lexfreq "file.name" ~~ BYE >out.log

mOleg

продолжаем баловаться (небольшая модификация предыдущего варианта)
введена дополнительная переменная, которая влияет на поведение слов в словаре STAT
в одном случае увеличивается счетчик повторений слова, в другом - выводится информация о этом самом счетчике, и слове соответственно.

source file: lx.fts
\ 16.07.2010 ~mOleg
\ Сopyright [C] 2009 mOleg mOlegg@ya.ru
\ решение задачки viewtopic.php?f=19&t=2602 для конкурса

         vocs/ vocab.fts
         vocs/ deref.fts

\ Дано имя файла.
\ Необходимо посчитать количество уникальных лексем в файле,
\ затем вывести собранную информацию в удобном виде.

VOCABULARY STAT

           USER-VECT mode \ режим работы

\ увеличить значение счетчика по addr на 1
: inc  ( addr --> ) 1 SWAP +! ;
       \ отобразить значение счетчика по addr и его имя
: info ( addr --> ) DUP @ . ." \t - " WBA TYPE CR ;

\ создать в текущем словаре лексему, которая при каждом вызове
\ будет себя увеличивать на 1
: lex ( asc # --> )
      CREATED 1 ,                  \ счетчик повторений
      DOES> mode ;

\ если имя уже есть в текущем словаре
: ?lex ( asc # --> )
       DDUP WHO STAT SEARCH-NAME
       *IF LINK>C EXECUTE DDROP ;THEN
       DROP lex ;CREATE ;

\ выполнить действие ?lex над каждым словом во входном потоке
: (stat) ( --> )
         ALSO STAT DEFINITIONS
         ['] inc IS mode
           BEGIN NextWord *WHILE ?lex REPEAT DDROP
         RECENT ;

\ посчитать количество уникальных лексем в заданном файле
: lexfreq ( / filename --> )
          ParseFileName FileSource ['] (stat) EvalSrcWith  ;

\ отобразить статистику по словам
: ~~ ( --> )
     ['] info IS mode
     WHO STAT <: LINK>C EXECUTE ;> WITH-VOC
     ;

mOleg

а теперь добавилась обрабока коментариев:

source file: lx.fts
\ 16.07.2010 ~mOleg
\ Сopyright [C] 2009 mOleg mOlegg@ya.ru
\ решение задачки viewtopic.php?f=19&t=2602 для конкурса

         vocs/ vocab.fts
         vocs/ deref.fts

\ Дано имя файла.
\ Необходимо посчитать количество уникальных лексем в файле,
\ затем вывести собранную информацию в удобном виде.

VOCABULARY STAT

           USER tail  \ хвост списка сообщений

\ создать в текущем словаре лексему, которая при каждом вызове
\ будет себя увеличивать на 1
: lex ( asc # --> )
      CREATED 1 ,                       \ счетчик повторений
              HERE  tail A@ A, tail A!  \ связка в односвязный список
      DOES> 1 SWAP +! ;

\ если имя уже есть в текущем словаре
: ?lex ( asc # --> )
       DDUP WHO STAT SEARCH-NAME
       *IF LINK>C EXECUTE DDROP ;THEN
       DROP lex ;CREATE ;

\ выполнить действие ?lex над каждым словом во входном потоке
: (stat) ( --> )
         ALSO STAT DEFINITIONS
           BEGIN NextWord *WHILE ?lex REPEAT DDROP
         RECENT ;

\ посчитать количество уникальных лексем в заданном файле
: lexfreq ( / filename --> )
          ParseFileName FileSource ['] (stat) EvalSrcWith  ;

\ отобразить статистику по словам
: ~~ ( --> )
     tail BEGIN A@ *WHILE
                CR DUP CELL - @ . ." \t"
                   DUP WBA TYPE
          REPEAT DROP ;

ALSO STAT DEFINITIONS
     \ теперь слова в коментариях не будут считаться
     ALIAS \ \ IMMEDIATE
     ALIAS ( ( IMMEDIATE
RECENT

*посчитать частоту повторения слов в файле

Кто сейчас на конференции