Dusty old markov chain program I wrote in Common LISP a long while ago. Dug it up recently in honor of Joe Biden.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

markov.lisp 2.8KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283
  1. (defpackage :markov
  2. (:use
  3. ; :alexandria :cl-utilities
  4. :common-lisp)
  5. (:export :concat-spaces
  6. :pick-node
  7. :build-chain
  8. :build-random-chain
  9. :genchain))
  10. (defun read-file-into-list (filename)
  11. (with-open-file (stream filename)
  12. (loop for line = (read-line stream nil)
  13. while line
  14. collect line)))
  15. (defun concat-spaces (strs)
  16. (remove #\Space (apply #'concatenate 'string
  17. (mapcar #'(lambda (x) (concatenate 'string x " ")) strs))
  18. :count 1 :from-end t))
  19. (defun copy-table (table)
  20. (let ((new-table (make-hash-table
  21. :test (hash-table-test table)
  22. :size (hash-table-size table))))
  23. (maphash #'(lambda(key value)
  24. (setf (gethash key new-table) value))
  25. table)
  26. new-table))
  27. (defun pick-node (node)
  28. (if (second node)
  29. (nth (random (length (second node))) (second node))
  30. nil))
  31. (defun build-chain (inode terminator termstr &optional inlist)
  32. (let ((startnode (if (symbolp inode) (eval inode) inode)))
  33. (cond
  34. ((equal termstr (first startnode)) inlist)
  35. ((not (second startnode)) (append inlist (list (first startnode))))
  36. ((zerop (1- terminator)) (append inlist (list (first startnode))))
  37. (t (build-chain (pick-node startnode)
  38. (1- terminator)
  39. termstr
  40. (append inlist (list (first startnode))))))))
  41. (defun build-random-chain (table terminator termstr)
  42. (build-chain
  43. (gethash (nth (random (length
  44. (alexandria:hash-table-keys table)))
  45. (alexandria:hash-table-keys table))
  46. table)
  47. terminator termstr))
  48. (defun process-str (strtable instr)
  49. (let ((tab (copy-table strtable)))
  50. (dolist (x (cl-utilities:split-sequence #\Space instr))
  51. (when (not (gethash x tab))
  52. (setf (gethash x tab) (list x nil))))
  53. (let ((y nil))
  54. (dolist (x (cl-utilities:split-sequence #\Space instr))
  55. (when (and x y)
  56. (push (gethash x tab) (second (gethash y tab))))
  57. (setf y x))
  58. (push '("!TERM" nil) (second (gethash y tab))))
  59. tab))
  60. (defun process-list (strtable inlist)
  61. (if inlist (process-list (process-str strtable (first inlist))
  62. (rest inlist))
  63. strtable))
  64. (defun bootstrap-table (filename)
  65. (let* ((flist (read-file-into-list filename))
  66. (mash (make-hash-table :test #'equal))
  67. (endtbl (process-list mash flist)))
  68. endtbl))
  69. (defun outchain (table terminator termstr)
  70. (let ((str "")
  71. (lst (build-random-chain table terminator termstr)))
  72. (dolist (x lst)
  73. (setf str (concatenate 'string str " " x)))
  74. str))
  75. (defun genchain (filename terminator &optional termstr times)
  76. (let ((table (bootstrap-table filename))
  77. (tstr (if termstr termstr "!TERM")))
  78. (if times
  79. (let ((outbl nil))
  80. (progn (dotimes (i times)
  81. (push (outchain table terminator tstr) outbl))
  82. outbl))
  83. (outchain table terminator tstr))))