generate text automatically

defgrammer.lisp

(setf *random-state* (make-random-state t))


(defun make-function-name (sym)
  (let ((fname 
         (string-upcase  (concatenate 'string "MAKE-" (symbol-name sym)))))
    (multiple-value-bind (sym pack) (find-package fname)
      (declare (ignore pack))
      (if sym sym (intern fname)))))



(defun make-string-from-symbol (name)
  (let ((function-name 
          (string-right-trim '(#\*) (make-function-name name))))
    (multiple-value-bind (sym pack) (find-package function-name)
      (declare (ignore pack))
      (funcall (if sym sym (intern function-name))))))


(defun make-clause (index clause)
  `(,index
    (reduce 
     (lambda (x y)
       (concatenate 
         'String 
         x 
         (cond 
           ((stringp y) y)
           ((let ((ystr (symbol-name y)))
              (string= "*" (subseq ystr (1- (length ystr)))))
            (format nil "~{~A~}" 
              (loop repeat 2
                    collect 
                    (make-string-from-symbol y))))
           (t (make-string-from-symbol y))))) 
     ',clause
     :initial-value "")))


(defmacro defgrammer (gname terminal &rest rec-rule)
  ;; terminalは評価する. それ以外は評価しない
  ;; terminalは全て文字列型であるとする

  (let* ((flag (gensym))
         (cnt (1+ (length rec-rule))))
    `(defun ,(make-function-name gname) ()

       (let ((,flag (random ,cnt)))
         (case ,flag
           (0 
            (let ((terminal (nth (random (length ,terminal)) ,terminal)))
              (if (stringp terminal)
                terminal
                (make-string-from-symbol terminal))))
           ,@(loop for i from 1 below cnt
                   for clause in rec-rule
                   collect 
                   (make-clause i clause )))))))



(defgrammer monadic-operator
   '("~"))

(defgrammer binary-operator
   '("V" "&" ">"  "-"))


(defgrammer expr 
   '("P" "Q" "R" "S")
   ("(" expr binary-operator expr ")")
   (monadic-operator "(" expr ")"))