102 lines
3.9 KiB
Common Lisp
102 lines
3.9 KiB
Common Lisp
;; splork.lsp
|
|
;; Copyright (C) 2025 William R. Moore <william@nerderium.com>
|
|
|
|
;; This program is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
(load "words.lsp")
|
|
(load "sent-struct.lsp")
|
|
|
|
(defun sentence-case (sentence)
|
|
"Changes the sentence to a capital case letter at the beginning."
|
|
(let* ((first-char (subseq (string-trim " " sentence) 0 1))
|
|
(rest-of-sentence (subseq (string-trim " " sentence) 1)))
|
|
(format nil "~A~A" (string-upcase first-char) rest-of-sentence)))
|
|
|
|
(defun find-pos (words pos excludeProper)
|
|
"Find the Part of Speech from the array"
|
|
(let* ((new-words '()))
|
|
(setf new-words (remove nil (mapcar (lambda (x) (and (equal pos (nth 1 x)) x)) words)))
|
|
(if (equal 'true excludeProper)
|
|
(setf new-words (remove nil (mapcar (lambda (x) (and (not (equal "PROPER" (nth 2 x))) x)) new-words)))
|
|
)
|
|
(nth 0 (nth (random (length new-words)) new-words))
|
|
))
|
|
|
|
(defun find-place-noun (words)
|
|
"Generates a word from the list of place nouns"
|
|
(let* ((new-words '()))
|
|
(setf new-words (remove nil (mapcar (lambda (x) (and (equal "NOUN" (nth 1 x)) x)) words)))
|
|
(setf new-words (remove nil (mapcar (lambda (x) (and (equal "PLACE" (nth 2 x)) x)) new-words)))
|
|
(nth 0 (nth (random (length new-words)) new-words))
|
|
))
|
|
|
|
(defun replace-substring (string substring replacement)
|
|
"Replaces all occurrences of substring in string with replacement."
|
|
(let ((result ""))
|
|
(loop while (position substring string)
|
|
do (let ((pos (position substring string)))
|
|
(setf result (concatenate 'string result
|
|
(subseq string 0 pos)
|
|
replacement))
|
|
(setf string (subseq string (+ pos (length substring))))))
|
|
(concatenate 'string result string)))
|
|
|
|
(defun find-noun-with-article (words)
|
|
"Generates any articles necessary for a noun"
|
|
(let* ((new-words '())
|
|
(word ""))
|
|
(setf new-words (remove nil (mapcar (lambda (x) (and (equal "NOUN" (nth 1 x)) x)) words)))
|
|
(setf word (nth (random (length new-words)) new-words))
|
|
|
|
(if (string-equal "PROPER" (nth 2 word))
|
|
(nth 0 word)
|
|
(if (string-equal "PLACE" (nth 2 word))
|
|
(nth 0 word)
|
|
(format nil "the ~A" (nth 0 word))
|
|
)
|
|
)
|
|
))
|
|
|
|
(defun exec-lambda (x)
|
|
(apply (eval x) '()))
|
|
|
|
(defun splork ()
|
|
(let* ((sent-index nil)
|
|
(compiled-results '())
|
|
(generated-sentence ""))
|
|
(setf compiled-results (mapcar #'exec-lambda *sentence-structures*))
|
|
(setf sent-index (random (length compiled-results)))
|
|
(setf generated-sentence (nth sent-index compiled-results))
|
|
(let* ( (interjection (find-pos words "INTERJECTION" 'false)) )
|
|
(if (<= 10 (random 10))
|
|
(if (string-equal "!" interjection)
|
|
(setf generated-sentence (format nil "~A ~A" interjection (sentence-case generated-sentence)))
|
|
(setf generated-sentence (format nil "~A ~A" interjection generated-sentence))
|
|
)
|
|
(setf generated-sentence (format nil "~A" (sentence-case generated-sentence)))
|
|
)
|
|
)
|
|
|
|
(if (not (string-equal "!" generated-sentence))
|
|
(setf generated-sentence (format nil "~A." generated-sentence))
|
|
)
|
|
(setf generated-sentence (replace-substring generated-sentence " " " "))
|
|
(setf generated-sentence (replace-substring generated-sentence "the the" "the"))
|
|
generated-sentence))
|
|
|
|
(defun splork-generate ()
|
|
(setf *random-state* (make-random-state t))
|
|
(princ (splork)))
|
|
|