Gauche:Experimental:MultiCollection

Gauche:Experimental:MultiCollection

yamasushi(2013/05/04 04:55:48 UTC)多値のコレクションです。

http://chaton.practical-scheme.net/gauche/a/2013/05/04#entry-5184950c-c6cb8

yamasushi
なぞの概念として「多値のコレクション」と書いてきましたが、とりあえず、形にしてみました。 http://practical-scheme.net/wiliki/wiliki.cgi?Gauche%3aExperimental%3aMultiCollection

多値は目に見えないもので、直積、タプルとして見えるのは、そういうふうに観測したからと解釈しました。つまり、観測できないデータ構造という考え方です。

これがあるとなにが嬉しいのかと問われると、困るのですが、ただイテレータが多値になったらどうなの？という自分への問いに答えてみたというか・・・

また、generatorは終端条件がeofオブジェクトなので、多値に拡張できないので、コレクションを使ってみたとも言えます。

コード 

;;; collection.scmを改造
;;; Shuji Yamamoto ("yamasushi")

;;; collection.scm - collection generics
;;;
;;;   Copyright (c) 2000-2013  Shiro Kawai  <shiro@acm.org>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

; マニュアルより:
;--------------------------------------------------------------------------------------------
; call-with-iterator collection proc :key start
; 基礎となるイテレータ構築メソッドです。
; このメソッドはコレクションCOLLECTIONから繰り返しのための二つの手続きを作成し、
; それらを引数として手続きPROCを呼びます。
;
; 作られる最初の手続きは終了判定手続きで、引数無しで呼び出され、繰り返しが
; 終了していれば`#t'を、まだ要素が残っていれば`#f'を返します。
;
; 作られる二番目の手続きはインクリメント手続きで、呼ばれる度に現在の要素を返し、
; 内部のポインタを次の要素へと進めます。
;
; 終了判定手続きが`#t'を返した後にインクリメント手続きを呼んだ場合の動作は未定義です。
;
; コレクションがシーケンスでもある場合、インクリメント手続きはシーケンスの順番に要素を取り出します。
;
; キーワード引数STARTが与えられていればイテレーションの範囲は
; START番目の要素から最後の要素までとなります。シーケンスでないコレクションに
; 対してはSTART引数は意味を持ちません。
;--------------------------------------------------------------------------------------------

;--------------------------------------------------------------------------------------------
; call-with-builder collection-class proc :key size
; 基礎的なビルダー構築メソッドです。
; ビルダーはコレクションをインクリメンタルに作成する方法です。
; コレクションクラスによってはこの手続きを提供しないものもあります。
;
; COLLECTION-CLASSは作成されるコレクションのクラスです。
; このメソッドは、追加手続きと結果手続きの二つの手続きを作成し、それらを
; 引数としてPROCを呼びます。
;
; 追加手続きは *一つ* 引数を取り、それを作成中のコレクションに追加します。
; 結果手続きは引数を取らず、作成されたコレクションを返します。
; 結果手続きが呼ばれた後で追加手続きを呼んだ場合の動作は未定義です。
;
; 作られるコレクションのサイズが分かっている場合、キーワード引数SIZEを与える
; ことができます。
; コレクションクラスによってはその情報を使って効率的にコレクションを作成することができます。
; その情報を単に無視するコレクションクラスもあります。
; SIZE個より多くの要素が追加されたり、SIZE個の要素が追加される前に
; 結果手続きが呼ばれたりした場合の動作は未定義です。
;
; コレクションクラスがシーケンスクラスであった場合、追加手続きは要素を
; シーケンスの順に追加してゆきます。
;
; コレクションクラスによっては、コレクションオブジェクトの初期化のために
; 他のキーワード引数を取るかもしれません。
;
; このメソッドはPROCが返す値を返します。
;--------------------------------------------------------------------------------------------

; call-with-iteratorで渡される、インクリメント手続きが多値を返せばどうなるだろうか？
; これは多値のコレクションを決めるのだろうか?

; call-with-builderの追加手続きが複数のパラメータを受け取るとき、多値のコレクションを構築すると言えるか？

(define-module multi.multi-collection
  ;(use srfi-1)
  (use gauche.collection)
  (use gauche.mop.singleton)
  (use util.queue)
  ;
  (export
    <unfold>
    empty-collection null-collection
    empty?
    collections->multi-collection x->multi-collection
    multi-unfold multi-unfoldn
    for-each
    map-to map multi-map
    fold multi-foldn
    filter filter-to
    multi-concatenate multi-append
    with-multi-iterator with-multi-builder
    call-with-multi-iterator call-with-multi-builder
    <multi-collection>)
)
(select-module multi.multi-collection)
(autoload komono-combinator tee) ; tee for debug

(define-class <multi-collection> [] [] )


; ----------------
;; call-with-builders
;; ( call-with-iteratorsを改造 )
;; n-ary case aux. proc
(define (call-with-builders clases proc)
  (let loop ([clases clases]
             [aprocs '()]
             [gprocs '()])
    (if (null? clases)
      (proc (reverse! aprocs) (reverse! gprocs))
      (with-builder ((car clases) add! get)
        (loop (cdr clases) (cons add! aprocs) (cons get gprocs))))))

; basic operation
(define-method empty? ((coll <collection>))
  (with-iterator (coll end? _ )
    (end?) ) )
(define-method empty? ((list <list>)) (null? list))

; <unfold>
(define-class <unfold> [<collection>]
  [ (p        :init-keyword :p    :init-value #f)
    (f        :init-keyword :f    :init-value #f)
    (g        :init-keyword :g    :init-value #f)
    (tail-gen :init-keyword :tail-gen :init-value #f)
    (seed     :init-keyword :seed :init-value (undefined) )
    ] )

(define-method call-with-iterator ((self <unfold>) proc :key start)
  (and-let* [ [p (slot-ref self'p)]
              [f (slot-ref self'f)]
              [g (slot-ref self'g)]
            ]
    (let [[seed     (slot-ref self'seed)]
          [tail-gen (slot-ref self'tail-gen) ]
          [tail-end? #f]
          [tail-next #f]
          ]
      (if (undefined? seed)
        #f
        (proc
          ; end?
          (^[]
            (let/cc next-of-end?
              (if tail-end?
                (tail-end?)
                (if (p seed)
                  (if tail-gen
                    (call-with-iterator (tail-gen seed)
                      (^[end? next]
                        (set! tail-end? end?)
                        (set! tail-next next)
                        (next-of-end? (tail-end?) )
                        ) )
                    #t)
                  #f) ) ) )
          ; next
          (^[]
            (if tail-next
              (tail-next)
              (begin0 (f seed) (set! seed (g seed) ) ) ) )
        ) ) ) ) )

; ----------------


(define-syntax with-multi-iterator
  (syntax-rules ()
    [(_ (coll end? next . opts) . body)
     (call-with-multi-iterator coll (^[end? next] . body) . opts)]))

(define-syntax with-multi-builder
  (syntax-rules ()
    [(_ (class add! get . opts) . body)
     (call-with-multi-builder class (^[add! get] . body) . opts)]))

(define-method call-with-multi-iterator ((collection <multi-collection> proc :key start))
  (error "call-with-multi-iterator が実装されていない" ) )

;--------------------------------------------------------------------
; 自明なコレクション

; empty
; 空のコレクションは列挙そのものをしないから、<collection>でもあり<multi-collection>でもある。
(define-class <empty-collection> [<multi-collection> <collection> <singleton-mixin>] [] )
(define empty-collection (instance-of <empty-collection>) )

(define-method call-with-multi-iterator ((self <empty-collection>) proc :key start)
  (proc (^[] #t) ; (end?) is always true
        (^[] (error "attempt to iterate empty!") ) ) )

(define-method call-with-iterator ((self <empty-collection> proc :key start))
  (proc (^[] #t) ; (end?) is always true
        (^[] (error "attempt to iterate empty!") ) ) )

(define-method write-object ((self <empty-collection>) port)
  (format port "<empty-collection>") )

; 空の多値を返す無限collection(emptyではない)
(define-class <null-collection> [<multi-collection> <singleton-mixin>] [] )
(define null-collection (instance-of <null-collection>) )
(define-method call-with-multi-iterator ((self <null-collection> proc :key start))
  (proc (^[] #f) (^[] (values) ) ) )
(define-method write-object ((self <null-collection>) port)
  (format port "<null-collection>") )

;--------------------------------------------------------------------
; multi-concatenateで使う
(define-class <concat-multi-collection> [<multi-collection>]
 [(colls  :init-keyword :colls :init-value #f)] )

(define-method call-with-multi-iterator ((self <concat-multi-collection>) proc :key start)
  (if (slot-ref self'colls)
    ($ values
      $* fold (^[coll _ ] ($ values->list $ call-with-multi-iterator coll proc) ) #f (slot-ref self'colls) )
    (errorf "call-with-multi-iterator ~a" self) ) )

(define-method write-object ((self <concat-multi-collection>) port)
  (format port "<concat-multi-collection colls:~a >" (slot-ref self'colls) ) )

;--------------------------------------------------------------------

; multi-map でつかう。
(define-class <mapped-multi-collection> [<multi-collection>]
 [(proc  :init-keyword :proc :init-value #f)
  (coll  :init-keyword :coll :init-value #f) ] )

(define-method call-with-multi-iterator ((self <mapped-multi-collection>) proc :key start)
  (if (and (slot-ref self'coll) (slot-ref self'proc) )
    (with-multi-iterator ((slot-ref self'coll) end? next)
      (proc end? (^[] (call-with-values next (slot-ref self'proc) ) ) ) )
    (errorf "call-with-multi-iterator ~a" self) ) )

(define-method write-object ((self <mapped-multi-collection>) port)
  (format port "<mapped-multi-collection coll:~a proc:~a>" (slot-ref self'coll) (slot-ref self'proc) ) )

;--------------------------------------------------------------------
; collections->multi-collectionで使う
(define-class <colls-multi-collection> [<multi-collection>]
 [(colls  :init-keyword :colls :init-value #f)] )

(define-method call-with-multi-iterator ((self <colls-multi-collection>) proc :key start)
  (if-let1 colls (slot-ref self'colls)
    (call-with-iterators colls
      (^[eprocs nprocs]
        (proc
          (^[] (any (cut <>) eprocs) )
          (^[] ($ values $* map (cut <>) nprocs) ) ) ) )
    (errorf "call-with-multi-iterator ~a" self) ) )

(define-method write-object ((self <colls-multi-collection>) port)
  (format port "<colls-multi-collection colls:~a >" (slot-ref self'colls) ) )

;-------------------------------------------------------
; multi-unfoldで使う
;
; p : 1 to 1 : seedをみて終了判定
; g : 1 to 1 : seed --> 次のseed
; f : 1 to n : seed --> element
(define-class <unfold-multi-collection> [<multi-collection>]
  [ (p        :init-keyword :p    :init-value #f)
    (f        :init-keyword :f    :init-value #f)
    (g        :init-keyword :g    :init-value #f)
    (tail-gen :init-keyword :tail-gen :init-value #f)
    (seed     :init-keyword :seed :init-value (undefined) )
    ] )

(define-method call-with-multi-iterator ((self <unfold-multi-collection>) proc :key start)
  (and-let* [ [p (slot-ref self'p)]
              [f (slot-ref self'f)]
              [g (slot-ref self'g)]
            ]
    (let [[seed     (slot-ref self'seed)]
          [tail-gen (slot-ref self'tail-gen) ]
          [tail-end? #f]
          [tail-next #f]
          ]
      (if (undefined? seed)
        #f
        (proc
          ; end?
          (^[]
            (let/cc next-of-end?
              (if tail-end?
                (tail-end?)
                (if (p seed)
                  (if tail-gen
                    (call-with-multi-iterator (tail-gen seed)
                      (^[end? next]
                        (set! tail-end? end?)
                        (set! tail-next next)
                        (next-of-end? (tail-end?) )
                        ) )
                    #t)
                  #f) ) ) )
          ; next
          (^[]
            (if tail-next
              (tail-next)
              (begin0 (f seed) (set! seed (g seed) ) ) ) )
        ) ) ) ) )

(define-method write-object ((self <unfold-multi-collection>) port)
  (format port "<unfold-multi-collection p:~a f:~a g:~a seed:~a >"
      (slot-ref self'p)
      (slot-ref self'f)
      (slot-ref self'g)
      (slot-ref self'seed)
      ) )

; multi-unfoldnで使う
; seeds .... m個
; p : m to 1 : seedをみて終了判定
; g : m to m : seed --> 次のseed
; f : m to n : seed --> element
(define-class <unfoldn-multi-collection> [<multi-collection>]
  [ (p        :init-keyword :p     :init-value #f)
    (f        :init-keyword :f     :init-value #f)
    (g        :init-keyword :g     :init-value #f)
    (tail-gen :init-keyword :tail-gen :init-value #f)
    (seeds    :init-keyword :seeds :init-value #f )
    ] )

(define-method call-with-multi-iterator ((self <unfoldn-multi-collection>) proc :key start)
  (and-let* [ [p     (slot-ref self'p)]
              [f     (slot-ref self'f)]
              [g     (slot-ref self'g)]
              [seeds (slot-ref self'seeds)]
            ]
    (let [[tail-gen (slot-ref self'tail-gen)]
          [tail-end? #f]
          [tail-next #f] ]
      (proc
        ; end?
        (^[]
          (let/cc next-of-end?
            (if tail-end?
              (tail-end?)
              (if (apply p seeds)
                (if tail-gen
                  (call-with-multi-iterator (apply tail-gen seeds)
                    (^[end? next]
                      (set! tail-end? end?)
                      (set! tail-next next)
                      (next-of-end? (tail-end?) )
                      ) )
                  #t)
                #f) ) ) )
        ; next
        (^[]
          (if tail-next
            (tail-next)
            (begin0 (apply f seeds) (set! seeds ($ values->list $ apply g seeds) ) ) ) )
      ) ) ) )


(define-method write-object ((self <unfoldn-multi-collection>) port)
  (format port "<unfoldn-multi-collection> p:~a f:~a g:~a seeds:~a >"
      (slot-ref self'p)
      (slot-ref self'f)
      (slot-ref self'g)
      (slot-ref self'seeds)
      ) )
;-------------------------------------------------------
; basic operation
(define-method empty? ((coll <multi-collection>))
  (with-multi-iterator (coll end? _ ) (end?) ) )

;-------------------------------------------------------
; multi-concatenate
(define (multi-concatenate colls)
  (make <concat-multi-collection> :colls colls) )

;-------------------------------------------------------
; multi-append
(define-method multi-append ( (coll <multi-collection>) . rest )
  (multi-concatenate `(,coll . ,rest) ) )

;-------------------------------------------------------

;; convertion from collections --------------------------
(define (collections->multi-collection colls )
  (make <colls-multi-collection> :colls colls) )

; -------------------------------------------------------
; 実験的。引数なしでx->multi-collection = (values)を無限にもつnull-collection
(define-method x->multi-collection () null-collection )

; 複数のコレクションからmulti-collection
(define-method x->multi-collection ( (coll <collection>) . rest )
  (collections->multi-collection `(,coll . ,rest) ) )

; --------------------------------------------------------
;; unfold
; p : 1 to 1 : seedをみて終了判定
; g : 1 to 1 : seed --> 次のseed
; f : 1 to n : seed --> element
; tail-gen pが#tを返したときのseedから残りの列を生成する
(define (multi-unfold p f g seed :optional (tail-gen #f) )
  (make <unfold-multi-collection> :p p :f f :g g :seed seed :tail-gen tail-gen) )

; --------------------------------------------------------
;; unfoldn
; seeds .... m個
; p : m to 1 : seedをみて終了判定
; g : m to m : seed --> 次のseed
; f : m to n : seed --> element
; tail-gen pが#tを返したときのseedから残りの列を生成する
(define (multi-unfoldn p f g tail-gen . seeds)
  (make <unfoldn-multi-collection> :p p :f f :g g :seeds seeds :tail-gen tail-gen) )

;; for-each ---------------------------------------------
; proc : n to *
(define-method for-each (proc (coll <multi-collection>) )
  ;#?=coll
  (with-multi-iterator (coll end? next) ; nextが多値を返す
    (until (end?)
      (call-with-values next proc) ) ) )

(define (for-each$ proc) (pa$ for-each proc))

;; fold -------------------------------------------------
; proc : n + 1 to 1
(define-method fold (proc seed (coll <multi-collection>) )
  (with-multi-iterator (coll end? next) ; nextが多値を返す
    (let loop ( (seed seed) )
      (if (end?)
        seed
        (loop ($ apply proc `( ,@($ values->list $ next) ,seed) )
          ) ) ) ) )


; proc : n + m to m
(define-method multi-foldn ((coll <multi-collection>) proc seed)
  (fold proc seed coll))

(define-method multi-foldn ((coll <multi-collection>) proc . seeds )
  (with-multi-iterator (coll end? next) ; nextが多値を返す
    (let loop ( (seeds seeds) )
      (if (end?)
        (apply values seeds)
        ($ loop $ values->list $ apply proc `( ,@($ values->list $ next) ,@seeds ) )
          ) ) ) )

;; multi-map --------------------------------------------------
; http://chaton.practical-scheme.net/gauche/a/2013/05/04#entry-51849847-4efb2
; Shiro
; あ、あと多値コレクションという主題からは外れますが、<multi-collection>へのmapは要素へのprocの適用をlazyにやるわけですが、
; 同じ関数で引数がeagerな構造ならeagerな評価、引数がlazyな構造ならlazyな評価、とオーバロードするのは私はうまくないと思いま
; す。このへんの関係: http://chaton.practical-scheme.net/gauche/a/2013/04/09#entry-5164639a-811eb
;
; http://chaton.practical-scheme.net/gauche/a/2013/04/09#entry-5164639a-811eb
; shiro
; ScalaのRangeの話 https://groups.google.com/forum/?hl=ja&fromgroups=#!topic/scala--tohoku/oKmOIiUPB04
; これってmapの動作を「入力がlazyなら出力もlazy; 入力がstrictなら出力もstrict
; 」にしてるのが根本的な問題な気がするんだけどどうなんだろ。
; lazy版とstrict版は色々違うのではっきり分けといた方が幸せではないかなあ。まあ2009
; 年の話だから今は違ってるのかもしれないけど。
; Gaucheは、動的型ってせいもあるけど、出力(動作)がlazyかどうかでlmapとmapで分けてて、どちらも入力はlazyでもstrict
; でもいい。計算済みのリスト突っ込んで出力はlazyに得たいって場合もあるし、入力lazy
; だけどどうせ全部使うから出力は一気に得たいって場合もある。lazy->lazy, strict->strict
; とする実用的な必然性ってあまり無いと思う。
(define-method multi-map(proc (coll <multi-collection>) )
  (make <mapped-multi-collection> :coll coll :proc proc) )

;; map --------------------------------------------------
; http://chaton.practical-scheme.net/gauche/a/2013/05/04#entry-5184975d-e6448
; Shiro
; mapが<multi-collection>を受け取って<multi-collection>を返す、というのは、理屈の上では綺麗です。
; Gaucheでmapは問答無用でリストを返すのは実用にすり寄ってる。

; proc : n to 1
(define-method map (proc (coll <multi-collection>) )
  (with-multi-iterator (coll end? next)
    (do ([q (make-queue)])
        [(end?) (queue->list q)]
      (enqueue! q (call-with-values next proc)))))

;; map-to --------------------------------------------------
; http://chaton.practical-scheme.net/gauche/a/2013/05/04#entry-5184975d-e6448
; Shiro
; ただまあGaucheのコンベンションに合わせるなら、
; mapはリストを返すのにとっといて、
; map-to <multi-collection-meta> でコレクションへの射影をやるのがいいかなあ。
(define-method map-to ((class <class>) proc (coll <multi-collection>) )
  (with-multi-builder (class add! get :size (size-of coll))
    (with-multi-iterator (coll end? next)
      (do ()
          [(end?) (get)]
        (call-with-values (compose proc next) add!) ) ) ) )

;; filter-to -----------------------------------------------
; pred : n --> boolean
(define-method filter-to ((class <class>) pred (coll <multi-collection>))
  (with-multi-builder (class add! get) ; add!は複数パラメータを受け入れる
    (with-multi-iterator (coll end? next)  ; nextは多値を返す
        (do ()
            [(end?) (get)]
            (let1 e ($ values->list $ next )
              (when (apply pred e) (apply add! e) )
        ) ) ) ) )

;; filter ------------------------------
; pred : n to boolean
(define-method filter (pred (coll <multi-collection>))
  (let1 q (make-queue)
    (with-multi-iterator (coll end? next)
      (until (end?)
        (let1 e ($ values->list $ next)
          (when (apply pred e) (enqueue! q e))))
      (queue->list q))))

;;------------------------------



;;------------------------------

(define-class <multi-test> [<multi-collection>]
  [(n :init-keyword :n :init-value 0) ] )

(define-method size-of ((self <multi-test>))
  (slot-ref self'n) )

(define-method call-with-iterator ((self <multi-test>) proc :key start)
  (let1 counter (slot-ref self'n)
    (proc (^[] (< counter 1) )
          (^[] (begin0 (values " hoge " counter " foo " ) (dec! counter) ) ) ) ) )

(define-class <multi-test2-meta> [<class>] [] )
(define-class <multi-test2> [<multi-collection>]
  [(coll :init-keyword :coll :init-value '()) ]
  :metaclass <multi-test2-meta> )
(define-method write-object ((self <multi-test2>) port)
  (format port "<multi-test2 ~a >" (slot-ref self'coll) ) )

(define-method call-with-iterator ((self <multi-test2>) proc :key start)
  (with-iterator ( (slot-ref self'coll) end? next :start start )
    (proc end? (^[] ($ values $* next ) ) )
    ) )

(define-method call-with-builder ((class <multi-test2-meta>) proc :key size)
  (let1 v (make <multi-test2> :coll '())
    (proc (^ arg (push! (slot-ref v'coll ) arg) )
          (^[] v) ) ) )

($ print
;$ map vector
;$ tee write
$ filter ($ odd? $ + $*)
$ with-builder (<multi-test2> add! get)
  (add! 0 1 2)
  (add! 1 2 3)
  (add! 2 3 4)
  (add! 3 4 5)
  (add! 4 5 6)
  (add! 5 6 7)
  (add! 6 7 8)
  (add! 7 8 9) (get) )


(define x (make <multi-test> :n 3))
(for-each print x)
($ for-each print
 ;$ tee write
 $ map-to <multi-test2> (cut values <> 'a <> " jag " <> ) x)

($ print
 $ fold (^[x y z s] (cons* x y z s) ) '()  x )

gosh> (define x (collections->multi-collection '((1 2) (3 4))))
x
gosh> (map vector x)
(#(1 3) #(2 4))
gosh> (multi-map vector x)
<mapped-multi-collection coll:<colls-multi-collection colls:((1 2) (3 4)) > proc:#<subr vector>>
gosh> ($ for-each print $ multi-map vector x)
#(1 3)
#(2 4)
#t

(define x (collections->multi-collection '((1   2  3)( 3  4  5)( 5  6 7)( 7  8 9)) ) )
(define y (collections->multi-collection '((11 12)(23 24)(35 36)(47 48)) ) )
(define z (collections->multi-collection '((31 32)(33 34)(35 36)(37 38)) ) )
(define w (multi-append x y z))

($ print $ values->list
  $ multi-foldn w (^ args
            (print args)
            (values (apply + args) (apply * args) ) )
            1 1 )

(define x (x->multi-collection '(1   2  3) '( 3  4  5) '( 5  6 7) '( 7  8 9) ) )

(for-each (cut print <> " " <>)
  (multi-unfold (^s (> s 5)) (^s (quotient&remainder s 3) ) (^s (+ s 1)) 0 ) )

(for-each (cut print <> " " <> " " <>)
  (multi-unfoldn (^[s t] (> s 5) ) (^[s t] (values (* 10 s) (* 100 t) (* 1000 (+ s t) ) ) ) (^[s t] (values (+ s 1) (+ t 3) ) ) #f 1 1 ) )

; tail-gen指定のunfold

(for-each (cut print <> " " <>)
  (multi-unfold
    (^s (> s 5))
    (^s (quotient&remainder s 3) )
    (^s (+ s 1))
    0
    (^s
      (x->multi-collection
        (iota 10 s)
        (iota 10 (* 2 s) ) ) )
    ) )

(for-each (cut print <> " " <> " " <>)
  (multi-unfoldn
    (^[s t] (> s 5) )
    (^[s t] (values (* 10 s) (* 100 t) (* 1000 (+ s t) ) ) )
    (^[s t] (values (+ s 1) (+ t 3) ) )
    (^[s t]
      (x->multi-collection
        (iota 10 s)
        (iota 10 t)
        (iota 10 (+ s t) ) ) )
    1 1 ) )

multi-foldnについて

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

  • fuyuki: applyでの多値のsplicingはfoldをいじくってたときにほしくなりました。 なんでfoldは多値を回せないんだろうって疑問に思ったことありません？
  • Shiro: あるある。無理矢理やろうとすると、srfi-37みたいに 複数のseedを持ち回ることになるんだけれど、あれはあれで使いにくいし、 fold対象のリストが複数になった場合との相性が良くない。結局、 いちいちリストにパックしたりとかしなくちゃならない。

背景

起源

発端

懐疑的な意見

新たな展開

関連する話題

Post a comment

Name:

Tags: Experimental, 多値

Topics
Sponsored Links
Search
Recent Changes
More ...
Last modified : 2013/05/12 07:19:32 UTC
WiLiKi 0.8.3 running on Gauche 0.9.15