teranishi

rubyから移ってきました。よろしくお願いします。


combinationsの高速化

util.combinationsのcombinationsを高速化してみました。 nが1の場合と、nがsetの長さと同じ場合を特殊処理して速度を稼いでいます。

(use srfi-1)

(define (combinations set n)
  (define (rec set tail)
    (cond [(null? tail) (list set)]
          [(eq? (cdr set) tail) (map list set)]
          [else (fold-right (cut acons (car set) <> <>)
                            (rec (cdr set) (cdr tail))
                            (rec (cdr set) tail))]))
  (cond [(not (positive? n)) (list '())]
        [(list-tail set n #f) => (pa$ rec set)]
        [else '()]))

Scheme:戻り値のスプライシング

今更ですが、戻り値のスプライシングを常に行う必要は無いのではないかと 思い、以下のようなものを作りました。

(define-syntax splice
  (syntax-rules ()
    ((_ func (fcall ...))
     (call-with-values (lambda () (fcall ...)) func))
    ((_ func args ...)
     (splice-iter func () args ...))))
(define-syntax splice-iter
  (syntax-rules ()
    ((_ func (quoted ...)) (apply func `(quoted ...)))
    ((_ func (quoted ...) (fcall ...) args ...)
     (splice-iter func (quoted ... ,@(receive lst (fcall ...) lst)) args ...))
    ((_ func (quoted ...) arg args ...)
     (splice-iter func (quoted ... ,arg) args ...))))

使用例

gosh> (splice + (values 1 2 3))
6
gosh> (splice + (values 1 2 3) (values 4 5 6))
21

要するに、GaucheRefj:cutのようなインタフェースで、 先頭に splice をつけた時だけスプライシングしようということです。

既に誰かが同じような事を考えていたらすみません。


今日の一行 木の復元

また後出しですが、木の復元を。 木をたどる順番の変更を、評価順の入れ替えのみで行うようにした結果、 自分でも訳が分からないコードになってしまいました。 (2006/03/20 21:57:27 PST)

(use srfi-42)

(define make-leaf values)
(define make-branch list)

(define (make-all-branch e left right)
  (list-ec (: l left)
           (: r right)
           (make-branch e l r)))

(define (traverse-rev order lst)
  (let loop ((n (length lst)))
    (if (= n 1)
      (list (make-leaf (pop! lst)))
      (append-ec
        (:let lst-backup lst)
        (: pos 1 (- n 1) 2)
        (begin (set! lst lst-backup))
        (case order
          ((pre)  (let* ((e     (pop! lst))
                         (left  (loop pos))
                         (right (loop (- n pos 1))))
                    (make-all-branch e left right)))
          ((in)   (let* ((left  (loop pos))
                         (e     (pop! lst))
                         (right (loop (- n pos 1))))
                    (make-all-branch e left right)))
          ((post) (let* ((left  (loop pos))
                         (right (loop (- n pos 1)))
                         (e     (pop! lst)))
                    (make-all-branch e left right))))))))

AA折れ線グラフ

ほとんどShiroさんのコードのパクリですが、せっかく作ったので貼っておきます。

zipperを使うことで、縦軸の最大、最小を調べずに済ませています。(2006/03/15 06:20:00 PST)

(use srfi-1)
(use gauche.sequence)

(define (circular-zipper elt)
  (let1 lst (circular-list elt)
    (cons lst lst)))
(define (prev zipper)
  (list* (cdar zipper) (caar zipper) (cdr zipper)))
(define (next zipper)
  (acons (cadr zipper) (car zipper) (cddr zipper)))
(define (modify proc zipper)
  (list* (car zipper) (proc (cadr zipper)) (cddr zipper)))
(define (take-while-zipper pred zipper)
  (append-reverse!  (take-while pred (cons (cadr zipper) (car zipper)))
                    (take-while pred (cddr zipper))))

(define (graph input)
  (define (input->zipper input)
    (fold-with-index
      (lambda (index char zipper)
        (case char
          ((#\R) (prev (modify (pa$ acons index #\/) zipper)))
          ((#\F) (modify (pa$ acons index #\\ ) (next zipper)))
          ((#\C) (modify (pa$ acons index #\_) zipper))))
      (circular-zipper '()) input))
  (define (draw-row alist)
    (for-each (lambda (prev curr)
                (format #t "~v@a" (- (car curr) (car prev)) (cdr curr)))
              (acons -1 #f alist) alist)
    (newline))
  (for-each (lambda (alist) (draw-row (reverse alist)))
            (take-while-zipper pair? (input->zipper input))))

(define (main args)
  (graph (cadr args)))

さらに IO Monad について

IO Monad がわかりづらいのは、通常の言語と制御の流れが逆になるからではないでしょうか。

通常の言語で、標準入力から文字を読む場合の流れは、こんな感じでしょう。

  1. ユーザプログラムで、文字を読み込む関数を呼ぶ
  2. システムが、標準入力から文字を拾ってくる
  3. 入力された文字が、関数の戻り値として返される
  4. ユーザプログラムで、戻り値を使用して計算を続ける

IO Monad を使うと、この流れが以下のようになります。

  1. ユーザプログラムから、文字を読み込むコマンドがシステムに戻り値として返される
  2. システムが、そのコマンドに従い、標準入力から文字を拾ってくる
  3. 入力された文字が、次の関数の引数として渡される
  4. ユーザプログラムで、渡された引数を使用して計算を続ける

この流れに近いのは、実は CGI なのかも知れません。

  1. CGI のプログラムから、データ入力用のHTMLがブラウザに返される
  2. ブラウザが、ユーザから入力を受けつける
  3. ユーザからの入力が、次の CGI にパラメータとして渡される
  4. CGI のプログラムで、その入力を受け取り、新たなページを生成する

・・・Schemeと関係ない話題で申し訳ないです。


IO Monad

IO Monad の Scheme での実装として、以下のようなものを考えました。

(define (ret x)    `((*ret* ,x)))
(define (mread)    '((*read*)))
(define (mwrite x) `((*write* ,x)))
(define (>>= m f)  (append m (list f)))

(define (runIO cmds)
  (let ((cmd (car cmds)) (funcs (cdr cmds)))
    (let1 result (runCmd cmd)
      (if (null? funcs)
        'done
        (let1 next-cmds ((car funcs) result)
          (runIO (append next-cmds (cdr funcs))))))))

(define (runCmd cmd)
  (case (car cmd)
    ((*ret*)   (cadr cmd))
    ((*read*)  (read))
    ((*write*) (write (cadr cmd)))))

(define (inc x) (ret (+ x 1)))
(define (sqr x) (ret (* x x)))
(define hs-main (>>= (>>= (>>= (mread) inc) sqr) mwrite))

(runIO hs-main)

(mread が毎回同じ値を返す事と、hs-main 自体には副作用が無い事が表現できていると思います)

IO Monad を単なるアクションの組合せと見なせば、 そのアクションを動的にくみ上げていく感覚が分かりやすいのではないでしょうか。

(2005/05/26 20:17:33 PDT追記) これって単に、2chのHaskellスレの 501 を焼き直しただけですね。今ごろ気付きました。

(2005/11/09 19:17:02 PST) 私が IO Monad に対して持っているイメージを反映するように修正。 上のプログラムにおける IO Monad の実体はリストであり、先頭要素がアクション、 2番目以降の要素は前のアクションの結果を受け取ってアクションを返す関数になっている。


every*

引数の長さが異なる場合には #f を返す GaucheRefj:every が必要だが、 eq? との整合性が無いので GaucheRefj:list= が使えない場合に、 この関数が使えると思います。 (例えば、下の「式の比較」の「equal-expr-list?」)

この関数がライブラリに無いのは、あまり需要が無いからでしょうか。

(define (every* pred . args)
  (if (any null? args)
    (every null? args)
    (and (apply pred (map car args))
         (apply every* pred (map cdr args)))))

Monad

haskell-jp MLのアーカイブをのぞいたら、cut-seaさんが訳した Monadic Programming in Schemeを見つけました。 面白かったので、最後の例のプログラムをGaucheで実装してみました。

(define-module Monad
  (extend util.match)
  (export-all)
  (define-macro (>> m1 m2)
    `(>>= ,m1 (lambda (,(gensym)) ,m2)))
  (define fail error)
  (define-macro (letM binding expr)
    (match binding
      (((pat initializer))
       `(>>= ,initializer
             ,(if (symbol? pat)
                `(lambda (,pat) ,expr)
                `(match-lambda (,pat ,expr)
                               (_ (fail "nomatch"))))))))
  (define-macro (letM* bindings expr)
    (match bindings
      ((binding)
       `(letM (,binding) ,expr))
      ((binding rest ...)
       `(letM (,binding)
              (letM* ,rest ,expr)))))
  (define-macro (beginM . body)
    (match body
      ((expr) expr)
      ((expr rest ...)
       `(>> ,expr (beginM ,@rest)))))
  (define-macro (with-monad monad . body)
    `(let ((return (with-module ,monad return))
           (>>= (with-module ,monad >>=))
           (fail (with-module ,monad fail)))
       ,@body))
)

(define-module IO
  (extend Monad)
  (export return >>= read-int put-line runIO)
  (define *command-table* (make-hash-table 'eq?))
  (define-syntax define-command
    (syntax-rules ()
      ((_ (func args ...) body ...)
       (begin
         (hash-table-put! *command-table* 'func (lambda (args ...) body ...))
         (define (func args ...) (list 'func args ...))))))
  (define-command (return a) a)
  (define-command (>>= m f) (runIO (f (runIO m))))
  (define-command (read-int) (read))
  (define-command (put-line s) (display s) (newline))
  (define (runIO cmd)
    (apply (hash-table-get *command-table* (car cmd)) (cdr cmd)))
)

(define-module List
  (use srfi-1)
  (extend Monad)
  (export-all)
  (define (return a) (list a))
  (define (>>= m f) (append-map f m))
  (define (fail _) ())
)

(import List)
(import IO)
(use srfi-1)

(define f
  (beginM
    (put-line "Enter a number: ")
    (letM*
      ((n (read-int))
       (all-n (return (iota n 1)))
       (evens (return
                (with-monad List
                  (letM* ((i all-n)
                          (#t (return (even? i))))
                    (return i)))))
       )
      (return evens))))

(define (main args)
  (runIO (letM ((r f))
           (put-line (write-to-string r)))))

モジュールの依存関係がうまくいかなかったので、define-macro でごまかしてます。 そのため、>> などを個々のモナドで上書きする事ができなくなってしまいました。

(2005/04/19 21:57:37 PDT) IO モナドが実際には Continuation モナドだったので、 もうすこし IO モナドっぽく書き換えました。

Shiro(2005/08/14 20:44:24 PDT) こんなん考えてみました→Scheme:ExplicitMonad


rxmatch-fold

webstealでこのパターンを使っていたので、regexp-replace-all のソースから 該当部分を引っ張ってきました。

(define (rxmatch-fold kons knil regexp str)
  (cond ((and (not (equal? str "")) (regexp str))
         => (lambda (match)
              (when (= (rxmatch-start match) (rxmatch-end match))
                (error "rxmatch-fold: matching zero-length string causes infinite loop:" rx))
              (rxmatch-fold kons (kons match knil) regexp (rxmatch-after match))))
        (else knil)))

一つの文字列に連続してある正規表現をマッチさせていく時、 regexp-replace-all のように結果を文字列として埋め込むのではなく、 単にマッチ結果を使いたいだけという状況は結構あるんじゃないでしょうか。


相対URIから絶対URIへの変換

webstealのソースを見ていて唐突に書きたくなったので。 しかし、rfc.uriモジュールにそれっぽいコメントがあるのに実体がないのが気になります。

(use srfi-11)
(use srfi-13)
(use file.util)
(use rfc.uri)

(define (uri-relative->absolute uri base)
  (let*-values (((scheme specific) (uri-scheme&specific uri))
                ((authority path query fragment) (uri-decompose-hierarchical specific))
                ((base-scheme base-specific) (uri-scheme&specific base))
                ((base-authority base-path . _) (uri-decompose-hierarchical base-specific)))
    (if (or (and (string-null? path) (not (or scheme authority query)))
            scheme)
      uri
      (uri-compose :scheme base-scheme
                   :authority (or authority base-authority)
                   :path (if (or authority (string-prefix? "/" path))
                           path
                           (simplify-path (string-append (string-trim-right base-path #[^/]) path)))
                   :query query
                   :fragment fragment))))

このコードですが、実際にRFC2396にある例を使ってテストすると、 いくつか引っかかります。

discrepancies found.  Errors are:
test //g: expects "http://g" => got "http://g/"
test .: expects "http://a/b/c/" => got "http://a/b/c/."
test ./g/.: expects "http://a/b/c/g/" => got "http://a/b/c/g/."

uri-composeがpathの前に'/'を補うのと、 simplify-pathが最後の'.'を除去しないのが原因のようです。


macroexpandの参照する環境

macroexpandが参照する環境は何でしょうか。with-moduleで影響を受けないようなので、カレントモジュールではないようですが・・・

gosh> (define push! list)
push!
gosh> (with-module gauche (macroexpand '(push! x 1)))
(push! x 1)
gosh> (select-module gauche)
#<module gauche>
gosh> (macroexpand '(push! x 1))
(#<id 0x113d60 gauche::set!> x (#<id 0x113d10 gauche::cons> 1 x))

一致させようとすると実行に非常に大きなペナルティを伴うのです。 Gaucheのゴールは「スクリプトエンジン」ですので、バッチでスクリプトを がりがり実行する際に余分な負担となるものは入れない方針です。


vectorの展開

ベクターがクォートなしでマクロ内に現れた場合、展開後にIdentifierが残ってしまいます。

gosh> (define-syntax foo (syntax-rules () ((_) #(a b))))
#<syntax foo>
gosh> (foo)
#(#<id 0xee270 user::a> #<id 0xee230 user::b>)

R5RSによると、ベクターはクォートなしで現れてはいけないらしいので、バグとは言い切れないかもしれませんが・・・


式の比較

2つの式のマクロをすべて展開し、変数の名前を変えて、等しくなるかを調べる関数。
マクロ展開のテストケースを書くのに使えると思います。
すでに同様のものを誰かが書いているような気がしますが・・・

(define-module equal-expr
  (use srfi-1)
  (use util.match)
  (use util.list)
  (export equal-expr?))

(select-module equal-expr)

(define equal-table (make-hash-table))

(define id? (any-pred symbol? identifier?))

(define (valid-args? args)
  (or (null? args) (id? args)
      (and (pair? args) (id? (car args))
           (valid-args? (cdr args)))))

(define (flatten tree)
  (let loop ((tree tree) (result ()))
    (cond ((null? tree) result)
          ((pair? tree) (loop (car tree) (loop (cdr tree) result)))
          (else (cons tree result)))))

(define (macroexpand-unbound bound? expr)
  (if (or (not-pair? expr) (bound? (car expr)))
    expr
    (let ((expanded (macroexpand-1 expr)))
      (if (eq? expr expanded)
        expr
        (macroexpand-unbound bound? expanded)))))

(define (collect-internal-define bound? body)
  (let loop ((tail body) (head ()) (local-bound ()))
    (if (null? tail)
      (values (reverse head) local-bound #f)
      (let ((expanded (macroexpand-unbound bound? (car tail))))
        (if (or (not-pair? expanded)
                (pair? (car expanded))
                (bound? (car expanded)))
          (values (append-reverse head tail) local-bound #t)
          (case (unwrap-syntax (car expanded))
            ((define)
             (match (cdr expanded)
               ((or ((? id? var) _) (((? id? var) . _) _ ..1))
                (loop (cdr tail) (cons expanded head) (cons var local-bound)))))
            ((begin)
             (receive (rest new-local-bound term?) (loop (cdr expanded) () local-bound)
               (let ((new-begin (cons (car expanded) rest)))
                 (if term?
                   (values (append-reverse head (cons new-begin (cdr tail))) new-local-bound #t)
                   (loop (cdr tail) (cons new-begin head) new-local-bound)))))
            (else (values (append-reverse head tail) local-bound #t))))))))

(define (eq-unwrap? expr1 expr2)
  (eq? (unwrap-syntax expr1) (unwrap-syntax expr2)))
(define (equal-unwrap? expr1 expr2)
  (equal? (unwrap-syntax expr1) (unwrap-syntax expr2)))

(define (same-args-pattern? args1 args2)
  (or (and (not-pair? args1) (not-pair? args2)
           (eq? (null? args1) (null? args2)))
      (and (pair? args1) (pair? args2)
           (same-args-pattern? (cdr args1) (cdr args2)))))

(define (%equal-expr? subst expr1 expr2)
  (cond ((and (id? expr1) (id? expr2))
         (cond ((assq-ref subst expr1) => (pa$ eq? expr2))
               (else (and (not (rassq expr2 subst))
                          (eq-unwrap? expr1 expr2)))))
        ((and (pair? expr1) (pair? expr2))
         (let ((expanded1 (macroexpand-unbound (cut assq <> subst) expr1))
               (expanded2 (macroexpand-unbound (cut rassq <> subst) expr2)))
           (cond ((and (pair? expanded1) (pair? expanded2)
                       (id? (car expanded1)) (id? (car expanded2))
                       (not (assq (car expanded1) subst))
                       (not (rassq (car expanded2) subst))
                       (eq-unwrap? (car expanded1) (car expanded2))
                       (hash-table-get equal-table (unwrap-syntax (car expanded1)) #f))
                  => (cut <> subst (cdr expanded1) (cdr expanded2)))
                 (else (equal-expr-list? subst expanded1 expanded2)))))
        (else (equal-unwrap? expr1 expr2))))

(define (every* pred . args)
  (if (any null? args)
    (every null? args)
    (and (apply pred (map car args))
         (apply every* pred (map cdr args)))))

(define (equal-expr-list? subst lst1 lst2)
  (every* (pa$ %equal-expr? subst) lst1 lst2))

(define (equal-expr-rest? subst rest1 rest2)
  (every* (pa$ equal-expr-list? subst) rest1 rest2))

(define (equal-expr-body? subst body1 body2)
  (receive (new-body1 vars1 _) (collect-internal-define (cut assq <> subst) body1)
    (receive (new-body2 vars2 _) (collect-internal-define (cut rassq <> subst) body2)
      (equal-expr-list? (fold acons subst vars1 vars2) new-body1 new-body2))))

(define equal-expr? (pa$ %equal-expr? ()))

(hash-table-put! equal-table 'quote
  (lambda (subst rest1 rest2)
    (equal-unwrap? rest1 rest2)))

(hash-table-put! equal-table 'quasiquote
  (lambda (subst rest1 rest2)
    (let loop ((depth 0) (expr1 (car rest1)) (expr2 (car rest2)))
      (cond ((or (not-pair? expr1) (not-pair? expr2)) (equal-unwrap? expr1 expr2))
            ((and (id? (car expr1)) (id? (car expr2))
                  (eq-unwrap? (car expr1) (car expr2)))
             (case (unwrap-syntax (car expr1))
               ((quasiquote)
                (loop (+ depth 1) (cadr expr1) (cadr expr2)))
               ((unquote unquote-splicing)
                (if (zero? depth)
                  (%equal-expr? subst (cadr expr1) (cadr expr2))
                  (loop (- depth 1) (cadr expr1) (cadr expr2))))
               (else (loop depth (cdr expr1) (cdr expr2)))))
            (else
             (and (loop depth (car expr1) (car expr2))
                  (loop depth (cdr expr1) (cdr expr2))))))))

(hash-table-put! equal-table 'cond
  (lambda (subst rest1 rest2)
    (match rest1
      (((clause1 ..1) ..1)
       (match rest2
         (((clause2 ..1) ..1)
          (equal-expr-rest? subst clause1 clause2)))))))

(hash-table-put! equal-table 'case
  (lambda (subst rest1 rest2)
    (match rest1
      ((key1 (datum1 rest1 ..1) ..1)
       (match rest2
         ((key2 (datum2 rest2 ..1) ..1)
          (and (%equal-expr? subst key1 key2)
               (equal-unwrap? datum1 datum2)
               (equal-expr-rest? subst rest1 rest2))))))))

(hash-table-put! equal-table 'let
  (lambda (subst rest1 rest2)
    (match rest1
      (((((? id? vars1) vals1) ...) body1 ...)
       (match rest2
         (((((? id? vars2) vals2) ...) body2 ...)
          (and (equal-expr-list? subst vals1 vals2)
               (equal-expr-body? (fold acons subst vars1 vars2) body1 body2)))
         (_ #f)))
      (((? id? func1) (((? id? vars1) vals1) ...) body1 ..1)
       (match rest2
         (((? id? func2) (((? id? vars2) vals2) ...) body2 ..1)
          (and (equal-expr-list? subst vals1 vals2)
               (equal-expr-body? (acons func1 func2 (fold acons subst vars1 vars2)) body1 body2)))
         (_ #f))))))

(hash-table-put! equal-table 'lambda
  (lambda (subst rest1 rest2)
    (match rest1
      (((? valid-args? args1) body1 ..1)
       (match rest2
         (((? valid-args? args2) body2 ..1)
          (and (same-args-pattern? args1 args2)
               (equal-expr-body? (fold acons subst (flatten args1) (flatten args2)) body1 body2))))))))

(hash-table-put! equal-table 'define
  (lambda (subst rest1 rest2)
    (match rest1
      (((? id? var1) val1)
       (match rest2
         (((? id? var2) val2)
          (and (%equal-expr? subst var1 var2)
               (%equal-expr? subst val1 val2)))
         (_ #f)))
      (((func1 . (? valid-args? args1)) body1 ..1)
       (match rest2
         (((func2 . (? valid-args? args2)) body2 ..1)
          (and (same-args-pattern? args1 args2)
               (%equal-expr? subst func1 func2)
               (equal-expr-body? (fold acons subst (flatten args1) (flatten args2)) body1 body2)))
         (_ #f))))))

(hash-table-put! equal-table 'let*
  (lambda (subst rest1 rest2)
    (match rest1
      (((((? id? vars1) vals1) ...) body1 ...)
       (match rest2
         (((((? id? vars2) vals2) ...) body2 ...)
          (let loop ((subst subst) (vars1 vars1) (vars2 vars2) (vals1 vals1) (vals2 vals2))
            (or (and (null? vars1) (null? vars2)
                     (equal-expr-body? subst body1 body2))
                (and (pair? vars1) (pair? vars2)
                     (%equal-expr? subst (car vals1) (car vals2))
                     (loop (acons (car vars1) (car vars2) subst)
                           (cdr vars1) (cdr vars2) (cdr vals1) (cdr vals2)))))))))))

(hash-table-put! equal-table 'letrec
  (lambda (subst rest1 rest2)
    (match rest1
      (((((? id? vars1) vals1) ...) body1 ...)
       (match rest2
         (((((? id? vars2) vals2) ...) body2 ...)
          (let ((new-subst (fold acons subst vars1 vars2)))
            (and (equal-expr-list? new-subst vals1 vals2)
                 (equal-expr-body? new-subst vals1 vals2)))))))))

(hash-table-put! equal-table 'do
  (lambda (subst rest1 rest2)
    (match rest1
      (((((? id? vars1) inits1 updates1 ...) ...) (test1 ..1) body1 ...)
       (match rest2
         (((((? id? vars2) inits2 updates2 ...) ...) (test2 ..1) body2 ...)
          (let ((new-subst (fold acons subst vars1 vars2)))
            (and (equal-expr-list? subst inits1 inits2)
                 (equal-expr-rest? new-subst updates1 updates2)
                 (equal-expr-list? new-subst test1 test2)
                 (equal-expr-body? new-subst body1 body2)))))))))

(hash-table-put! equal-table 'receive
  (lambda (subst rest1 rest2)
    (match rest1
      (((? valid-args? args1) expr1 body1 ..1)
       (match rest2
         (((? valid-args? args2) expr2 body2 ..1)
          (and (same-args-pattern? args1 args2)
               (%equal-expr? subst expr1 expr2)
               (equal-expr-body? (fold acons subst (flatten args1) (flatten args2)) body1 body2))))))))

(provide "equal-expr")

使用例

gosh> (equal-expr? '(let ((val val)) (set! val (cdr val)) (car val)) '(pop! val))
#f
gosh> (equal-expr? '(let ((x val)) (set! val (cdr x)) (car x)) '(pop! val))
#t

多値と一時変数

多値は便利なのですが、多値を使うために一時変数を使わざるを得ないのが個人的には面倒です。
一時変数は、同じ値が複数の場所で使われる場合や、式が複雑になりすぎて分割したい場合にしか必要性を感じないのに、多値が出てくるとそれだけで変数名を考えなければならなくなります。
もう少し、一時変数を介さずに使える多値の関数が欲しいですね。
使いどころが限られるものしか作れないかもしれませんが。


Scheme:多値の引数へのスプライシング

Scheme:戻り値のスプライシングのお試し実装に移ったようです。


多値のそれぞれの値に別の関数を適用する

多値のコードを組んでいると、cut-seaさんがScheme:多値の分配で書いているapply-val-to-funcsのように、多値のそれぞれに別の関数を適用したくなる事があります。
多値の一番目の値のみ加工して返したり、リスト構造を渡り歩いて多値を集めたりする場合です。
ただ、apply-val-to-funcsだと一引数に限定されるので、以下のようなものを考えてみました。(既出だったらすみません)

最新のコードはScheme:多値の分配にありますが、以下の議論で参照しているので一応古いコードを残しておきます。

(use srfi-11)

(define-syntax call-each-values
  (syntax-rules ()
    ((_ (func funcs ...) args ...)
     (call-each-values "gensym" () () (args ...) (funcs ...) (func funcs ...) (args ...)))
    ((_ "gensym" l (lr ...) () () (func ...) (args ...))
     (call-each-values "bind" () (l lr ...) (l lr ...) (func ...) (args ...)))
    ((_ "gensym" l (lr ...) () (f g ...) (func ...) (args ...))
     (call-each-values "gensym" () (l lr ...) (args ...) (g ...) (func ...) (args ...)))
    ((_ "gensym" (tr ...) (lr ...) (a b ...) (f ...) (func ...) (args ...))
     (call-each-values "gensym" (t tr ...) (lr ...) (b ...) (f ...) (func ...) (args ...)))
    ((_ "bind" (b ...) (() ...) ((l ...)  ...) (func ...) ())
     (let-values (b ...) (values (func l ...) ...)))
    ((_ "bind" (b ...) ((v vr ...) ...) ((l ...) ...) (func ...) (arg args ...))
     (call-each-values "bind" (((v ...) arg) b ...) ((vr ...) ...) ((l ...) ...) (func ...) (args ...)))))

使用例

(define (qr-list a b)
  (if (or (null? a) (null? b))
    (values () ())
    (call-each-values (cons cons)
      (quotient&remainder (car a) (car b))
      (qr-list (cdr a) (cdr b)))))

gosh> (qr-list '(10 9 8 7 6) '(5 4 3 2 1))
(2 2 2 3 6)
(0 1 2 1 0)

見てくれが通常の再帰に近くなるし、一時変数を使う必要もありません。

More ...