syntax-rules: define-same-params

(define-same-params (idx edge)
  (index->x (remainder idx edge))
  (index->y (quotient idx edge))
  (index->xy (values (index->x idx edge)
                     (index->y idx edge)))
  (hline-indices (vector-iota edge (* (index->y idx edge) edge))))

小手先の誤魔化しのような気もしますが。

(define-syntax define-same-params
  (syntax-rules ()
    ((_ (params ...)(name body ...))
     (define (name params ...)
       body ...))
    ((_ (params ...)(name body ...) x ...)
     (begin
       (define-same-params (params ...)(name body ...))
       (define-same-params (params ...) x ...)
       (undefined)))))

追記

• Twitter / SaitoAtsushi: @valvallow R6RSならこれでいける(de ...

@valvallow R6RSならこれでいける(define-syntax define-same-params(syntax-rules()((_(p ...)(n b ...)...)(begin(define(n p ...)b ...)...)))) R5RSの微妙な不備

(define-syntax define-same-params
  (syntax-rules ()
    ((_ (p ...)(n b ...) ...)
     (begin
       (define (n p ...) b ...) ...))))

R6RS 。。

PAIP: queue

このブログでは毎月、月の日数より多く記事を書くことを軽く目標にしてきましたが、ここ2ヶ月停滞気味です。
で、気づけば次の記事で365 記事目ということで、年単位で見れば目標達成ですかね。去年は2ヶ月間まったく書かないことがあったので、320 記事でした。

PAIP も購入してから継続的に読んできて、1～11・22～25・17～18章と読みましたが、これも現在停滞気味。7～8割くらいは読んだことになりますが、例題や演習はほとんど書いてないので、むしろ「これから」といったところです。

で、結構いまさらですが、10章の queue の実装がおもしろかったので、gauche で書いてみました。cons の cdr 部に queue 本体を、car 部に queue の末尾の cons のポインタを突っ込んだ形です。この car と cdr を逆にした tconc も紹介されていますが割愛。

P.322 ～

(define (queue-contents q)
  (cdr q))

(define (make-queue)
  (rlet1 q (cons '() '())
         (set! (car q) q)))

(define (enqueue item q)
  (set! (car q)
        (rlet1 f (cons item '())
               (set! (cdr (car q)) f)))
  q)

(define (dequeue q)
  (pop! (cdr q))
  (when (null? (cdr q))
    (set! (car q) q))
  q)

(define (front q)
  (car (queue-contents q)))

(define (empty-queue? q)
  (null? (queue-contents q)))

(define (queue-append! q ls)
  (set! (cdr (car q)) ls)
  (set! (car q)
        (last-pair q))
  q)



(define q (make-queue))

(queue-contents q)
;; ()

(empty-queue? q)
;; #t

(enqueue 'a q)
;; (#0=(a) . #0#)
(enqueue 'b q)
;; (#0=(b) a . #0#)
(enqueue 'c q)
;; (#0=(c) a b . #0#)

(empty-queue? q)
;; #f

(front q)
;; a

(queue-contents q)
;; (a b c)

(queue-append! q '(d e f))
;; (#0=(f) a b c d e . #0#)

(dequeue q)
;; (#0=(f) b c d e . #0#)
(dequeue q)
;; (#0=(f) c d e . #0#)
(dequeue q)
;; (#0=(f) d e . #0#)

追記

• vallog: consでqueue

BiwaScheme on Google Site

• life is biwa

BiwaScheme も Google Gadget に突っ込めば、きっと Google Site で動くんだろうなぁ。
ということで

Gauche でライフゲームを書いて

• lifegame2.scm at master from valvallow's lifegame - GitHub

BiwaScheme 向けに少し追加修正して

• life_is_biwa.scm at master from valvallow's lifegame - GitHub

Google Gadget の xml にしました。

• life_is_biwascheme.xml at master from valvallow's lifegame - GitHub

見た目がすごい雑ですが、上記の画像の通り動きました。
ちなみにフィールドの前後左右がつながってるタイプのライフゲームです。

Google Gadget の xml は以下の通り。

<?xml version="1.0" encoding="UTF-8" ?>
<Module>
  <ModulePrefs title="Life is BiwaScheme"
               title_url="http://www.biwascheme.org/"
               height="500"
               author="valvallow"
               author_email="valvalloooooooooow@gmail.com"
               description="lifegame written in BiwaScheme"/>
  <Content type="html">
    <![CDATA[
             <div>step<input type="text" size=3 id="step" value="10"></div>
             <div>interval<input type="text" size=2 id="interval" value="1"></div>
             <div>size<input type="text" size=3 id="size" value="15"></div>
             <button id="start">start</button>
             <div id="lifegame-console" style="border: dotted;">
             </div>
             <script src="https://sites.google.com/site/lifeisbiwa/biwascheme.js">
(define *relatives*
  '((-1 . 1)(0 . 1)(1 . 1)(-1 . 0) ;; (0 . 0)
    (1 . 0)(-1 . -1)(0 . -1)(1 . -1)))

(define (call-with-output-string proc)
  (let ((out (open-output-string)))
    (proc out)
    (get-output-string out)))

(define (dec n)
  (- n 1))

(define (random-bit)
  (random-integer 2))

(define (complement pred)
  (lambda args
    (not (apply pred args))))

(define (bit->bool bit)
  ((complement zero?) bit))

(define (square-edge square)
  (sqrt (vector-length square)))

(define (index->xy idx edge)
  (let ((m (mod idx edge))
        (q (div idx edge)))
    (values m q)))

(define (xy->index x y edge)
  (+ x (* y edge)))

(define (sphere n edge)
  (mod (+ n edge) edge))

(define (neighbor-relative-xy idx edge relatives)
  (call-with-values (lambda ()
                      (index->xy idx edge))
    (lambda (x y)
      (map (lambda (r)
             (let ((rx (+ x (car r)))
                   (ry (+ y (cdr r))))
               (cons (sphere rx edge)
                     (sphere ry edge))))
           relatives))))

(define (neighbor-relative-indices idx edge relatives)
  (let1 rel (neighbor-relative-xy idx edge relatives)
    (map (lambda (r)
           (xy->index (car r)(cdr r) edge))
         rel)))

(define-macro (rlet1 var exp . body)
  `(let ((,var ,exp))
     (unquote-splicing body)
     ,var))

(define (square x)
  (* x x))

(define (make-neighbor-indices edge relatives)
  (let1 idx 0
    (vector-map
     (lambda (v)
       (rlet1 r (neighbor-relative-indices idx edge relatives)
              (set! idx (+ idx 1))))
     (make-vector (square edge)))))


;; ------------------------------------------------------------
;;  lifegame
;; ------------------------------------------------------------

(define (pa$ proc . params)
  (lambda args
    (apply proc (append params args))))

(define (lifegame:neighbor lifegame neighbor)
  (map (pa$ vector-ref lifegame) neighbor))

(define (lifegame:random-life edge)
  (list->vector (map (lambda (e)
                       (bit->bool (random-bit)))
                     (iota (square edge)))))

(define (count pred ls)
  (let rec ((ls ls)(acc 0))
    (if (null? ls)
        acc
        (rec (cdr ls)(+ acc
                        (if (pred (car ls))
                            1
                            0))))))

(define (lifegame:live? life neighbor-life)
  (let1 cnt (count identity neighbor-life)
    (if life
        (<= 2 cnt 3)
        (= cnt 3))))

(define (lifegame:next-step lifegame neighbor)
  (vector-map (lambda (e nh)
                (lifegame:live? e (lifegame:neighbor lifegame nh)))
              lifegame neighbor))

(define (lifegame:make-stepper lifegame relatives)
  (let1 nh (make-neighbor-indices (square-edge lifegame) relatives)
    (lambda _
      (rlet1 r (lifegame:next-step lifegame nh)
             (set! lifegame r)))))

(define (lifegame:auto-step lifegame relatives step before after finally)
  (let1 next (lifegame:make-stepper lifegame relatives)
    (let rec ((l lifegame)(step step))
      (if (zero? step)
          (finally l step)
          (begin
            (before l step)
            (let1 r (next)
              (after r step)
              (rec r (dec step))))))))

(define (lifegame:make-web-printer sym finally)
  (let1 newline (lambda (out)
                  (display "<br />" out))
    (lambda (lifegame step)
      (let ((edge (square-edge lifegame))
            (idx 0))
        (let1 s (call-with-output-string
                  (lambda (out)
                    (display "step:" out)
                    (display step out)
                    (newline out)
                    (vector-for-each (lambda (e)
                                       (when (zero? (mod idx edge))
                                         (newline out))
                                       (display ((if e car cdr) sym) out)
                                       (set! idx (+ idx 1)))
                                     lifegame)
                    (newline out)
                    (newline out)))
          (finally s))))))

;; ------------------------------------------------------------
;;  test
;; ------------------------------------------------------------

(define (start-lifegame . args)
  (let ((live "<img border=\"0\" height=\"15\" src=\"https://sites.google.com/site/lifeisbiwa/lisplogo_alien_128.png\" width=\"25\" />")
        (dead "<img border=\"0\" height=\"15\" src=\"\" width=\"25\" />")
        (step (string->number (get-content ($ "step"))))
        (interval (string->number (get-content ($ "interval"))))
        (size (string->number (get-content ($ "size"))))
        (console ($ "lifegame-console")))
  (let ((game (lifegame:random-life size))
        (printer (lifegame:make-web-printer
                  (cons live dead)
                  (lambda (val)
                    (element-update! console val)))))
    (lifegame:auto-step game *relatives* step printer
                        (lambda _ (sleep interval))
                        (lambda (l s)
                          (set! game l))))))
(add-handler! ($ "start") "click" start-lifegame)
             </script>
    ]]>
  </Content>
</Module>

BiwaScheme on Blogger (2)

test
(map (lambda (n)(let rec ((n n)(acc 1))(if (zero? n)acc(rec (- n 1)(* n acc)))))(iota 20))

記事単体で表示してる時に動かない。ブログ全体で表示すると動く。なんでだ。

<textarea cols="50" id="bs-input" rows="5">(map (lambda (n)(let rec ((n n)(acc 1))(if (zero? n)acc(rec (- n 1)(* n acc)))))(iota 100))</textarea>
<button id="eval">eval</button>

<div id="bs-console2" style="border: dotted;">
</div>
<script src="biwascheme.js">
(define (eval-code arg)
  (let* ((src (get-content ($ "bs-input")))
         (code (read-from-string src)))
    (element-update! ($ "bs-console2")(eval code))))
(add-handler! ($ "eval") "click" eval-code)
</script>

参考

• htmlのフォームのボタンを押したらBiwaSchemeでなんかするサンプル - `(Hello ,world) - cadr group

biwascheme on blogger

• BiwaScheme : Scheme interpreter for browsers

ちょっと試してみたくて。

<div id="bs-console" style="border-style: dotted;">
</div>
<script src="biwascheme.js">
;; (js-call (js-eval "alert") "Hello, world !! (powerd by biwascheme)")
(element-update! ($ "bs-console") "Hello, world !! (by biwascheme)")
</script>

↓結果↓

（chrome, firefox, operaでは動いてるっぽいですが、IEでは動いてないみたい？）

ビルド

• Files - biwascheme - GitHub

How to build lib/biwascheme.js
You need make and Java installed.

(1) Download and unpack YUI compressor

(2) Create a shell script ‘yuicomp’ like:

#!/bin/sh
java -jar /somewhere/yuicompressor-2.4.2/build/yuicompressor-2.4.2.jar $*

(3) make

参考

• yhara's biwascheme at master - GitHub
• Files - biwascheme - GitHub
• BiwaScheme : Scheme interpreter for browsers
• BiwaScheme REPL
• A Picture Language (from SICP 2.2.4)
• どぼん on BiwaScheme
• How to use BiwaScheme « Jakub Jankiewicz (jcubic) Blog
• firegoby » Blog Archive » JavaSCriptを圧縮 – yuicompressor

quine ： 自分自身を出力するプログラム

• クワイン (プログラミング) - Wikipedia

クワイン（英: Quine）は、コンピュータプログラムにおけるメタプログラミングの一形態であり、自身の完全なソースコードだけを出力するプログラムである。

だそうです。

quine というものを初めて目にしたのはこれでした。

• プログラム・プロムナード
• （PDF）自分自身を出力するプログラム

((lambda (x)
   `(,x ',x))
 `(lambda (x)
    `(,x ',x)))

でもこれ↑実行すると評価されちゃってて自身のソースコードを出力してないんじゃぁ・・・。（ソースの転載ミスでした）

そういえば、LOL（LET OVER LAMBDA Edition 1.0） にもありました。

• 4-2 : Backquote - Let Over Lambda

* (let ((let '`(let ((let ',let))
                 ,let)))
    `(let ((let ',let)) ,let))

(LET ((LET '`(LET ((LET ',LET))
               ,LET)))
  `(LET ((LET ',LET)) ,LET))

この方のプロフィール欄とか。

• zick (zick_minoh) on Twitter

((lambda (lambda) `((lambda (lambda) ,lambda) ',lambda)) '`((lambda (lambda) ,lambda) ',lambda))

検索してみたらこんなページがありました。

• The Quine Page (self-reproducing code)
• www.nyx.net/~gthompso/self_scheme.txt

(call/cc
 (lambda (c)
   (call/cc
    (lambda (cc)
      (c ((lambda (c)
            `(call/cc
              (lambda (c) (call/cc (lambda (cc) (c (,c ',c)))))))
          '(lambda (c)
             `(call/cc
               (lambda (c) (call/cc (lambda (cc) (c (,c ',c)))))))))))))

((lambda (x) `(,(reverse x) ',x)) '(`(,(reverse x) ',x) (x) lambda))

ハンパねぇ！


まぁ、だからどうということではないのですが。。

gauche-refj.pdf

というのがあったので眺めていました。
こういうリファレンスを上からシーケンシャルに眺めるのは結構好きです。

• filetype:pdf "gauche-refj" - Google 検索

setter, getter のこととか良く知らなかったのですが、これを読んでわかりました。clamp とか知らないとその都度自分で定義してしまいがちですよね。私のことですが。

• clamp - Gauche ユーザリファレンス: 6.2 数値
• setter - Gauche ユーザリファレンス: 4.4 代入