It is not difficult to solve the eight-queens puzzle using amb evaluator,
but have to specify either row number or column number explicitly because it will
takes a couple of hours for the program to find an answer if we let the
program to try each number against both row and column.
E.g. we can specify a position of the first row as
(list 0 (amb 0 1 2 3 4 5 6 7))
amb evaluatorを使ってeight-queensパズルは簡単に解けますが、queenの場所を
指定するときに、行、列のどれかを固定する必要があります。
たとえば、一行目のqueenは(list 0 (amb 0 1 2 3 4 5 6 7))の形ですれば、秒単位で
答えが出ますが、単にそれぞれのqueenを(list (amb 0 1 2 3 4 5 6 7) (amb 0 1 2 3 4 5 6 7))
のように指定すると、選択肢が多くなり、1時間がたっても答えが出ません。
用amb evaluator解决eight queens问题没有什么难度。但是在指定王后时要注意
固定某一行或者是某一列。比如，指定第一行王后的位置为
(list 0 (amb 0 1 2 3 4 5 6 7)),而不是指定第一个王后为
(list (amb 0 1 2 3 4 5 6 7) (amb 0 1 2 3 4 5 6 7)).
否则由于分支太多而导致运算会持续很长时间。
(define (eight-queens)
(define (checked a b)
(or
(or (= (car a) (car b))
(= (cadr a) (cadr b)))
(= (abs (- (car a) (car b)))
(abs (- (cadr a) (cadr b))))))
(let ((q1 (list 0 (amb 0 1 2 3 4 5 6 7))))
(let ((q2 (list 1 (amb 0 1 2 3 4 5 6 7))))
(require (not (checked q2 q1)))
(let ((q3 (list 2 (amb 0 1 2 3 4 5 6 7))))
(require (and
(not (checked q3 q1))
(not (checked q3 q2))))
(let ((q4 (list 3 (amb 0 1 2 3 4 5 6 7))))
(require (and
(not (checked q4 q1))
(not (checked q4 q2))
(not (checked q4 q3))))
(let ((q5 (list 4 (amb 0 1 2 3 4 5 6 7))))
(require (and
(not (checked q5 q1))
(not (checked q5 q2))
(not (checked q5 q3))
(not (checked q5 q4))))
(let ((q6 (list 5 (amb 0 1 2 3 4 5 6 7))))
(require (and
(not (checked q6 q1))
(not (checked q6 q2))
(not (checked q6 q3))
(not (checked q6 q4))
(not (checked q6 q5))))
(let ((q7 (list 6 (amb 0 1 2 3 4 5 6 7))))
(require (and
(not (checked q7 q1))
(not (checked q7 q2))
(not (checked q7 q3))
(not (checked q7 q4))
(not (checked q7 q5))
(not (checked q7 q6))))
(let ((q8 (list 7 (amb 0 1 2 3 4 5 6 7))))
(require (and
(not (checked q8 q1))
(not (checked q8 q2))
(not (checked q8 q3))
(not (checked q8 q4))
(not (checked q8 q5))
(not (checked q8 q6))
(not (checked q8 q7))))
(list q1 q2 q3 q4 q5 q6 q7 q8))))))))))
Friday, November 26, 2010
Thursday, November 25, 2010
amb evaluator of SICP
It is necessary to implement the amb evaluator in order to keep up with
the text and the evaluator does not make sense if it can not handle logical
AND/OR.
Here is the analayze-and in my evaluator which took me some time to work out
continuation part.
为了更好地理解内容，有必要实现amb evaluator。而不能处理逻辑与或的evaluator是没有
什么实际意义的。因为至今对continuation也不是很理解，费了好大劲儿才实现了。
下面是逻辑或的主要部分。
テキストを良く理解するために、amb evaluatorを実装しなければなりません。テキストに
は主な部分がありますが、論理AND、ORの部分がありませんでした。しかし、これがない限り、
amb evaluatorとしてあまり意味がないので、試しに実装してみました。何とか動き出しましたが、
いまだに継続についてあまり理解できていません。
以下は論理ANDのメイン部分になります。
(define (analyze-and exp)
(define (iter first rest env succ fl)
(if (null? rest)
((analyze first) env
(lambda (v fl1)
(succ v fl1))
fl)
((analyze first) env
(lambda (v fl2)
(if (true? v)
(iter (car rest) (cdr rest) env succ fl2)
(succ false fl2)))
fl)))
(let ((f (cadr exp))
(r (cddr exp)))
(lambda (env succeed fail)
(iter f r env succeed fail))))
the text and the evaluator does not make sense if it can not handle logical
AND/OR.
Here is the analayze-and in my evaluator which took me some time to work out
continuation part.
为了更好地理解内容，有必要实现amb evaluator。而不能处理逻辑与或的evaluator是没有
什么实际意义的。因为至今对continuation也不是很理解，费了好大劲儿才实现了。
下面是逻辑或的主要部分。
テキストを良く理解するために、amb evaluatorを実装しなければなりません。テキストに
は主な部分がありますが、論理AND、ORの部分がありませんでした。しかし、これがない限り、
amb evaluatorとしてあまり意味がないので、試しに実装してみました。何とか動き出しましたが、
いまだに継続についてあまり理解できていません。
以下は論理ANDのメイン部分になります。
(define (analyze-and exp)
(define (iter first rest env succ fl)
(if (null? rest)
((analyze first) env
(lambda (v fl1)
(succ v fl1))
fl)
((analyze first) env
(lambda (v fl2)
(if (true? v)
(iter (car rest) (cdr rest) env succ fl2)
(succ false fl2)))
fl)))
(let ((f (cadr exp))
(r (cddr exp)))
(lambda (env succeed fail)
(iter f r env succeed fail))))
Tuesday, August 17, 2010
Bubble sort program in Arc, a dialect of LISP
Wrote a bubble sort program using Arc just to have a try of this Lisp dialect.
试着用Arc，Lisp的一种方言，写了一个冒泡排序程序。
試しに、Lispの一種、Arcを使ってバッブルソートプログラムを書いてみました。
-------------------------------
Use (quit) to quit, (tl) to return here after an interrupt.
arc> (def mn (s m)
(if (no s) m
(< (car s) m) (mn (cdr s) (car s)) (mn (cdr s) m))) arc> #
arc> (def bsort (s)
(if (no s) nil
(let x (mn s (car s))
(cons x
(bsort (rem [is _ x] s))))))
#
arc> :a
> (require (lib "trace.ss"))
> (trace _mn)
(_mn)
> (tl)
Use (quit) to quit, (tl) to return here after an interrupt.
arc> (bsort '(2 1 9 3))
|(_mn (2 1 9 3 . nil) 2)
|(_mn (1 9 3 . nil) 2)
|(_mn (9 3 . nil) 1)
|(_mn (3 . nil) 1)
|(_mn nil 1)
|1
|(_mn (2 9 3 . nil) 2)
|(_mn (9 3 . nil) 2)
|(_mn (3 . nil) 2)
|(_mn nil 2)
|2
|(_mn (9 3 . nil) 9)
|(_mn (3 . nil) 9)
|(_mn nil 3)
|3
|(_mn (9 . nil) 9)
|(_mn nil 9)
|9
(1 2 3 9)
试着用Arc，Lisp的一种方言，写了一个冒泡排序程序。
試しに、Lispの一種、Arcを使ってバッブルソートプログラムを書いてみました。
-------------------------------
Use (quit) to quit, (tl) to return here after an interrupt.
arc> (def mn (s m)
(if (no s) m
(< (car s) m) (mn (cdr s) (car s)) (mn (cdr s) m))) arc> #
arc> (def bsort (s)
(if (no s) nil
(let x (mn s (car s))
(cons x
(bsort (rem [is _ x] s))))))
#
arc> :a
> (require (lib "trace.ss"))
> (trace _mn)
(_mn)
> (tl)
Use (quit) to quit, (tl) to return here after an interrupt.
arc> (bsort '(2 1 9 3))
|(_mn (2 1 9 3 . nil) 2)
|(_mn (1 9 3 . nil) 2)
|(_mn (9 3 . nil) 1)
|(_mn (3 . nil) 1)
|(_mn nil 1)
|1
|(_mn (2 9 3 . nil) 2)
|(_mn (9 3 . nil) 2)
|(_mn (3 . nil) 2)
|(_mn nil 2)
|2
|(_mn (9 3 . nil) 9)
|(_mn (3 . nil) 9)
|(_mn nil 3)
|3
|(_mn (9 . nil) 9)
|(_mn nil 9)
|9
(1 2 3 9)
Saturday, July 10, 2010
Ex 3.22 of SICP Presenting queue with local state
(define (make-q)
(let ((front-ptr '())
(rear-ptr '()))
(define (empty-q?)
(null? front-ptr))
(define (insert-q itm)
(let ((new-pair (cons itm '())))
(if (empty-q?)
(begin
(set! front-ptr new-pair)
(set! rear-ptr new-pair))
(begin
(set-cdr! rear-ptr new-pair)
(set! rear-ptr new-pair)))
front-ptr))
(define (front-q)
(if (empty-q?)
(error "FRONT called with an empty queue" front-ptr)
(car front-ptr)))
(define (delete-q)
(cond ((empty-q?)
(error "DELETE! called with an empty queue" front-ptr))
(else
(set! front-ptr (cdr front-ptr)))))
(define (dispatch m)
(cond ((eq? m 'empty-q?) (empty-q?))
((eq? m 'insert-q) insert-q)
((eq? m 'front-q) (front-q))
((eq? m 'delete-q) (delete-q))))
dispatch))
(let ((front-ptr '())
(rear-ptr '()))
(define (empty-q?)
(null? front-ptr))
(define (insert-q itm)
(let ((new-pair (cons itm '())))
(if (empty-q?)
(begin
(set! front-ptr new-pair)
(set! rear-ptr new-pair))
(begin
(set-cdr! rear-ptr new-pair)
(set! rear-ptr new-pair)))
front-ptr))
(define (front-q)
(if (empty-q?)
(error "FRONT called with an empty queue" front-ptr)
(car front-ptr)))
(define (delete-q)
(cond ((empty-q?)
(error "DELETE! called with an empty queue" front-ptr))
(else
(set! front-ptr (cdr front-ptr)))))
(define (dispatch m)
(cond ((eq? m 'empty-q?) (empty-q?))
((eq? m 'insert-q) insert-q)
((eq? m 'front-q) (front-q))
((eq? m 'delete-q) (delete-q))))
dispatch))
Sunday, June 13, 2010
modification of Ex 3.19 of SICP - use constant amount of space to determine if a list contains loop
There was a flaw in my last post and modified it as below.
前回のアルゴリズムに欠陥があり、修正した。
上次的算法有问题，修改后可以保证只是用固定的存储空间
(define (loop? x)
(define (iter y mk)
(if (null? y) #f
(if (eq? (car y) mk) #t
(iter (cdr y) mk))))
(if (null? x) #f
(let ((mark (car x)))
(iter (cdr x) mark))))
gosh> loop?
gosh> (define s '( 1 2 3))
s
gosh> (set-cdr! (cddr s) s)
#
gosh>
(loop? s)
#t
gosh> (loop? '(1 2 3))
#f
前回のアルゴリズムに欠陥があり、修正した。
上次的算法有问题，修改后可以保证只是用固定的存储空间
(define (loop? x)
(define (iter y mk)
(if (null? y) #f
(if (eq? (car y) mk) #t
(iter (cdr y) mk))))
(if (null? x) #f
(let ((mark (car x)))
(iter (cdr x) mark))))
gosh> loop?
gosh> (define s '( 1 2 3))
s
gosh> (set-cdr! (cddr s) s)
#
gosh>
(loop? s)
#t
gosh> (loop? '(1 2 3))
#f
Saturday, June 12, 2010
Ex 3.19 of SICP - use constant amount of space to find if a list contains a cycle
We can set a mark of a list,e.g. the address of the
head of a list and to see if this mark is accessed twice.
リストの頭のアドレスを記憶し、2回目アクセスされるときに、ロープが
あると判断できる。
可以记录一下list的头地址，如果此地址第二次被访问说明有循环在里面。
不是很确定是否为正解。因为要求使用一定量的空间。而记录头地址实际上
要记录整个list。但不须记录嵌套的list。
(define (loop? x)
(define (iter y mk)
(if (null? y) #f
(if (eq? y mk) #t
(iter (cdr y) mk))))
(if (null? x) #f
(let ((mark x))
(iter (cdr x) mark))))
loop?
gosh> loop?
gosh> (loop? '( 1 2 3))
#f
gosh> (define s '( 1 2 3))
s
gosh> (set-cdr! (cddr s) s)
#
gosh>
#t
gosh> (loop? s)
#t
head of a list and to see if this mark is accessed twice.
リストの頭のアドレスを記憶し、2回目アクセスされるときに、ロープが
あると判断できる。
可以记录一下list的头地址，如果此地址第二次被访问说明有循环在里面。
不是很确定是否为正解。因为要求使用一定量的空间。而记录头地址实际上
要记录整个list。但不须记录嵌套的list。
(define (loop? x)
(define (iter y mk)
(if (null? y) #f
(if (eq? y mk) #t
(iter (cdr y) mk))))
(if (null? x) #f
(let ((mark x))
(iter (cdr x) mark))))
loop?
gosh> loop?
gosh> (loop? '( 1 2 3))
#f
gosh> (define s '( 1 2 3))
s
gosh> (set-cdr! (cddr s) s)
#
gosh>
#t
gosh> (loop? s)
#t
Ex3.16 a& Ex3.17 count-pairs
Paste here the answer of Ex3.16 and Ex3.17.
count-pairs function may return unexpected result
due to the introduction of set-car! etc.
Here we can show how it return 7 when there are just 3 pairs.
Also show the modified version of this function.
set-car!などにより、count-pairs関数が予想外の結果
を返してしまうことがある。ペアが三つなのに、7を返すケースを示します。
また、修正後の関数は以下の通りになります。
使用set-car!等可以任意改变pair的内容，导致count-pairs函数返回
我们并不期待的值。比如下面的例子显示此函数返回7。而实际上只有3个pair。
(define (count-pairs x)
(let ((ref '()))
(define (count-iter z)
(if (not (pair? z))
0
(if (counted? z ref) 0
(begin
(set! ref (append ref (list z)))
(+ (count-iter (car z))
(count-iter (cdr z))
1)))))
(count-iter x)))
(define (counted? y rf)
(if (null? rf) #f
(if (eq? y (car rf)) #t
(counted? y (cdr rf)))))
counted?
gosh> (count-pairs '(1 2 3))
3
gosh> (define k '( 1 2 3))
k
gosh> (set-car! k (cdr k))
gosh> (set-car! (cdr k) (cddr k))
gosh> (count-pairs k)
3
count-pairs function may return unexpected result
due to the introduction of set-car! etc.
Here we can show how it return 7 when there are just 3 pairs.
Also show the modified version of this function.
set-car!などにより、count-pairs関数が予想外の結果
を返してしまうことがある。ペアが三つなのに、7を返すケースを示します。
また、修正後の関数は以下の通りになります。
使用set-car!等可以任意改变pair的内容，导致count-pairs函数返回
我们并不期待的值。比如下面的例子显示此函数返回7。而实际上只有3个pair。
(define (count-pairs x)
(let ((ref '()))
(define (count-iter z)
(if (not (pair? z))
0
(if (counted? z ref) 0
(begin
(set! ref (append ref (list z)))
(+ (count-iter (car z))
(count-iter (cdr z))
1)))))
(count-iter x)))
(define (counted? y rf)
(if (null? rf) #f
(if (eq? y (car rf)) #t
(counted? y (cdr rf)))))
counted?
gosh> (count-pairs '(1 2 3))
3
gosh> (define k '( 1 2 3))
k
gosh> (set-car! k (cdr k))
gosh> (set-car! (cdr k) (cddr k))
gosh> (count-pairs k)
3
Friday, May 28, 2010
Ex3.5 of SICP(monte-calo simulation)
Use monte-carlo simulation to estimate integrals of an unit cycle
inside a rectangle area.
(define (random-in-range low high)
(let ((range (- high low)))
(+ low (random range))))
(define (estimate-integral trials predicate lf ur)
(* (* (- (car ur) (car lf)) (- (cadr ur) (cadr lf)))
(monte-carlo trials cesaro-test predicate lf ur)))
(define (cesaro-test predicate lf ur)
(let* (
(x1 (car lf))
(y1 (cadr lf))
(x2 (car ur))
(y2 (cadr ur))
(x (random-in-range x1 x2))
(y (random-in-range y1 y2))
(px (car predicate))
(py (cadr predicate)))
(<= (+ (* (- x px) (- x px))
(* (- y py) (- y py)))
1)))
(define (monte-carlo trials experiment predicate lf ur)
(define (iter trials-remaining trials-passed)
(cond ((= trials-remaining 0)
(/ trials-passed trials))
((experiment predicate lf ur)
(iter (- trials-remaining 1) (+ trials-passed 1)))
(else
(iter (- trials-remaining 1) trials-passed))))
(iter trials 0))
;;;for gauche since there is no built-in random function
(define (random x)
(modulo (sys-random) x))
inside a rectangle area.
(define (random-in-range low high)
(let ((range (- high low)))
(+ low (random range))))
(define (estimate-integral trials predicate lf ur)
(* (* (- (car ur) (car lf)) (- (cadr ur) (cadr lf)))
(monte-carlo trials cesaro-test predicate lf ur)))
(define (cesaro-test predicate lf ur)
(let* (
(x1 (car lf))
(y1 (cadr lf))
(x2 (car ur))
(y2 (cadr ur))
(x (random-in-range x1 x2))
(y (random-in-range y1 y2))
(px (car predicate))
(py (cadr predicate)))
(<= (+ (* (- x px) (- x px))
(* (- y py) (- y py)))
1)))
(define (monte-carlo trials experiment predicate lf ur)
(define (iter trials-remaining trials-passed)
(cond ((= trials-remaining 0)
(/ trials-passed trials))
((experiment predicate lf ur)
(iter (- trials-remaining 1) (+ trials-passed 1)))
(else
(iter (- trials-remaining 1) trials-passed))))
(iter trials 0))
;;;for gauche since there is no built-in random function
(define (random x)
(modulo (sys-random) x))
Sunday, May 23, 2010
SICP Ex3.2
Nothing special just to make sure to call mf in the block of let.
Otherwise,the value of counter cannot be set correctly
没有什么难度，但是要注意一定要在let的内部调用mf。
否则，counter的值不正确。
難しくないですが、letの内部でmf関数をコールすること。
でもないと、counterの値が正しく保持されてない。
(define (make-monitored f)
(let ((counter 0))
(define (mf m)
(cond ((eq? m 'how-many-calls) counter)
((eq? m 'reset-count) (set! counter 0))
(else (set! counter (+ counter 1)) (f m))))
mf))
Otherwise,the value of counter cannot be set correctly
没有什么难度，但是要注意一定要在let的内部调用mf。
否则，counter的值不正确。
難しくないですが、letの内部でmf関数をコールすること。
でもないと、counterの値が正しく保持されてない。
(define (make-monitored f)
(let ((counter 0))
(define (mf m)
(cond ((eq? m 'how-many-calls) counter)
((eq? m 'reset-count) (set! counter 0))
(else (set! counter (+ counter 1)) (f m))))
mf))
Saturday, April 24, 2010
Quick sort in Scheme
Just enjoy myself to write quick sort in Scheme.
いろんなところにCやJavaで書かれたQuick sortの例が見られますが、
Schemeの例があまりみたことがないので、試しに作ってみました。
试着用Scheme写了一个Quick sort的小程序。纯属自娱自乐。
C或者Java的例子多见，但是很少见到有LISP的例子。
(define (qsort seq)
(if (null? seq) '()
(let ((piv (car seq)))
(append (qsort (first-half (cdr seq) piv))
(append (list piv) (qsort (second-half (cdr seq) piv)))))))
(define (first-half seq piv)
(if (null? seq) '()
(if (< (car seq) piv) (cons (car seq) (first-half (cdr seq) piv)) (first-half (cdr seq) piv)))) (define (second-half seq piv) (if (null? seq) '() (if (or (> (car seq) piv)
(= (car seq) piv))
(cons (car seq) (second-half (cdr seq) piv))
(second-half (cdr seq) piv))))
いろんなところにCやJavaで書かれたQuick sortの例が見られますが、
Schemeの例があまりみたことがないので、試しに作ってみました。
试着用Scheme写了一个Quick sort的小程序。纯属自娱自乐。
C或者Java的例子多见，但是很少见到有LISP的例子。
(define (qsort seq)
(if (null? seq) '()
(let ((piv (car seq)))
(append (qsort (first-half (cdr seq) piv))
(append (list piv) (qsort (second-half (cdr seq) piv)))))))
(define (first-half seq piv)
(if (null? seq) '()
(if (< (car seq) piv) (cons (car seq) (first-half (cdr seq) piv)) (first-half (cdr seq) piv)))) (define (second-half seq piv) (if (null? seq) '() (if (or (> (car seq) piv)
(= (car seq) piv))
(cons (car seq) (second-half (cdr seq) piv))
(second-half (cdr seq) piv))))
Wednesday, March 10, 2010
Generate a Huffman-tree (Ex2.69 SICP)
(define (generate-huffman-tree pairs)
(successive-merge (make-leaf-set pairs)))
(define (successive-merge set)
(if (= (length set) 1) set
(successive-merge (adjoin-set
(make-code-tree (car set) (cadr set))
(cddr set)))))
番号付きSETを使い、処理中要素の中身の非対称に気にしなければ上記のように簡単にできる。
It is very easy to implement if used ordered set and do not mind asymmetry of the elements
during the processing.
利用有序集合并不介意处理过程中元素的不对称的话，可以如上简单地生成霍夫曼树。
(successive-merge (make-leaf-set pairs)))
(define (successive-merge set)
(if (= (length set) 1) set
(successive-merge (adjoin-set
(make-code-tree (car set) (cadr set))
(cddr set)))))
番号付きSETを使い、処理中要素の中身の非対称に気にしなければ上記のように簡単にできる。
It is very easy to implement if used ordered set and do not mind asymmetry of the elements
during the processing.
利用有序集合并不介意处理过程中元素的不对称的话，可以如上简单地生成霍夫曼树。
Thursday, February 11, 2010
KaMail and IMAP
KamailでGMAILのIMAPフォルダアクセスしても何も表示されなかったので、
imap.lの一部を下記のように変更した。正規表現の部分を直した。
Modified IMAP related part of KaMail (regular expression) as below.
用Kamail不能访问GMAIL的IMAP账户，原因是由于程序的正规表现有点问题。
(defun imap4-fetch (stream num &optional part)
"IMAP4 FETCH"
(unless part
(setq part "RFC822"))
(let ((return "")
(flags "")
mail
last
total)
(message "Fetching ~A as ~A: " num part)
(format (imapstream-stream stream) "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-increment stream) num part)
(format *imap4-stream-output* "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-current stream) num part)
(setq return (imap4-read-line stream))
(if (string-match (format nil "^\*[ \t]+~A[ \t]+FETCH[ \t]+(\\(FLAGS[ \t]+(\\)*\\([^)]*\\))*[^{]*{\\([0-9]+\\)}" num) return)
(progn
(setq flags (substring return (match-beginning 2) (match-end 2)))
(setq total (substring return (match-beginning 3) (match-end 3)))
(setq return (imap4-read-line stream))
)
(return-from imap4-fetch nil))
(kamail-interval-message (300)
(while (not (string-match (concat "^" (imap4-tag-current stream) "[ \t]+\\(OK\\|NO\\|BAD\\)") return))
(setq last (length return))
(if mail
(setq mail (concat mail "\n" return))
(setq mail return))
(message "Fetching ~A as ~A: ~D/~A" num part (length mail) total)
(setq return (imap4-read-line stream)))
)
;最後の行を取り除く
(setq mail (substring mail 0 (- (length mail) last)))
(message "~A" return)
(values (imap4-return-ok-p stream return) mail flags total)
)
)
(defun imap4-fetch-to-stream (stream num os)
"IMAP4 FETCH"
(let ((return "")
(flags "")
(part "RFC822")
mail
last
(len 0)
total)
(message "Fetching ~A as ~A" num part)
(format (imapstream-stream stream) "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-increment stream) num part)
(format *imap4-stream-output* "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-current stream) num part)
(setq return (imap4-read-line stream))
(if (string-match (format nil "^\*[ \t]+~A[ \t]+FETCH[ \t]+(\\(FLAGS[ \t]+(\\)*\\([^)]*\\))*[^{]*{\\([0-9]+\\)}" num) return)
(progn
(setq flags (substring return (match-beginning 2) (match-end 2)))
(setq total (substring return (match-beginning 3) (match-end 3))))
(return-from imap4-fetch-to-stream nil))
;(msgbox "~S" total)
(message "Fetching ~A as ~A ..." num part)
(read-bytes-from-stream (imapstream-stream stream) os (parse-integer total))
(while (not (string-match (concat "^" (imap4-tag-current stream) "[ \t]+\\(OK\\|NO\\|BAD\\)") return))
(setq return (imap4-read-line stream)))
(message "~A" return)
(imap4-return-ok-p stream return)
))
imap.lの一部を下記のように変更した。正規表現の部分を直した。
Modified IMAP related part of KaMail (regular expression) as below.
用Kamail不能访问GMAIL的IMAP账户，原因是由于程序的正规表现有点问题。
(defun imap4-fetch (stream num &optional part)
"IMAP4 FETCH"
(unless part
(setq part "RFC822"))
(let ((return "")
(flags "")
last
total)
(message "Fetching ~A as ~A: " num part)
(format (imapstream-stream stream) "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-increment stream) num part)
(format *imap4-stream-output* "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-current stream) num part)
(setq return (imap4-read-line stream))
(if (string-match (format nil "^\*[ \t]+~A[ \t]+FETCH[ \t]+(\\(FLAGS[ \t]+(\\)*\\([^)]*\\))*[^{]*{\\([0-9]+\\)}" num) return)
(progn
(setq flags (substring return (match-beginning 2) (match-end 2)))
(setq total (substring return (match-beginning 3) (match-end 3)))
(setq return (imap4-read-line stream))
)
(return-from imap4-fetch nil))
(kamail-interval-message (300)
(while (not (string-match (concat "^" (imap4-tag-current stream) "[ \t]+\\(OK\\|NO\\|BAD\\)") return))
(setq last (length return))
(if mail
(setq mail (concat mail "\n" return))
(setq mail return))
(message "Fetching ~A as ~A: ~D/~A" num part (length mail) total)
(setq return (imap4-read-line stream)))
)
;最後の行を取り除く
(setq mail (substring mail 0 (- (length mail) last)))
(message "~A" return)
(values (imap4-return-ok-p stream return) mail flags total)
)
)
(defun imap4-fetch-to-stream (stream num os)
"IMAP4 FETCH"
(let ((return "")
(flags "")
(part "RFC822")
last
(len 0)
total)
(message "Fetching ~A as ~A" num part)
(format (imapstream-stream stream) "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-increment stream) num part)
(format *imap4-stream-output* "~A FETCH ~A (FLAGS ~A)~%" (imap4-tag-current stream) num part)
(setq return (imap4-read-line stream))
(if (string-match (format nil "^\*[ \t]+~A[ \t]+FETCH[ \t]+(\\(FLAGS[ \t]+(\\)*\\([^)]*\\))*[^{]*{\\([0-9]+\\)}" num) return)
(progn
(setq flags (substring return (match-beginning 2) (match-end 2)))
(setq total (substring return (match-beginning 3) (match-end 3))))
(return-from imap4-fetch-to-stream nil))
;(msgbox "~S" total)
(message "Fetching ~A as ~A ..." num part)
(read-bytes-from-stream (imapstream-stream stream) os (parse-integer total))
(while (not (string-match (concat "^" (imap4-tag-current stream) "[ \t]+\\(OK\\|NO\\|BAD\\)") return))
(setq return (imap4-read-line stream)))
(message "~A" return)
(imap4-return-ok-p stream return)
))
Monday, February 8, 2010
kamail(xyzzy) and POP3 over SSL
Kamail does not support POP3S (pop3 over SSL) but found a solution
that uses a free packet repeater called "stone" to act as proxy
between mailer and POP3S server.
Below is the setting in my .kamail.
KmailがPOP3S（POP3 over SSL）サポートしていないので、仙石さん作のStoneを利用しています。
kamail不支持POP3S（POP3 over SSL）但是发现一个非常小巧的packet repeater，可以作为
kamail和服务器之间的proxy。
;;;POP3S対応のために、パケットリピータstoneを使用
(progn (set-buffer (get-buffer-create "*stone*"))
(execute-subprocess "stone.exe -C stone.conf" nil (selected-buffer) nil (concat (default-directory) "tools/stone23xp/")))
that uses a free packet repeater called "stone" to act as proxy
between mailer and POP3S server.
Below is the setting in my .kamail.
KmailがPOP3S（POP3 over SSL）サポートしていないので、仙石さん作のStoneを利用しています。
kamail不支持POP3S（POP3 over SSL）但是发现一个非常小巧的packet repeater，可以作为
kamail和服务器之间的proxy。
;;;POP3S対応のために、パケットリピータstoneを使用
(progn (set-buffer (get-buffer-create "*stone*"))
(execute-subprocess "stone.exe -C stone.conf" nil (selected-buffer) nil (concat (default-directory) "tools/stone23xp/")))
Saturday, January 23, 2010
Saturday, January 2, 2010
xyzzy and kamail
This is for Japanese readers, I think,since there is a very good
Emacs-like text editor, xyzzy, created by a Japanese.
And based on this editor, another Japanese wrote a mailer called KaMail.
This mail soft is not so completed and I made some improvements.
我想本篇只是面向日本的读者。因为一个日本人制作了一个非常好的
文本编辑器，xyzzy。在此基础上另外一个人写了一个邮件软件，Kamail。
但是此软件还不是很完善，我觉得别扭的地方改写了一下。
日本にはファンが多いと思いますが、亀井さん作のテキストエディターｘｙｚｚyに、
KaMail（服部さん作）というメールソフトが組み込まれています。
ただし、不完全なところがあり、私なりに修正を入れて使っています。
以下は、あくまでもメモになります。
(defun kamail-cite-body (&optional prefix buffer)
"本文を挿入する"
(interactive "p")
(setq buffer (or buffer (kamail-draft-old-buffer)))
(unless (find-buffer buffer)
(return-from kamail-cite-body))
(save-excursion
(with-input-from-buffer (buffer)
(let (line)
(while (setq line (read-line nil nil))
(when (string= line "")
(return)))
(while (setq line (read-line nil nil))
;;;added by chen
(unless (string-matchp "^\[[0-9-]+: \\(.+ \\)*<.+/.+> *\\(\[.+\]\\|\(.+\)\\|.+\\)* *\]$" line)
;;;chen
(insert (format nil "~@[~A~]~A~%"
prefix
line))))
)))
(when (interactive-p)
(kamail-color-mail))
)
(defun kamail-prepare-forward-with-attachment ()
(interactive)
(let ((buffer (selected-buffer))
(hash (header-to-alist))
(boundary (kamail-boundary-string))
(number kamail-number)
start
ref id to to-name osubject subject date from ng group cc oto occ)
(and (kamail-mail-status-forwarded)
(kamail-summary-status-forwarded))
(kamail-create-draft-buffer)
(switch-to-buffer *kamail-buffer-draft*)
(setq kamail-draft-reply-header hash)
(multiple-value-setq (osubject id from oto occ date ref ng)
(kamail-draft-header-values hash))
(setq to (kamail-draft-ask-to))
(setq to-name (get-header-value to *kamail-address-alist*))
(when to-name
(setq to (format nil "~A <~A>" to-name to))
)
(setq subject (concat "Fw: " osubject))
(kamail-draft-format-header (kamail-draft-select-from)
to cc subject ng nil ref)
(insert (or *kamail-draft-new-string* "\n"))
(when *kamail-signature-auto-insert*
(kamail-insert-signature))
; (kamail-change-header-multipart boundary)
; (kamail-change-body-multipart boundary)
(kamail-cite-body nil
(buffer-name buffer))
(kamail-forward-attachments)
; 最初のパートを探す
(goto-char (point-min))
(when (scan-buffer (format nil "^--~A$" boundary)
:regexp t :tail t)
(if (scan-buffer (format nil "^--~A$" boundary)
:regexp t :tail nil)
(forward-line -2)
(while (forward-line 1)
(and (eolp) (return)))))
(kamail-draft-refresh)
(run-hooks '*kamail-prepare-draft-hook*)
))
(defun kamail-forward-attachments ()
#|
(let ((end-reg (format nil "^--~A--$" boundary)))
(save-excursion
(goto-char (point-min))
(unless (scan-buffer end-reg :regexp t :tail nil)
(error "Multipartの終わりがないっす: ~A" end-reg))
(insert (format nil "--~A~%" boundary))
(insert (format nil "Content-Type: message/rfc822~%"))
(insert (format nil "~%"))
; 再度メッセージを取得
(kamail-account-select-folder *kamail-folder-current*)
(kamail-get-message number))
|#
(save-excursion
(set-buffer *kamail-buffer-multipart*)
(kamail-save-attach-all)))
(defun kamail-attach-files (files)
(progn
;(delete-buffer *kamail-buffer-multipart*)
(switch-to-buffer *kamail-buffer-draft*)
(setq files (mapcar #'(lambda (x)
(list x)) files))
(kamail-add-attachments files)
(while (not (endp files))
(delete-file (car (pop files))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-decode-mime-header ()
(save-excursion
(while (or (looking-for ">From ")
(looking-for *kamail-status-header-field*))
(or (forward-line 1) (return)))
;;;;added by chen to decode Chinese characters
(let ((beg (point)))
(save-excursion
(when
(scan-buffer "\\(^[sS]ubject: \\|^[tT]o: \\|^[cC]c: \\|^[bB]cc: \\)\\(=\\?\\)[gG][bB][^\\?]*\\(\\?\\)"
:regexp t :case-fold t
:tail t)
(replace-match "\\1\\2gb2312\\3"))))
(let ((beg (point-min)))
(save-excursion
;;(goto-char beg)
(when
(scan-buffer "\\(^content-type: .+\\)\\(\n[ \t]+\\)*\\(.*charset.*=.*\\)[gG][bB]\\w*"
:regexp t :case-fold t
:tail t)
(replace-match "\\1\\3gb2312"))))
;;;end
(let ((beg (point)))
(save-excursion
(when (scan-buffer "^X-Mailer :"
:regexp t
:tail t)
(delete-region (- (point) 2) (- (point) 1)))))
(decode-mime-header)))
;;;added by chen;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-save-attach-all ()
; (interactive)
(progn ;;;;;save-excursion
(setq attachments nil)
(goto-char (point-min))
(while (kamail-multipart-next-part nil)
(refresh-screen)
(kamail-save-attach-this-part))
(kamail-attach-files attachments)))
(defun kamail-save-attach-this-part ()
(let ((part (kamail-multipart-this)))
(when part
(let ((header (kamail-multipart-header part))
(start (kamail-multipart-start part))
(stop (kamail-multipart-stop part))
type
enc
charset
disp
file
savename
;;;attach
)
(multiple-value-setq (type enc charset disp file)
(kamail-get-part-header header))
(when file
;(return nil))
(setq savename (concat *kamail-attach-save-directory* file))
(when savename
(setq *kamail-attach-save-directory*
(directory-namestring savename))
(setq enc (or enc ""))
(save-excursion
(set-buffer *kamail-buffer-view*)
(cond ((string-matchp "base64" enc)
(and
(base64-decode-region-to-file savename start stop)
(message "Saved: ~A" savename)
)
)
((string-matchp "uuencode" enc)
(let (begin endin)
(goto-char start)
(when (scan-buffer "^begin" :regexp t :tail nil)
(forward-line 1)
(setq begin (point))
(when (and (scan-buffer "^end" :regexp t :tail nil)
(<= (point) stop))
(setq endin (point)))
)
(if (and begin endin)
(and
(uudecode-region-to-file savename begin endin)
(message "Saved: ~A" savename)
)
(message-box "Could not find \"begin\" or \"end\" for uudecode")
)
))
((string-matchp "quoted-printable" enc)
(and
(quoted-printable-decode-region-to-file savename start stop)
(message "Saved: ~A" savename)
)
)
((or (string-matchp "binhex" type)
(string-matchp "binhex" enc))
(let (begin)
(goto-char start)
(when (scan-buffer "^:" :regexp t :tail nil)
(setq begin (point))
(when (scan-buffer ":$" :regexp t :tail t)
(binhex-decode-region-to-file savename begin (point))
(message "Saved: ~A" savename))
)))
(t
(and
(kamail-write-selected-buffer savename start stop)
(message "Saved: ~A" savename)
)
)
);cond
)
)
(push savename attachments))))))
; (kamail-attach-file savename)
; ))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-create-send-buffer ()
(interactive)
(goto-char (point-min))
; from den8view.l
(when (re-search-forward "[\xa0-\xdf\X8540-\X889e\Xeb40-\Xffff]+" t)
(ed::show-match)
(msgbox "送信しちゃまずい文字発見")) ;;changed by chen according to info on the net (error "送信しちゃまずい文字発見"))
(let ((attach kamail-draft-attach-alist))
(kamail-send-buffer-create)
(kamail-send-mode)
(insert-buffer *kamail-buffer-draft*)
(goto-char (point-min))
(kamail-header-date-update)
(kamail-encode-message)
(when attach
(kamail-change-to-multipart attach))
(set-buffer-modified-p nil)
(run-hooks '*kamail-create-send-buffer-hook*)))
(defun kamail-list-mail ()
(interactive)
(when (and (stringp kamail-summary-folder)
(string= kamail-summary-folder *kamail-folder-current*))
(return-from kamail-list-mail nil)
)
(kamail-summary-mode)
(let (headers
(buffer-read-only nil)
(type (kamail-folder-type)))
(declare (special buffer-read-only))
(erase-buffer (selected-buffer))
(when *kamail-close-other-connection*
(kamail-close-other t))
(cond ((not (characterp type))
(error "できまへん: ~S" *kamail-folder-current*))
((char= type *kamail-folder-imap-char*);IMAP
(setq headers (kamail-imap-mail-list)))
((char= type *kamail-folder-news-char*);NEWS
(setq headers (kamail-news-list)))
((char= type *kamail-folder-pop3-char*);POP3
(setq headers (kamail-pop3-list)))
((char= type *kamail-folder-local-char*);LOCAL
(setq headers (kamail-local-list *kamail-folder-current*)))
((char= type *kamail-folder-spool-char*);SPOOL
(setq headers (kamail-spool-list *kamail-folder-current*)))
((char= type *kamail-folder-archive-char*);ARCHIVE
(setq headers (kamail-archive-list *kamail-folder-current*)))
(t
(error "まだできません: ~S" *kamail-folder-current*))
)
(setq kamail-headers (kamail-summary-parse-headers-date headers))
;(setq kamail-headers headers)
;;;modified by chen
;(kamail-list-refresh t)
(kamail-list-refresh t 'kamail-sortfunc-by-date-reverse)
;;;chen
(setq kamail-summary-folder *kamail-folder-current*)
(set-buffer-modified-p nil)
(when *kamail-summary-open-unread*
(kamail-next-new))
(run-hooks '*kamail-list-mail-hook*)
))
(define-key *kamail-view-map* '(#\C-c #\f) 'kamail-prepare-forward-with-attachment)
Emacs-like text editor, xyzzy, created by a Japanese.
And based on this editor, another Japanese wrote a mailer called KaMail.
This mail soft is not so completed and I made some improvements.
我想本篇只是面向日本的读者。因为一个日本人制作了一个非常好的
文本编辑器，xyzzy。在此基础上另外一个人写了一个邮件软件，Kamail。
但是此软件还不是很完善，我觉得别扭的地方改写了一下。
日本にはファンが多いと思いますが、亀井さん作のテキストエディターｘｙｚｚyに、
KaMail（服部さん作）というメールソフトが組み込まれています。
ただし、不完全なところがあり、私なりに修正を入れて使っています。
以下は、あくまでもメモになります。
(defun kamail-cite-body (&optional prefix buffer)
"本文を挿入する"
(interactive "p")
(setq buffer (or buffer (kamail-draft-old-buffer)))
(unless (find-buffer buffer)
(return-from kamail-cite-body))
(save-excursion
(with-input-from-buffer (buffer)
(let (line)
(while (setq line (read-line nil nil))
(when (string= line "")
(return)))
(while (setq line (read-line nil nil))
;;;added by chen
(unless (string-matchp "^\[[0-9-]+: \\(.+ \\)*<.+/.+> *\\(\[.+\]\\|\(.+\)\\|.+\\)* *\]$" line)
;;;chen
(insert (format nil "~@[~A~]~A~%"
prefix
line))))
)))
(when (interactive-p)
(kamail-color-mail))
)
(defun kamail-prepare-forward-with-attachment ()
(interactive)
(let ((buffer (selected-buffer))
(hash (header-to-alist))
(boundary (kamail-boundary-string))
(number kamail-number)
start
ref id to to-name osubject subject date from ng group cc oto occ)
(and (kamail-mail-status-forwarded)
(kamail-summary-status-forwarded))
(kamail-create-draft-buffer)
(switch-to-buffer *kamail-buffer-draft*)
(setq kamail-draft-reply-header hash)
(multiple-value-setq (osubject id from oto occ date ref ng)
(kamail-draft-header-values hash))
(setq to (kamail-draft-ask-to))
(setq to-name (get-header-value to *kamail-address-alist*))
(when to-name
(setq to (format nil "~A <~A>" to-name to))
)
(setq subject (concat "Fw: " osubject))
(kamail-draft-format-header (kamail-draft-select-from)
to cc subject ng nil ref)
(insert (or *kamail-draft-new-string* "\n"))
(when *kamail-signature-auto-insert*
(kamail-insert-signature))
; (kamail-change-header-multipart boundary)
; (kamail-change-body-multipart boundary)
(kamail-cite-body nil
(buffer-name buffer))
(kamail-forward-attachments)
; 最初のパートを探す
(goto-char (point-min))
(when (scan-buffer (format nil "^--~A$" boundary)
:regexp t :tail t)
(if (scan-buffer (format nil "^--~A$" boundary)
:regexp t :tail nil)
(forward-line -2)
(while (forward-line 1)
(and (eolp) (return)))))
(kamail-draft-refresh)
(run-hooks '*kamail-prepare-draft-hook*)
))
(defun kamail-forward-attachments ()
#|
(let ((end-reg (format nil "^--~A--$" boundary)))
(save-excursion
(goto-char (point-min))
(unless (scan-buffer end-reg :regexp t :tail nil)
(error "Multipartの終わりがないっす: ~A" end-reg))
(insert (format nil "--~A~%" boundary))
(insert (format nil "Content-Type: message/rfc822~%"))
(insert (format nil "~%"))
; 再度メッセージを取得
(kamail-account-select-folder *kamail-folder-current*)
(kamail-get-message number))
|#
(save-excursion
(set-buffer *kamail-buffer-multipart*)
(kamail-save-attach-all)))
(defun kamail-attach-files (files)
(progn
;(delete-buffer *kamail-buffer-multipart*)
(switch-to-buffer *kamail-buffer-draft*)
(setq files (mapcar #'(lambda (x)
(list x)) files))
(kamail-add-attachments files)
(while (not (endp files))
(delete-file (car (pop files))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-decode-mime-header ()
(save-excursion
(while (or (looking-for ">From ")
(looking-for *kamail-status-header-field*))
(or (forward-line 1) (return)))
;;;;added by chen to decode Chinese characters
(let ((beg (point)))
(save-excursion
(when
(scan-buffer "\\(^[sS]ubject: \\|^[tT]o: \\|^[cC]c: \\|^[bB]cc: \\)\\(=\\?\\)[gG][bB][^\\?]*\\(\\?\\)"
:regexp t :case-fold t
:tail t)
(replace-match "\\1\\2gb2312\\3"))))
(let ((beg (point-min)))
(save-excursion
;;(goto-char beg)
(when
(scan-buffer "\\(^content-type: .+\\)\\(\n[ \t]+\\)*\\(.*charset.*=.*\\)[gG][bB]\\w*"
:regexp t :case-fold t
:tail t)
(replace-match "\\1\\3gb2312"))))
;;;end
(let ((beg (point)))
(save-excursion
(when (scan-buffer "^X-Mailer :"
:regexp t
:tail t)
(delete-region (- (point) 2) (- (point) 1)))))
(decode-mime-header)))
;;;added by chen;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-save-attach-all ()
; (interactive)
(progn ;;;;;save-excursion
(setq attachments nil)
(goto-char (point-min))
(while (kamail-multipart-next-part nil)
(refresh-screen)
(kamail-save-attach-this-part))
(kamail-attach-files attachments)))
(defun kamail-save-attach-this-part ()
(let ((part (kamail-multipart-this)))
(when part
(let ((header (kamail-multipart-header part))
(start (kamail-multipart-start part))
(stop (kamail-multipart-stop part))
type
enc
charset
disp
file
savename
;;;attach
)
(multiple-value-setq (type enc charset disp file)
(kamail-get-part-header header))
(when file
;(return nil))
(setq savename (concat *kamail-attach-save-directory* file))
(when savename
(setq *kamail-attach-save-directory*
(directory-namestring savename))
(setq enc (or enc ""))
(save-excursion
(set-buffer *kamail-buffer-view*)
(cond ((string-matchp "base64" enc)
(and
(base64-decode-region-to-file savename start stop)
(message "Saved: ~A" savename)
)
)
((string-matchp "uuencode" enc)
(let (begin endin)
(goto-char start)
(when (scan-buffer "^begin" :regexp t :tail nil)
(forward-line 1)
(setq begin (point))
(when (and (scan-buffer "^end" :regexp t :tail nil)
(<= (point) stop))
(setq endin (point)))
)
(if (and begin endin)
(and
(uudecode-region-to-file savename begin endin)
(message "Saved: ~A" savename)
)
(message-box "Could not find \"begin\" or \"end\" for uudecode")
)
))
((string-matchp "quoted-printable" enc)
(and
(quoted-printable-decode-region-to-file savename start stop)
(message "Saved: ~A" savename)
)
)
((or (string-matchp "binhex" type)
(string-matchp "binhex" enc))
(let (begin)
(goto-char start)
(when (scan-buffer "^:" :regexp t :tail nil)
(setq begin (point))
(when (scan-buffer ":$" :regexp t :tail t)
(binhex-decode-region-to-file savename begin (point))
(message "Saved: ~A" savename))
)))
(t
(and
(kamail-write-selected-buffer savename start stop)
(message "Saved: ~A" savename)
)
)
);cond
)
)
(push savename attachments))))))
; (kamail-attach-file savename)
; ))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-create-send-buffer ()
(interactive)
(goto-char (point-min))
; from den8view.l
(when (re-search-forward "[\xa0-\xdf\X8540-\X889e\Xeb40-\Xffff]+" t)
(ed::show-match)
(msgbox "送信しちゃまずい文字発見")) ;;changed by chen according to info on the net (error "送信しちゃまずい文字発見"))
(let ((attach kamail-draft-attach-alist))
(kamail-send-buffer-create)
(kamail-send-mode)
(insert-buffer *kamail-buffer-draft*)
(goto-char (point-min))
(kamail-header-date-update)
(kamail-encode-message)
(when attach
(kamail-change-to-multipart attach))
(set-buffer-modified-p nil)
(run-hooks '*kamail-create-send-buffer-hook*)))
(defun kamail-list-mail ()
(interactive)
(when (and (stringp kamail-summary-folder)
(string= kamail-summary-folder *kamail-folder-current*))
(return-from kamail-list-mail nil)
)
(kamail-summary-mode)
(let (headers
(buffer-read-only nil)
(type (kamail-folder-type)))
(declare (special buffer-read-only))
(erase-buffer (selected-buffer))
(when *kamail-close-other-connection*
(kamail-close-other t))
(cond ((not (characterp type))
(error "できまへん: ~S" *kamail-folder-current*))
((char= type *kamail-folder-imap-char*);IMAP
(setq headers (kamail-imap-mail-list)))
((char= type *kamail-folder-news-char*);NEWS
(setq headers (kamail-news-list)))
((char= type *kamail-folder-pop3-char*);POP3
(setq headers (kamail-pop3-list)))
((char= type *kamail-folder-local-char*);LOCAL
(setq headers (kamail-local-list *kamail-folder-current*)))
((char= type *kamail-folder-spool-char*);SPOOL
(setq headers (kamail-spool-list *kamail-folder-current*)))
((char= type *kamail-folder-archive-char*);ARCHIVE
(setq headers (kamail-archive-list *kamail-folder-current*)))
(t
(error "まだできません: ~S" *kamail-folder-current*))
)
(setq kamail-headers (kamail-summary-parse-headers-date headers))
;(setq kamail-headers headers)
;;;modified by chen
;(kamail-list-refresh t)
(kamail-list-refresh t 'kamail-sortfunc-by-date-reverse)
;;;chen
(setq kamail-summary-folder *kamail-folder-current*)
(set-buffer-modified-p nil)
(when *kamail-summary-open-unread*
(kamail-next-new))
(run-hooks '*kamail-list-mail-hook*)
))
(define-key *kamail-view-map* '(#\C-c #\f) 'kamail-prepare-forward-with-attachment)
Subscribe to:
Posts (Atom)