Gauche:共通の「命令」をつかう処理を記述する

yamasushi(2013/03/30 04:34:39 UTC)リスト処理のなかには、共通の「命令セット」のようなものがあり、それだけを使ったコードなら、別のデータにも使えるというケースがあると思いました。
yamasushi(2013/03/30 21:51:29 UTC)listなど基本的な列データならコレクションを使えばよいのですが、無限列を考えると、統一したインターフェースがないように思いました。それで、以下のような試みをしてみました。
yamasushi(2013/04/13 11:26:28 UTC)無限列のほかにもdictionaryも同じような「命令セット」をつくれそうな気がしています。

; 命令セット
(use gauche.generator)
(use gauche.lazy)
(use util.stream)
(use srfi-13)


(define-macro (inst-generator sym)
  (case sym
    ((append      ) gappend)
    ((car         ) #f)
    ((cdr         ) #f)
    ((concatenate ) gconcatenate)
    ((cons        ) gcons*)
    ((cons*       ) gcons*)
    ((drop        ) gdrop )
    ((drop-while  ) gdrop-while)
    ((filter      ) gfilter    )
    ((filter-map  ) gfilter-map)
    ((fold        ) generator-fold)
    ((fold-right  ) generator-fold-right)
    ((for-each    ) generator-for-each)
    ((iota        ) giota)
    ((map         ) gmap )
    ((map-accum   ) gmap-accum)
    ((merge       ) gmerge)
    ((null        ) null-generator)
    ((range       ) grange)
    ((rxmatch     ) grxmatch)
    ((slices      ) gslices)
    ((state-filter) gstate-filter)
    ((take        ) gtake)
    ((take-while  ) gtake-while)
    ((unfold      ) gunfold)
    ((*->generator ) identity)
    ((*->list      ) generator->list)
    ((*->lseq      ) generator->lseq)
    ((*->stream    ) #f )
    ((*->string    ) #f )
    ((list->*      )     list->generator)
    ((port->byte-* )     port->byte-generator)
    ((port->char-* )     port->char-generator)
    ((port->line-* )     port->line-generator)
    ((port->sexp-* )     port->sexp-generator)
    ((reverse-bits->*  ) reverse-bits->generator)
    ((reverse-vector->*) reverse-vector->generator)
    ((string->*        ) string->generator)
    ((vector->*        ) vector->generator)
    ((x->*             ) x->generator)
    (else #f)
))

(define-macro (inst-lseq sym)
  (case sym
    ((append      ) lappend)
    ((car         ) car)
    ((cdr         ) cdr)
    ((concatenate ) lconcatenate)
    ((cons        ) lcons )
    ((cons*       ) lcons*)
    ((drop        ) drop*)
    ((drop-while  ) drop-while)
    ((filter      ) lfilter)
    ((filter-map  ) lfilter-map)
    ((fold        ) fold)
    ((fold-right  ) fold-right)
    ((for-each    ) for-each)
    ((iota        ) liota)
    ((map         ) lmap)
    ((map-accum   ) lmap-accum)
    ((merge       ) #f)
    ((null        ) '())
    ((range       ) lrange)
    ((rxmatch     ) lrxmatch)
    ((slices      ) #f )
    ((state-filter) lstate-filter)
    ((take        ) ltake)
    ((take-while  ) ltake-while)
    ((unfold      ) lunfold)
    ((*->generator) list->generator ) ; ?
    ((*->list     )  identity)
    ((*->lseq     )  identity)
    ((*->stream   )  #f )
    ((*->string   )  list->string )
    ((list->*     )  x->lseq )
    ((port->byte-*     ) ($ generator->lseq $ port->byte-generator $) )
    ((port->char-*     ) ($ generator->lseq $ port->char-generator $) )
    ((port->line-*     ) ($ generator->lseq $ port->line-generator $) )
    ((port->sexp-*     ) ($ generator->lseq $ port->sexp-generator $) )
    ((reverse-bits->*  ) ($ generator->lseq $ reverse-bits->generator $) )
    ((reverse-vector->*) ($ generator->lseq $ reverse-vector->generator $) )
    ((string->*        ) ($ generator->lseq $ string->generator $) )
    ((vector->*        ) ($ generator->lseq $ vector->generator $) )
    ((x->*             ) x->lseq )
    (else #f)
))

(define-macro (inst-stream sym)
  (case sym
    ((append      ) stream-append)
    ((car         ) stream-car)
    ((cdr         ) stream-cdr)
    ((concatenate ) stream-concatenate)
    ((cons        ) stream-cons)
    ((cons*       ) stream-cons*)
    ((drop        ) stream-drop)
    ((drop-while  ) stream-drop-while)
    ((filter      ) stream-filter)
    ((filter-map  ) #f )
    ((fold        ) #f )
    ((fold-right  ) #f )
    ((for-each    ) stream-for-each)
    ((iota        ) #f ) ; stream-iotaは仕様が違う
    ((map         ) stream-map)
    ((map-accum   ) #f )
    ((merge       ) #f )
    ((null        ) stream-null)
    ((range       ) #f )
    ((rxmatch     ) #f )
    ((slices      ) #f )
    ((state-filter) #f )
    ((take        ) stream-take)
    ((take-while  ) stream-take-while)
    ((unfold      )  #f )
    ((*->generator )     #f )
    ((*->list      )     stream->list)
    ((*->lseq      )     #f )
    ((*->stream    )     identity)
    ((*->string    )     stream->string)
    ((list->*      )     list->stream)
    ((port->byte-* )     #f)
    ((port->char-* )     #f)
    ((port->line-* )     #f)
    ((port->sexp-* )     #f)
    ((reverse-bits->* )  #f)
    ((reverse-vector->*) #f)
    ((string->*)         string->stream)
    ((vector->*)         #f)
    ((x->*     )         #f)
    (else #f)
))

(define-macro (inst-string sym) ; 文字列についても試してみます。
  (case sym
    ((append      ) string-append)
    ((car         ) #f)
    ((cdr         ) #f)
    ((concatenate ) string-concatenate)
    ((cons        ) #f)
    ((cons*       ) #f)
    ((drop        ) string-drop )
    ((drop-while  ) #f)
    ((filter      ) string-filter )
    ((filter-map  ) #f)
    ((fold        ) string-fold)
    ((fold-right  ) string-fold-right)
    ((for-each    ) string-for-each)
    ((iota        ) #f)
    ((map         ) string-map )
    ((map-accum   ) #f)
    ((merge       ) #f)
    ((null        ) "")
    ((range       ) #f)
    ((rxmatch     ) #f) ; ! stringのrxmatchと列のrxmatchのあつかいの違い
    ((slices      ) #f)
    ((state-filter) #f)
    ((take        ) string-take)
    ((take-while  ) #f)
    ((unfold      )  string-unfold)
    ((*->generator)  string->generator )
    ((*->list     )  string->list)
    ((*->lseq     )  ($ x->lseq $ string->list $) )
    ((*->stream   )  string->stream )
    ((*->string   )  string->list )
    ((list->*     )  list->string )
    ((port->byte-*     ) #f)
    ((port->char-*     ) #f)
    ((port->line-*     ) #f)
    ((port->sexp-*     ) #f)
    ((reverse-bits->*  ) #f)
    ((reverse-vector->*) #f)
    ((string->*        ) identity)
    ((vector->*        ) ($ list->string $ vector->list $) )
    ((x->*             ) x->string) ; ! これはまずい
    (else #f)
  ))

(define-macro (define-with-inst-set name inst-set proc . param)
  (let [[arg  (gensym)]
        [code (map (^s (macroexpand `(,inst-set ,s)) ) param)]
        ]
    ;(print code)
    (if (every identity code )
      (begin
        ;(print code)
        `(define (,name . ,arg)
           (apply ,proc ,@code ,arg) ) )
      (error (format #f "未対応のコードがあります ~a --> ~a " param code) )
    ) ) )

(define (hoge appendfn foreachfn x->*fn x y)
  ($ foreachfn print $ appendfn (x->*fn x) (x->*fn y) ) )

(define-with-inst-set hoge-generator inst-generator hoge append for-each x->* )
(define-with-inst-set hoge-lseq      inst-lseq      hoge append for-each x->* )
(define-with-inst-set hoge-stream    inst-stream    hoge append for-each x->* )
(define-with-inst-set hoge-string    inst-string hoge append for-each x->* )

(hoge-lseq "123" "456")
(hoge-lseq '(a b c) '(d e f))

(hoge-generator "123" "456")
(hoge-generator '(a b c) '(d e f))

(hoge-string "123" "456")
(hoge-string '(a b c) '(d e f)) ; !うまくいかない

• 齊藤 : やりたいことがよくわからないので見当外れかもしれませんが、オブジェクトシステム (CLOS) を活用できる場面ではないでしょうか。 map や for-each 等は gauche.collection モジュールを use することでリストだけでなく他のコレクションに適用できるように拡張されたりもしますよ。 http://practical-scheme.net/gauche/man/?l=jp&p=gauche.collection

• yamasushi ジェネレータで書いたコードをストリームや遅延シーケンスでも動くようにするというのがもともとの動機です。クラスの支援が受けられないタイプのデータなので・・・・(無限列を包括するようなクラスがあればいいのですが・・・)(2013/03/30 21:46:26 UTC)
  "OpenSearchを使うAPIにアクセスする"のもともとのコードはジェネレータで書いていたのですが、べつにジェネレータじゃなくてもいいということに気づいたのでした。そして、「命令」部分をパラメータの先頭に書いたわけです。(2013/03/30 21:59:58 UTC)
  

• Shiro(2013/04/11 22:15:46 UTC): まあどうせinst-***を渡さなければならないのなら、メタなクラスを渡すようにしてそれでディスパッチしても同じかなという気はしますが。

  (define-class <generator-dispatcher> () :metaclass <singleton-meta>)
  (define generator-dispatcher (instance-of <generator-dispatcher>))
  
  (define-method generic-append ((dispatcher <generator-dispatcher>) . args) (apply gappend args))
  (define-method generic-map ((dispatcher <generator-dispatcher>) proc . args)
  (apply gmap proc args))
  

  そんで、

  (define (compose-with-dispatcher dispatcher . procs)
    (if (null? procs)
      identity
      (lambda (var)
        ((car procs) dispatcher ((apply compose-with-dispatcher dispatcher (cdr procs)) var)))))
  

  みたいにdispatcherを第一引数に渡してゆくようなcomposeと組み合わせるとか。(つまり、引数そのものによってディスパッチするのではなく、ディスパッチ用の情報を別に流し込んでやるということです。Scheme:ExplicitMonadと似た発想。)
  • yamasushi(2013/04/13 11:18:41 UTC)このdispatcherのmethodを、命令コードのシンボルのリストと「命令セット」(上で定義しているもの)から生成できればいいのかなと考えました。

    (define instsym-seq '(append car cdr concatenate cons cons* drop drop-while filter filter-map fold fold-right for-each
    iota map map-accum merge null range rxmatch slices state-filter take take-while unfold
    *->generator *->list *->lseq *->stream *->string list->* port->byte-* port->char-* port->line-*
    port->sexp-* reverse-bits->* reverse-vector->* string->* vector->* x->*))
    ; このリストと「命令セット」からdispacherを生成する。
    

    どうも、マクロのことがよくわかっていないので、うまくできないのですが・・・(汗
    マクロで「命令セット」を定義したのも、このようなことをするにはマクロかなあと漠然と考えたからなのでした。

    ; instsym ... 命令シンボル
    ; instset ... 命令セット
    (define-macro (define-dispatcher prefix instsym instset)
      (let* [[arg (gensym)]
             [str #`",(symbol->string prefix)-dispatcher"]
             [cls (string->symbol (string-append "<" str ">" ))]
             [obj (string->symbol str)]]
        `(begin
          (use gauche.mop.singleton)
          (define-class ,cls () () :metaclass <singleton-meta>)
          (define ,obj (instance-of ,cls))
          
          ; (methodを生成する)
          
          ) ) )
    

    ここまで書いたのはいいのですが、肝心のmethod生成で詰まってます。

• Shiro(2013/04/11 22:15:46 UTC): あと上のコードでinsn-* は単なる手続きで良いのでは? そしたらdefine-with-insn-setでmacroexpandを呼ばなくても済みます。 マクロはcomposabilityの点で手続きより扱いが面倒なので、手続きで抽象化出来るならなるべく手続き使った方がいいかなと。

• yamasushi(2013/04/12 23:28:19 UTC)マクロより手続きを使ったほうがよいのですね。マクロをつかったほうがいいのかなあとなんとなく思ってしまったでした。
  compose-with-dispatcher、おもしろそうですね。CLOSSのことはよくわかっていないので勉強になります。
  • 手続きを使ったものを書いて見ました。(yamasushi2013/04/13 01:38:54 UTC)

    (define (lambda-with-inst-set proc inst-set . param)
      (let1 code (map inst-set param)
        (if (every identity code )
          (^ arg (apply proc (append code arg) ) )
          (error (format #f "未対応のコードがあります ~a --> ~a " param code) )
        ) ) )
    
    (define-macro (define-with-inst-set name inst-set proc . param)
      `(define ,name (lambda-with-inst-set ,proc ,inst-set ,@(map (^c `(quote ,c)) param) ) ) )