Webプログラミングに継続を採り入れると、より美しいコードが書けるんじゃないかと、興味を持っています。
最近、Smalltalkでも継続を扱えることを知りました。
Seasideの、
がまさに求めているものなのかもしれない。
memo: Scheme:リスト処理
(defun longer (x y)
(labels ((compare (x y)
(and (consp x)
(or (null y)
(compare (cdr x) (cdr y))))))
(if (and (listp x) (listp y))
(compare x y)
(> (length x) (length y)))))
memo: Smalltalkでも制約指向プログラミングがある。 http://www.sra.co.jp/people/aoki/SmalltalkTextbookJ/textbook33.html
memo: スーパークリエイタの研究はさすがに画期的。 http://www.ipa.go.jp/NBP/14nendo/14mito/creator.html
memo: http://www.cincomsmalltalk.com/userblogs/avi/blogView?showComments=true&entry=3240140310
memo: SISC Second Interpreter of Scheme Code http://sisc.sourceforge.net/
memo: あとで読みたい。 Scheme:オブジェクト指向表現
(define match (#/(?<integer>\d+)\.(?<fraction>(\d+)/ "pi=3.14..."))
↑<fraction>の後ろの、強調したところのカッコは要らないはず。正しくは↓だと思う。
(define match (#/(?<integer>\d+)\.(?<fraction>\d+)/ "pi=3.14..."))
(2006/06/18 00:07:10 PDT)
ambの勉強
http://www.shido.info/lisp/scheme_amb.html
のために書いたものです。
0 5 0 0 0 0 0 4 0 0 0 0 1 0 0 3 2 0 0 0 9 0 6 2 0 0 5 3 0 0 8 0 0 0 0 4 8 4 0 0 0 1 0 5 0 0 0 6 0 0 0 8 0 1 0 9 0 0 0 4 0 0 0 0 0 0 0 2 0 0 0 0 0 6 0 3 1 8 0 0 0
問題をこのように入力したものを、ファイルに保存して、例えばそのファイル名をprobremとすると、
$ ./suudoku.scm probrem ........................ solved. counts of answer=1 1 5 2 9 8 3 6 4 7 6 7 8 1 4 5 3 2 9 4 3 9 7 6 2 1 8 5 3 1 5 8 9 6 2 7 4 8 4 7 2 3 1 9 5 6 9 2 6 4 5 7 8 3 1 2 9 3 6 7 4 5 1 8 7 8 1 5 2 9 4 6 3 5 6 4 3 1 8 7 9 2 ....answer is not any further
と出力されます。内部でバックトラックが動くたびに"."が表示されます。
#!/usr/bin/env gosh
(use srfi-1)
(use srfi-43)
(use util.combinations)
(use util.list)
(use gauche.array)
(define-constant dim 9)
(define-constant 1-9-list (iota dim 1))
(define-constant 0-8-list (iota dim))
(define-constant all-list (cartesian-product `(,0-8-list ,0-8-list)))
(define (array-ref-multi G l)
(map (lambda (x)
(array-ref G (car x) (cadr x)))
l))
(define (row-list row)
(cartesian-product `((,row) ,0-8-list)))
(define (col-list col)
(cartesian-product `(,0-8-list (,col))))
(define (region-list row col)
(let* ((a0 (* (quotient row 3) 3))
(a1 (+ a0 1))
(a2 (+ a0 2))
(b0 (* (quotient col 3) 3))
(b1 (+ b0 1))
(b2 (+ b0 2)))
(cartesian-product `((,a0 ,a1 ,a2) (,b0 ,b1 ,b2)))))
(define (get-usable-number-list G row col)
(define (get-row-used-number-list G row)
(remove! zero? (array-ref-multi G (row-list row))))
(define (get-col-used-number-list G col)
(remove! zero? (array-ref-multi G (col-list col))))
(define (get-region-used-number-list G row col)
(remove! zero? (array-ref-multi G (region-list row col))))
(define (get-used-number-list G row col)
(lset-union =
(get-row-used-number-list G row)
(get-col-used-number-list G col)
(get-region-used-number-list G row col)))
(lset-difference =
1-9-list
(get-used-number-list G row col)))
(define (read-data inp)
(apply (cut array (shape 0 dim 0 dim) <...>)
(apply append!
(map (cut map x->integer <>)
(map (cut string-split <> #\space)
(port->string-list inp))))))
(define (my-array-print G)
(for-each (lambda (x)
(apply print (intersperse #\space (array-ref-multi G (row-list x)))))
0-8-list))
(define (single? l)
(and (pair? l) (null? (cdr l))))
(define (fixed-num-finder A row col)
(define (unique-in-list? a l)
(single? (filter (cut eq? a <>) l)))
(any (lambda (x)
(find (cut unique-in-list? <> x) (array-ref A row col)))
(map (lambda (x)
(apply append x))
(list (array-ref-multi A (row-list row))
(array-ref-multi A (col-list col))
(array-ref-multi A (region-list row col))))))
(define (usable-number-list-array G)
(let1 usable-number-list (map (lambda (x)
(let ((row (car x))
(col (cadr x)))
(if (zero? (array-ref G row col))
(get-usable-number-list G row col)
'())))
all-list)
(apply (cut array (shape 0 dim 0 dim) <...>) usable-number-list)))
(define (fixed-num-list G)
(let1 A (usable-number-list-array G)
(filter-map (lambda (x)
(let ((row (car x))
(col (cadr x)))
(let1 p (fixed-num-finder A row col)
(if (eq? p #f)
#f
(list row col p)))))
all-list)))
(define (solvable? G)
(let1 A (usable-number-list-array G)
(null? (filter-map (lambda (x)
(let ((row (car x))
(col (cadr x)))
(and
(= (array-ref G row col) 0)
(null? (array-ref A row col)))))
all-list))))
(define (back-track-candidates G)
(define (array-index pred a)
(let1 i (vector-index pred (array->vector a))
(if (eq? i #f)
#f
(list (quotient i dim) (modulo i dim)))))
(let1 A (usable-number-list-array G)
(let length-loop ((len 2))
(if (> len dim)
(print "wtf?")
(let1 x (array-index (lambda (x)
(= (length x) len))
A)
(if (not (eq? x #f))
(let ((row (car x))
(col (cadr x)))
(map (lambda (p)
(list row col p)) (array-ref A row col)))
(length-loop (+ len 1))))))))
(define (solve G)
(define (solve-fork G x)
(format #t ".")
(flush)
(let1 G0 (apply (cut array (shape 0 dim 0 dim) <...>) (array->list G))
(array-set! G0 (car x) (cadr x) (caddr x))
(solve G0)))
(cond
((null? (filter zero? (array-ref-multi G all-list)))
(if (answer-checker G)
(begin
(inc! answer-count)
(newline)
(format #t "solved. counts of answer=~s\n" answer-count)
(my-array-print G)
(choose))
(choose)))
((not (solvable? G))
(choose))
(else
(let1 l (fixed-num-list G)
(if (null? l)
(solve-fork G (apply choose (back-track-candidates G)))
(begin
(for-each (lambda (x)
(array-set! G (car x) (cadr x) (caddr x)))
l)
(solve G)))))))
(define (answer-checker G)
(define (checker G row col)
(and
(equal? 1-9-list (sort (array-ref-multi G (row-list row))))
(equal? 1-9-list (sort (array-ref-multi G (col-list col))))
(equal? 1-9-list (sort (array-ref-multi G (region-list row col))))))
(null? (filter-map (lambda (x)
(not (checker G (car x) (cadr x))))
all-list)))
(define answer-count 0)
(define fail #f)
(define (choose . ls)
(if (null? ls)
(fail)
(let ((fail0 fail))
(call/cc
(lambda (cc)
(set! fail
(lambda ()
(set! fail fail0)
(cc (apply choose (cdr ls)))))
(cc (car ls)))))))
(define (main args)
(if (call/cc
(lambda (cc)
(set! fail (lambda ()
(cc #f)))
(cc #t)))
(solve (call-with-input-file (cadr args) read-data))
(print "answer is not any further")))
(define (array-print mat)
(for-each (lambda (r)
(let1 row-r (share-array mat (shape (array-start mat 1) (array-end mat 1)) (lambda (k) (values r k)))
(print (array->list row-r))))
(iota (array-length mat 0) (array-start mat 0)))
(newline))
Schemeに慣れてきて、以前のコードを今ならもっときれいに書けるはずと、改良してみた。2006/06/10 18:35:16 PDT
(define (graph input)
(define (input->plist in)
(let1 y 0
(port-map (lambda (c)
(case c
((#\R)
(inc! y)
(cons (- y 1) #\/))
((#\F)
(dec! y)
(cons y #\\))
((#\C)
(cons y #\_))))
(lambda ()
(read-char in)))))
(define (draw-row y plist)
(for-each (lambda (x)
(if (= (car x) y)
(display (cdr x))
(display #\space)))
plist))
(let ((plist (call-with-input-string input input->plist)))
(receive (min-y max-y) (apply min&max (map car plist))
(let loop ((y max-y))
(if (< y min-y)
'AA-graph
(begin
(draw-row y plist)
(display #\newline)
(loop (- y 1))))))))
(graph "RCRFCRFFCCRFFRRCRRCCFRFRFF")
(define (graph input)
(define (input->plist input)
(let1 input-p (open-input-string input)
(let loop ((plist '())
(y 0))
(let1 c (read-char input-p)
(if (eof-object? c)
(reverse! plist)
(let1 obj '()
(case c
((#\R)
(set! obj (cons y #\/))
(inc! y))
((#\F)
(set! obj (cons (- y 1) #\\))
(dec! y))
((#\C)
(set! obj (cons y #\_))))
(loop (cons obj plist) y)))))))
(define (draw-row y plist)
(for-each (lambda (obj)
(if (= (car obj) y)
(display (cdr obj))
(display #\space)))
plist))
(let ((plist (input->plist input)))
(receive (min-y max-y) (apply min&max (map car plist))
(let loop ((y max-y))
(if (< y min-y)
'AA-graph
(begin
(draw-row y plist)
(display #\newline)
(loop (- y 1))))))))
gosh> (graph "RCRFCRFFCCRFFRRCRRCCFRFRFF")
__
/ \/\/\
_/\_/\ _/ \
/ \__/\ /
\/
AA-graph
AC_CHECK_HEADERS(GLUT/glut.h, [を
AC_CHECK_HEADERS(GL/glut.h, [に。
いつもどおり、tar.gzを展開して、Gauche-glのconfigureを実行すると、 GLUT/glut.hが見つからないと言われる。
$ ./configure checking GL/glx.h usability... yes checking GL/glx.h presence... yes checking for GL/glx.h... yes checking GLUT/glut.h usability... no checking GLUT/glut.h presence... no checking for GLUT/glut.h... no
それもそのはず、freeglut-develパッケージをまだインストールしていない。
#yum install freeglut-devel
よし、これでGLUT/glut.hを見つけてくれるはずだ。と思ったら、また失敗、見つからないと言われる。
glut.hが、GL/glut.hにインストールされてしまっているので、GLUT/glut.hは存在しないのだ。 そこで、Gauche-glのconfigure.inを書き換える。69行目、
AC_CHECK_HEADERS(GLUT/glut.h, [
を
AC_CHECK_HEADERS(GL/glut.h, [
に。
変更をconfigureスクリプトに反映するために、
$ autoconf
を実行。
$ ./configure checking GL/glx.h usability... yes checking GL/glx.h presence... yes checking for GL/glx.h... yes checking GL/glut.h usability... yes checking GL/glut.h presence... yes checking for GL/glut.h... yes
正常。この後めでたく、make, make install で、インストール完了。
SDL_Surfaceを回転するC言語の関数を、Gaucheから呼び出したくなった。 spigotとgenstubのソースコードが参考になった。
$ gauche-package generate hoge $ cd hoge/ hogelib.stub, hoge.c, hoge.h, hoge.scm を書いて、 $ ./DIST gen $ ./configure $ make # make install
配布したくなったら
$ ./DIST tgz
C言語の関数を呼び出す方法を調べるにあたって、参考にしたページ Gauche:FFI Gauche:MeCab