gemma

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:オブジェクト指向表現

Gauche ユーザリファレンスのtypo 

 (define match (#/(?<integer>\d+)\.(?<fraction>(\d+)/ "pi=3.14..."))

 ↑<fraction>の後ろの、強調したところのカッコは要らないはず。正しくは↓だと思う。

 (define match (#/(?<integer>\d+)\.(?<fraction>\d+)/ "pi=3.14..."))

Typo ではなくて、要望。

数独の解答プログラム

(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")))

AA折れ線グラフ二度

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

AA折れ線グラフ 

(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

Fedora Core 5での、Gauche-glのインストール。

  1. $ yum install freeglut-devel
  2. Gauche-gl の configure.in 69行目を書き換える。 
    AC_CHECK_HEADERS(GLUT/glut.h, [
    を 
    AC_CHECK_HEADERS(GL/glut.h, [
    に。
  3. $ autoconf
  4. $ ./configure & make & make install

いつもどおり、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 で、インストール完了。

C言語の関数をGaucheから呼び出そう。

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

Topics
Sponsored Links
Search
Recent Changes
More ...
Last modified : 2014/01/14 11:04:56 UTC
WiLiKi 0.8.3 running on Gauche 0.9.15