Gauche:MOP:GenericCollection

yamasushi(2013/05/15 21:41:28 UTC) Scheme:MOP:パラメタライズドクラスでつくったものを部品化しました。

• generic-collection
• generic-sequence

generic-collection

;---------------------------------------------------------------
; generic-collection
;---------------------------------------------------------------
; Scheme:MOP:パラメタライズドクラス
; http://practical-scheme.net/wiliki/wiliki.cgi?Scheme%3aMOP%3a%E3%83%91%E3%83%A9%E3%83%A1%E3%82%BF%E3%83%A9%E3%82%A4%E3%82%BA%E3%83%89%E3%82%AF%E3%83%A9%E3%82%B9

(define-module generic.collection (extend gauche.collection)
  (export
    <generic-collection-meta>
    <generic-collection>
  ) )
(select-module generic.collection)

(define-class <generic-collection-meta> [<class>]
  [ (collection-type :init-keyword :collection-type :init-value  #f )
    (collection-opts :init-keyword :collection-opts :init-value '() )
    (collection-make :init-keyword :collection-make :init-value  #f )
    (collection-put! :init-keyword :collection-put! :init-value  #f )
    (element-type    :init-keyword :element-type    :init-value  <top>) ] )

(define-method compute-slots ((class <generic-collection-meta>))
  (and-let* [ [type (slot-ref class'collection-type ) ]
              [opts (slot-ref class'collection-opts ) ]
              [empty (if-let1 %make (slot-ref class'collection-make)
                        (apply %make opts)
                        (apply call-with-builder type (^[ _ get] (get) ) opts) ) ] ]
    (slot-push! class 'direct-slots
                `(elements :init-keyword :elements :init-value ,empty) ) )
  (next-method) )

(define-class <generic-collection> [ <collection> ] [] :metaclass <generic-collection-meta>)

(define-method write-object ((self <generic-collection-meta>) port)
  (format port "<generic-collection-meta type:~a opts:~a elem-type:~a >"
    (slot-ref self'collection-type )
    (slot-ref self'collection-opts )
    (slot-ref self'element-type    ) ) )

(define-method write-object ((self <generic-collection>)      port)
  (format port "<generic-collection class:~a elems:~a >" (class-of self) (slot-ref self'elements) ) )

(define-method size-of ((self <generic-collection>))
  (and-let* [[elems (slot-ref self'elements)]] (size-of elems) ) )

(define-method call-with-iterator ((self <generic-collection>) proc . opts)
  (and-let* [ [elems (slot-ref self'elements) ] ]
    (apply call-with-iterator elems proc opts ) ) )

(define-method call-with-builder ((class <generic-collection-meta>) proc . more-opts)
  (and-let* [ [%type       (slot-ref class'collection-type) ]
              [%opts       (slot-ref class'collection-opts) ]
              [%elem-type  (slot-ref class'element-type   ) ] ]
    (let [[ %make (slot-ref class'collection-make) ]
          [ %put! (slot-ref class'collection-put!) ] ]
      (if (and %make %put!)
        (let1 obj (apply %make (append %opts more-opts) )
          (proc
            (^x (unless (is-a? x %elem-type) (errorf "type error@call-with-builder x:~a" x) )
              (%put! obj x ) )
            (^[] (make class :elements obj ) ) ) )
        (apply call-with-builder %type
          (^[add! get]
            (proc
              (^x (unless (is-a? x %elem-type) (errorf "type error@call-with-builder x:~a" x) )
                (add! x) )
              (^[] (make class :elements (get) ) ) ) )
          (append %opts more-opts) ) ) ) ) )

(use generic.collection)
(use util.sparse)

;---------------------------------------------------------------
(debug-print-width #f)

(define-class <list-of-strings>    [<generic-collection>] []
  :metaclass <generic-collection-meta>
    :collection-type <list> :element-type <string> )

(define-class <vector-of-integer>  [<generic-collection>] []
  :metaclass <generic-collection-meta>
    :collection-type <vector> :element-type <integer> )

(define-class <eq-hash-table>     [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <hash-table> :collection-opts '(:type eq?) )

(define-class <equal-hash-table>  [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <hash-table> :collection-opts '(:type equal?) )

(define-class <string-hash-table> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <hash-table> :collection-opts '(:type string=?) )

(define-class <number-tree-map> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <tree-map> :collection-opts (list :key=? = :key<? < ) )

(define-class <string-tree-map> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <tree-map> :collection-opts (list :key=? string=? :key<? string<? ) )

(define-class <generic-sparse-u8vector> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <sparse-u8vector>  :collection-opts '(u8)
    :collection-make (^[type . rest] (make-sparse-vector type) )
    :collection-put! (^[o kv] (sparse-vector-set! o (car kv) (cdr kv) ) ) )

(define-class <generic-sparse-u32vector> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <sparse-u32vector>  :collection-opts '(u32)
    :collection-make (^[type . rest] (make-sparse-vector type) )
    :collection-put! (^[o kv] (sparse-vector-set! o (car kv) (cdr kv) ) ) )

(define-class <eq-sparse-table> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <sparse-table>  :collection-opts '(eq?)
    :collection-make (^[type . rest] (make-sparse-table type) )
    :collection-put! (^[o kv] (sparse-table-set! o (car kv) (cdr kv) ) ) )

(define-class <eqv-sparse-table> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <sparse-table>  :collection-opts '(eqv?)
    :collection-make (^[type . rest] (make-sparse-table type) )
    :collection-put! (^[o kv] (sparse-table-set! o (car kv) (cdr kv) ) ) )

(define-class <equal-sparse-table> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <sparse-table>  :collection-opts '(equal?)
    :collection-make (^[type . rest] (make-sparse-table type) )
    :collection-put! (^[o kv] (sparse-table-set! o (car kv) (cdr kv) ) ) )

(define-class <string-sparse-table> [<generic-collection>][]
  :metaclass <generic-collection-meta>
    :collection-type <sparse-table>  :collection-opts '(string=?)
    :collection-make (^[type . rest] (make-sparse-table type) )
    :collection-put! (^[o kv] (sparse-table-set! o (car kv) (cdr kv) ) ) )

#?=(make <vector-of-integer>)
#?=(make <list-of-strings>)
;(exit)

(define x (map-to <list-of-strings> number->string (iota 10 2 3)) )
#?=x
#?=(size-of x)
(for-each write x )
(newline)
;(exit)


(define y (with-builder (<vector-of-integer> add! get)
  (add! 1111  )
  (add! 1234 )
  (add! 2222  )
  (add! 333   )
  (add! 4444  )
  (get) ) )
#?=y
(for-each write y )
(newline)

;(exit)
(define x (make <string-hash-table>))
#?=x

(define y (with-builder (<string-hash-table> add! get)
  (add! '("a" . 1111) )
  (add! '("a" . 12.34) )
  (add! '("b" . 2222) )
  (add! '("c" . 3333) )
  (add! '("d" . 4444) )
  (get) ) )
#?=y
#?=(coerce-to <list> y)
;(exit)
(define z (coerce-to <equal-hash-table> '( ("a" . 1) ("a" . 'a11) ("b" . 2) ("c" . 3)) ))
#?=z
#?=(coerce-to <list> z)
;(exit)
(define y (with-builder (<string-tree-map> add! get)
  (add! '("a" . 1111) )
  (add! '("a" . 1234) )
  (add! '("b" . 2222) )
  (add! '("c" . 3333) )
  (add! '("d" . 4444) )
  (get) ) )
#?=y
#?=(coerce-to <list> y)
;(exit)
(define z (coerce-to <string-tree-map> '( ("a" . 1) ("a" . 11) ("b" . 2) ("c" . 3)) ))
#?=(coerce-to <list> z)

(define ny (with-builder (<number-tree-map> add! get)
  (add! '(1 . 1111) )
  (add! '(1 . 111 ) )
  (add! '(1.0 . 1234) )
  (add! '(2 . 2222) )
  (add! '(3 . 3333) )
  (add! '(4 . 4444) )
  (get) ) )
#?=(coerce-to <list> ny)

(define nz (coerce-to <number-tree-map> '( (1 . 1) (1 . 11) (2 . 2) (3 . 3)) ))
#?=(coerce-to <list> nz)

(define s1 (coerce-to <string-sparse-table> '( ("a1" . 9) ("a1" . 8) ("a2" . 7) ("a3" . 6)) ))
#?=(slot-ref s1'elements)
#?=(coerce-to <list> s1)

generic-sequence

;---------------------------------------------------------------
; generic sequence
;---------------------------------------------------------------
; Scheme:MOP:パラメタライズドクラス
; http://practical-scheme.net/wiliki/wiliki.cgi?Scheme%3aMOP%3a%E3%83%91%E3%83%A9%E3%83%A1%E3%82%BF%E3%83%A9%E3%82%A4%E3%82%BA%E3%83%89%E3%82%AF%E3%83%A9%E3%82%B9

#|
目的
「文字列のみを要素に持つリスト」とか、 「整数のみを要素に持つベクタ」とかいうクラスが欲しいことがたまにある。
強い型付き言語だとこういうクラスを多用するが、 Schemeではそのへんは運用で何とかしてしまう場合が多い。
しかし、規模が大きくなってきてデータの境界条件をきちんとマネージしたい
場合や、メタデータを用いていろいろやりたい場合には、型が「何でも有り」 だと困ることもある。
Gaucheでは例えばvalidatorメタクラスを使ってスロットの値にvalidateを 噛ましてやるってことは出来なくはない。
|#
;↑をvalidatorではなく、builderでやったらどうかと。

(define-module generic.sequence (extend gauche.sequence generic.collection)
  (export
    <generic-sequence-meta>
    <generic-sequence>
  ) )
(select-module generic.sequence)

(define-class <generic-sequence-meta> [<generic-collection-meta>] [] )
(define-class <generic-sequence> [<generic-collection> <sequence>] [] :metaclass <generic-sequence-meta> )

(define-method write-object ((self <generic-sequence>) port)
  (format port "<generic-sequence ~a >" (slot-ref self'elements) ) )

(define-method write-object ((self <generic-sequence-meta>) port)
  (format port "<generic-sequence-meta collection-type:~a element-type:~a >"
    (slot-ref self'collection-type) (slot-ref self'element-type) ) )

(define-method referencer ((self <generic-sequence>))
  (^[obj index]
    (if-let1 seq (slot-ref obj'elements)
      ((referencer seq) seq index)
      (errorf "no seq ~a" obj) ) ) )

(define-method modifier ((self <generic-sequence>))
  (and-let* [ [class      (class-of self) ]
              [seq-type   (slot-ref class'collection-type)  ]
              [elem-type  (slot-ref class'element-type) ] ]
    (^ [obj index x]
      (unless (is-a? x elem-type) (errorf "~a is not ~a" x elem-type) )
      (if-let1 seq (slot-ref obj'elements)
        ((modifier seq) seq index x)
        (errorf "no seq ~a" obj) ) ) ) )

(define-method subseq ((self <generic-sequence>) start end)
  (and-let* [ [class (class-of self) ]
              [seq   (slot-ref self'elements) ]]
    (make class :elements (subseq seq start end) ) ) )

(define-method (setter subseq) ((self <generic-sequence>) start (vals <sequence> ))
  (and-let* [ [class   (class-of self)]
              [vals    (coerce-to class vals) ]
              [seq     (slot-ref self'elements)]
              [val-seq (slot-ref vals'elements)] ]
      ((setter subseq) seq start val-seq) ) )

(define-method (setter subseq) ((self <generic-sequence>) start end (vals <sequence> ))
  (and-let* [ [class   (class-of self)]
              [vals    (coerce-to class vals) ]
              [seq     (slot-ref self'elements)]
              [val-seq (slot-ref vals'elements)] ]
      ((setter subseq) seq start end val-seq) ) )

; Javaのジェネリクス的なこと

; Scheme:MOP:パラメタライズドクラス
; http://practical-scheme.net/wiliki/wiliki.cgi?Scheme%3aMOP%3a%E3%83%91%E3%83%A9%E3%83%A1%E3%82%BF%E3%83%A9%E3%82%A4%E3%82%BA%E3%83%89%E3%82%AF%E3%83%A9%E3%82%B9

#|
目的
「文字列のみを要素に持つリスト」とか、 「整数のみを要素に持つベクタ」とかいうクラスが欲しいことがたまにある。
強い型付き言語だとこういうクラスを多用するが、 Schemeではそのへんは運用で何とかしてしまう場合が多い。
しかし、規模が大きくなってきてデータの境界条件をきちんとマネージしたい
場合や、メタデータを用いていろいろやりたい場合には、型が「何でも有り」 だと困ることもある。
Gaucheでは例えばvalidatorメタクラスを使ってスロットの値にvalidateを 噛ましてやるってことは出来なくはない。
|#

;↑をvalidatorではなく、builderでやったらどうかと。

(use generic.sequence)

(define-class <list-of-strings>    [<generic-sequence>] []
  :metaclass <generic-sequence-meta>
    :collection-type <list>  :element-type  <string> )

(define-class <vector-of-integer>  [<generic-sequence>] []
  :metaclass <generic-sequence-meta>
    :collection-type <vector> :element-type  <integer> )

;(define a (make <list-of-strings>))
;(define b (make <vector-of-integer>))

(define x (map-to <list-of-strings> number->string (iota 10 2 3)) )
(for-each-with-index (pa$ format #t "[~a] ~s~%") x )
(newline)
(for-each-with-index (pa$ format #t "[~a] ~s~%") (subseq x 2 5) )
(set! (subseq x 2 5) #("a+++++a" "b++++b" "c++++c"))
(newline)
;(for-each-with-index (pa$ format #t "[~a] ~s~%") (subseq x 2 5) )
(for-each-with-index (pa$ format #t "[~a] ~s~%") x)
(newline)

(set! (~ x 6) "s0----------s")
(for-each-with-index (pa$ format #t "[~a] ~s~%") x)

Tag: MOP