184 lines
5.5 KiB
Common Lisp
184 lines
5.5 KiB
Common Lisp
(defvar *line-number* 0)
|
|
(defvar *total-lines* 0)
|
|
(defvar *stanza-array* nil)
|
|
(defvar *avg-line* 0)
|
|
|
|
(defun up-down (r)
|
|
#'(lambda (x) (+ x (- (random (* 2 r)) r ))))
|
|
|
|
(defun up-down-half (r)
|
|
(funcall (up-down (floor (/ r 2))) r))
|
|
|
|
(defun sines (&rest args)
|
|
#'(lambda (time)
|
|
(let ((res 0))
|
|
(dotimes (i (length args))
|
|
(setf res (+ res (* (nth i args) (sin (/ time (+ 1 i)))))))
|
|
res)))
|
|
|
|
(defun gen-line-rand (i)
|
|
(declare (ignore i))
|
|
(loop for x from 1 to (funcall (up-down (floor (/ *avg-line* 2))) *avg-line*)
|
|
collecting (let ((r (random 10)))
|
|
(cond ((< r 3) 'b)
|
|
(t '-)))))
|
|
|
|
(defun rand-list (avg-size low-bound up-bound)
|
|
(let ((l (up-down-half avg-size)))
|
|
(loop for x from 1 to l
|
|
collecting (+ low-bound (random (- up-bound low-bound))))))
|
|
|
|
(defun gen-line-half-space (f)
|
|
#'(lambda (i)
|
|
(let ((n (funcall f i)))
|
|
(append
|
|
(make-list (floor (/ n 2)) :initial-element 'b)
|
|
(make-list n :initial-element '-)))))
|
|
|
|
(defun gen-line-sine ()
|
|
(let ((sins (apply #'sines (rand-list 5 -3 3))))
|
|
(gen-line-half-space #'(lambda (x) (floor (+ *avg-line* (funcall sins x)))))))
|
|
|
|
(defun gen-line-signal (f)
|
|
#'(lambda (i)
|
|
(let ((len (up-down-half *avg-line*)))
|
|
(loop for x from 1 to len
|
|
collecting (if (> (funcall f (+ (* i *avg-line*) x)) 0)
|
|
'-
|
|
'b)))))
|
|
|
|
(defun palindrome (l)
|
|
(append l (reverse l)))
|
|
|
|
(defun gen-line-signal-sym (f)
|
|
#'(lambda (i)
|
|
(let ((len (floor (/ (up-down-half *avg-line*) 2))))
|
|
(palindrome (loop for x from 1 to len
|
|
collecting (if (> (funcall f (+ (* i *avg-line*) x)) 0)
|
|
'-
|
|
'b))))))
|
|
|
|
(defun gen-line-horiz-sines ()
|
|
(let ((sins (apply #'sines (rand-list 5 -3 3))))
|
|
(gen-line-signal sins)))
|
|
|
|
(defun gen-line-horiz-sines-sym ()
|
|
(let ((sins (apply #'sines (rand-list (+ 3 (random 4)) -3 3))))
|
|
(gen-line-signal-sym sins)))
|
|
|
|
(defun get-stanza-length (s)
|
|
(let ((st (aref *stanza-array* s)))
|
|
(if (arrayp st)
|
|
(length st)
|
|
(case (car st) ;for the constraints we have they're all the same but not necessarily
|
|
(=line (get-stanza-length (cadr st)))
|
|
(rotate (get-stanza-length (cadr st)))))))
|
|
|
|
(defun choose-stanza-con (s)
|
|
(let ((rando (random 10))
|
|
(const-st (if (> s 0) (random s) 0)))
|
|
(cond ((< rando 2) (list '=line const-st))
|
|
((< rando 4) (list 'rotate const-st (random (get-stanza-length s))))
|
|
(t nil))))
|
|
|
|
(defun rhyme-to-rep (rhyme)
|
|
(if (null rhyme)
|
|
""
|
|
(let ((ty (car rhyme))
|
|
(rhyme-char (string (code-char (+ 97 (cadr rhyme))))))
|
|
(case ty
|
|
(rhyme rhyme-char)
|
|
(slant (concatenate 'string rhyme-char "/"))
|
|
(=word (format nil "=~a" (cadr rhyme)))))))
|
|
|
|
(defun choose-line-con (rhymes cur-line)
|
|
(let ((rando (random 10)))
|
|
(cond ((< rando 4) (list 'rhyme (random rhymes)))
|
|
((< rando 8) (list 'slant (random rhymes)))
|
|
((> cur-line 0) (list '=word (random cur-line)))
|
|
(t nil))))
|
|
|
|
(defun gen-stanza (s avg-st)
|
|
(let ((constr (choose-stanza-con s)))
|
|
(if (not constr)
|
|
(let ((ls (up-down-half avg-st)))
|
|
(setf (aref *stanza-array* s)
|
|
(make-array ls :initial-element nil))
|
|
(incf *total-lines* ls))
|
|
(progn
|
|
(setf (aref *stanza-array* s) constr)
|
|
(incf *total-lines* (get-stanza-length constr))))))
|
|
|
|
(defun rot-array (a n)
|
|
(let* ((l (length a))
|
|
(a-new (make-array l)))
|
|
(dotimes (i l)
|
|
(setf (aref a-new (mod (+ i n) l)) (aref a i)))
|
|
a-new))
|
|
|
|
(defun gen-lines-cons (s-index st rhymes)
|
|
(let ((fin-st (make-array (get-stanza-length st) :initial-element nil)))
|
|
(setf (aref *stanza-array* s-index) fin-st)
|
|
(case (car st)
|
|
(=line (dotimes (i (get-stanza-length st))
|
|
(setf (aref fin-st i) (cons (car (aref *stanza-array* (cadr st)))
|
|
(choose-line-con rhymes *line-number*)))
|
|
(incf *line-number*)))
|
|
(rotate (progn
|
|
(setf (aref *stanza-array* s-index)
|
|
(rot-array (aref *stanza-array* (cadr st)) (caddr st)))
|
|
(incf *line-number* (get-stanza-length st)))))))
|
|
|
|
(defun gen-lines-free (s line-fun rhymes)
|
|
(dotimes (i (length s))
|
|
(let ((constr (choose-line-con rhymes *line-number*)))
|
|
(setf (aref s i) (cons (funcall line-fun *line-number*) constr))
|
|
(incf *line-number*))))
|
|
|
|
(defun gen-lines (s line-fun rhymes)
|
|
(let ((st (aref *stanza-array* s)))
|
|
(if (arrayp (type-of st))
|
|
(gen-lines-free st line-fun rhymes)
|
|
(gen-lines-cons s st rhymes))))
|
|
|
|
(defun gen-poem (num-stanzas avg-stanza line-fun)
|
|
(let* ((total-stanzas (funcall (up-down 2) num-stanzas))
|
|
(*stanza-array* (make-array total-stanzas :initial-element nil))
|
|
(rhymes 0))
|
|
(dotimes (i total-stanzas)
|
|
(gen-stanza i avg-stanza))
|
|
(setf rhymes (random *total-lines*))
|
|
(dotimes (i total-stanzas)
|
|
(gen-lines i line-fun rhymes))))
|
|
|
|
(defun print-line (l)
|
|
(let ((s "")
|
|
(line-struct (car l))
|
|
(rhyme (rhyme-to-rep (cdr l))))
|
|
(dolist (c line-struct)
|
|
(setf s (concatenate 'string s "|"
|
|
(case c
|
|
(b " ")
|
|
(- "-")))))
|
|
(format t "~a: ~a~%" rhyme s)))
|
|
|
|
(defun print-poem ()
|
|
(dotimes (i (length *stanza-array*))
|
|
(let ((st (aref *stanza-array* i)))
|
|
(dotimes (j (length st))
|
|
(print-line (aref st j))))
|
|
(format t "~%")))
|
|
|
|
(defun main (argv)
|
|
(let* ((fun-choice (parse-integer (nth 1 argv)))
|
|
(num-stanza (parse-integer (nth 2 argv)))
|
|
(avg-stanza (parse-integer (nth 3 argv)))
|
|
(*avg-line* (parse-integer (nth 4 argv)))
|
|
(line-fun (cond ((= fun-choice 0) #'gen-line-rand)
|
|
((= fun-choice 1) (gen-line-sine))
|
|
((= fun-choice 2) (gen-line-horiz-sines))
|
|
((= fun-choice 3) (gen-line-horiz-sines-sym)))))
|
|
(setf *random-state* (make-random-state t))
|
|
(gen-poem num-stanza avg-stanza line-fun)
|
|
(print-poem)))
|