scheme_baton.lisp

;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;
;; 第1回 Scheme コードバトン (CL fork)
;;
;; ■ これは何か？
;;   「Scheme のコードをバトンのように回していき面白い物ができあがるのを楽しむ遊びです。」のCL版です。
;;   次回 Shibuya.lisp で成果を発表します。
;;   Scheme 初心者のコードを書くきっかけに、中級者には他人のコードを読む機会になればと思います。
;;
;; ■ 2 つのルール
;;
;;   (1)自分がこれだと思える変更をコードに加えて2日以内に次の人にまわしてください。
;;      「人に優しい」変更なら何でも良い。1文字の変更でも可。
;;      「人に優しい」とは例えば、次の人が読みやすいコードを書くなど。
;;       コードを削るのもあり。
;;
;;   (2)次の人にまわしコードが変更されるのを"見守る"。
;;       この説明書きを含めてバトンが伝わった事を必ず確認してください。
;;       止まっていたら助けてあげてください。
;;
;; ■ バトンの回し方
;;
;;    (1) 回ってきたバトンは http://gist.github.com/xxxx という URL のはずです。
;;    (2) fork をクリックしてください（アカウントを持っていない人はこのとき作成します）
;;    (3) edit で変更したファイルを貼り付けます。
;;    (4) 自分が fork した新しい URL を回してください
;;
;;
;; ■ 良くある質問
;;
;;   (a) 初心者です。参加したいけどちょっと不安です。
;;      higepon がフォローしますので大丈夫です。分からない事があれば遠慮無く聞いてください。
;;
;;   (b) 次にまわす人がいません
;;      higepon に知らせてください。twitter, 日記のコメントなどで。
;;
;;   (c) 次の人がコードを止めてしまいました
;;      残念ですが別の人にバトンを渡してください。
;;
;;   (d) Mosh で動かないとダメですか？
;;      いいえ。Scheme なら何でも良いです。Gauche, Ypsilon 用に書き換えるのも面白いですね。
;;      そのときは起動方法の説明も変えてください。
;;
;; ■ バトンの行方を記録
;;   名前(URL)：一言
;;   1. higepon (http://d.hatena.ne.jp/higepon/): 最初はコマンドライン英単語暗記ツールでした。これが何に化けるのか楽しみ。全く別物になるかな？
;;   2. g000001 (http://cadr.g.hatena.ne.jp/g000001/): CLに翻訳してみましたが、higeponさんのコードとは考え方が結構違うものになってしまいました!
;;   3. aka (http://aka-cs-blog.blogspot.com/): さらにCL臭く。足回りの整備を実施。REPL上での使い勝手を強化。副作用って何？という感じの仕立て。
;;   4. quek (http://read-eval-print.blogspot.com/): 辞書ファイルがない状態からでも (hige:pin) できるようにしました。
;;   5. 佐野匡俊 (http://twitter.com/snmsts): ABCLとswingでぬるめのUIを。他の処理系での動作は鐚一文変えるつもりなく結果的に#+/-ABCLまみれ。
;;   6. 備前達矢(び) (http://twitter.com/bizenn): SBCL+Mac OS X縛りで出題単語を読み上げ。sayコマンドを叩くだけという手抜きっぷり。
;;   7. naoya_t (http://blog.livedoor.jp/naoya_t/): 辞書からの単語検索 (hige:pan) を実装。
;;   8. masatoi (http://d.hatena.ne.jp/masatoi/): n択問題(hige:pen)を実装．英単語から意味を問うのと意味から英単語を問うのと選べる．named-let使いまくり．
;;   9. cranebird (http://d.hatena.ne.jp/cranebird/): CL と言えばマルチパラダイムなので CLOS を。with-系のマクロを追加。
;;
;; =================================================================================================================================================
;;                            これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================

;; ■英単語暗記補助ツールです
;;   起動すると辞書ファイルから単語が表示されるので意味を頭で考えます。改行を入力すると答えが表示されます。 (y/n) を聞かれるので正解なら y を押してください。
;;   間違った単語は辞書ファイルに記録され次回出題されます。
;;
;; ■動作方法
;;   ANSI Common Lisp で動作します。
;;   (hige:pin)   ; 辞書に英単語を登録
;;   (hige:pon)   ; 英単語ゲームの開始
;;   (hige:pun)   ; 辞書の一覧表示
;;   (hige:pan)   ; 辞書から単語を検索
;;   (hige:pen)   ; 英単語ゲームの開始 (三択問題)
;;   (hige:pen :n-choice 5 :meaning? t)   ; (五択問題で意味に対応する英単語を選ぶ)
;;
;;   オリジナルはシェルスクリプトとして動作しますが、CL版は現状REPLでの対話です。
;;   ※R6RS Schemeで書かれたオリジナル版
;;     http://gist.github.com/273431
;;
;; ■辞書ファイルの例
;;   http://gist.github.com/273424

;;; Package Management
(in-package :cl-user)

(defpackage :hige
  (:use :cl)
  #+ABCL (:shadow :y-or-n-p)
  (:export #:pin
           #:pon
           #:pun
           #:pan
           #:pen))

(in-package :hige)

;;quek-san's  http://read-eval-print.blogspot.com/2009/04/abcl-java.html without cl-ppcre
#+ABCL (defmacro jimport (fqcn &optional (package *package*))
	 (let ((fqcn (string fqcn))
	       (package package))
	   (let ((class (java:jclass fqcn)))
	     `(progn
		(defparameter ,(intern fqcn package) ,class)
		,@(map 'list
		       (lambda (method)
			 (let ((symbol (intern (java:jmethod-name method) package))
			       (fn (if (java:jmember-static-p method)
				     #'java:jstatic
				     #'java:jcall)))
			   `(progn
			      (defun ,symbol (&rest args)
				(apply ,fn ,(symbol-name symbol) args))
			      (defparameter ,symbol #',symbol))))
		       (java:jclass-methods class))))))
#+ABCL (jimport |javax.swing.JOptionPane|)

#+ABCL (defun y-or-n-p (fmt &rest args)
	 (zerop (|showConfirmDialog| |javax.swing.JOptionPane| nil (apply #'format nil fmt args) "y-or-n-p" 0)))

;; aif macro (from "On Lisp")
(defmacro aif (test-form then-form &optional else-form)
  `(let ((it ,test-form))
     (if it ,then-form ,else-form)))

;; named-let macro (from "Let Over Lambda")
(defmacro nlet (tag var-vals &body body)
  `(labels ((,tag ,(mapcar #'car var-vals) ,@body))
     (declare (optimize (speed 3))) ; for tail recursion optimization
     (,tag ,@(mapcar #'cadr var-vals))))

;;; Special Variables
(defvar *dict-file* (merge-pathnames ".hige/words.txt" (user-homedir-pathname))
        "Path object for the dictionary file.")

(defvar *dict* nil
        "The dictionary object contains the entry structures.")

;;; Data Types
(defstruct (entry (:type list))
  "An entry for dictionary."
  word meaning ok-count ng-count)

(defclass dict ()
  ((entries
    :accessor entries-of
    :initform nil
    :initarg :entries
    :documentation "Entries"))
  (:documentation "Container class"))

(defun make-dict (entries)
  (make-instance 'dict :entries entries))

(defmethod print-object ((dict dict) stream)
  (print-unreadable-object (dict stream)
    (format stream "dict: entries: ~a "
            (length (entries-of dict)))
    (loop :for e :in (entries-of dict)
       :sum (+ (entry-ok-count e) (entry-ng-count e)) :into total
       :sum (+ (entry-ok-count e)) :into total-ok
       :sum (+ (entry-ng-count e)) :into total-ng
       :finally
       (format stream "total/ok/ng: ~a/~a/~a" total total-ok total-ng))))

;;; Top-Level Functions
(defmacro with-dict ((&key (read-only nil)) &rest body)
  `(progn
     (format *debug-io* ";; setup dict")
     (setup-dict)
     (format *debug-io* "...done~%")
     ,@body
     (unless ,read-only
       (format *debug-io* ";; saving dict...")
       (save-dict)
       (format *debug-io* "done~%"))
     *dict*))

(defmacro with-entries ((entry) &rest body)
  `(dolist (,entry (entries-of *dict*))
     ,@body))

(defun pin ()
  "Register new entries to the dictionary."
  (unless *dict-file*
    (ensure-directories-exist *dict-file*))
  (with-dict ()
    (loop (add-entry (prompt-for-entry))
       (if (not (y-or-n-p "Another words to register? [yn]: ")) (return)))))

(defun pon ()
  "Start self-study english vocabulary quiz."
  (with-dict ()
    (with-entries (e)
      (p "~&~A : " (read-aloud (entry-word e)))
      (ready?)
      #-ABCL (p "~&~A [Ynq]: " (entry-meaning e))
      :again
      (case (query #+ABCL (entry-meaning e))
        ((#\Y #\y) (incf (entry-ok-count e)))
        ((#\N #\n) (incf (entry-ng-count e)))
        ((#\Q #\q) (return))
        (otherwise
         (p "~&Please type Y for yes or N for no or Q for quit.~%[Ynq]: ")
         (go :again))))))

(defun pan ()
  "Search the word user has input from the dictionary"
  (with-dict (:read-only t)
    (let ((word (intern (prompt-read "Word to search") :hige)))
      (format t "~a" (or (search-dict word) "Not found.")))))

;; pun defined as an alias for dump-dict function (see Auxiliary Functions)

(defun pen (&key (n-choice 3) (meaning? nil))
  "Start self-study english vocabulary quiz with selection.
   n-choice is number of choices.
   If meaning? is not nil, you sellect a word corresponding posed meanings."
  (with-dict ()
    (when (> n-choice (length (entries-of *dict*))) ; 辞書の長さチェック
      (error "Dictionary size is too small .~%"))
    (with-entries (e)
      (p "~&~A : " (if meaning? (entry-meaning e) (read-aloud (entry-word e))))
      (ready?)
      (let* ((choices-list (choices e (entries-of *dict*) :n-choice n-choice))
             (correct-answer (1+ (position e choices-list))))
        (loop                             ; プロンプト
           :for item :in choices-list
           :for i :from 1 :to n-choice
           :do (p "~A.~A  " i (if meaning? (entry-word item) (entry-meaning item))))
        (p " [1-~Aq]: " n-choice)
        (nlet itr ((query (read *query-io* nil nil)))
          (cond ((and (numberp query) (> query 0) (> (1+ n-choice) query))
                 (if (= query correct-answer)
                     (incf (entry-ok-count e))
                     (incf (entry-ng-count e))))
                ((and (symbolp query) (string= (symbol-name query) "Q")) (return))
                (t (p "~&Please type number of the choice or Q for quit.~%[1-3q]: ")
                   (itr (read *query-io* nil nil)))))))))

;;; Auxiliary Functions
(defun setup-dict (&key (fn #'sort-dict-standard) (file *dict-file*))
  "Setup a dictionary for quiz; maybe read data from a file and apply
   fn to the dictionary."
  (unless *dict*
    (setf *dict* (make-dict (read-dict file))))
  (setf (entries-of *dict*) (funcall fn (entries-of *dict*)))
  *dict*)

(defun normalize-dict (entries)
  "Complement entries of a dictionary if one has missing slots."
  (mapcar #'(lambda (e)
              (make-entry :word (entry-word e)
                          :meaning (entry-meaning e)
                          :ok-count (or (entry-ok-count e) 0)
                          :ng-count (or (entry-ng-count e) 0)))
          entries))

(defun read-dict (file)
  "Read dictionary data from a file."
  (let ((*readtable* (copy-readtable nil))
        (*package* #.*package*)) ; 単語Symbolのホームは:higeパッケージです。
    (setf (readtable-case *readtable*) :preserve) ; 単語Symbolは大文字小文字を区別して扱います。
    (with-open-file (in file)
      (normalize-dict
       (loop :for word := (read in nil in) :until (eq word in)
          :collect word)))))

(defun save-dict (&key (file *dict-file*))
  "Save the dictionary data into a file."
  (with-open-file (out file :direction :output :if-exists :supersede)
    (with-standard-io-syntax
      (dolist (word (entries-of *dict*)) (print word out)))))

(defun dump-dict ()
  "Print the dictionary in CSV format."
  (let ((output (format nil "~{~{~a~^,~}~%~}" (entries-of *dict*))))
    #-ABCL (format t "~a" output)
    #+ABCL (|showMessageDialog| |javax.swing.JOptionPane| nil output)))

(setf (symbol-function 'pun)
  (symbol-function 'dump-dict))

(defun sort-dict-standard (dict)
  "Standard sort function for ordering the quiz."
  (sort dict
        #'>
        :key #'(lambda (e)
                 (- (entry-ng-count e) (entry-ok-count e)))))

(defun search-dict (word)
  "Search the dictionary for a word."
  (aif (assoc word (entries-of *dict*))
       (entry-meaning it)
       NIL))

;;; Auxiliary Functions for the User Interface
(defun p (&rest args)
  #-ABCL (apply #'format *query-io* args)
  #+ABCL (|showMessageDialog| |javax.swing.JOptionPane| nil (apply #'format nil args)))

(defun ready? ()
  (read-line *query-io*))

(defun query #+ABCL (&optional message) #-ABCL ()
       #-ABCL (let ((input (read-line *query-io*)))
                (if (= 0 (length input))
                    #\Y
                    (elt input 0)))
       #+ABCL (case (|showConfirmDialog| |javax.swing.JOptionPane| nil message "query" 1)
                (0 #\Y)
                (1 #\N)
                (2 #\Q)))


(defun prompt-read (prompt)
  #-ABCL (progn
           (p "~a: " prompt)
           (force-output *query-io*)
           (read-line *query-io*))
  #+ABCL (or (|showInputDialog| |javax.swing.JOptionPane| nil prompt "prompt-read" 3) "")
  )

(defun add-entry (entry)
  (push entry (entries-of *dict*)))

(defun prompt-for-entry ()
  (make-entry
   :word  (intern (prompt-read "Word")
                  #.*package*)          ; 単語Symbolの登録先は:higeパッケージです。
   :meaning (prompt-read "Meaning")
   :ok-count 0
   :ng-count 0))

(defun read-aloud (word)
  "Read aloud the given word and return it."
  #+SBCL (sb-ext:run-program "/usr/bin/say" `(,(symbol-name word)) :wait t)
  word)

(defun nthcar (n list)
  "Performs the car function n times on a list."
  (nlet itr ((n n) (list list) (product '()))
    (if (or (zerop n) (null list))
        (nreverse product)
        (itr (1- n) (cdr list) (cons (car list) product)))))

(defun insert (element n list)
  "Insert element to position n of list"
  (append (nthcar n list) (list element) (nthcdr n list)))

(defun random-pickup (n m)
  "Pickup m elements from list randomly without overlapping."
  (if (> m n)
      (error "m is needed to be n and fewer.")
      (nlet itr ((m m) (product '()))
        (if (= m 0)
            product
            (let ((rand (random n)))
              (if (member rand product)
                  (itr m product)
                  (itr (1- m) (cons rand product))))))))

(defun random-pickup-list (m list)
  "Pickup m elements from list randomly without overlapping."
  (let ((positions (random-pickup (length list) m)))
    (mapcar (lambda (p) (nth p list)) positions)))

(defun choices (entry dict &key (n-choice 3))
  "Make choices list which contains entry and it's length is n-choice"
  (let ((dict-leaved-out (remove entry dict)))
    (insert entry (random n-choice)
            (random-pickup-list (1- n-choice) dict-leaved-out))))