Forth и другие саморасширяющиеся системы программирования Locations of visitors to this page
Текущее время: Сб июл 21, 2018 13:58

...
Google Search
Forth-FAQ Spy Grafic

Часовой пояс: UTC + 3 часа [ Летнее время ]




Начать новую тему Ответить на тему  [ Сообщений: 6 ] 
Автор Сообщение
 Заголовок сообщения: *посчитать частоту повторения слов в файле
СообщениеДобавлено: Ср май 19, 2010 15:59 
Не в сети
Аватара пользователя

Зарегистрирован: Вт мар 20, 2007 23:39
Сообщения: 1254
Благодарил (а): 3 раз.
Поблагодарили: 16 раз.
Дано имя файла.
Необходимо посчитать количество уникальных лексем в файле,
затем вывести собранную информацию в удобном виде.

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


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

_________________
Cтоимость сопровождения программного обеспечения пропорциональна квадрату творческих способностей программиста.
Роберт Д. Блисc


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *посчитать частоту повторения слов в файле
СообщениеДобавлено: Пт июн 04, 2010 12:39 
Не удержался и написал программу, которая решает сразу две задачи: первоначальную и изменённую.
Программа написана для 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
;


Вернуться к началу
  
Ответить с цитатой  
 Заголовок сообщения: Re: *посчитать частоту повторения слов в файле
СообщениеДобавлено: Пт июн 11, 2010 15:20 
Не в сети
Аватара пользователя

Зарегистрирован: Чт июл 20, 2006 11:31
Сообщения: 2109
Откуда: Екб
Благодарил (а): 0 раз.
Поблагодарили: 36 раз.
Отдыхая от отпуска. :)
Код:
\ читать файл в первый буфер
\ и выделить второй буфер для координат лексем( 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

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

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

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

_________________
С уважением, chess


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *посчитать частоту повторения слов в файле
СообщениеДобавлено: Пт июл 16, 2010 18:08 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4920
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 56 раз.
ну вот и я решил побаловаться.
Правда, в первую очередь код иллюстрирует идею (использовать стандартный словарь для подсчета слов)

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

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *посчитать частоту повторения слов в файле
СообщениеДобавлено: Пн июл 19, 2010 14:57 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4920
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 56 раз.
продолжаем баловаться (небольшая модификация предыдущего варианта)
введена дополнительная переменная, которая влияет на поведение слов в словаре 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
;

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *посчитать частоту повторения слов в файле
СообщениеДобавлено: Пн июл 19, 2010 15:54 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4920
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 56 раз.
а теперь добавилась обрабока коментариев:

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

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 6 ] 

Часовой пояс: UTC + 3 часа [ Летнее время ]


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

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы не можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
phpBB сборка от FladeX // Русская поддержка phpBB