подсчёт русских и английских слов в ЯОС

Только технические вопросы по ЯОС. Терминология и прочее - в других форумах.
Ответить
БудДен
Сообщения: 2237
Зарегистрирован: 07.10.18 14:01

подсчёт русских и английских слов в ЯОС

Сообщение БудДен » 28.01.22 17:20

для начала так:

Код: Выделить всё

(in-package :cl-user)

(defparameter *результаты* -1000)

(defun обнули-результаты ()
  (setf *результаты* (make-hash-table :test 'equalp)))

(defparameter *разделители*
  (format nil "\"\|<>\\'.:,-;(){}[]^&+*/!~~#$ %=?¿`„“«»˛_ˉ¡~A" #\Tab))

(defun разделитель-ли (б)
  (find б *разделители*))

(defun интересный-файл-из-A2-ли (имя-файла)
  (member (pathname-type имя-файла) 
          '("Mod" "ярм" "md" "txt" "sh" "xml") 
          :test 'string-equal))


(defun посчитай-слова-в-A2 (директория имя-файла-отчёта)
  (обнули-результаты)
  (budden-tools:map-dir 'посчитай-в-одном директория
                        :subdirs :recurse 
                        :file-test 'интересный-файл-из-A2-ли)
  (отфильтруй-результаты)
  (выведи-отчёт имя-файла-отчёта)
  (values))


(defun выкинуть-это-слово-ли (слово)
  (cond
   ((find (elt слово 0) "0123456789")
    t)
   ((= (length слово) 1)
    t)
   ((every (lambda (б) (find б "0123456789")) слово)
    t)
   ((and (find #\0 слово)
         (find #\h слово :test 'equalp)
         (every (lambda (б) (find б "01234567890ABCDEFH")) слово))
    t)
   ((and (= (length слово) 8)
         (every (lambda (б) (find б "01234567890ABCDEF")) слово))
    t)
   (t
    nil)))

(defun отфильтруй-результаты ()
  (maphash (lambda (к з)
             (declare (ignore з))
             (when (выкинуть-это-слово-ли к)
               (remhash к *результаты*)))
           *результаты*))


(defun выведи-отчёт (имя-файла-отчёта)
  (with-open-file (в имя-файла-отчёта
                     :direction :output
                     :if-does-not-exist :create
                     :if-exists :supersede
                     :external-format :utf-8)
    (maphash 
     (lambda (к з)
       (print `(,к ,з) в))
     *результаты*)))


(defun посчитай-долю-русских ()
  (let ((к-во-русских 0)
        (к-во-всего 0))
    (maphash 
     (lambda (к з)
       (declare (ignore з))
       (when (some 'russian-budden-tools:cyrillic-char-p к)
         (incf к-во-русских))
       (incf к-во-всего))
     *результаты*)
    (format t "~&Русских: ~A, всего: ~A, доля = ~A"
            к-во-русских
            к-во-всего
            (float (/ к-во-русских (+ 0.01 к-во-всего))))))

(defun посчитай-в-одном (имя-файла)
  (handler-case
      (with-open-file (ч имя-файла :direction :input :external-format :utf-8)
        (loop
          (let* ((строка (read-line ч nil nil))
                 (кнф (null строка)))
            (when кнф (return))
            (let* ((слова
                    (split-sequence:split-sequence-if #'разделитель-ли 
                                                      строка
                                                      :remove-empty-subseqs t)))
              (dolist (слово слова)
                (учти-слово слово))))))
    (sb-impl::stream-decoding-error 
     (e)
     (declare (ignore e))                     
     (format *error-output* "~&Файл ~S - не в ФПЮ8~%" имя-файла))))

(defun учти-слово (слово)
  (cond ((gethash слово *результаты*)
         (incf (gethash слово *результаты*)))
        (t
         (setf (gethash слово *результаты*) 1))))

#|
(progn 
  (посчитай-слова-в-A2 #p"c:/ob/jaos/" "c:/ob/отчёт.текст") 
  (посчитай-долю-русских))  
|#



БудДен
Сообщения: 2237
Зарегистрирован: 07.10.18 14:01

Re: подсчёт русских и английских слов в ЯОС

Сообщение БудДен » 28.01.22 17:29

Теперь надо ещё побить на слова по заглавным буквам.

БудДен
Сообщения: 2237
Зарегистрирован: 07.10.18 14:01

Re: подсчёт русских и английских слов в ЯОС

Сообщение БудДен » 28.01.22 18:10

Код: Выделить всё

(named-readtables:in-readtable :buddens-readtable-a)

(ql:quickload :ЯР.НАНО-ПАРСЕР)

(in-package :cl-user)

(defparameter *результаты* -1000)

(defun обнули-результаты ()
  (setf *результаты* (make-hash-table :test 'equalp)))

(defparameter *разделители*
  (format nil "\"\|<>\\'.:,-;(){}[]^&+*/!~~#$ %=?¿`„“«»˛_ˉ¡~A" #\Tab))

(defun разделитель-ли (б)
  (find б *разделители*))

(defun интересный-файл-из-A2-ли (имя-файла)
  (member (pathname-type имя-файла) 
          '("Mod" "ярм" "md" "txt" "sh" "xml") 
          :test 'string-equal))


(defun посчитай-слова-в-A2 (директория имя-файла-отчёта)
  (обнули-результаты)
  (budden-tools:map-dir 'посчитай-в-одном директория
                        :subdirs :recurse 
                        :file-test 'интересный-файл-из-A2-ли)
  (отфильтруй-результаты)
  (выведи-отчёт имя-файла-отчёта)
  (values))


(defun выкинуть-это-слово-ли (слово)
  (cond
   ((find (elt слово 0) "0123456789")
    t)
   ((= (length слово) 1)
    t)
   ((every (lambda (б) (find б "0123456789")) слово)
    t)
   ((and (find #\0 слово)
         (find #\h слово :test 'equalp)
         (every (lambda (б) (find б "01234567890ABCDEFH")) слово))
    t)
   ((and (= (length слово) 8)
         (every (lambda (б) (find б "01234567890ABCDEF")) слово))
    t)
   (t
    nil)))

(defun отфильтруй-результаты ()
  (maphash (lambda (к з)
             (declare (ignore з))
             (when (выкинуть-это-слово-ли к)
               (remhash к *результаты*)))
           *результаты*))


(defun выведи-отчёт (имя-файла-отчёта)
  (with-open-file (в имя-файла-отчёта
                     :direction :output
                     :if-does-not-exist :create
                     :if-exists :supersede
                     :external-format :utf-8)
    (maphash 
     (lambda (к з)
       (print `(,к ,з) в))
     *результаты*)))


(defun посчитай-долю-русских ()
  (let ((к-во-русских-уник 0)
        (к-во-всего-уник 0)
        (к-во-русских 0)
        (к-во-всего 0))
    (maphash 
     (lambda (к з)
       (when (some 'russian-budden-tools:cyrillic-char-p к)
         (incf к-во-русских-уник)
         (incf к-во-русских з))
       (incf к-во-всего-уник)
       (incf к-во-всего з))
     *результаты*)
    (format t "~&Русских: ~A (уник ~A), всего: ~A (уник ~A)~%, доля = ~A (уник ~A)"
            к-во-русских
            к-во-русских-уник
            к-во-всего
            к-во-всего-уник
            (float (/ к-во-русских (+ 0.01 к-во-всего)))
            (float (/ к-во-русских-уник (+ 0.01 к-во-всего-уник))))))

(defun посчитай-в-одном (имя-файла)
  (handler-case
      (with-open-file (ч имя-файла :direction :input :external-format :utf-8)
        (loop
          (let* ((строка (read-line ч nil nil))
                 (кнф (null строка)))
            (when кнф (return))
            (let* ((слова
                    (split-sequence:split-sequence-if #'разделитель-ли 
                                                      строка
                                                      :remove-empty-subseqs t)))
              (dolist (слово слова)
                (dolist (кусок-слова
                         (Читать-слова-разбитые-по-большим-буквам слово))
                  (учти-слово 
                   (russian-budden-tools:string-downcase-cyr кусок-слова))))))))
    (sb-impl::stream-decoding-error 
     (e)
     (declare (ignore e))                     
     (format *error-output* "~&Файл ~S - не в ФПЮ8~%" имя-файла))))


(defun учти-слово (слово)
  (cond ((gethash слово *результаты*)
         (incf (gethash слово *результаты*)))
        (t
         (setf (gethash слово *результаты*) 1))))



(defun Читать-слова-разбитые-по-большим-буквам (Стр)
  (let ((ЯР.НАНО-ПАРСЕР:сп-Контекст-разбора
         (ЯР.НАНО-ПАРСЕР:MAKE-Контекст-разбора
               :Источник (ПОЛНОСТЬЮ-КЕШИРОВАННЫЙ-ПОТОК:Создать-Полностью-кешированный-поток-из-потока (make-string-input-stream Стр))
               :Функция-получения-класса 'БУКВЫ-И-МЕСТА-В-ФАЙЛЕ:Пб-Бу
               :Значение-КФ :eof
               )))
    (Читать-слова-с-большой-буквы-выкидывая-подчёркивания)))

(defun Читать-слова-с-большой-буквы-выкидывая-подчёркивания ()
  (budden-tools:perga
   (let Рез nil)
   (let первая-буква-ли? t)
   (loop
     (cond ((eql (ЯР.НАНО-ПАРСЕР:л-Класс) #\_) (ЯР.НАНО-ПАРСЕР:Чит-э))
           ((eql (ЯР.НАНО-ПАРСЕР:л-Класс) :eof)
            (return Рез))
           ((budden-tools:perga
             (let Б (БУКВЫ-И-МЕСТА-В-ФАЙЛЕ-ЛИЦО:Пб-Бу 
                     (ЯР.НАНО-ПАРСЕР:Предвидеть-э)))
             (or первая-буква-ли?
                 (eql Б (russian-budden-tools:char-upcase-cyr Б))))
            (let ((Ч 
                   (Читать-слово-с-буквы-а-буква-вот 
                    (БУКВЫ-И-МЕСТА-В-ФАЙЛЕ-ЛИЦО:Пб-Бу (ЯР.НАНО-ПАРСЕР:Чит-э)))))
              (when Ч (push Ч Рез))))
           (t ; если что-то не так, просто пропускаем
            (ЯР.НАНО-ПАРСЕР:Чит-э)
            ))
     (setq первая-буква-ли? nil))))

(defun Читать-слово-с-буквы-а-буква-вот (Б)
 (budden-tools:perga
   (let Рез (list Б))
   (loop (cond
          ((eql (ЯР.НАНО-ПАРСЕР:л-Класс) #\_) (ЯР.НАНО-ПАРСЕР:Чит-э))
          ((eql (ЯР.НАНО-ПАРСЕР:л-Класс) :eof)
           (return (map 'string 'identity (reverse Рез))))
          ((budden-tools:perga
            (let Б (БУКВЫ-И-МЕСТА-В-ФАЙЛЕ-ЛИЦО:Пб-Бу (ЯР.НАНО-ПАРСЕР:Предвидеть-э)))
            (eql Б (russian-budden-tools:char-upcase-cyr Б)))
           (return (map 'string 'identity (reverse Рез))))
          (t (push (БУКВЫ-И-МЕСТА-В-ФАЙЛЕ-ЛИЦО:Пб-Бу (ЯР.НАНО-ПАРСЕР:Чит-э)) Рез))))))



#|
(progn 
  (посчитай-слова-в-A2 #p"c:/ob/jaos/" "c:/ob/отчёт.текст") 
  (посчитай-долю-русских))  
|#


БудДен
Сообщения: 2237
Зарегистрирован: 07.10.18 14:01

Re: подсчёт русских и английских слов в ЯОС

Сообщение БудДен » 28.01.22 18:15

Результаты удивительны.

Я разбил идентификаторы на слова по заглавным буквам и дальше посчитал вхождение каждого слова, без учёта словоформ и регистра.

Вышло:

Код: Выделить всё

Русских: 1302204 (уник 10455), всего: 4335548 (уник 30387)
, доля = 0.3003551101259746 (уник 0.344061492065195)
Т.е. всего в ЯОС 4 млн английских слов или идентификаторов, нарезанных по заглавным буквам и иным разделителям. Уникальных английских слов - 30 тыс. При том, уникальных русских слов - уже 11 тыс. Т.е. я неплохо потрудился, если считать таким образом. Теперь надо ещё составить ретроспективу и графичек.
Вложения
отчёт.7z
(142.99 КБ) 15 скачиваний

БудДен
Сообщения: 2237
Зарегистрирован: 07.10.18 14:01

Re: подсчёт русских и английских слов в ЯОС

Сообщение БудДен » 28.01.22 18:22

Неплохо бы, если бы кто-то проверил. МихалНик, ау?


MihalNik
Сообщения: 239
Зарегистрирован: 05.11.18 11:02

Re: подсчёт русских и английских слов в ЯОС

Сообщение MihalNik » 28.01.22 22:12

БудДен писал(а):
28.01.22 18:15
Результаты удивительны.
<...>Уникальных английских слов - 30 тыс.
Закономерно - втрое меньше цельных уникальных имен.
Это Вы еще не оценивали вероятное число сокращений из них, когда сочетание является подмножеством хотя бы какого-то другого, но не является словом из обычного английского словаря. Доля словарных тоже сама по себе интересна и важна для оценки объема работы.

MihalNik
Сообщения: 239
Зарегистрирован: 05.11.18 11:02

Re: подсчёт русских и английских слов в ЯОС

Сообщение MihalNik » 28.01.22 22:20

БудДен писал(а):
28.01.22 18:22
Неплохо бы, если бы кто-то проверил?
Лень читать лисп, последовательности заглавных букв считались за целое, исключая последнюю, если за ней есть строчная?

БудДен
Сообщения: 2237
Зарегистрирован: 07.10.18 14:01

Re: подсчёт русских и английских слов в ЯОС

Сообщение БудДен » 30.01.22 14:59

он каждый раз начинает новое слово с заглавной буквы, т.е. аббревиатура, набранная заглавными, рассыпется на буквы. Но проблема в другом:

* Это не я потрудился, а мы потрудились, поскольку в переводе описания языка 3400 слов.
* документация в форматах Text и Bbt не учтена, а её много. Видимо, нужно уже переписывать счётчик на самом Обероне.

Парсер, который пытается более умно разбивать слова, находится тут https://gitlab.com/budden/ja-o-s/-/blob ... ВФайле.ярм

В конце есть куча примеров разбора. Там последовательность заглавных всё равно рассыпается, но это я так специально сделал. Возможно, идея о том, что если за цепочкой заглавных идёт строчная, то считать лексемой последовательность заглавных без последней тоже хороша, но лень к этому вопросу возвращаться. То, как у меня сделано - тоже достаточно хорошо.

Ответить