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)

追記

• Twitter / SaitoAtsushi: @valvallow (use srfi-42)(d ...

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

内包表記、使いこなせねぇー！

熊本 #Emacs 的何か #Ekumacs ！

• Twitter / myuhe: 正式アナウンスです。熊本でEmacsにまつわる何かを ...

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

• Twitter / @myuhe/Ekumacs

技術系の勉強会や集まりがあまりなかった熊本でもいろいろ始まってきましたね！良いことだ！やったー！

• 日本Androidの会　熊本支部 | Google グループ
• Kumamoto.rb: Welcome to Kumatmo.rb
• Kumamoto Programming Freaks
• 9LISP

私が知っている限りではこの辺りですが、Android に Ruby に Lisp に、今回 Emacs と・・・。結構とんがってるね熊本！

追記

• kumamoto-emacs | Google グループ

Scheme で数独を解く

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

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

• 数独 - Wikipedia

簡単な問題を解いてみるとこんな具合。

(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 が終わってからまた改めて考えてみます。

• vallog: On Lisp 非決定性
• vallog: syntax-rules: amb

ということで、とりあえずさらしておきます。

• valvallow's sudoku at master - GitHub
• sudoku.scm at master from valvallow's sudoku - GitHub
• temp.scm at master from valvallow's sudoku - GitHub
• data.scm at master from valvallow's sudoku - GitHub

全景はこんな感じ。

(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 倍高速でした！

• gist: 629486 - GitHub

追記2

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

• gist: 638160 - GitHub

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

• 壊れていく日々: Collatz 予想

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

とりあえず、Scheme で改めて書いてみました。

Common Lisp だと、こうでしょうか。

或いはこう？（仕様を満たせていませんね・・・）


書いているうちに、こういうのがあったら良いんじゃないかなぁ、と思いました。

(hoge pred calc acc dec i) ==
(if (pred i)
    acc
    (hoge pred calc (calc i acc) dec (dec i)))

パッと見 unfold に似てるので、unfold で無理やり書いてみました。

やはり unfold では強引な気がしたので試しに accum というのを定義してみました。

試しに fizzbuzz を書いてみたり。

いまいち。ちょっと変更。

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

追記

調べたら、ちょっと前に unfold で書いてた。今日書いたものより、こっちの方が良い・・・。

• vallog: collatz unfold

Common Lisp の loop マクロ

難しい。すごく柔軟で便利だと聞くけど、個人的な印象では融通が効かないなぁと感じている次第です。きっと慣れないせいなんだきっと。。

• Common Lisp's Loop Macro Examples for Beginners
• Tutorial for the Common Lisp Loop Macro
• 26. Loop
• 微酔半壊: Common Lisp: loopマクロ用法抄
• loopの奥深さを知る - (rubikitch loves (Emacs Ruby CUI))

やっぱ named let でいいじゃん・・・。と思ってしまいます。再帰かわいいよ再帰。
その点、Common Lisp はほとんどの処理系が末尾呼び出し最適化をしてくれるらしいので良いとして、Emacs Lisp てめぇは（ｒｙ

• vallog: Emacs Lisp の cl package には loop マクロがあるので、取りあえず fold もどきを定義
• vallog: Emacs Lisp: fold に続いて pair-fold
• vallog: Emacs Lisp: intersperse

Emacs Lisp: intersperse

まぁ、こうやって自前で用意しなくてもあるんでしょうが・・・。

• vallog: Emacs Lisp: fold に続いて pair-fold

(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 Lisp: fold に続いて pair-fold

ちょっと強引ですが。。

• vallog: Emacs Lisp の cl package には loop マクロがあるので、取りあえず 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 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 辺りを用意しとけばある程度困らないかも・・・？

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 を使えば良い話なんですけどね。

• vallog: Emacs で JavaScript （js2.el, js-comint.el）
• vallog: Re: javascript - にも無限リストを （遅延ストリーム pipe 編）
• vallog: ソースコードハイライト htmlize.el

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

• Scheme手習い

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

• Scheme(スキーム)手習い―直感で学ぶLisp (COMPUTATION & SOFTWARE SCIENCE)

追記

書評！
• 2010-10-21 - あどけない話

原書はこちら。

• The Little Schemer, 4th Edition