2011年9月18日日曜日

popup.elで遊んでみる

overlayを使ってポップアップメニューを表示するpopup.elを使ってみました。
rclk:rclkコマンドを実行すると、*rckl:clauses*に設定されている条件に
したがってメニューを表示します。


右クリックをイメージしています。



;; (require 'popup)

(defvar *rclk:clauses* nil)

(defvar *rclk:format-function* nil)

(defun rclk:rclk ()
(interactive)
(rclk:popup-menu*
(rclk:select *rclk:clauses*)))

(defun rclk:clause-name (clause)
(if (<= (length clause) 2)
(second clause)
(third clause)))

(defun rclk:select (clauses)
(let ((result nil))
(dolist (c clauses)
(let ((strs (funcall (first c))))
(unless (listp strs)
(setf strs (list strs)))
(dolist (s strs)
(push (list s (second c) (third c)) result))))
(nreverse result)))

(defun rclk:popup-menu* (clauses)
(when clauses
(let ((popup-clauses (mapcar 'rclk:clause->popup clauses)))
(let ((result (popup-menu* (mapcar 'first popup-clauses))))
(when result
(let ((selected (find result popup-clauses
:key 'first
:test 'string-equal)))
(funcall (third selected) (second selected))
t))))))

(defun rclk:clause->popup (clause)
(let ((str (substring-no-properties
(funcall *rclk:format-function* clause))))
(cons str clause)))

;;; test
(defun symbol-at-point-as-str ()
(when (symbol-at-point)
(symbol-name (symbol-at-point))))
(defun find-function-from-str (str)
(find-function (intern str)))

;; clause = (文字列のリストを返す関数 選択時に呼び出される関数 表示項目名)
(setf *rclk:clauses*
`((word-at-point apropos "apropos")
(symbol-at-point-as-str find-function-from-str "find-function")))

(setf *rclk:format-function*
(lambda (clause)
(format "<%s> %s"
(rclk:clause-name clause)
(first clause))))

2011年8月29日月曜日

Windows Power Shell で Word の表に書き込む

大量のWordやExcelファイルを一括で処理する方法が知りたいです。
とりあえず、Power Shell で頑張るための第一歩。



既存のファイルを開いて、Word中の表の(1,1)に文字列を挿入します。




$w = New-Object -ComObject "Word.Application"
$d = $w.Documents.open("filename")
$d.Tables.Item(1).Cell(1,1).Range.Text = "hoge"


1日の間に更新されたファイルをカレントディレクトリ以下から探します。




$d = (date).AddDays(-1)
Get-ChildItem -Recurse | Where-Object { $_.LastWriteTime -gt $d }

2011年8月14日日曜日

F#でキーボードフック

C#でできるらしいので、F#でもできるだろうということでやってみました。
.Net上の言語でキーボードフックしてるプログラムを載せてる色々なWebページを参考にしました。


F#のコンソールにコピペしてhook_start関数を実行すると,PrintScreenをフックするようになります。



open System

open System.Diagnostics
open System.Runtime.InteropServices

[<Literal>]
let WH_KEYBOARD_LL = 13

[<Literal>]
let HC_ACTION = 0

[<Literal>]
let WM_KEYDOWN = 0x0100

[<Literal>]
let WM_KEYUP = 0x0101

[<Literal>]
let WM_SYSKEYDOWN = 0x0104

[<Literal>]
let WM_SYSKEYUP = 0x0105

[<Literal>]
let VK_SNAPSHOT = 0x2Cu

[<StructLayout(LayoutKind.Sequential)>]
type KBDLLHOOKSTRUCT =
val vkCode : uint32
val scanCode : uint32
val flags : uint32
val time : uint32
val dwExtraInfo : uint32

type LowLevelKeyboardProc = delegate of int * nativeint * KBDLLHOOKSTRUCT ->\
nativeint

[<DllImport("kernel32.dll")>]
extern uint32 GetCurrentThreadId()

[<DllImport("kernel32.dll", SetLastError = true)>]
extern nativeint GetModuleHandle(string lpModuleName)

[<DllImport("user32.dll", SetLastError = true)>]
extern bool UnhookWindowsHookEx(nativeint hhk)

[<DllImport("user32.dll", SetLastError = true)>]
extern nativeint SetWindowsHookEx(int idhook, LowLevelKeyboardProc proc, native\
int hMod, uint32 threadId)

[<DllImport("user32.dll", SetLastError = true)>]
extern nativeint CallNextHookEx(nativeint hHook, int nCode, nativeint wParam, K\
BDLLHOOKSTRUCT lParam)

let mutable s_hook = 0n

let SetHook (proc : LowLevelKeyboardProc) =
use curProc = Process.GetCurrentProcess()
use curMod = curProc.MainModule
s_hook <- SetWindowsHookEx(WH_KEYBOARD_LL, proc, GetModuleHandle(curMod.\
ModuleName), 0u)
if s_hook = 0n then false else true

let UnSetHook () =
if s_hook <> 0n then
if UnhookWindowsHookEx(s_hook) then
s_hook <- 0n
true
else
false
else
false

let MyHookProc (nCode : int) (wParam : nativeint) (lParam : KBDLLHOOKSTRUCT) =
if nCode = HC_ACTION then
match (int wParam, lParam.vkCode) with
| (WM_KEYDOWN, VK_SNAPSHOT) -> printf "Print Screen\n"; 1\
n
| (_, _) -> CallNextHookEx(s_hook, nCode, wParam, lParam)
else
CallNextHookEx(s_hook, nCode, wParam, lParam)

let hook_start() = SetHook(new LowLevelKeyboardProc(MyHookProc))



2011年7月3日日曜日

Emacsのコマンド2

1つのキーストロークに複数コマンドを割り当ててみる試みその2。

変数の真偽に応じて2種類のうちどちらかの動作をするコマンドを作成しました。

(require 'cl)
(defvar *toggle-command-flag* nil)

(defun toggle-command-flag ()
(interactive)
(setf *toggle-command-flag*
(not *toggle-command-flag*)))

(defun parse-body (body)
(let (fst scd rest)
(setf fst (car body)
scd (cadr body)
rest (cddr body))
(unless (stringp fst)
(when scd (push scd rest))
(setf scd fst)
(setf fst nil))
(unless (and (listp scd)
(eq (car scd) 'interactive))
(when scd (push scd rest))
(setf scd nil))
(list fst scd rest)))

(defun parse-toggle-command-form (form)
(when (or (<= (length form) 0)
(<= 3 (length form)))
(error "invalid toggle-command form"))
(list (first form) (second form)))

(defmacro define-toggle-command (name args &rest body)
(destructuring-bind (doc interactive form)
(parse-body body)
(destructuring-bind (then else)
(parse-toggle-command-form form)
`(defun ,name ,args
,@(when doc (list doc))
,@(when interactive (list interactive))
(if *toggle-command-flag*
,then
,else)))))

;; コマンド定義
(define-toggle-command toggle-ctrl-l-cmd ()
(interactive)
(call-interactively 'goto-line)
(call-interactively 'recenter-top-bottom))

(global-set-key (kbd "C-l") 'toggle-ctrl-l-cmd)

toggle-ctrl-l-cmdは、変数が偽の時はrecenter-top-bottomコマンドを、真の時は goto-lineコマンドを呼び出します。

2011年6月30日木曜日

Emacsのコマンド

貴重なC-a,C-eといったキーが行頭/行末移動しかしないのはもったいない、ということで、 sequential-command.elなどのように、多少空気を読んで動作を変えるようなコマンドを定義します。

(defmacro as-this-command (cmd &rest args)
`(progn
(setq this-command ',cmd)
(call-interactively ',cmd ,@args)))

(defun buffer-empty? ()
(= (point-min) (point-max)))

(defun initialize-buffer ()
(interactive)
(call-interactively 'auto-insert))

(defun at-line-start? ()
(= (point) (line-beginning-position)))

(defun at-line-end? ()
(= (point) (line-end-position)))

(defun at-word? ()
(case (char-after (point))
((9 10 13 32 59
?( ?) ?[ ?] ?{ ?}) nil)
((nil) nil)
(t t)))

(defun at-paren-start? ()
(find (char-after (point))
"([{"))

(defun at-paren-end? ()
(when (> (point) 1)
(find (char-after (point))
")]}")))

(defun at-end-of-symbol? ()
(when (> (point) 1)
(save-excursion
(unless (at-word?)
(backward-char)
(at-word?)))))

(defun forward-at-paren-end ()
(interactive)
(let ((pos (point)))
(cond
((= pos (point-max)) (call-interactively 'newline-and-indent))
((= pos (line-end-position))
(call-interactively 'forward-char)
(call-interactively 'indent-for-tab-command))
(t (call-interactively 'forward-char)))))

(defun forward-at-line-end ()
(interactive)
(let ((pos (point)))
(cond
((= pos (point-max)) (call-interactively 'newline-and-indent))
(t
(call-interactively 'forward-char)
(call-interactively 'indent-for-tab-command)))))

(defun my-ctrl-o ()
(interactive)
(cond
;; markが有効な場合、インデントする
(mark-active (as-this-command indent-region))
;; バッファが空の場合、初期化する(auto-insert)
((buffer-empty?) (as-this-command initialize-buffer))
;; ポイントが単語上にある場合、次の単語に移動する
((at-word?) (as-this-command forward-word))
;; ポイントが開き括弧上にある場合、対応する括弧の終わりに移動する
((at-paren-start?) (as-this-command forward-sexp))
;; ポイントが単語の終わりにある場合、hippie-expandを呼び出す
((at-end-of-symbol?) (as-this-command hippie-expand))
;; ポイントが閉じ括弧の次にある場合、次の文字に進む
((at-paren-end?) (as-this-command forward-at-paren-end))
;; ポイントが行頭にある場合、インデントする
((at-line-start?) (as-this-command indent-for-tab-command))
;; ポイントが行末にある場合、次の行に移動する。
;; バッファの終端でもある場合、改行する。
((at-line-end?) (as-this-command forward-at-line-end))
(t t)))

(defun my-ctrl-a ()
(interactive)
(when (and (eq last-command 'my-ctrl-a)
(= (point) (line-beginning-position)))
(call-interactively 'scroll-down))
(call-interactively 'move-beginning-of-line))

(defun my-ctrl-e ()
(interactive)
(when (and (eq last-command 'my-ctrl-e)
(= (point) (line-end-position)))
(call-interactively 'scroll-up))
(call-interactively 'move-end-of-line))

(global-set-key (kbd "C-o") 'my-ctrl-o)
(global-set-key (kbd "C-a") 'my-ctrl-a)
(global-set-key (kbd "C-e") 'my-ctrl-e)

my-ctrl-aコマンドはC-aに割り当てるつもりで定義したものです。普段は通常のC-aの動作をしますが、すでにポイントが行頭にあり、 1つ前に実行されたコマンドもmy-ctrl-aの場合には、M-v(scroll-down)の動作を行います。

my-ctrl-eコマンドはmy-ctrl-aのC-eバージョンです。 1つ前のコマンドがmy-ctrl-eの場合にはC-v(scroll-up)の動作を行います。

これでscroll-downが押しやすくなった上、C-vを他のコマンドに割り当てる余裕ができました。

また、普段はC-oをhippie-expandコマンドにしているので、展開が必要なさそうな箇所では別の動作をするmy-ctrl-oも定義しました。こちらはC-a/C-eに比べて残念な感じがします。

2011年6月15日水曜日

cl-gtk2 + Glade

cl-gtk2はgladeで作成したファイルを利用できるようなので遊んで見ました。

ソースコード

(asdf:load-system :cl-gtk2-glib)
(asdf:load-system :cl-gtk2-gdk)
(asdf:load-system :cl-gtk2-cairo)
(asdf:load-system :closure-html)
(asdf:load-system :cxml-stp)
(asdf:load-system :drakma)
(asdf:load-system :cl-ppcre)
(asdf:load-system :cl-interpol)

(defpackage :gtk-user
(:use :cl)
(:export run))

(in-package :gtk-user)

(cl-interpol:enable-interpol-syntax)
(setf drakma:*drakma-default-external-format* :utf-8)

(defun reference-of (node)
(let ((tag (stp:local-name node)))
(cond
((string= tag "a")
(or (stp:attribute-value node "href") ""))
((string= tag "img")
(or (stp:attribute-value node "src") ""))
((string= tag "link")
(or (stp:attribute-value node "href") ""))
((string= tag "script")
(or (stp:attribute-value node "src") ""))
(T ""))))

(defun text-of (node)
(let ((text (stp:string-value node)))
(if (> (length text) 30)
(concatenate 'string (subseq text 0 27 ) "...")
text)))

;; ありそうな文字コードを総当たりで試す。富豪的富豪的。
(defun octets-to-string-by-error-handler (octets)
(let ((formats (list :shift_jis :utf-8 :euc-jp :eucjp
:sjis
:utf-16 :utf-16BE :utf-16le
:utf-32 :utf-32be :utf-32le
:utf-8b )))
(tagbody
:retry
(print formats)
(handler-case
(return-from octets-to-string-by-error-handler
(sb-ext:octets-to-string octets :external-format (pop formats)))
(error (e)
(declare (ignore e))
(if formats
(go :retry)
(error "can't convert octets to string")))))))

(defun get-http-body-string (url)
(multiple-value-bind
(arr code headers url stream)
(drakma:http-request url :external-format-in :binary)
(let ((content-type (cdr (find :content-type headers :test #'string= :key #'car))))
(if content-type
(cl-ppcre:register-groups-bind (charset)
((cl-ppcre:create-scanner #?/charset=(\w+)/ :case-insensitive-mode t)
content-type)
;; todo
(octets-to-string-by-error-handler arr))))))

(defun run ()
(let ((out *standard-output*))
(gtk:within-main-loop
(let* ((builder
(make-instance 'gtk:builder
:from-file "/path/to/GladeTest.glade"))
(window (gtk:builder-get-object builder "ToplevelWindow"))
(entry (gtk:builder-get-object builder "entry1"))
(button (gtk:builder-get-object builder "button1"))
(tree (gtk:builder-get-object builder "treeview1"))
;; treeview1のmodelは後で上書きする
(dummy (gtk:builder-get-object builder "liststore1"))
(liststore (make-instance 'gtk:array-list-store)))

;; treeview1のmodelを上書き
(setf (gtk:tree-view-model tree) liststore)

;; tree-viewの列(model)
(gtk:store-add-column liststore "gchararray" #'stp:local-name)
(gtk:store-add-column liststore "gchararray" #'text-of)
(gtk:store-add-column liststore "gchararray" #'reference-of)

;; tree-viewの列(view)
(let ((col-tag (make-instance 'gtk:tree-view-column :title "タグ"))
(col-text (make-instance 'gtk:tree-view-column :title "text"))
(col-ref (make-instance 'gtk:tree-view-column :title "参照先"))
(cr (make-instance 'gtk:cell-renderer-text)))
(gtk:tree-view-column-pack-start col-tag cr)
(gtk:tree-view-column-add-attribute col-tag cr "text" 0)
(gtk:tree-view-column-pack-start col-text cr)
(gtk:tree-view-column-add-attribute col-text cr "text" 1)
(gtk:tree-view-column-pack-start col-ref cr)
(gtk:tree-view-column-add-attribute col-ref cr "text" 2)
(gtk:tree-view-append-column tree col-tag)
(gtk:tree-view-append-column tree col-text)
(gtk:tree-view-append-column tree col-ref))

;; ボタンクリック時の動作
(gobject:g-signal-connect
button "clicked"
(lambda (b)
(handler-case
(let* ((str (get-http-body-string (gtk:entry-text entry)))
(doc (chtml:parse str (cxml-stp:make-builder))))
(stp:do-recursively (node doc)
(when
(and
(typep node 'stp:element)
(some
(lambda (s) (string-equal s (stp:local-name node)))
'("a" "link" "script" "img")))
(gtk:store-add-item liststore node))))
(error (e)
(let ((diag (make-instance 'gtk:message-dialog
:text (format nil
"error:(~A) ~A"
(gtk:entry-text entry)
e)
:message-type :error)))
(unwind-protect (gtk:dialog-run diag)
(gtk:object-destroy diag)))))))
(gtk:widget-show window)))))


gladeファイル

<?xml version="1.0" encoding="UTF-8"?>
<interface>
<requires lib="gtk+" version="2.16"/>
<!-- interface-naming-policy toplevel-contextual -->
<object class="GtkWindow" id="ToplevelWindow">
<property name="title" translatable="yes">ToplevelWindow</property>
<child>
<object class="GtkVBox" id="vbox3">
<property name="visible">True</property>
<child>
<object class="GtkHBox" id="hbox1">
<property name="height_request">30</property>
<property name="visible">True</property>
<child>
<object class="GtkLabel" id="label5">
<property name="visible">True</property>
<property name="label" translatable="yes">URL:</property>
</object>
<packing>
<property name="expand">False</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="entry1">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="invisible_char">•</property>
</object>
<packing>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkButton" id="button1">
<property name="label" translatable="yes">読み込み</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="position">2</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkTreeView" id="treeview1">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="model">liststore1</property>
</object>
<packing>
<property name="position">1</property>
</packing>
</child>
</object>
</child>
</object>
<object class="GtkListStore" id="liststore1"/>
</interface>

利用しているライブラリはすべてquicklispでインストールできます。

ライブラリのおおまかな内容は以下のとおり。

  • cl-gtk2-*** : GTKバインディング
  • closure-html : HTMLパーサー
  • cxml-stp : DOMに似たもの
  • cl-ppcre : 正規表現
  • drakma : HTTPクライアント
  • cl-interpol : リーダーの拡張。正規表現リテラルに利用。

sb-ext:octets-to-stringを利用しているのでSBCLでのみ動作します。他の処理系で動作ささせる場合、バイト列を文字列に変換する箇所を変更する必要があります。

(gtk-user::run) を評価するとテキストボックス(entry)を持ったウィンドウが表示されます。このテキストボックスにURLを入力して隣のボタンをクリックすると、URLの内容(HTML)を取得し、他のURLへを参照していそうなa/link/img/scriptタグを抜き出してtree-viewに表示します。

わかりづらかった点として、gtk:array-list-storeがCommonLisp側で定義されたクラスだということがありました。 array-list-storeは便利そうだと思いましたが、GTK側に組み込まれているクラスではないので、 Gladeでモデルに指定できない(ような気がします)。

2011年6月11日土曜日

ネタ言語 primefu*k

ネタ言語を実装しました。

;; 素数リストの作成
(defun make-prime-list (n)
(let ((arr (make-array n :initial-element 0 :element-type '(integer 0 1))))
(setf (aref arr 0) 1)
(setf (aref arr 1) 1)
(loop
:for i from 2 below n
:when (zerop (aref arr i))
:do (loop
:for j from (* i 2) below n by i
:do (setf (aref arr j) 1)))
(loop
:for i from 0 below n
:when (zerop (aref arr i))
:collect i)))

(defparameter
*primes*
(coerce (make-prime-list 100000) 'vector))

;; 素因数分解
(defun integer-factorization (n prime-vector)
(let ((result nil))
(loop
:for x across prime-vector
:until (= n 1)
:do
(loop
:while (zerop (mod n x))
:do (setf n (/ n x))
:sum 1 into acc
:finally (push (cons x acc) result)))
(nreverse result)))

;; 数値を引き数として受け取り、Common Lispプログラムを返す
(defun n->cl (n primes)
(let ((operators
(mapcar #'cdr (integer-factorization n primes))))
(let ((tags nil)
(result nil))
(dolist (op operators)
(case op
((0) ;; >: ptr++
(push `(incf ptr) result))
((1) ;; <: ptr--
(push `(decf ptr) result))
((2) ;; +: (*ptr)++
(push `(incf (aref memory ptr)) result))
((3) ;; -: (*ptr)--
(push `(decf (aref memory ptr)) result))
((4) ;; .: putchar(*ptr)
(push `(write-char (code-char (aref memory ptr)))
result))
((5) ;; ,: *ptr=getchar()
(push `(setf (aref memory ptr) (char-code (read-char)))
result))
((6) ;; [: while(*ptr){
(let ((from (gensym))
(to (gensym)))
(push (cons from to) tags)
(push
`(when (zerop (aref memory ptr))
(go ,to))
result)
(push from result)))
((7) ;; ]: }
(destructuring-bind (from . to) (pop tags)
(push
`(unless (zerop (aref memory ptr))
(go ,from))
result)
(push to result)))
(T (error "unexpected operator"))))
`(let ((memory (make-array 30000
:initial-element 0
:element-type '(unsigned-byte 8)))
(ptr 0))
(tagbody
,@(nreverse result))))))

(defvar *bf-char->op*
"><+-.<[]")

;; Brainfu*kプログラムを数値に変換
(defun bf->n (bf-string primes)
(let ((result 1))
(loop
:for ch across bf-string
:for p across primes
:do (setf result
(* result
(expt p (position ch *bf-char->op*)))))
result))

(defvar *helloworld-bf*
"+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+.")


(defun execute (n &optional (primes *primes*))
(eval (n->cl n primes)))

;; test
(execute (bf->n *helloworld-bf* *primes*))

名前のとおり、中身はBrainfu*kです。

入力となるソースコードは数値で、素因数分解によって命令列が作成されます。

例えば"Hello, world!"と出力するプログラムは以下の値です。 (10進数、25桁ごとに改行)

4502303465384972596608528
2944087262557401643378529
8625080698782925063959121
7719172880530482008491550
8597084354818091584552183
1319098036757291006692817
9301283601343001317452270
0376267461517920956544956
5153324663016284459064839
1911228540917237768596719
1754627268505767395202314
3109320783377732443055786
7415159648646742451459077
8603291732011810376948079
2004773113078228397846041
4399383865663430345291483
4231649128778405945758270
3488234290362476776792281
3785655092937989870582015
2313906809006976695583076
4202816254753054328113083
3788768481801880471791973
8660596785756596281519027
4112020595197735280186913
1838747769408930883235538
9738739557566706588749933
2671373192590205308149393
8139362300