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. ;; (obrabotat-frazu "война майка")
  94. (terpri) ; Перевод строки в конце
Success #stdin #stdout #stderr 0.01s 9600KB
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
  0x14c689000000 - 0x14c6892e4fff
  0x14c689400000 - 0x14c689402fff
  0x14c689403000 - 0x14c689601fff
  0x14c689602000 - 0x14c689602fff
  0x14c689603000 - 0x14c689603fff
  0x14c689615000 - 0x14c689639fff
  0x14c68963a000 - 0x14c6897acfff
  0x14c6897ad000 - 0x14c6897f5fff
  0x14c6897f6000 - 0x14c6897f8fff
  0x14c6897f9000 - 0x14c6897fbfff
  0x14c6897fc000 - 0x14c6897fffff
  0x14c689800000 - 0x14c689803fff
  0x14c689804000 - 0x14c689a03fff
  0x14c689a04000 - 0x14c689a04fff
  0x14c689a05000 - 0x14c689a05fff
  0x14c689a1f000 - 0x14c689a20fff
  0x14c689a21000 - 0x14c689a30fff
  0x14c689a31000 - 0x14c689a64fff
  0x14c689a65000 - 0x14c689b9bfff
  0x14c689b9c000 - 0x14c689b9cfff
  0x14c689b9d000 - 0x14c689b9ffff
  0x14c689ba0000 - 0x14c689ba0fff
  0x14c689ba1000 - 0x14c689ba2fff
  0x14c689ba3000 - 0x14c689ba3fff
  0x14c689ba4000 - 0x14c689ba5fff
  0x14c689ba6000 - 0x14c689ba6fff
  0x14c689ba7000 - 0x14c689ba7fff
  0x14c689ba8000 - 0x14c689ba8fff
  0x14c689ba9000 - 0x14c689bb6fff
  0x14c689bb7000 - 0x14c689bc4fff
  0x14c689bc5000 - 0x14c689bd1fff
  0x14c689bd2000 - 0x14c689bd5fff
  0x14c689bd6000 - 0x14c689bd6fff
  0x14c689bd7000 - 0x14c689bd7fff
  0x14c689bd8000 - 0x14c689bddfff
  0x14c689bde000 - 0x14c689bdffff
  0x14c689be0000 - 0x14c689be0fff
  0x14c689be1000 - 0x14c689be1fff
  0x14c689be2000 - 0x14c689be2fff
  0x14c689be3000 - 0x14c689c10fff
  0x14c689c11000 - 0x14c689c1ffff
  0x14c689c20000 - 0x14c689cc5fff
  0x14c689cc6000 - 0x14c689d5cfff
  0x14c689d5d000 - 0x14c689d5dfff
  0x14c689d5e000 - 0x14c689d5efff
  0x14c689d5f000 - 0x14c689d72fff
  0x14c689d73000 - 0x14c689d9afff
  0x14c689d9b000 - 0x14c689da4fff
  0x14c689da5000 - 0x14c689da6fff
  0x14c689da7000 - 0x14c689dacfff
  0x14c689dad000 - 0x14c689daffff
  0x14c689db2000 - 0x14c689db2fff
  0x14c689db3000 - 0x14c689db3fff
  0x14c689db4000 - 0x14c689db4fff
  0x14c689db5000 - 0x14c689db5fff
  0x14c689db6000 - 0x14c689db6fff
  0x14c689db7000 - 0x14c689dbdfff
  0x14c689dbe000 - 0x14c689dc0fff
  0x14c689dc1000 - 0x14c689dc1fff
  0x14c689dc2000 - 0x14c689de2fff
  0x14c689de3000 - 0x14c689deafff
  0x14c689deb000 - 0x14c689debfff
  0x14c689dec000 - 0x14c689decfff
  0x14c689ded000 - 0x14c689dedfff
  0x5645b4fb8000 - 0x5645b50a8fff
  0x5645b50a9000 - 0x5645b51b2fff
  0x5645b51b3000 - 0x5645b5212fff
  0x5645b5214000 - 0x5645b5242fff
  0x5645b5243000 - 0x5645b5273fff
  0x5645b5274000 - 0x5645b5277fff
  0x5645b5a45000 - 0x5645b5a65fff
  0x7ffdb2711000 - 0x7ffdb2731fff
  0x7ffdb27ed000 - 0x7ffdb27f0fff
  0x7ffdb27f1000 - 0x7ffdb27f2fff


    

	
			

					
			
			
			
			
			
			
			
			

			
			
			
		

	
		
		

			

			                        







			
			

				

	
					
					 https://ideone.com/7KGF4F
					
					
					
					
					

												

												
						
						

					

					
					
					

						
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!