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) を実装。

;; =================================================================================================================================================
;;                            これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================

;; ■英単語暗記補助ツールです
;;   起動すると辞書ファイルから単語が表示されるので意味を頭で考えます。改行を入力すると答えが表示されます。 (y/n) を聞かれるので正解なら y を押してください。
;;   間違った単語は辞書ファイルに記録され次回出題されます。
;;
;; ■動作方法
;;   ANSI Common Lisp で動作します。
;;   (hige:pin)   ; 英単語入力の開始
;;   (hige:pon)   ; 英単語ゲームの開始
;;   (hige:pun)   ; 辞書の一覧表示
;;   (hige:pan)   ; 辞書から単語を検索
;;   オリジナルはシェルスクリプトとして動作しますが、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))

(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)))

;;; Special Variables
(defvar *dict-file* (merge-pathnames ".hige/words.txt" (user-homedir-pathname))
        "Path object for the dictionary file.")
(defvar *dict* nil
        "The dictionary. a list of the entry structures.")


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


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

(defun pon ()
  "Start self-study english vocabulary quiz."
  (setup-dict)
  (dolist (e *dict*)
    (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))))
  (save-dict))

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

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


;;; 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."
  (setf *dict*
    (funcall fn (if *dict* *dict* (read-dict file))))) ; introduce aif if you prefer. ;)

(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)
                    (nomalize-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 *dict*) (print word out)))))

(defun nomalize-dict (dict)
  "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)))
          dict))

(defun dump-dict ()
  "Print the dictionary in CSV format."
  (let ((output (format nil "~{~{~a~^,~}~%~}" *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 *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 *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)