gistfile1.lisp

;; 前置きとして…
;; どんな言語にもあると思いますが、 Common Lisp にも一般的なスタイルがあります。
;; まずは、それに目を通すことをおすすめします。
;;
;; Google Common Lisp Style Guide
;;   en: https://google-styleguide.googlecode.com/svn/trunk/lispguide.xml
;;   jp: http://lisphub.jp/doc/google-common-lisp-style-guide/
;; 
;; Tutorial on Good Lisp Programming Style
;;   en: http://www.norvig.com/luv-slides.ps
;;   jp: https://sites.google.com/site/okshirai/home/tutorial-on-good-lisp-programming-style-ja.txt?attredirects=0&d=1

;; 全体的に・・
;; 横に長すぎで、適宜改行すべきと思います。
;; 例えば、 Google Common Lisp Style Guide では、 100 文字程度での改行を推奨しています。
;; また、 Common Lisp のスタイルとして一般的な改行を入れる位置があるので、
;; それに沿って書いた方がいいかと思います。
;;   (ex. defun の arglist の後、 body に入る前に改行。)


(defparameter *problem-num* 10)

;; なんと、 Common Lisp ではコマンドライン引数へのアクセスも処理系依存です。
;; ポータブルに書くためのライブラリもあるのですが・・
;; 一応、適当に clisp 以外では読まれないようにしておきました。
#+clisp
(when (> (length *args*) 0)
  (defparameter *problem-num*
    (parse-integer (car *args*))))

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

;; ANSI CL外ですが、有名ライブラリ alexandria に、まさにこれと同じこと
;; を行うrandom-elt があります。
;; http://common-lisp.net/project/alexandria/draft/alexandria.html#Sequences
(defun rand-elt (lst)
  (elt lst (random (length lst))))

(defun rand-range (min max)
  (let ((r (random (- max min))))
    (+ r min)))

(defun 1+rand (m)
  (1+ (random m)))

(defun divisor-lst (num mindiv maxdiv)
  ;; idiom として、「push して(逆順に) list を作っておき、最後に
  ;; nreverse で並びかえて戻す」というのがあります。ここは、まさにそれ
  ;; が使えるパターンです。
  (let ((lst nil))
    (do ((n mindiv (1+ n)))
      ((or (>= n num)
           (>= n maxdiv)))
      (when (zerop (mod num n))
	(push n lst)))
    (nreverse lst)))

(defun create-formula-poland (answer maxlen) ; 関数名と引数リストの間は、スペースを挟むのが一般的です。
  (let ((remaindar 0) (stack ()))
    ;; 再帰や相互参照がないのであれば、 labels ではなく flet を使うべきです。
    (flet ((pushform (op num)
	     ;; if で返す結果が重要なのではなく、その中で実行される式が
	     ;; 重要であれば、when を使うべきです。
	     ;; 特に、 if の中で progn を使用するときは、まさにその機
	     ;; 能を when が与えてくれます。
	     (when (zerop (length stack))
	       (setq remaindar num))
	     (setq stack (append stack (list num)))
	     (when op
	       ;; ` の中の , の付け方を変えています。
	       ;; , は、 , の次の式に作用するので、作用する先の後の式
	       ;; にくっつけて書いたほうがいいでしょう。
	       (setq stack (append stack `(,op)))
	       (setq remaindar (funcall op remaindar num)))))
      ;; if の両方の節を使い、その中で progn を呼んでいる場合は、
      ;; progn を内包する cond に書きかえることも考えられます。
      (cond ((= maxlen 1)
	     (pushform nil answer))
	    (t
	     (pushform nil (1+rand answer))
	     ;; ここも、 flet にしました。
	     (flet ((choice-push (num)
		      (let ((divisor-lst (divisor-lst remaindar 2 100)))
			(cond	     ; indent のスタイルを変えました。
			  ;; and の中があまりに横長だったので、改行を入れていす。
			  ((and (> remaindar 1)
				(<= remaindar 20)
				(not (member '* stack))
				(<= 25 (random 100)))
			   (pushform '* (rand-range 2 11)))
			  ((<= 1 (length divisor-lst))
			   (pushform '/ (rand-elt divisor-lst)))
			  (t
			   (pushform (rand-elt '(- +)) num))))))
	       ;; これは完全に私の趣味ですが…
	       ;; この場合だと、 flet を使って関数を取りだす意味が薄いので、
	       ;; 以下の dotimes の中にベタっと処理を書くのもいいかもしれません。
	       (dotimes (random (1- maxlen))
		 (choice-push (1+rand answer))))
	     ;; when を使う理由と同様の理由で、 unless にした
	     (unless (= remaindar answer)
	       (if (< answer remaindar)
		   (pushform '- (- remaindar answer))
		   (pushform '+ (- answer remaindar))))))
      stack)))

(defun create-dummy-answers (answer dummy-num)
  ;; loop の中で collect を使っているのに、collect の中の form で起こ
  ;; る副作用だけを当てにしており、collect が集めた結果は捨ててしまっ
  ;; ています。結果を集めるのではなく、副作用を当てにするのなら、
  ;; collect ではなく do を使うべきです。
  ;; また、「ある要素が含まれているかを member で確認し、含まれていな
  ;; ければ追加する」 ということをしていますが、まさにこの仕事を行う
  ;; pushnew というものがあります。
  (loop with lst = nil
     until (= (length lst) dummy-num)
     for r = (random 100)
     when (/= r answer)		; (not (= ...)) を (/= ...) にしました。
     do (pushnew r lst)
     finally (return lst)))

(defun formula-to-problem (formula)
  ;; let を nest することで、外側で let したものを見ようとしていますが、
  ;; まさにこれと同じことを行う let* があります。
  (let* ((numbers (remove-if (lambda (x) (not (integerp x))) formula))
	 (answer (rand-elt numbers))
	 ;; 順序を変えて、 setq を消してます。
	 (answer-list (append (list answer)
			      (create-dummy-answers answer 3))))
    (setq formula
	  ;; やってることは、「 sequence を見て、最初に見つかったもの
	  ;; 一つだけを交換する」ということと解釈しました。
	  ;; すると、「交換」は substitute で、「一つだけ」は :count 1
	  ;; で実現できます。
	  (substitute '? answer formula :count 1))
    (list formula answer-list)))

(defun poland-to-normal (poland-lst)
  (let ((ret (list (car poland-lst)))
	(last-num (car poland-lst))
	(last-op nil))
    (setq poland-lst (cdr poland-lst))
    ;; 関数適用の結果を使用しないのであれば、結果を集めない mapc で十分でしょう。
    (mapc (lambda (x) (cond ((integerp x)
    			     (setq last-num x))
    			    (t
    			     ;; cond には progn が組み込まれているので、 progn は不要です。
    			     (when (and (member x '(* /))
    					(member last-op '(+ -)))
    			       (setq ret (append '([) ret '(]))))
    			     (setq last-op x)
			     ;; , の style を変えました。
    			     (setq ret (append ret `(,x ,last-num))))))
    	  poland-lst)
    ret))

(defun create-problem (answer) 
  (let ((problem-lst (formula-to-problem
		      (poland-to-normal (create-formula-poland answer 3)))))
    (format
     t "\"~{~a~<~^ ~>~} = ~{~a~<~^ ~>~}\",~{~a~<~^,~>~}~%"
     (car problem-lst)
     (poland-to-normal (create-formula-poland answer (1+rand 2)))
     (cadr problem-lst))))

(dotimes (n *problem-num*) (create-problem (1+rand 100)))

;; 全般的に・・
;; 
;; このプログラムは、 list の末尾に要素を繋げていくというスタイルで書かれています。
;; しかし、 list の末尾に要素を加えることは、 list の構造上とても遅く、さらに
;; プログラムも面倒になります。(お気付きの通り、 setq と append を駆使しなければなりません)。
;;
;; 末尾に要素を追加することが重要なら、いっそのこと list をやめて vector にし、
;; vector-push-extend で末尾に追加していくことも考えられます。