fork download
copy 
  1. ;;; Глобальные константы
  2. (defconstant +glasn+ '(#\А #\Е #\Ё #\И #\О #\У #\Ы #\Э #\Ю #\Я #\а #\е #\ё #\и #\о #\у #\ы #\э #\ю #\я)
  3.   "Список гласных букв")
  4. (defconstant +sonorn+ '(#\Л #\М #\Н #\Р #\л #\м #\н #\р #\Й #\й)
  5.   "Список сонорных согласных букв")
  6.  
  7. ;;; Функция для проверки, является ли символ гласной буквой
  8. (defun glasn (char)
  9.   (member char +glasn+ :test #'char-equal))
  10.  
  11. ;;; Функция для проверки, является ли символ сонорным согласным
  12. (defun sonorn (char)
  13.   (member char +sonorn+ :test #'char-equal))
  14.  
  15. ;;; Функция для проверки, является ли символ шумным согласным
  16. (defun shumn (char)
  17.   (and (not (glasn char)) (not (sonorn char))))
  18.  
  19. ;;; Функция для разбиения слова на слоги (с учетом правил стечения согласных)
  20. (defun razbit-na-slogi (word)
  21.   (let ((slogi nil)       ; Список слогов (будет содержать списки символов)
  22.         (current-slog nil))  ; Текущий слог (список символов)
  23.     (dotimes (i (length word))  ; Перебираем символы в слове
  24.       (let ((char (char word i))) ; Получаем текущий символ
  25.         (push char current-slog) ; Добавляем символ в текущий слог
  26.  
  27.         (when (glasn char)      ; Если текущий символ - гласная
  28.           (cond
  29.             ((= (length current-slog) 1) ; Если слог состоит только из гласной
  30.              (push (reverse current-slog) slogi) ; Добавляем слог в список слогов
  31.              (setf current-slog nil))           ; Начинаем новый слог
  32.             (t                                ; Если перед гласной есть согласные
  33.              (let ((rev-slog (reverse current-slog))) ; Переворачиваем слог для удобства анализа
  34.                (cond
  35.                  ((and (>= (length current-slog) 2)  ; Если в слоге минимум 2 символа
  36.                        (shumn (nth 1 rev-slog))       ; И предпоследний - шумный
  37.                        (shumn (nth 0 rev-slog)))      ; И последний (перед гласной) - шумный
  38.                   ; Два шумных согласных: оба отходят к следующему слогу
  39.                   (push (reverse (subseq rev-slog 1)) slogi) ; Все, кроме последней буквы (гласной) образуют новый слог
  40.                   (setf current-slog (list char)))            ; Начинаем с гласной новый слог
  41.  
  42.                  ((and (>= (length current-slog) 2)  ; Если в слоге минимум 2 символа
  43.                        (sonorn (nth 1 rev-slog))      ; И предпоследний - сонорный
  44.                        (sonorn (nth 0 rev-slog))      ; И последний (перед гласной) - сонорный
  45.                        (not (char-equal (nth 0 rev-slog) #\й))) ; И это не "й"
  46.                   ; Два сонорных согласных (кроме "й"): оба отходят к следующему слогу
  47.                   (push (reverse (subseq rev-slog 1)) slogi) ; Новый слог без последней буквы(гласной)
  48.                   (setf current-slog (list char)))            ; Начинаем новый слог с гласной
  49.  
  50.                  ((and (>= (length current-slog) 2)  ; Если в слоге минимум 2 символа
  51.                        (char-equal (nth 1 rev-slog) #\й))  ; Если предпоследний символ - "й"
  52.                   ; "й" всегда отходит к предыдущей гласной (в этом коде - к текущему слогу)
  53.                   (push (reverse (subseq rev-slog 1)) slogi) ; Новый слог без гласной
  54.                   (setf current-slog (list char)))            ; Начинаем новый слог с гласной
  55.                  ((and (>= (length current-slog) 2)  ; Если в слоге минимум 2 символа
  56.                        (sonorn (nth 1 rev-slog))      ; Если предпоследний символ — сонорный
  57.                        (shumn (nth 0 rev-slog)))      ; Если последний символ — шумный
  58.                   ; Сонорный перед шумным:  отходит к предыдущему слогу.
  59.                   ; (Можно добавить свои правила, например, смотреть на соседние буквы в словаре)
  60.                   (push (reverse (subseq rev-slog 1)) slogi) ; Все кроме гласной добавляем в новый слог
  61.                   (setf current-slog (list char)))            ; Начинаем новый слог
  62.                  (t                                ; Во всех остальных случаях
  63.                   ; Просто отделяем слог
  64.                   (push (reverse (subseq rev-slog 1)) slogi) ; Добавляем слог
  65.                   (setf current-slog (list char))))))))))         ; Начинаем новый слог
  66.  
  67.     (reverse (mapcar #'(lambda (slog) (coerce slog 'string)) (reverse slogi))))) ; Преобразуем списки символов в строки и переворачиваем обратно
  68.  
  69. ;;; Функция для разбиения фразы на слова (замена split-sequence)
  70. (defun razbit-frazu-na-slova (fraza)
  71.   (let ((words nil)
  72.         (start 0)
  73.         (end nil))
  74.     (loop
  75.       (setf end (position #\Space fraza :start start)) ; Ищем пробел начиная с позиции start
  76.       (if end  ; Если пробел найден
  77.           (progn
  78.             (push (subseq fraza start end) words) ; Извлекаем слово и добавляем в список
  79.             (setf start (1+ end)))              ; Передвигаем start на позицию после пробела
  80.           (progn  ; Если пробел не найден (последнее слово)
  81.             (push (subseq fraza start) words)    ; Добавляем последнее слово
  82.             (return (nreverse words)))))))      ; Переворачиваем список и возвращаем
  83.  
  84. ;;; Главная функция, которая принимает фразу и выводит ее по слогам
  85. (defun obrabotat-frazu (fraza)
  86.   (if (null fraza)
  87.       (format t "Фраза пуста.")
  88.       (format t "~{~{~A~^-~}~%~}"   ; Выводим все слоги в одной строке, разделенные дефисами
  89.               (mapcar #'(lambda (slovo) (razbit-na-slogi slovo)) ; Для каждого слова разбиваем на слоги
  90.                       (razbit-frazu-na-slova fraza))))) ; Разбиваем фразу на слова
  91.  
  92. ;;; Примеры использования:
  93. (format t "Примеры использования:~%")
  94. (format t "---------------------~%")
  95.  
  96. (format t "Фраза: принцип восходящей звучности ~%")
  97. (obrabotat-frazu "принцип восходящей звучности")
  98. (format t "Ожидаемый результат: прин-цип-вос-хо-дя-щей- звуч-нос-ти~%")
  99. (format t "---------------------~%")
  100.  
  101. (format t "Фраза: стройка ~%")
  102. (obrabotat-frazu "стройка")
  103. (format t "Ожидаемый результат: строй-ка~%")
  104. (format t "---------------------~%")
  105.  
  106. (format t "Фраза: слогораздел ~%")
  107. (obrabotat-frazu "слогораздел")
  108. (format t "Ожидаемый результат: сло-го-раз-дел~%")
  109. (format t "---------------------~%")
  110.  
  111. (format t "Фраза: антенна ~%")
  112. (obrabotat-frazu "антенна")
  113. (format t "Ожидаемый результат: ~%")
  114. (format t "---------------------~%")
  115.  
  116. (format t "Фраза: космос ~%")
  117. (obrabotat-frazu "космос")
  118. (format t "Ожидаемый результат: ~%")
  119. (format t "---------------------~%")
  120.  
  121. (format t "Фраза: рысь ~%")
  122. (obrabotat-frazu "рысь")
  123. (format t "Ожидаемый результат: ~%")
  124. (format t "---------------------~%")
  125.  
  126. (terpri) ; Перевод строки в конце
Success #stdin #stdout #stderr 0.02s 9676KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Примеры использования:
---------------------
Фраза: принцип восходящей звучности 
ицн-ир
ещ-яд-охс-о
итс-онч-ув
Ожидаемый результат: прин-цип-вос-хо-дя-щей- звуч-нос-ти
---------------------
Фраза: стройка 
акй-орт
Ожидаемый результат: строй-ка
---------------------
Фраза: слогораздел 
едз-ар-ог-ол
Ожидаемый результат: сло-го-раз-дел
---------------------
Фраза: антенна 
анн-ет-а
Ожидаемый результат: 
---------------------
Фраза: космос 
омс-о
Ожидаемый результат: 
---------------------
Фраза: рысь 
ы
Ожидаемый результат: 
---------------------
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x145ddb600000 - 0x145ddb8e4fff
  0x145ddba00000 - 0x145ddba02fff
  0x145ddba03000 - 0x145ddbc01fff
  0x145ddbc02000 - 0x145ddbc02fff
  0x145ddbc03000 - 0x145ddbc03fff
  0x145ddbc15000 - 0x145ddbc39fff
  0x145ddbc3a000 - 0x145ddbdacfff
  0x145ddbdad000 - 0x145ddbdf5fff
  0x145ddbdf6000 - 0x145ddbdf8fff
  0x145ddbdf9000 - 0x145ddbdfbfff
  0x145ddbdfc000 - 0x145ddbdfffff
  0x145ddbe00000 - 0x145ddbe03fff
  0x145ddbe04000 - 0x145ddc003fff
  0x145ddc004000 - 0x145ddc004fff
  0x145ddc005000 - 0x145ddc005fff
  0x145ddc063000 - 0x145ddc064fff
  0x145ddc065000 - 0x145ddc074fff
  0x145ddc075000 - 0x145ddc0a8fff
  0x145ddc0a9000 - 0x145ddc1dffff
  0x145ddc1e0000 - 0x145ddc1e0fff
  0x145ddc1e1000 - 0x145ddc1e3fff
  0x145ddc1e4000 - 0x145ddc1e4fff
  0x145ddc1e5000 - 0x145ddc1e6fff
  0x145ddc1e7000 - 0x145ddc1e7fff
  0x145ddc1e8000 - 0x145ddc1e9fff
  0x145ddc1ea000 - 0x145ddc1eafff
  0x145ddc1eb000 - 0x145ddc1ebfff
  0x145ddc1ec000 - 0x145ddc1ecfff
  0x145ddc1ed000 - 0x145ddc1fafff
  0x145ddc1fb000 - 0x145ddc208fff
  0x145ddc209000 - 0x145ddc215fff
  0x145ddc216000 - 0x145ddc219fff
  0x145ddc21a000 - 0x145ddc21afff
  0x145ddc21b000 - 0x145ddc21bfff
  0x145ddc21c000 - 0x145ddc221fff
  0x145ddc222000 - 0x145ddc223fff
  0x145ddc224000 - 0x145ddc224fff
  0x145ddc225000 - 0x145ddc225fff
  0x145ddc226000 - 0x145ddc226fff
  0x145ddc227000 - 0x145ddc254fff
  0x145ddc255000 - 0x145ddc263fff
  0x145ddc264000 - 0x145ddc309fff
  0x145ddc30a000 - 0x145ddc3a0fff
  0x145ddc3a1000 - 0x145ddc3a1fff
  0x145ddc3a2000 - 0x145ddc3a2fff
  0x145ddc3a3000 - 0x145ddc3b6fff
  0x145ddc3b7000 - 0x145ddc3defff
  0x145ddc3df000 - 0x145ddc3e8fff
  0x145ddc3e9000 - 0x145ddc3eafff
  0x145ddc3eb000 - 0x145ddc3f0fff
  0x145ddc3f1000 - 0x145ddc3f3fff
  0x145ddc3f6000 - 0x145ddc3f6fff
  0x145ddc3f7000 - 0x145ddc3f7fff
  0x145ddc3f8000 - 0x145ddc3f8fff
  0x145ddc3f9000 - 0x145ddc3f9fff
  0x145ddc3fa000 - 0x145ddc3fafff
  0x145ddc3fb000 - 0x145ddc401fff
  0x145ddc402000 - 0x145ddc404fff
  0x145ddc405000 - 0x145ddc405fff
  0x145ddc406000 - 0x145ddc426fff
  0x145ddc427000 - 0x145ddc42efff
  0x145ddc42f000 - 0x145ddc42ffff
  0x145ddc430000 - 0x145ddc430fff
  0x145ddc431000 - 0x145ddc431fff
  0x55f80a265000 - 0x55f80a355fff
  0x55f80a356000 - 0x55f80a45ffff
  0x55f80a460000 - 0x55f80a4bffff
  0x55f80a4c1000 - 0x55f80a4effff
  0x55f80a4f0000 - 0x55f80a520fff
  0x55f80a521000 - 0x55f80a524fff
  0x55f80a704000 - 0x55f80a724fff
  0x7ffd9d96a000 - 0x7ffd9d98afff
  0x7ffd9d9eb000 - 0x7ffd9d9eefff
  0x7ffd9d9ef000 - 0x7ffd9d9f0fff
https://ideone.com/QmaI4d
language:
Common Lisp (clisp 2.49.92)
created:
1 day ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!