fork download
  1. ;; Гласные буквы русского языка
  2. (defun vowel-p (char)
  3. (member char '(#\а #\е #\ё #\и #\о #\у #\ы #\э #\ю #\я
  4. #\А #\Е #\Ё #\И #\О #\У #\Ы #\Э #\Ю #\Я)
  5. :test #'char=))
  6.  
  7. ;; Согласные буквы русского языка
  8. (defun consonant-p (char)
  9. (not (vowel-p char)))
  10.  
  11. ;; Функция для проверки наличия "й" после гласной
  12. (defun yot-after-vowel-p (chars index)
  13. (and (< (1+ index) (length chars))
  14. (let ((next-char (elt chars (1+ index))))
  15. (or (char= next-char #\й)
  16. (member next-char '(#\е #\ё #\ю #\я) :test #'char=)))
  17. (vowel-p (elt chars index))))
  18.  
  19. ;; Разбиение слова на слоги по правилам русского языка (рекурсивная версия без SETF)
  20. (defun split-word (word)
  21. (labels ((split-word-recursive (chars syllables current i)
  22. (cond
  23. ((>= i (length chars))
  24. (if current
  25. (reverse (cons (coerce (reverse current) 'string) syllables))
  26. (reverse syllables)))
  27. (t
  28. (let ((ch (elt chars i)))
  29. (cond
  30. ((vowel-p ch)
  31. (if (yot-after-vowel-p chars i)
  32. (let ((next-char (elt chars (1+ i))))
  33. (cond
  34. ((char= next-char #\й)
  35. (let ((new-current (append current (list ch next-char))))
  36. (split-word-recursive chars
  37. (cons (coerce (reverse new-current) 'string) syllables)
  38. nil
  39. (+ i 2))))
  40. ((member next-char '(#\е #\ё #\ю #\я) :test #'char=)
  41. (split-word-recursive chars
  42. (cons (coerce (reverse (cons ch current)) 'string) syllables)
  43. nil
  44. (+ i 1)))
  45. (t
  46. (split-word-recursive chars
  47. (cons (coerce (reverse (cons ch current)) 'string) syllables)
  48. nil
  49. (+ i 1)))))
  50. (split-word-recursive chars
  51. (cons (coerce (reverse (cons ch current)) 'string) syllables)
  52. nil
  53. (+ i 1))))
  54. (t
  55. (split-word-recursive chars
  56. syllables
  57. (cons ch current)
  58. (+ i 1)))))))))
  59. (split-word-recursive (coerce word 'list) nil nil 0)))
  60.  
  61. ;; Разбиение строки на слова (рекурсивная версия без SETF)
  62. (defun split-string (str)
  63. (labels ((split-string-recursive (str current-word words)
  64. (cond
  65. ((null str)
  66. (if current-word
  67. (reverse (cons (coerce (reverse current-word) 'string) words))
  68. (reverse words)))
  69. ((char= (car str) #\Space)
  70. (if current-word
  71. (split-string-recursive (cdr str) nil (cons (coerce (reverse current-word) 'string) words))
  72. (split-string-recursive (cdr str) nil words)))
  73. (t
  74. (split-string-recursive (cdr str) (cons (car str) current-word) words)))))
  75. (split-string-recursive (coerce str 'list) nil nil)))
  76.  
  77. ;; Главная функция с использованием MAPCAR
  78. (defun split-phrase (phrase)
  79. (mapcar #'split-word (split-string phrase)))
  80.  
  81. ;; Тест
  82. (print (split-phrase "написать программу"))
  83. (print (split-phrase "дана фраза на русском языке"))
  84. (print (split-phrase "война, мир, эвакуатор"))
  85. (print (split-phrase "скамейка"))
  86. (print (split-phrase "ванна"))
  87. (print (split-phrase "коллекция"))
  88. (print (split-phrase "чай"))
  89.  
  90.  
Success #stdin #stdout #stderr 0.02s 9728KB
stdin
Standard input is empty
stdout
(("на" "пи" "са" "ть") ("про" "гра" "мму")) 
(("да" "на") ("фра" "за") ("на") ("ру" "сско" "м") ("я" "зы" "ке")) 
(("йов" "на" ",") ("ми" "р,") ("э" "ва" "ку" "а" "то" "р")) 
(("ска" "йем" "ка")) 
(("ва" "нна")) 
(("ко" "лле" "кци" "я")) 
(("йач")) 
stderr
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x14d829200000 - 0x14d8294e4fff
  0x14d829615000 - 0x14d829639fff
  0x14d82963a000 - 0x14d8297acfff
  0x14d8297ad000 - 0x14d8297f5fff
  0x14d8297f6000 - 0x14d8297f8fff
  0x14d8297f9000 - 0x14d8297fbfff
  0x14d8297fc000 - 0x14d8297fffff
  0x14d829800000 - 0x14d829802fff
  0x14d829803000 - 0x14d829a01fff
  0x14d829a02000 - 0x14d829a02fff
  0x14d829a03000 - 0x14d829a03fff
  0x14d829a80000 - 0x14d829a8ffff
  0x14d829a90000 - 0x14d829ac3fff
  0x14d829ac4000 - 0x14d829bfafff
  0x14d829bfb000 - 0x14d829bfbfff
  0x14d829bfc000 - 0x14d829bfefff
  0x14d829bff000 - 0x14d829bfffff
  0x14d829c00000 - 0x14d829c03fff
  0x14d829c04000 - 0x14d829e03fff
  0x14d829e04000 - 0x14d829e04fff
  0x14d829e05000 - 0x14d829e05fff
  0x14d829eb3000 - 0x14d829eb6fff
  0x14d829eb7000 - 0x14d829eb7fff
  0x14d829eb8000 - 0x14d829eb9fff
  0x14d829eba000 - 0x14d829ebafff
  0x14d829ebb000 - 0x14d829ebbfff
  0x14d829ebc000 - 0x14d829ebcfff
  0x14d829ebd000 - 0x14d829ecafff
  0x14d829ecb000 - 0x14d829ed8fff
  0x14d829ed9000 - 0x14d829ee5fff
  0x14d829ee6000 - 0x14d829ee9fff
  0x14d829eea000 - 0x14d829eeafff
  0x14d829eeb000 - 0x14d829eebfff
  0x14d829eec000 - 0x14d829ef1fff
  0x14d829ef2000 - 0x14d829ef3fff
  0x14d829ef4000 - 0x14d829ef4fff
  0x14d829ef5000 - 0x14d829ef5fff
  0x14d829ef6000 - 0x14d829ef6fff
  0x14d829ef7000 - 0x14d829f24fff
  0x14d829f25000 - 0x14d829f33fff
  0x14d829f34000 - 0x14d829fd9fff
  0x14d829fda000 - 0x14d82a070fff
  0x14d82a071000 - 0x14d82a071fff
  0x14d82a072000 - 0x14d82a072fff
  0x14d82a073000 - 0x14d82a086fff
  0x14d82a087000 - 0x14d82a0aefff
  0x14d82a0af000 - 0x14d82a0b8fff
  0x14d82a0b9000 - 0x14d82a0bafff
  0x14d82a0bb000 - 0x14d82a0c0fff
  0x14d82a0c1000 - 0x14d82a0c3fff
  0x14d82a0c6000 - 0x14d82a0c6fff
  0x14d82a0c7000 - 0x14d82a0c7fff
  0x14d82a0c8000 - 0x14d82a0c8fff
  0x14d82a0c9000 - 0x14d82a0c9fff
  0x14d82a0ca000 - 0x14d82a0cafff
  0x14d82a0cb000 - 0x14d82a0d1fff
  0x14d82a0d2000 - 0x14d82a0d4fff
  0x14d82a0d5000 - 0x14d82a0d5fff
  0x14d82a0d6000 - 0x14d82a0f6fff
  0x14d82a0f7000 - 0x14d82a0fefff
  0x14d82a0ff000 - 0x14d82a0fffff
  0x14d82a100000 - 0x14d82a100fff
  0x14d82a101000 - 0x14d82a101fff
  0x56308a425000 - 0x56308a515fff
  0x56308a516000 - 0x56308a61ffff
  0x56308a620000 - 0x56308a67ffff
  0x56308a681000 - 0x56308a6affff
  0x56308a6b0000 - 0x56308a6e0fff
  0x56308a6e1000 - 0x56308a6e4fff
  0x56308bcb5000 - 0x56308bcd5fff
  0x7fff9ea2a000 - 0x7fff9ea4afff
  0x7fff9eb7e000 - 0x7fff9eb81fff
  0x7fff9eb82000 - 0x7fff9eb83fff