package.lisp

;; -*- Mode: Lisp; Syntax: Common-Lisp -*-

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

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

scheme_baton.asd

(defsystem :scheme_baton
  :serial t
  :depends-on (:drakma :cl-ppcre :trivial-gray-streams)
  :components ((:file "package") (:file "scheme_baton"))
  )

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-系のマクロを追加。
;;  10. smeghead (http://d.hatena.ne.jp/smeghead/): 単語のスコアを導入した。問題の単語表示時にスコアを表示するようにした。単語の一覧表示(hige:pun)にキーワード引数 score-thresholdを追加。
;;  11. NANRI (http://raido.sakura.ne.jp/southly/rn/): デバッグとちょっとした整理。あと (asdf:oos 'asdf:load-op :scheme_baton) でロードできるようにした。
;;  12. 佐野匡俊 (http://twitter.com/snmsts): 備前さんの変更がSBCL+OS Xなのでread-time conditionalizationをらしく修正。これがschemeに無いらしいのが残念。
;;  13. making (http://blog.ik.am): 辞書ファイルをhttp経由で取得できるようにした。要drakma。
;;  14. 深町英太郎 (http://e-arrows.sakura.ne.jp/): 単語登録時に意味を空にした際にGoogle翻訳の結果を登録できるようにした。要cl-ppcre。
;;  15. kurohuku(@sirohuku) (http://kurohuku.blogspot.com/): Gray Streamを使ってpon,pen時に回答のログをとるようにした。要trivial-gray-streams。
;;  16. kosh (http://lisperblog.blogspot.com/): 空のエントリを登録しないようにした(add empty-entry-p), ログファイルもディレクトリがない場合は作成するように
;; =================================================================================================================================================
;;                            これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================

;; ■英単語暗記補助ツールです
;;   起動すると辞書ファイルから単語が表示されるので意味を頭で考えます。改行を入力すると答えが表示されます。 (y/n) を聞かれるので正解なら y を押してください。
;;   間違った単語は辞書ファイルに記録され次回出題されます。
;;
;; ■動作方法
;;   ANSI Common Lisp で動作します。
;;   (hige:pin)   ; 辞書に英単語を登録
;;   (hige:pin :uri "http://gist.github.com/273424.txt")  ; http経由で辞書に登録
;;   (hige:pon)   ; 英単語ゲームの開始
;;   (hige:pun)   ; 辞書の一覧表示
;;   (hige:pun :score-threshold 10)   ; 辞書の一覧表示(スコアが10以下の単語のみを表示する）
;;   (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

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

(defvar *log-file* (merge-pathnames ".hige/baton.log" (user-homedir-pathname)))
(defparameter *mode* nil)
(defparameter *entry* nil)
(defparameter *choices-list* nil)
(defparameter *logged-input* *query-io*)

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

(defclass logged-input-stream (trivial-gray-streams:fundamental-character-stream)
  ((log-output :accessor log-output-of :initarg :log-output :initform nil)
   (input :accessor input-of :initform *query-io*)))

(defmethod trivial-gray-streams:stream-read-line ((stream logged-input-stream))
  (let ((line (read-line (input-of stream)))
	(log (log-output-of stream)))
    (when log
      (case (car *mode*)
	;;*mode* = (:pen n meaning?)
	((:pen)
	 (log-pen log *entry* line (second *mode*) *choices-list* (third *mode*)))
	;;*mode* = (:pon)
	((:pon)
	 (log-pon log *entry* line))
	(T nil)))
    line))

(defun entry-score (entry)
  "Return a score of this entry."
  (- (entry-ok-count entry) (* (entry-ng-count entry) 3)))

(defmacro with-dict ((&key (read-only nil) (uri nil)) &rest body)
  `(progn
     (format *debug-io* ";; setup dict")
     (if ,uri (format *debug-io* "~%;; download dictionary from ~a " ,uri))
     (if ,uri (setup-dict :file ,uri :http? t) (setup-dict)) 
     (format *debug-io* "...done~%")
     ,@body
     (unless ,read-only
       (format *debug-io* ";; saving dict...")
       (save-dict)
       (format *debug-io* "done~%"))
     *dict*))

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

(defmacro with-http-request ((stream uri &rest drakma-args) &body body)
  `(let ((,stream (drakma:http-request ,uri :want-stream t ,@drakma-args)))
     (unwind-protect (progn ,@body)
       (when ,stream (close ,stream)))))
    
(defmacro with-open-dict ((dict in &key (http? nil)) &body body)
  `(if ,http?
       (with-http-request (,dict ,in) ,@body)
       (with-open-file (,dict ,in) ,@body)))

(defmacro with-logged-input ((input &optional (filename '*log-file*)) &body body)
  (let ((log-output (gensym)))
    `(progn
       (unless (and ,filename (probe-file ,filename))
         (ensure-directories-exist ,filename))
       (with-open-file (,log-output ,filename
                                    :direction :output
                                    :if-exists :append
                                    :if-does-not-exist :create)
         (let ((,input (make-instance 'logged-input-stream :log-output ,log-output)))
           ,@body)))))

(defmacro with-mode (mode &body body)
  `(let ((*mode* (list ,(first mode) ,(second mode) ,(third mode))))
     ,@body))

;;; Top-Level Functions
(defun pin (&key (uri nil))
  "Register new entries to the dictionary."
  (with-dict (:uri uri)
    (unless uri
      (loop 
         (add-entry (prompt-for-entry))
         (unless (y-or-n-p "Another words to register? [yn]: ")
           (return))))))
  
(defun pon ()
  "Start self-study english vocabulary quiz."
  ;;fix
  (with-mode (:pon)
    (with-logged-input (*logged-input*)
      (with-dict ()
	(do-entries (e)
	  (p "~&~A (score: ~D): " (read-aloud (entry-word e)) (entry-score e))
	  #-ABCL (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") #.*package*)))
      (format t "~A~%" (or (search-dict word) "Not found.")))))

(defun pun (&key score-threshold)
  (unless (numberp score-threshold)
    (error "pun: score-threshold must be number."))
  (setup-dict)
  (dump-dict :score-threshold score-threshold))

(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 .~%"))
    ;;fix
    (with-mode (:pen n-choice meaning?)
      (with-logged-input (*logged-input*) 
	(do-entries (e)
	  (p "~&~A (score: ~D): "
	     (if meaning? (entry-meaning e) (read-aloud (entry-word e)))
	     (entry-score 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-from-string (read-line *logged-input*))))
	      (cond ((and (numberp query) (< 0 query (1+ n-choice)))
		     (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-from-string (read-line *logged-input*))))))))))))

;;; Auxiliary Functions
(defun setup-dict (&key (fn #'sort-dict-standard)
                        (file *dict-file*)
                        (http? nil))
  "Setup a dictionary for quiz;
maybe read data from a file and apply fn to the dictionary."
  (unless (and (not http?) *dict*)
    (setf *dict* (make-dict (read-dict file :http? http?))))  
  (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 (ignore-errors (entry-ok-count e)) 0)
                          :ng-count (or (ignore-errors (entry-ng-count e)) 0)))
          entries))

(defmacro with-dictionary-io-syntax (&body body)
  `(with-standard-io-syntax
       (let ((*readtable* (copy-readtable nil))
             (*package* #.*package*) ; 単語Symbolのホームは:higeパッケージです。
             (*read-eval* nil))
         (setf (readtable-case *readtable*) :preserve) ; 単語Symbolは大文字小文字を区別して扱います。
         ,@body)))

(defun read-dict (file &key (http? nil))
  "Read dictionary data from a file or http."
  (unless (or http? (probe-file file))
    (return-from read-dict NIL))
  (with-open-dict (in file :http? http?)
    (with-dictionary-io-syntax
        (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."
  (unless (probe-file file)
    (ensure-directories-exist file))
  (with-open-file (out file
                       :direction :output
                       :if-exists :supersede
                       :if-does-not-exist :create)
    (with-dictionary-io-syntax
        (let ((*package* #.*package*))
          (dolist (word (entries-of *dict*)) (print word out))))))

(defun dump-dict (&key score-threshold)
  "Print the dictionary in CSV format."
  (let ((output (format nil "~{~{~A~^,~}~%~}"
                        (if (null score-threshold)
                            (entries-of *dict*) ; score-thresholdが指定されない場合は全件
                            (delete NIL ; score-thresholdが指定された場合は絞り込む
                                    (mapcar (lambda (e)
                                              (if (<= (entry-score e) score-threshold)
                                                  e
                                                  NIL))
                                            (entries-of *dict*)))))))
    #-ABCL (format t "~A" output)
    #+ABCL (|showMessageDialog| |javax.swing.JOptionPane| nil output)))

(defun sort-dict-standard (dict)
  "Standard sort function for ordering the quiz."
  (sort dict
        #'<
        :key #'(lambda (e) (entry-score 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*))

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

(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 empty-entry-p (entry)
  (equal entry '(|| "" 0 0)))

(defun add-entry (entry &key (if-exists :overwrite))
  (declare (ignore if-exists))
  (unless (empty-entry-p entry)
    (pushnew entry (entries-of *dict*))))

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

(defun read-aloud (word)
  "Read aloud the given word and return it."
  #+(and SBCL DARWIN) (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))))

(defun prompt-for-translate (word)
  (let ((meaning (ignore-errors (google-translate word))))
    (if (and meaning
             (y-or-n-p (format nil "~a? [yn]:" meaning)))
        meaning
        "")))

(defun google-translate (word)
  "Translate with Google Translate"
  (let ((uri "http://ajax.googleapis.com/ajax/services/language/translate?v=1.0&langpair=en%7Cja&q="))
    (cl-ppcre:register-groups-bind (meaning)
        ("\"translatedText\":\"([^\"]+)\"" (drakma:http-request (concatenate 'string uri word)))
        (if (not (equal word meaning)) meaning))))

(defun log-pen (out entry reply n choices-list meaning?)
  (let ((question
	 (if meaning? (hige::entry-meaning entry) (hige::entry-word entry)))
	(select-list
	 (mapcar #'(lambda (e)
		     (if meaning? (hige::entry-word e) (hige::entry-meaning e)))
		 choices-list)))
    (format out "~A choice: Q.~A " n question)
    (loop
       :for i from 1
       :for s in select-list
       :do (format out " ~A.~A" i s))
    (format out " ... ~A~%" reply)))

(defun log-pon (out entry reply)
  (format out "Q.~A ... ~A~%" (hige::entry-word entry) reply))