About | Profile | まとめ | オリジナル | xyzzy | あんてな | ■ | buzz

• Scheme コードバトン (CL fork)
• やったことは以下の通り。
• untabify
• format指示子を大文字に揃える
• インデントを調整
• 辞書が存在しない時の動作を修正
• package-nameがprintされないようにして、オリジナルの辞書と似た感じの出力を目指した
• asdfのパッケージ化
• lispの関数は10行越えると、理解が大変になってくる。修行が足りないなぁ
• xyzzy lispでforkしようかと思っていたけれど、ABCLの動作と似た感じになるだろうから、微妙。

diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..3667c7a
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,13 @@
+;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
+
+;;; Package Management
+(in-package :cl-user)
+
+(defpackage :hige
+  (:use :cl)
+  #+ABCL (:shadow :y-or-n-p)
+  (:export #:pin
+           #:pon
+           #:pun
+           #:pan
+           #:pen))
diff --git a/scheme_baton.asd b/scheme_baton.asd
new file mode 100644
index 0000000..b2d9ce6
--- /dev/null
+++ b/scheme_baton.asd
@@ -0,0 +1,4 @@
+(defsystem :scheme_baton
+  :serial t
+  :components ((:file "package") (:file "scheme_baton"))
+  )
diff --git a/scheme_baton.lisp b/scheme_baton.lisp
index 27713dc..fc50ad7 100644
--- a/scheme_baton.lisp
+++ b/scheme_baton.lisp
@@ -53,6 +53,7 @@
 ;;   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) でロードできるようにした。
 ;;
 ;; =================================================================================================================================================
 ;;                            これより下がコードとその説明 - 変更・削除歓迎
@@ -79,18 +80,6 @@
 ;; ■辞書ファイルの例
 ;;   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
@@ -177,25 +166,25 @@
        (format *debug-io* "done~%"))
      *dict*))
 
-(defmacro with-entries ((entry) &rest body)
+(defmacro do-entries ((entry) &rest body)
   `(dolist (,entry (entries-of *dict*))
      ,@body))
 
 ;;; Top-Level Functions
 (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)))))
+    (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."
   (with-dict ()
-    (with-entries (e)
+    (do-entries (e)
       (p "~&~A (score: ~D): " (read-aloud (entry-word e)) (entry-score e))
-      (ready?)
+      #-ABCL (ready?)
       #-ABCL (p "~&~A [Ynq]: " (entry-meaning e))
       :again
       (case (query #+ABCL (entry-meaning e))
@@ -209,12 +198,12 @@
 (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)))
+    (let ((word (intern (prompt-read "Word to search") #.*package*)))
       (format t "~A" (or (search-dict word) "Not found.")))))
 
 (defun pun (&key score-threshold)
-  (if (and score-threshold
-           (not (numberp score-threshold)))
+  (when (and score-threshold
+             (not (numberp score-threshold)))
     (error "pun: score-threshold must be number."))
   (setup-dict)
   (dump-dict :score-threshold score-threshold))
@@ -226,7 +215,7 @@
   (with-dict ()
     (when (> n-choice (length (entries-of *dict*))) ; 辞書の長さチェック
       (error "Dictionary size is too small .~%"))
-    (with-entries (e)
+    (do-entries (e)
       (p "~&~A (score: ~D): "
          (if meaning? (entry-meaning e) (read-aloud (entry-word e)))
          (entry-score e))
@@ -239,13 +228,15 @@
            :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))
+          (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 *query-io* nil nil)))))))))
+                ((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*))
@@ -261,36 +252,51 @@
   (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)))
+                          :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)
   "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)))))
+  (unless (probe-file file)
+    (return-from read-dict NIL))
+  (with-open-file (in file)
+    (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."
-  (with-open-file (out file :direction :output :if-exists :supersede)
-    (with-standard-io-syntax
-      (dolist (word (entries-of *dict*)) (print word out)))))
+  (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が指定されない場合は全件
-                          (remove nil ;score-thresholdが指定された場合は絞り込む
-                                  (mapcar (lambda (e)
-                                            (if (<= (entry-score e) score-threshold)
-                                              e))
-                                          (entries-of *dict*)))))))
+                            (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)))
 
@@ -324,7 +330,6 @@
                 (1 #\N)
                 (2 #\Q)))
 
-
 (defun prompt-read (prompt)
   #-ABCL (progn
            (p "~A: " prompt)

こんなのを用意してみた。
cronがちゃんと働けば、一日3回更新チェックをするはず。

(defun ni::add-site-from-raido ()
  (interactive)
  (ni::load-site-data)
  (mapcar
   (lambda (x) (ignore-errors (ni::site-add x)))
   (set-difference
    (let ((stream (ni::http-get-url "http://raido.sakura.ne.jp/southly/lisp/ni/ni-status.txt")))
      (do* ((line (read-line stream nil nil) (read-line stream nil nil))
            (r nil))
          ((not line) (nreverse r))
        (unless (string-matchp "^\\(4[0-9][0-9]\\|NIL\\)" line)
          (push (second (split-string line " ")) r))))
    (mapcar (lambda (x) (cdr (assoc "src" x :test #'equal))) ni::*site-data*)
    :test #'string=)))
(define-key ni::*site-map* #\N 'ni::add-site-from-raido)

• 2008-02-06 : タイムアウトしているときは除外しましょうということで修正

http://homepage3.nifty.com/e-papy/pdftool/index.html
まだ要素のみ。

(defvar *pdftool-dll-path* nil)
(unless *pdftool-dll-path*
  (setq *pdftool-dll-path* (merge-pathnames "pdftool.dll" (si:system-root))))

(c:define-dll-entry c:int *get-pdf-text ((c:char *) (c:char *))
  *pdftool-dll-path* "GetPDFText")

(c:define-dll-entry c:int *write-pdf-txt ((c:char *) (c:char *))
  *pdftool-dll-path* "WritePDFText")

(defun get-pdf-text(pdf txt)
  (if (path-equal pdf txt)
      (error "入出力のファイルが一致")
    (case (*get-pdf-text (si:make-string-chunk pdf)
                         (si:make-string-chunk txt))
      (-1 (error "失敗"))
      (-2 (error "PDFファイルが暗号化されてる"))
      (t t))))

(defun write-pdf-txt(txt pdf)
  (if (path-equal txt pdf)
      (error "入出力のファイルが一致")
    (case (*write-pdf-txt (si:make-string-chunk txt)
                          (si:make-string-chunk pdf))
      (-1 (error "失敗"))
      (t t))))

(let ((num 0) (time nil) (mes ""))
  (defun test ()
    (unless time (setq time (get-internal-real-time)))
    (setq mes (concat mes (format nil "~d: ~d~%" (incf num) (- (get-internal-real-time) time))))
    (msgbox "~a" mes)
    (setq time (get-internal-real-time))))

(start-timer 5 'test)

(stop-timer 'test)

1: 0
2: 15
3: 5000
4: 5000
5: 5000
6: 5000

変数の初期化漏れとかなのかな

てきとー

(defun insert-include (file &optional cwd)
  (interactive "lHeader: " :default0 (merge-pathnames "*.h"))
  (unless cwd
    (if (get-buffer-file-name)
        (setq cwd (directory-namestring (get-buffer-file-name)))
      (return-from insert-include nil)))
  (if (consp file)
      (dolist (f file)
        (insert-include f cwd))
    (insert (format nil "~%#include \"~A\"" (substitute-string file (regexp-quote cwd) "" :case-fold t)))))

ヒストリ変数でパスを指定する場合でのみ問題ということであれば.xyzzy.historyの出力をどうにかすればいいのでは?と思い、書いてみる。
未テストなので注意。
帰ってからテストします。
(ReadMore...)

http://xyzzy.s53.xrea.com/wiki/index.php?%BC%C1%CC%E4%C8%A2%2F173
上のページにいくつかありますが元のpopup-listと引数が異なっていて置き換えにくいので書き直し。正規表現を使っていなかった佐野さんのがベース。

(defun popup-list-loop (list callback &optional point with-insert)
  (let ((str "") (matched list) matched1 selected input)
    (loop
      (if with-insert (insert str))
      (popup-list matched (lambda (x) (setq selected x)) point) ; #\ESC
      (refresh-screen)
      (while (not (or selected (setq input (read-char-no-hang *keyboard*))))
        (do-events))
      (if with-insert (delete-region (- (point) (length str)) (point)))
      (cond (selected
             (funcall callback selected)
             (if (eql input #\SPC) (unread-char input))
             (return t))
;           ((eql input #\ESC) (return nil))
            ((eql input #\C-h) (unless (zerop (length str)) (setq str (substring str 0 -1))))
            ((graphic-char-p input) (setq str (format nil "~A~C" str input)))
            (t (unread-char input) (return nil)))
      (setq matched1 (remove-if (lambda (x)
                                  (or (< (length x) (length str))
                                      (string/= x str :end1 (length str))))
                                list))
      (if (endp matched1) (if with-insert
                              (progn (funcall callback str) (return t))
                            (setq str (substring str 0 -1)))
        (setq matched matched1)))))

できるだけ元のpopup-listと同じ操作感になるようにしたつもりですが、ウィンドウをESCで閉じたときの動作だけは感知する手段が無くて無理でした。

• 2006-10-19修正。eqで文字を比較するのは処理系依存だったのでeqlに。

ちなみに実際に使うときはこれみたいに引数にbase（すでに一致している部分）をとらないといけないような気がしてる。

絞込み
(ReadMore...)

候補の絞込みしていなかったのを修正。
(ReadMore...)

C/C++とかJavaとかのメンバをdabbrevライクに補完。
てきとー
(ReadMore...)

また勢いだけで使いそうに無いものを作ってしまった。
(ReadMore...)

RandomNote投稿lisp。
refwikiのPOST用も作ってみたり。公開はしないけど。
(ReadMore...)

適当にNOT検索ができるようにしてみる。
Rubyはまだよく分からんので変なことしているかも。
どなたかうまいこと実装してくれないかなぁ。

検索語が「-」で始まる場合はNOT検索をします。
(ReadMore...)

;;; RandomNote投稿
(require "junk/http")

(in-package "junk")

(defvar *rn-url* "http://raido.sakura.ne.jp/southly/rn/index.rb")

(defun rn-post (url str)
  (let (http)
    (multiple-value-bind (proto host file anchor port)
        (junk-http-url-study url)
      (unless (string= proto "http")
        (junk-error "Protocol is not http: ~A" url))
      (unwind-protect
          (multiple-value-prog1
           (setq http (junk-http-request-send host file "POST" :data (format nil "cmd=edit_do&fname=&mes=~A" (si:www-url-encode str nil "0-9A-Za-z"))))
           ; 結果確認するならここ
           (and http (close http)))
        (close http :abort t)))))

(defun user::rn-post-region (beg end)
  (interactive "r")
  (rn-post *rn-url* (buffer-substring beg end)))

ということでできたRandomNote投稿Lisp。
xyzzyからM-x rn-post-regionで投稿します。
編集とか削除はしない方針なので作る予定はありません。

with-open-streamを見てちょっと修正。
一応closeしたほうがいいんだっけ?