2010/10/29

Emacs Lisp : complement

述語を反転させるアレですね。(complement equal) とやると (lambda args (not (apply equal args))) が返るような高階関数です。

Scheme を書いている時によく使います。定義も簡単なので、無ければすぐ書けます。たまたま今日は Emacs Lisp で自前の関数を書いている時に complement が欲しかったので、書こうとしたらしばらくハマりました。。無ければ無いでよかったんですが、この際自前の Emacs Lisp 関数を定義したファイルに書き加えておいても良いかなと思い、書くことにしたのです。

デフォルトがダイナミックスコープである点にやられました。やはりデフォルトはレキシカルスコープでスペシャル変数や fluid-let などを用意してある方が良いなぁと思うわけです。慣れなんでしょうけどね。
(defun complement (f)
  (lexical-let ((f f))
    (lambda (&rest args)
      (not (apply f args)))))

(defun not-equal (x y)
  (funcall (complement #'equal) x y))

(funcall #'not-equal "" "a")
;; -> t

追記

検索したら素敵なページがあった!complement だけでなく fold や compose も再帰ではなく反復で定義してあるし、any, every, filter, take-while などなど Schemer 歓喜!

自分でちくちく書く必要はなかったようです。

Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

2010/10/28

gist を blog に embed する時の見た目や色(CSS) を変える

blog に gist を貼り付けることが多いです。見た目を変えたいなぁと思っていたのでやってみました。
参考にしたのはこちら。

色合いは自分の Emacs のハイライトを htmlize.el したものを参考にしてやってみました。やってみたんですが、どうにもクドイので実際にこのまま使うか迷っています。
こんな感じ。
;; fold-right
(display
(fold-right (lambda (e acc)
(let ((p (compose zero? (cut modulo e <>))))
(cons (cond ((p 15) "fizzbuzz")
((p 5) "buzz")
((p 3) "fizz")
(else e)) acc)))
'() (iota 100 1)))
view raw temp.scm hosted with ❤ by GitHub


css

用意した css は以下のものです。

余談ですが

Emacs では color-theme.el の midnight を少し変更したものを使っています。
;; color theme
(require 'color-theme nil t)
(color-theme-initialize)
(color-theme-midnight)
(set-face-background 'region "blue4")
(set-face-background 'trailing-whitespace "purple4")
(set-face-background 'modeline-buffer-id "grey5")
(set-face-foreground 'modeline-buffer-id "maroon2")
(set-face-background 'mode-line "grey20")
(set-face-foreground 'mode-line "grey75")
(set-face-background 'mode-line-inactive "grey3")
(set-face-foreground 'mode-line-inactive "grey35")
(set-face-background 'secondary-selection "red")
(set-face-underline-p 'modeline nil)
(custom-set-faces
 '(font-lock-comment-face ((t (:italic nil :foreground "slate gray")))))

Scheme のハイライトは quack.el の pltish を少し変更しています。
;; quack
(custom-set-faces
 '(quack-pltish-keyword-face ((t (:bold t :foreground "maroon2"))))
 '(quack-pltish-defn-face ((t (:bold t :foreground "darkgoldenrod3"))))
 '(quack-threesemi-semi-face ((t (:bold t :foreground "blue"))))
 '(quack-threesemi-text-face ((t (:bold t :foreground "blue")))))

追記

gist のハイライトの変更は止めました。




Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

2010/10/22

vector-iota

(vector-iota 10)
;; #(0 1 2 3 4 5 6 7 8 9)
(vector-iota 10 10)
;; #(10 11 12 13 14 15 16 17 18 19)
(vector-iota 10 0 2)
;; #(0 2 4 6 8 10 12 14 16 18)

(use srfi-43)
(define (vector-iota count :optional (start 0)(step 1))
(vector-unfold
(lambda (i x)
(values (+ (* i step) x) x)) count start))
view raw vector-iota.scm hosted with ❤ by GitHub


追記

@valvallow (use srfi-42)(define (vector-iota c :optional(b 0)(s 1))(vector-ec(: x b (+ b(* s c))s)x)) 内包表記ってドキュメントがよくわかんないですよね。
(use srfi-42)

(define (vector-iota c :optional(b 0)(s 1))
  (vector-ec (: x b (+ b (* s c)) s) x))

(vector-iota 10 1 3)
;; #(1 4 7 10 13 16 19 22 25 28)
内包表記、使いこなせねぇー!

プログラミングGauche

2010/10/20

熊本 #Emacs 的何か #Ekumacs !

正式アナウンスです。熊本でEmacsにまつわる何かをする会を企画しています。興味のある方はリプライください。ハッシュタグは #ekumacs にしようと思います。

技術系の勉強会や集まりがあまりなかった熊本でもいろいろ始まってきましたね!良いことだ!やったー!
私が知っている限りではこの辺りですが、Android に Ruby に Lisp に、今回 Emacs と・・・。結構とんがってるね熊本!

追記


Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

2010/10/15

Scheme で数独を解く

明日で 25 回目となる 9LISP(もはや言語は Lisp に限らない、という状態ですが(笑))の宿題が、「数独を解くプログラム」なのでやってみました。Scheme (Gauche)で書きました。

まず数独を良く知らなかったのでそこから。

簡単な問題を解いてみるとこんな具合。
(define test-data-1
  '((7 8 0 5 2 0 0 0 6)
    (9 0 0 0 0 3 0 7 5)
    (0 0 5 0 0 6 0 4 0)
    (0 0 4 0 6 1 3 0 2)
    (1 0 0 9 0 0 0 0 7)
    (8 0 2 0 7 0 6 0 0)
    (0 5 0 2 0 0 8 0 0)
    (6 3 0 4 0 0 0 0 1)
    (2 0 0 0 3 7 0 5 9)))

(define test-data-1-ans
  '((7 8 1 5 2 4 9 3 6)
    (9 4 6 1 8 3 2 7 5)
    (3 2 5 7 9 6 1 4 8)
    (5 7 4 8 6 1 3 9 2)
    (1 6 3 9 4 2 5 8 7)
    (8 9 2 3 7 5 6 1 4)
    (4 5 7 2 1 9 8 6 3)
    (6 3 9 4 5 8 7 2 1)
    (2 1 8 6 3 7 4 5 9)))

(define test-data-2
  '((0 0 7 0 4 0 0 0 0)
    (0 3 0 9 1 0 6 2 0)
    (0 0 0 7 0 0 3 8 4)
    (2 4 9 0 7 1 5 3 6)
    (1 5 0 0 0 0 0 7 8)
    (0 0 8 5 0 0 0 9 1)
    (0 9 2 0 8 4 7 5 3)
    (0 8 0 6 0 2 1 4 9)
    (5 1 4 3 0 0 0 6 2)))

(define test-data-2-ans
  '((8 6 7 2 4 3 9 1 5)
    (4 3 5 9 1 8 6 2 7)
    (9 2 1 7 6 5 3 8 4)
    (2 4 9 8 7 1 5 3 6)
    (1 5 6 4 3 9 2 7 8)
    (3 7 8 5 2 6 4 9 1)
    (6 9 2 1 8 4 7 5 3)
    (7 8 3 6 5 2 1 4 9)
    (5 1 4 3 9 7 8 6 2)))

(time (equal? (backtrack-solver test-data-1)
              test-data-1-ans))
; real   0.109
; user   0.094
; sys    0.000
;; #t

(time (equal? (backtrack-solver test-data-2)
              test-data-2-ans))
; real   0.172
; user   0.125
; sys    0.015
;; #t
とても遅いですね。。

バックトラックで解く方の実装がだいぶ残念な感じですが、一応「数学のエキスパートが3ヶ月かけて作成した「世界一難しい数独」 - GIGAZINE」も解けました。遅いですが。
(define most-difficult-data
  '((0 0 5 3 0 0 0 0 0)
    (8 0 0 0 0 0 0 2 0)
    (0 7 0 0 1 0 5 0 0)
    (4 0 0 0 0 5 3 0 0)
    (0 1 0 0 7 0 0 0 6)
    (0 0 3 2 0 0 0 8 0)
    (0 6 0 5 0 0 0 0 9)
    (0 0 4 0 0 0 0 3 0)
    (0 0 0 0 0 9 7 0 0)))

(define most-difficult-data-ans
  '((1 4 5 3 2 7 6 9 8)
    (8 3 9 6 5 4 1 2 7)
    (6 7 2 9 1 8 5 4 3)
    (4 9 6 1 8 5 3 7 2)
    (2 1 8 4 7 3 9 5 6)
    (7 5 3 2 9 6 4 8 1)
    (3 6 7 5 4 2 8 1 9)
    (9 8 4 7 6 1 2 3 5)
    (5 2 1 8 3 9 7 6 4)))

(time (equal? (backtrack-solver most-difficult-data)
              most-difficult-data-ans))
; real  15.438
; user  15.375
; sys    0.047
;; #t

amb とか cps を使ってできそうな気がしたので、四苦八苦しながらやってみましたが、結局できずこの有様・・・。明日の 9LISP が終わってからまた改めて考えてみます。


ということで、とりあえずさらしておきます。
全景はこんな感じ。
(use srfi-1) ; drop, split-at
(use srfi-9) ; define-record-type
(use util.list) ; slices
(use liv.matrix) ; matrix-*, *-matrix

(define-constant region-size 3)
(define-constant fullset-numbers (iota (* region-size region-size) 1))

(define (single? ls)
  (and (pair? ls)
       (null? (cdr ls))))

;; matrix x or y -> region position
(define (region-pos mn)
  (quotient mn region-size))

;; mmatrix x and y -> region index
(define (region-index mx my)
  (+ (region-pos mx)
     (* region-size
        (region-pos my))))

(define (region-ref region n)
  (list-ref region n))

(define (slice-matrix-rows matrix size)
  (map (lambda (row)
         (slices row size)) matrix))

(define (matrix->regions matrix size)
  (let1 sliced (slice-matrix-rows matrix size)
    (let rec ((m sliced)(acc '()))
      (if (null? m)
          (apply append (reverse acc))
          (receive (took dropped)(split-at m size)
            (rec dropped (cons (apply map append took) acc)))))))

(define (candidates matrix x y . keywords)
  (let-keywords* keywords ((eq? =)
                           (empty? zero?)
                           (ignore '()))
    (let1 f (pa$ filter (complement empty?))
      (let* ((row-candidates (f (matrix-row-ref matrix y)))
             (col-candidates (f (matrix-col-ref matrix x)))
             (region-candidates (f (region-ref (matrix->regions matrix region-size)
                                               (region-index x y)))))
        (lset-difference eq? fullset-numbers row-candidates
                         col-candidates region-candidates
                         ignore)))))

(define (has-empty? matrix :optional (empty? zero?))
  (let/cc hop
    (fold (lambda (row acc)
            (if-let1 it (any empty? row)
                     (hop it)
                     acc)) #f matrix)))

;;
;; naked single solve
;;

(define (fix-naked-singles matrix . keywords)
  (let-keywords* keywords ((empty? zero?)
                           (car car))
    (let1 exist? #f
        (values (map-matrix-with-index
                 (lambda (e x y)
                   (if (empty? e)
                       (let1 can (candidates matrix x y)
                         (if (single? can)
                             (begin
                               (unless exist?
                                 (set! exist? (not exist?)))
                               (car can))
                             e))
                       e)) matrix)
                exist?))))

(define (fix-naked-singles-solver matrix
                                  :optional (more identity))
  (let rec ((m matrix))
    (receive (cand exist?)(fix-naked-singles m)
      (cond (exist? (rec cand))
            ((has-empty? cand)(more cand))
            (else cand)))))

;;
;; backtrack solver
;;

(define-record-type point
  (make-point x y) point?
  (x point-x)
  (y point-y))

(define (backtrack-solver matrix)
  (let/cc hop
    (let ((mstack '())(cstack '())(pstack '())(count 0))
      (let backtrack ((m (matrix-copy matrix))(bt-cand '())
                      (bt-point (make-point -1 -1)))
        (for-each-matrix-with-index
         (lambda (e x y)
           (when (zero? e)
             (let1 cand (if (and (= x (point-x bt-point))
                                 (= y (point-y bt-point)))
                            bt-cand
                            (candidates m x y))
               (cond ((null? cand)
                      (inc! count)
                      (backtrack (pop! mstack)
                                 (pop! cstack)
                                 (pop! pstack)))
                     ((single? cand)
                      (matrix-set! m x y (car cand)))
                     (else
                      (push! mstack (matrix-copy m))
                      (push! cstack (cdr cand))
                      (push! pstack (make-point x y))
                      (matrix-set! m x y (car cand))))))) m)
        (hop m count)))))

追記

@aharisu さんが scheme で書いたものは、私が書いたものと比べて 3 ~ 7 倍高速でした!

追記2

@kikuchan98 さんによる実装。短くて美しくて速い!流石っす。amb 使ってあります。しかもこれが scheme で書いた初めてのコードらしいです・・・。

プログラミングGauche

2010/10/14

ちょっと考えてみたけど、やっぱボツだった accum

これを読んで、以前再帰とか S 式に慣れるために何度も書いたことを思い出しました。
SICPThe Little Schemer にも登場しますね。

とりあえず、Scheme で改めて書いてみました。
(define (collatz n)
(let rec ((n n)(acc `(,n)))
(if (<= n 1)
acc
(let1 r (if (even? n)
(/ n 2)
(+ 1 (* 3 n)))
(rec r (cons r acc))))))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)
view raw collatz.scm hosted with ❤ by GitHub

Common Lisp だと、こうでしょうか。
(defun collatz (n)
(labels ((rec (n acc)
(if (<= n 1)
acc
(let ((r (if (evenp n)
(/ n 2)
(+ 1 (* 3 n)))))
(rec r (cons r acc))))))
(rec n (list n))))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325
;; 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734
;; 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276
;; 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186
;; 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121
;; 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)
view raw collatz.lisp hosted with ❤ by GitHub

或いはこう?(仕様を満たせていませんね・・・)
(defun collatz (n)
(loop
with x = n
while (/= x 1)
if (evenp x)
do (setf x (/ x 2))
else
do (setf x (+ 1 (* 3 x)))
end
collect x))


書いているうちに、こういうのがあったら良いんじゃないかなぁ、と思いました。
(hoge pred calc acc dec i) ==
(if (pred i)
    acc
    (hoge pred calc (calc i acc) dec (dec i)))

パッと見 unfold に似てるので、unfold で無理やり書いてみました。
(use srfi-1)
(define (collatz n)
(unfold (lambda (ls)
(<= (car ls) 1))
car
(lambda (ls)
(let1 a (car ls)
(cons (if (even? a)
(/ a 2)
(+ 1 (* 3 a))) ls)))
(list n)
(lambda _
(list 1))))
(collatz 27)
;; (27 82 41 124 62 31 94 47 142 71 214 107 322 161 484 242 121 364 182 91 274 137 412 206 103 310 155 466 233 700 350 175 526 263 790 395 1186 593 1780 890 445 1336 668 334 167 502 251 754 377 1132 566 283 850 425 1276 638 319 958 479 1438 719 2158 1079 3238 1619 4858 2429 7288 3644 1822 911 2734 1367 4102 2051 6154 3077 9232 4616 2308 1154 577 1732 866 433 1300 650 325 976 488 244 122 61 184 92 46 23 70 35 106 53 160 80 40 20 10 5 16 8 4 2 1)

やはり unfold では強引な気がしたので試しに accum というのを定義してみました。
;; (hoge pred calc acc dec i) ==
;; (if (pred i)
;; acc
;; (hoge pred calc (calc i acc) dec (dec i)))
(define (accum pred proc seed . keywords)
(let-keywords* keywords ((terminal-fun identity)
(cons cons)
(acc-init '()))
(let rec ((seed seed)(acc acc-init))
(if (pred seed)
(terminal-fun acc)
(let1 r (proc seed)
(rec r (cons r acc)))))))
(define (collatz n)
(accum (pa$ = 1)
(lambda (n)
(if (even? n)
(/ n 2)
(+ 1 (* 3 n))))
n
:acc-init (list n)))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)

試しに fizzbuzz を書いてみたり。
(define (fizzbuzz n)
(accum (pa$ >= 1)
(cut - <> 1)
n
:cons (lambda (n acc)
(let1 mul? (compose zero? (pa$ remainder n))
(cons (cond ((mul? 15) "fizzbuzz")
((mul? 5) "buzz")
((mul? 3) "fizz")
(else n))
acc)))))
(print (fizzbuzz 100))
;; (1 2 fizz 4 buzz fizz 7 8 fizz buzz 11 fizz 13 14 fizzbuzz 16 17 fizz 19 buzz fizz 22 23 fizz buzz 26 fizz 28 29 fizzbuzz 31 32 fizz 34 buzz fizz 37 38 fizz buzz 41 fizz 43 44 fizzbuzz 46 47 fizz 49 buzz fizz 52 53 fizz buzz 56 fizz 58 59 fizzbuzz 61 62 fizz 64 buzz fizz 67 68 fizz buzz 71 fizz 73 74 fizzbuzz 76 77 fizz 79 buzz fizz 82 83 fizz buzz 86 fizz 88 89 fizzbuzz 91 92 fizz 94 buzz fizz 97 98 fizz)
(use srfi-1)
(fold-right (lambda (e acc)
(let ((p (compose zero? (cut modulo e <>))))
(cons (cond ((p 15) "fizzbuzz")
((p 5) "buzz")
((p 3) "fizz")
(else e)) acc)))
'() (iota 100 1))
view raw fizzbuzz.scm hosted with ❤ by GitHub

いまいち。ちょっと変更。
(define (accum pred proc seed . keywords)
(let-keywords* keywords ((terminal-fun identity)
(cons cons)
(acc-init '()))
(let rec ((seed seed)(acc acc-init))
(if (pred seed)
(terminal-fun acc)
(rec (proc seed)(cons seed acc))))))
(define (collatz n)
(accum (pa$ = 1)
(lambda (n)
(if (even? n)
(/ n 2)
(+ 1 (* 3 n))))
n
:terminal-fun (pa$ cons 1)))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)
(define (fizzbuzz n)
(accum zero?
(cut - <> 1)
n
:cons (lambda (n acc)
(let1 mul? (compose zero? (pa$ remainder n))
(cons (cond ((mul? 15) "fizzbuzz")
((mul? 5) "buzz")
((mul? 3) "fizz")
(else n))
acc)))))
(print (fizzbuzz 100))
;; (1 2 fizz 4 buzz fizz 7 8 fizz buzz 11 fizz 13 14 fizzbuzz 16 17 fizz 19 buzz fizz 22 23 fizz buzz 26 fizz 28 29 fizzbuzz 31 32 fizz 34 buzz fizz 37 38 fizz buzz 41 fizz 43 44 fizzbuzz 46 47 fizz 49 buzz fizz 52 53 fizz buzz 56 fizz 58 59 fizzbuzz 61 62 fizz 64 buzz fizz 67 68 fizz buzz 71 fizz 73 74 fizzbuzz 76 77 fizz 79 buzz fizz 82 83 fizz buzz 86 fizz 88 89 fizzbuzz 91 92 fizz 94 buzz fizz 97 98 fizz buzz)

それでもいまいち。きっともっとちゃんと抽象化されたものがどこかにあるはず。。

追記

調べたら、ちょっと前に unfold で書いてた。今日書いたものより、こっちの方が良い・・・。
(use srfi-1)
(define (collatz n)
(unfold (lambda (s)
(= s 1))
(lambda (s)
s)
(lambda (s)
(cond ((even? s)(/ s 2))
((odd? s)(+ (* s 3) 1))
(else s)))
n
(lambda (s)
(cons s '()))))
(collatz 10)
; -> (10 5 16 8 4 2 1)


Scheme手習い

Common Lisp の loop マクロ

難しい。すごく柔軟で便利だと聞くけど、個人的な印象では融通が効かないなぁと感じている次第です。きっと慣れないせいなんだきっと。。
やっぱ named let でいいじゃん・・・。と思ってしまいます。再帰かわいいよ再帰。
その点、Common Lisp はほとんどの処理系が末尾呼び出し最適化をしてくれるらしいので良いとして、Emacs Lisp てめぇは(ry


実践Common Lisp

2010/10/12

Emacs Lisp: intersperse

まぁ、こうやって自前で用意しなくてもあるんでしょうが・・・。
(defun single? (ls)
  (and (not (null ls))
       (null (cdr ls))))

(defun intersperse (item ls)
  (pair-fold1 #'(lambda (pr acc)
                  (if (single? pr)
                      (cons (car pr) acc)
                      (cons item (cons (car pr) acc))))
              '() (reverse ls)))
ELISP> (intersperse " " '(1 2 3))
(1 " " 2 " " 3)

Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

Emacs Lisp: fold に続いて pair-fold

ちょっと強引ですが。。
(defun pair-fold1 (proc seed ls)
  (loop
     for e on ls by #'cdr
     for acc = (funcall proc ls seed)
     then (funcall proc e acc)
     finally (return acc)))

Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

Emacs Lisp の cl package には loop マクロがあるので、取りあえず fold もどきを定義

loop マクロに慣れないので、取りあえずその場しのぎ的に fold を。。
(defun fold1 (proc seed ls)
  (loop for e in ls
     for acc = seed then (funcall proc e acc)
     finally (return acc)))

そういえば、先日知ったんですが、M-x ielm で Emacs Lisp の REPL が立ち上がるみたいですね。
ELISP> (fold1 #'* 1 '(1 2 3 4 5))
120
ELISP> (fold1 #'cons '() '(1 2 3 4 5))
(5 4 3 2)

あと unfold と pair-fold 辺りを用意しとけばある程度困らないかも・・・?

Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

2010/10/08

JavaScript の継続(continuation)によるループ

ちょっと試してみました。JavaScript の処理系は Rhino(Rhino 1.7 release 2 2009 03 22) です。

Continuation を使って sum を定義してみました。
function callcc (f){
  return f(new Continuation());
}

function identity (x){
  return x;
}

function sum (n){
  var i = 0;
  var total  = 0;
  var hop = new Continuation();
  var next = callcc(identity);

  if (n < i){
    hop(total);
  } else {
    total += i;
    ++i;
    next(next);
  }
}

sum(10);
// -> 55

loop 関数にしてみました。loop 関数を使って sum と fact を定義してみました。期待通りに動いているようです。
function loop (func){
  var hop = new Continuation();
  var next = callcc(identity);
  func(hop);
  next(next);
}

function fact (i) {
  var acc = 1;
  return loop (function (hop){
                 if (i === 0){
                   hop(acc);
                 } else {
                   acc *= i--;
                 }
               });
}

fact(10);
// 3628800

function sum (i) {
  var acc = 0;
  return loop (function (hop) {
                 if (i === 0){
                   hop(acc);
                 } else {
                   acc += i--;
                 }
               });
}

sum(10);
// 55

accum を定義。
function accum (i, pred, afunc, ifunc, seed){
  var acc = seed;
  return loop (function (hop){
                 if (pred(i)) {
                   hop(acc);
                 } else {
                   acc = afunc(i, acc);
                   i = ifunc(i);
                 }});
}

function zerop (i){
  return i === 0;
}

function dec (i){
  return --i;
}

function mul (x, y){
  return x * y;
}

function plus (x, y){
  return x + y;
}

function sum (i){
  return accum (i, zerop, plus, dec, 0);
}

function fact (i){
  return accum(i, zerop, mul, dec, 1);
}

sum(10);
// -> 55
fact(10);
// -> 3628800


while を使えば良い話なんですけどね。

JavaScript 第5版

2010/10/06

新しい「Scheme手習い」amazonに並んだっぽい!

Scheme手習い


絶版になった旧版の方、高けぇ(笑)表紙はどんなのだったんだろう。

追記


原書はこちら。
The Little Schemer, 4th Edition

Emacs で JavaScript (js2.el, js-comint.el)


掲題の設定をさらしておこうかと。雑な設定ですけども。。実際の画面は上の画像の通りです。

参考にしたのはこちら。
ポイントは js2-mode-hook に以下の一行を加えていることくらいでしょうか。
(local-set-key "\C-c\C-r" 'js-send-region)
region を js の repl に送るコマンドです。

(require 'js-comint)
(setq inferior-js-program-command "java org.mozilla.javascript.tools.shell.Main")
(add-hook 'js2-mode-hook '(lambda ()
                            (local-set-key "\C-x\C-e" 'js-send-last-sexp)
                            (local-set-key "\C-\M-x" 'js-send-last-sexp-and-go)
                            (local-set-key "\C-cb" 'js-send-buffer)
                            (local-set-key "\C-c\C-b" 'js-send-buffer-and-go)
                            (local-set-key "\C-cl" 'js-load-file-and-go)
                            (local-set-key "\C-c\C-r" 'js-send-region)
                            ))

(when (load "js2" t)
  (setq js2-cleanup-whitespace nil
        js2-mirror-mode nil
        js2-bounce-indent-flag nil)
  (defun indent-and-back-to-indentation ()
    (interactive)
    (indent-for-tab-command)
    (let ((point-of-indentation
           (save-excursion
             (back-to-indentation)
             (point))))
      (skip-chars-forward "\s " point-of-indentation)))
  (define-key js2-mode-map "\C-i" 'indent-and-back-to-indentation)
;;  (define-key js2-mode-map "\C-m" nil)
  (add-to-list 'auto-mode-alist '("\\.js$" . js2-mode)))
(setq-default c-basic-offset 4)
(defun js-other-window ()
  "Run JavaScript on other window"
  (interactive)
  (split-window-horizontally 80)
  (let ((buf-name (buffer-name (current-buffer))))
    (js2-mode)
    (run-js inferior-js-program-command)
    (switch-to-buffer-other-window
     (get-buffer-create buf-name))))
;; (define-key global-map
;;    "\C-cj" 'js-other-window)


Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

Re: javascript - にも無限リストを (遅延ストリーム pipe 編)

PAIP(実用 Common Lisp (IT Architects’Archive CLASSIC MODER))に載ってる pipe は JavaScript でもいけそうだなぁと思って書いてみました。わりと強引に書きました。JavaScript には Lisp/Scheme のマクロのように引数の評価を遅らせるような機能(?)がないので、しかたなく呼び出し側で無名関数で包みました。よくないスタイルですが、取りあえず動くので良いんじゃないでしょうか。他に何か良い方法があれば、教えていただけると助かります。

で、その pipe でエラトステネスの篩をやってみると以下のような感じです。
var primes = sieve(integers(2));
enumerate(primes, 10);
// ->  [2,3,5,7,11,13,17,19,23,29,31,function () { return filter(pred, tail(pipe));}]

JavaScript による pipe とエラトステネスの篩のソースは以下のもの。JavaScript っぽさとかないかもしれませんし、突っ込みどころも多々あるでしょうが多めに見てください。。
function car (ls){
return ls[0];
}
function cdr (ls){
return ls[1];
}
function functionp (v){
return typeof(v) === 'function';
}
function nullp(a) {
return null === a || typeof(a) === 'undefined';
}
function makePipe (head, tail){
return [head, tail];
}
function pipeEmptyp (pipe){
return nullp(pipe) || pipe.length === 0;
}
function head (pipe){
return car(pipe);
}
function tail (pipe){
var kdr = cdr(pipe);
return functionp(kdr) ? pipe[1] = kdr(): kdr;
}
function pipeElt(pipe, i){
return i === 0 ? head(pipe) : pipeElt(tail(pipe), i - 1);
}
function integers (){
var start = arguments[0] | 0;
var end = arguments[1];
return (nullp(end) || start <= end)
? makePipe(start, function (){ return integers(start + 1, end); })
: [];
}
function enumerate (pipe){
var count = arguments[1];
var result = nullp(arguments[2]) ? pipe : arguments[2];
var ncount = count - 1;
return (pipeEmptyp(pipe) || count === 0)
? result
: enumerate(tail(pipe), ncount, result);
}
function filter (pred, pipe){
return pred(head(pipe))
? makePipe(head(pipe), function (){ return filter(pred, tail(pipe)); })
: filter(pred, tail(pipe));
}
function sieve (pipe){
return makePipe(head(pipe), function (){ return filter(function (x){
return 0 !== x % head(pipe); }, sieve(tail(pipe))); });
}
var primes = sieve(integers(2));
enumerate(primes, 10);
// -> [2,3,5,7,11,13,17,19,23,29,31,function () { return filter(pred, tail(pipe));}]
view raw pipe.js hosted with ❤ by GitHub


階乗のリストだとこうでしょうか。
function facts (pipe) {
  var rec = function (p, acc){
    var h = head(p);
    var cur = 0 === h ? 1 : h * acc;
    return makePipe(cur, function () { return rec(tail(p), cur); });
  };
  return rec(pipe, 1);
}

enumerate(facts(integers(0)), 5);
// -> [1,1,2,6,24,120,function () { return rec(tail(p), cur); }]

enumerate(facts(integers(0)), 10);
// [1,1,2,6,24,120,720,5040,40320,362880,3628800,function () { return rec(tail(p), cur); }

ところで

JavaScript の生みの親であるブレンダン・アイクが、実は
ブラウザで動く Scheme が作れると聞いて!
ということでネスケに入ったなんて話もあるらしいですね。
伝統的なマクロじゃないにしろ、それっぽいものがあったら JavaScript ももっと強力だったでしょうに。

そういえば

Rhino だと Scheme 由来の継続(continuation)や let が使えるそうで。
Scheme 以外で明示的に継続に触れたことが無いので、試して見ます。
(ruby にも call/cc があるんでしたっけ)

例えば、何の変哲もない、というかただ再帰するだけの deep 関数を例に取ると、
function deep (n){
  var ret;
  if (n === 0){
    ret = n;
  } else {
    ret =  deep(n - 1);
  }
  print(n);
  return ret;
}
deep(10);
/*
0
1
2
3
4
5
6
7
8
9
10
0
*/

再帰の基底条件に達した後は、今まで潜った再帰を戻るわけですよね。そのときに n が print されている状態です。
で、継続のお決まりの例である脱出をしてみたいので、以下のように書き換えて見ます。

ポイントは、実際の再帰を内部で定義した rec 関数に任せている点と、deep の先頭で継続オブジェクトを取得している点。
function deep (n){
  var cont = new Continuation();
  var rec = function (n){
    var ret;
    if (n === 0){
      ret = n;
      cont(ret);
    } else {
      ret =  rec(n - 1);
    }
    print(n);
    return ret;
  };
  return rec(n);
}

deep(10);
// -> 0
print されませんね。結果である 0 だけが表示されています。この結果が意図通りのものです。

基底条件に達した時点で保存しておいた継続に結果を渡して呼び出しているので、潜った再帰はなかったことに。なかったことに、と言うと語弊があるでしょうか。まぁ、気になったら Scheme でもやってみてください。

一応確認するために、rec の下で print すると、ちゃんと再帰していることがわかります。基底条件、つまり最深部まで再帰を潜って cont に渡された値が cont が宣言された以降の処理の結果となるわけです。何を言ってるかわから(ry。
function deep (n){
  var cont = new Continuation();
  var rec = function (n){
    print(n);
    var ret;
    if (n === 0){
      ret = n;
      cont(ret);
    } else {
      ret =  rec(n - 1);
    }
    print(n);
    return ret;
  };
  return rec(n);
}
deep(10);
/*
10
9
8
7
6
5
4
3
2
1
0
0
 */

追記

あ、今回使った JavaScript の処理系は
Rhino 1.7 release 2 2009 03 22
です。

Emacs + Rhino + js2.el + js-comint.el 最強です。

追記2

いつも教えて頂いてます!ありがとうございます!
@valvallow ジェネレータが実装されてない処理系も多いみたいですね。 とりあえず、無限リストとかの考え方は無視して典型的な JavaScript らしい書き方で書いてみました。 http://gist.github.com/613523
function Primes() {
this.index=3;
this.nums=[2];
}
Primes.prototype.next=function() {
var i;
for(i=this.index; !(this.primep(i)); i++);
this.index=i+1;
this.nums.push(i);
return this.nums[this.nums.length-2];
};
Primes.prototype.primep=function(x) {
var limit=Math.floor(Math.sqrt(x));
var i;
for(i=0; this.nums[i]<=limit && x%this.nums[i]; i++){};
return this.nums[i]>limit;
};
function enumerate(ps, n) {
var r=[];
for(var i=0; i<n; i++) r.push(ps.next());
return r;
}
var primes = new Primes();
print(enumerate(primes, 10));
view raw gistfile1.js hosted with ❤ by GitHub


実用 Common Lisp (IT Architects’Archive CLASSIC MODER)

ソースコードハイライト htmlize.el

教えて頂きました!
@valvallow emacs の表示をそのまま html 化する elisp コード htmlize というのがあります。 http://bit.ly/IdlEc もし html を貼れるブログならこういうのもアリかも。
これはイイかも!!
(define (fact n)
  (if (zero? n)
      1
      (* n (fact (- n 1)))))

(fact 10)
;; 3628800

;; --------------------------------

(use srfi-1)
(define (fact n)
  (fold * 1 (unfold zero? identity (lambda (n)
                                     (- n 1)) n)))

(fact 10)
;; 3628800


Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

2010/10/05

ソースコードハイライト highlight.js

blogger でのコードハイライトは悩みますよね・・・。Lisp/Scheme に関しては google code prettify もいまいちですし。いまいちというか、全然ダメですよね。
最近はずっと gist にアップしたものを貼り付けていました。しかし、毎度毎度小さなコード片までもアップすることに嫌気がさしていたので、どうにかならないものかと思っていました。

そこで、再度探してみたら highlight.js というものがあったので、下記の記事で試してみました。
いろいろなテーマがあるようです。
しばらくは背景が黒の sunburst にしてみます。
(use srfi-1)
(define (fact n)
  (fold * 1 (unfold zero? identity (lambda (n)
                                     (- n 1)) n)))

(fact 10)
;; 3628800

追記

全然ダメなのは使い方みたい。。もっかい google code prettify を使ってみることにします。

追記2

結局、以下を参考に google code prettify にしました。

追記3

結局 google code prettify もやめて、これにしました。
(define (fact n)
  (if (zero? n)
      1
      (* n (fact (- n 1)))))

(fact 10)
;; 3628800


JavaScript 第5版

2010/10/04

plus1

学生さんもカッコだらけの言語が宿題に出るなんて大変ですね。
;; (plus1 5) =&gt; error 発生
;; (plus1 '()) =&gt; ()
;; (plus1 '(5)) =&gt; (6)
;; (plus1 '(1 2 3 7)) =&gt; (2 3 4 8)

;; map
(define (plus1 ls)
  (map (lambda (n)
         (+ n 1)) ls))

(plus1 5)
;; error
(plus1 '())
;; ()
(plus1 '(5))
;; (6)
(plus1 '(1 2 3 7))
;; (2 3 4 8)


;; unfold
(use srfi-1)
(define (plus1 ls)
  (unfold null?
          (lambda (ls)
            (+ (car ls) 1))
          cdr ls))

(plus1 5)
;; error
(plus1 '())
;; ()
(plus1 '(5))
;; (6)
(plus1 '(1 2 3 7))
;; (2 3 4 8)


;; recursive
(define (plus1 ls)
  (if (null? ls)
      '()
      (cons (+ 1 (car ls))
            (plus1 (cdr ls)))))

(plus1 5)
;; error
(plus1 '())
;; ()
(plus1 '(5))
;; (6)
(plus1 '(1 2 3 7))
;; (2 3 4 8)


;; tail call recursive
(define (plus1 ls)
  (let rec ((ls ls)(acc '()))
    (if (null? ls)
        (reverse acc)
        (rec (cdr ls)(cons (+ (car ls) 1) acc)))))

(plus1 5)
;; error
(plus1 '())
;; ()
(plus1 '(5))
;; (6)
(plus1 '(1 2 3 7))
;; (2 3 4 8)





;; (min 5) =&gt; error発生
;; (min '()) =&gt; error
;; (min '(20 15)) =&gt; 15
;; (min '(30 5 90 25)) =&gt; 5

(define (min ls)
  (if (null? ls)
      (error)
      (fold (lambda (e ret)
              (if (&lt; e ret)
                  e
                  ret))(car ls) ls)))

(min 5)
;; error
(min '())
;; error
(min '(20 15))
;; 15
(min '(30 5 90 25))
;; 5

(define (min ls)
  (if (null? ls)
      (error)
      (let rec ((ls ls)(ret (car ls)))
        (if (null? ls)
            ret
            (rec (cdr ls)(if (&lt; (car ls) ret)
                             (car ls)
                             ret))))))

(min 5)
;; error
(min '())
;; error
(min '(20 15))
;; 15
(min '(30 5 90 25))
;; 5
The Little Schemer, 4th Edition