Gauche:dictionaryを使う

Gauche:dictionaryを使う

関連ファイル

<dictionary>とはなに？

  • Shiro: <dictionary>は(1) (キー,値)のタプルの集合であり、かつ (2) キーから値が素早く引ける、というものです。

連想配列

<dictionary>

なにが<dicitionary>ではないか？

オブジェクト

  • Shiro(2013/04/18 00:08:42 UTC): 確かにオブジェクトをスロットから値へマップする辞書とみることはできますが(JavaScriptやPerlは両者の区別がほとんど無いですしね)、get/put!目的ならref (~) が使えるわけですし、辞書として統一的に扱う意味が無い、というかむしろ、動的型言語ではプログラマが型を意識して使い方を変えた方が見通しが良くなるんで、「普通辞書として使わないものは、辞書として使えるべきでない」とする方が理にかなっているように思います。実際、オブジェクトを(スロット . 値)のcollectionやsequenceと見なすことだってできるんですがあえてそうしていません。
  • Shiro :allocation :virtualなスロットは (変更がある場合) ひとつのエントリの変更が別のエントリに影響を及ぼすわけで、それはむしろ「オブジェクトのスロット-値の関係を辞書にしてはいけない理由」と素直に考えれば良いと思うんですが。

関数

<sequence>

fallbackはなぜ定数か？

SRFI 69: Basic hash tables

いろいろな試み

プロトコルの伝播

ref

キーの参照時のfallbackに手続きを与える

キーの参照時の失敗時用のプロトコル(slot-refのような)

<top>にdict-*メソッドをつけてみたら・・・・

<dictionary>を生成する。 

; dict->alist
(define-method dict->alist ((dict <dictionary>))
  (coerce-to <list> dict) )

; lazy-dict : 遅延辞書生成
(define-method lazy-dict ((init <dictionary>) filler)
  (let1 ht init
    (and
      (applicable? filler <dictionary>)
      (delay (and (filler ht) ht)))))

; 生成protocol
; alist->dict
; TODO case文の排除
; TODO <dictionary>のサブクラスで生成可能なものは指定可能にしたい。
; TODO sparse-table, sparse-vectorの処理
(define-method alist->dict ((class <class>) alist . rest)
  (case (class-name class)
    [(<trie>      )            (apply trie rest alist) ]
    [(<tree-map>  )            (apply alist->tree-map   alist rest)]
    [(<hash-table>)            (apply alist->hash-table alist rest)]
    ; TODO [(<sparse-table>)          (apply alist->sparse-table alist rest)]
    ;;
    ; TODO [(<sparse-vector>)         (apply alist->sparse-vector alist rest)]
    ; TODO [(<sparse-vector-base>)    (apply alist->sparse-vector alist rest)]
    ; TODO [(<sparse-s8vector>)       (alist->sparse-vector alist 's8 )]
    ; TODO [(<sparse-u8vector>)       (alist->sparse-vector alist 'u8 )]
    ; TODO [(<sparse-s16vector>)      (alist->sparse-vector alist 's16)]
    ; TODO [(<sparse-u16vector>)      (alist->sparse-vector alist 'u16)]
    ; TODO [(<sparse-s32vector>)      (alist->sparse-vector alist 's32)]
    ; TODO [(<sparse-u32vector>)      (alist->sparse-vector alist 'u32)]
    ; TODO [(<sparse-s64vector>)      (alist->sparse-vector alist 's64)]
    ; TODO [(<sparse-u64vector>)      (alist->sparse-vector alist 'u64)]
    ; TODO [(<sparse-f16vector>)      (alist->sparse-vector alist 'f16)]
    ; TODO [(<sparse-f32vector>)      (alist->sparse-vector alist 'f32)]
    ; TODO [(<sparse-f64vector>)      (alist->sparse-vector alist 'f64)]
    ;;
    [else (errorf "unknown dictionary ~a" class) ] ) )

; dict-make
; TODO case文の排除
; TODO <dictionary>のサブクラスで生成可能なものは指定可能にしたい。
(define-method dict-make ((class <class>) . rest )
  (case (class-name class)
    [(<trie>      )            (apply make-trie rest) ]
    [(<tree-map>  )            (apply make-tree-map rest)]
    [(<hash-table>)            (apply make-hash-table rest)]
    [(<sparse-table>)          (apply make-sparse-table rest)]
    ;;
    [(<sparse-vector>)         (apply make-sparse-vector rest)]
    [(<sparse-vector-base>)    (apply make-sparse-vector rest)]
    [(<sparse-s8vector>)       (make-sparse-vector 's8  )]
    [(<sparse-u8vector>)       (make-sparse-vector 'u8  )]
    [(<sparse-s16vector>)      (make-sparse-vector 's16 )]
    [(<sparse-u16vector>)      (make-sparse-vector 'u16 )]
    [(<sparse-s32vector>)      (make-sparse-vector 's32 )]
    [(<sparse-u32vector>)      (make-sparse-vector 'u32 )]
    [(<sparse-s64vector>)      (make-sparse-vector 's64 )]
    [(<sparse-u64vector>)      (make-sparse-vector 'u64 )]
    [(<sparse-f16vector>)      (make-sparse-vector 'f16 )]
    [(<sparse-f32vector>)      (make-sparse-vector 'f32 )]
    [(<sparse-f64vector>)      (make-sparse-vector 'f64 )]
    ;;
    [else (errorf "unknown dictionary ~a" class) ] ) )

generic-dictionary

generic.sequence generic.collectionはGauche:MOP:GenericCollectionを参照。 

; generic dictionary

; 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

;---------------------------------------------------------------
; orderd-dictionary時のときに、modifier,subseqで入力したときの扱い？

(define-module generic.dictionary
  (extend
    gauche.dictionary
    generic.sequence
    generic.collection )
  ;;
  (use util.match)
  (use komono-dict :only (define-dict-interface-propagate) )
  (export
    <generic-dictionary-meta> <generic-ordered-dictionary-meta>
    <generic-dictionary> <generic-ordered-dictionary> ) )
(select-module generic.dictionary)

(define-class <generic-dictionary-meta> [<generic-collection-meta>]
  [ (key-type   :init-keyword :key-type   :init-value <top>)
    (value-type :init-keyword :value-type :init-value <top>) ] )

(define-class <generic-ordered-dictionary-meta> [<generic-sequence-meta>]
  [ (key-type   :init-keyword :key-type   :init-value <top>)
    (value-type :init-keyword :value-type :init-value <top>) ] )

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

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

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

(define-method write-object ((self <generic-ordered-dictionary>) port)
  (format port "<generic-ordered-dictionary type:~a opts:~a key-type:~a value-type:~a >"
    (slot-ref self'collection-type )
    (slot-ref self'collection-opts )
    (slot-ref self'key-type  )
    (slot-ref self'value-type) ) )

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

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

(define-dict-interface-propagate <generic-dictionary> elements
  :get :exists? :delete! :clear! :fold :map :for-each :keys :values
  :pop! :->alist :call-with-iterator)

(define-dict-interface-propagate <generic-ordered-dictionary> elements
  :get :exists? :delete! :clear! :fold :fold-right :map :for-each :keys :values
  :pop! :->alist :call-with-iterator)

(define (%dict-put! self key val)
  (and-let* [ [dict       (slot-ref self'elements) ]
              [class      (class-of self) ]
              [key-type   (slot-ref class'key-type) ]
              [value-type (slot-ref class'value-type) ] ]
   (unless (is-a? key key-type   ) (errorf "type error@dict-put! key:~s" key) )
   (unless (is-a? val value-type ) (errorf "type error@dict-put! val:~s" val) )
   (dict-put! dict key val) ) )

(define (%dict-push! self key val)
  (and-let* [ [dict       (slot-ref self'elements) ]
              [class      (class-of self) ]
              [key-type   (slot-ref class'key-type) ]
              [value-type (slot-ref class'value-type) ] ]
   (unless (is-a? key key-type   ) (errorf "type error@dict-push! key:~s" key) )
   (unless (is-a? val value-type ) (errorf "type error@dict-push! val:~s" val) )
   (dict-push! dict key val) ) )

; TODO fallbackを型チェックすべきか？
(define (%dict-update! self key proc :optional fallback)
  (and-let* [ [dict       (slot-ref self'elements) ]
              [class      (class-of self) ]
              [key-type   (slot-ref class'key-type) ]
              [value-type (slot-ref class'value-type) ] ]
    (unless (is-a? key key-type ) (errorf "type error@dict-update! key:~s" key) )
    (dict-update! dict key
      (^x (rlet1 v (proc x) (unless (is-a? v value-type) (errorf "type error@dict-update! value:~s" v) ) ) )
      fallback) ) )

(define (%call-with-builder class proc . more-opts)
  (and-let* [ [%type       (slot-ref class'collection-type) ]
              [%opts       (slot-ref class'collection-opts) ]
              [%key-type   (slot-ref class'key-type) ]
              [%value-type (slot-ref class'value-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 (match x
                  [((? (cut is-a? <> %key-type ) _ ) . (? (cut is-a? <> %value-type ) _ ) ) (%put! obj x) ]
                  [ _ (errorf "type error@call-with-builder x:~a" x) ] ) )
            (^[] (make class :elements obj ) ) ) )
        (apply call-with-builder %type
          (^[add! get]
            (proc
              (^x (match x
                    [((? (cut is-a? <> %key-type ) _ ) . (? (cut is-a? <> %value-type ) _ ) ) (add! x) ]
                    [ _ (errorf "type error@call-with-builder x:~a" x) ] ) )
              (^[] (make class :elements (get) ) ) ) )
          (append %opts more-opts) ) ) ) ) )

; generic-dictionary
(define-method dict-put! ( (self <generic-dictionary> ) key val)
  (%dict-put! self key val) )

(define-method dict-push! ( (self <generic-dictionary>) key val)
  (%dict-push! self key val) )

(define-method dict-update! ((self <generic-dictionary>) key proc :optional fallback)
  (%dict-update! self key proc fallback))

(define-method call-with-builder ((class <generic-dictionary-meta> ) proc . more-opts)
  (apply %call-with-builder class proc more-opts) )

; generic-ordered-dictionary

(define-method dict-put! ( (self <generic-ordered-dictionary> ) key val)
  (%dict-put! self key val) )

(define-method dict-push! ( (self <generic-ordered-dictionary>) key val)
  (%dict-push! self key val) )

(define-method dict-update! ((self <generic-ordered-dictionary>) key proc :optional fallback)
  (%dict-update! self key proc fallback))

(define-method call-with-builder ((class <generic-ordered-dictionary-meta> ) proc . more-opts)
  (apply %call-with-builder class proc more-opts) )

(use generic.dictionary)
(use util.sparse)
(debug-print-width #f)

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

(define-class <eq-hash-table>     [<generic-dictionary>][]
  :metaclass <generic-dictionary-meta>
    :collection-type <hash-table> :collection-opts '(:type eq?) )
#?=<eq-hash-table>
(define-class <eqv-hash-table>    [<generic-dictionary>][]
  :metaclass <generic-dictionary-meta>
    :collection-type <hash-table> :collection-opts '(:type eqv?) )
#?=<eqv-hash-table>
(define-class <equal-hash-table>  [<generic-dictionary>][]
  :metaclass <generic-dictionary-meta>
    :collection-type <hash-table> :collection-opts '(:type equal?) )
#?=<equal-hash-table>
(define-class <string-hash-table> [<generic-dictionary>][]
    :metaclass <generic-dictionary-meta>
      :collection-type <hash-table> :collection-opts '(:type string=?)
      :key-type <string> :value-type <number> )
#?=<string-hash-table>

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

(define-class <generic-sparse-u8vector> [<generic-dictionary>][]
  :metaclass <generic-dictionary-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) ) ) )
#?=<generic-sparse-u8vector>

(define-class <generic-sparse-u32vector> [<generic-dictionary>][]
  :metaclass <generic-dictionary-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) ) ) )
#?=<generic-sparse-u32vector>


(define-class <eq-sparse-table> [<generic-dictionary>][]
  :metaclass <generic-dictionary-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-dictionary>][]
  :metaclass <generic-dictionary-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-dictionary>][]
  :metaclass <generic-dictionary-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-dictionary>][]
  :metaclass <generic-dictionary-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) ) ) )

;(exit)
(define x (make <string-sparse-table>))
(set! (dict-get x "a") 12)
(set! (dict-get x "A") 12)
(set! (dict-get x "B") 2)
(set! (dict-get x "C") 3)

#?=(coerce-to <list> x)
;(exit)

(dict-put! x "K" 12 )
(dict-push! x "AA" 666 )
(dict-put! x "C" 123 )
#?=(dict-get x "A")
(dict-update! x "A" (^x (+ x 11000000) ))
#?=(coerce-to <list> x)
;(exit)

(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) ) )
#?=(coerce-to <list> y)

(define z (coerce-to <eq-sparse-table> '( (a . 1) (a . 'a11) (b . 2) (c . 3)) ))
#?=(class-of z)
#?=(coerce-to <list> z)
#?=(dict-get z 'a)
(exit)

(define x (make <string-tree-map>))
(set! (dict-get x "A") 1)
(set! (dict-get x "A") 111)
(set! (dict-get x "B") 2)
(set! (dict-get x "C") 3)

#?=(coerce-to <list> x)

(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) ) )
#?=(coerce-to <list> y)

(define z (coerce-to <string-tree-map> '( ("a" . 1) ("a" . 11) ("b" . 2) ("c" . 3)) ))
#?=(dict-get z "a")
#?=(coerce-to <list> z)

(define nx (make <number-tree-map>))
(set! (dict-get nx 1) 1)
(set! (dict-get nx 1) 111)
(set! (dict-get nx 2.5) 2)
(set! (dict-get nx 3) 3)

#?=(dict-fold        nx cons* '() )
#?=(dict-fold-right  nx cons* '() )
#?=(coerce-to <list> nx)
(newline)
(for-each-with-index (pa$ format #t "[~a] ~s~%") nx)

(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) ) )
#?=(dict-fold        ny cons* '() )
#?=(dict-fold-right  ny cons* '() )
#?=(coerce-to <list> ny)
(newline)
(for-each-with-index (pa$ format #t "[~a] ~s~%") ny)

(define nz (coerce-to <number-tree-map> '( (1 . 1) (1 . 11) (2 . 2) (3 . 3) (4 . 4) ) ))
#?=(dict-fold       nz cons* '() )
#?=(dict-fold-right nz cons* '() )
#?=(dict-get nz 1)
#?=(coerce-to <list> nz)
(newline)
(for-each-with-index (pa$ format #t "[~a] ~s~%") nz)
;(set! (ref (~ nz'elements ) 2.5) 12)
;(set! (ref nz 2.5) 12 )
(newline)
(print "------")
(for-each-with-index (pa$ format #t "[~a] ~s~%") (subseq nz 1 2))

(define s1 (coerce-to <generic-sparse-u8vector> '( (1 . 9) (1 . 8) (2 . 7) (3 . 6)) ))
#?=(slot-ref s1'elements)
#?=(coerce-to <list> s1)

Tag: gauche.dictionary

Topics
Sponsored Links
Search
Recent Changes
More ...
Last modified : 2013/05/06 06:46:35 UTC
WiLiKi 0.8.3 running on Gauche 0.9.15