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.01s 9584KB
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
  0x14a4efe00000 - 0x14a4f00e4fff
  0x14a4f0215000 - 0x14a4f0239fff
  0x14a4f023a000 - 0x14a4f03acfff
  0x14a4f03ad000 - 0x14a4f03f5fff
  0x14a4f03f6000 - 0x14a4f03f8fff
  0x14a4f03f9000 - 0x14a4f03fbfff
  0x14a4f03fc000 - 0x14a4f03fffff
  0x14a4f0400000 - 0x14a4f0402fff
  0x14a4f0403000 - 0x14a4f0601fff
  0x14a4f0602000 - 0x14a4f0602fff
  0x14a4f0603000 - 0x14a4f0603fff
  0x14a4f0680000 - 0x14a4f068ffff
  0x14a4f0690000 - 0x14a4f06c3fff
  0x14a4f06c4000 - 0x14a4f07fafff
  0x14a4f07fb000 - 0x14a4f07fbfff
  0x14a4f07fc000 - 0x14a4f07fefff
  0x14a4f07ff000 - 0x14a4f07fffff
  0x14a4f0800000 - 0x14a4f0803fff
  0x14a4f0804000 - 0x14a4f0a03fff
  0x14a4f0a04000 - 0x14a4f0a04fff
  0x14a4f0a05000 - 0x14a4f0a05fff
  0x14a4f0b6d000 - 0x14a4f0b70fff
  0x14a4f0b71000 - 0x14a4f0b71fff
  0x14a4f0b72000 - 0x14a4f0b73fff
  0x14a4f0b74000 - 0x14a4f0b74fff
  0x14a4f0b75000 - 0x14a4f0b75fff
  0x14a4f0b76000 - 0x14a4f0b76fff
  0x14a4f0b77000 - 0x14a4f0b84fff
  0x14a4f0b85000 - 0x14a4f0b92fff
  0x14a4f0b93000 - 0x14a4f0b9ffff
  0x14a4f0ba0000 - 0x14a4f0ba3fff
  0x14a4f0ba4000 - 0x14a4f0ba4fff
  0x14a4f0ba5000 - 0x14a4f0ba5fff
  0x14a4f0ba6000 - 0x14a4f0babfff
  0x14a4f0bac000 - 0x14a4f0badfff
  0x14a4f0bae000 - 0x14a4f0baefff
  0x14a4f0baf000 - 0x14a4f0baffff
  0x14a4f0bb0000 - 0x14a4f0bb0fff
  0x14a4f0bb1000 - 0x14a4f0bdefff
  0x14a4f0bdf000 - 0x14a4f0bedfff
  0x14a4f0bee000 - 0x14a4f0c93fff
  0x14a4f0c94000 - 0x14a4f0d2afff
  0x14a4f0d2b000 - 0x14a4f0d2bfff
  0x14a4f0d2c000 - 0x14a4f0d2cfff
  0x14a4f0d2d000 - 0x14a4f0d40fff
  0x14a4f0d41000 - 0x14a4f0d68fff
  0x14a4f0d69000 - 0x14a4f0d72fff
  0x14a4f0d73000 - 0x14a4f0d74fff
  0x14a4f0d75000 - 0x14a4f0d7afff
  0x14a4f0d7b000 - 0x14a4f0d7dfff
  0x14a4f0d80000 - 0x14a4f0d80fff
  0x14a4f0d81000 - 0x14a4f0d81fff
  0x14a4f0d82000 - 0x14a4f0d82fff
  0x14a4f0d83000 - 0x14a4f0d83fff
  0x14a4f0d84000 - 0x14a4f0d84fff
  0x14a4f0d85000 - 0x14a4f0d8bfff
  0x14a4f0d8c000 - 0x14a4f0d8efff
  0x14a4f0d8f000 - 0x14a4f0d8ffff
  0x14a4f0d90000 - 0x14a4f0db0fff
  0x14a4f0db1000 - 0x14a4f0db8fff
  0x14a4f0db9000 - 0x14a4f0db9fff
  0x14a4f0dba000 - 0x14a4f0dbafff
  0x14a4f0dbb000 - 0x14a4f0dbbfff
  0x5569dfaf7000 - 0x5569dfbe7fff
  0x5569dfbe8000 - 0x5569dfcf1fff
  0x5569dfcf2000 - 0x5569dfd51fff
  0x5569dfd53000 - 0x5569dfd81fff
  0x5569dfd82000 - 0x5569dfdb2fff
  0x5569dfdb3000 - 0x5569dfdb6fff
  0x5569e08b9000 - 0x5569e08d9fff
  0x7ffd0bbf0000 - 0x7ffd0bc10fff
  0x7ffd0bc4a000 - 0x7ffd0bc4dfff
  0x7ffd0bc4e000 - 0x7ffd0bc4ffff
https://ideone.com/49h2op
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!