extra/assoc-heaps/assoc-heaps.factor

   1 USING: assocs heaps kernel sequences ;
   2 IN: assoc-heaps
   3
   4 TUPLE: assoc-heap assoc heap ;
   5
   6 INSTANCE: assoc-heap assoc
   7 INSTANCE: assoc-heap priority-queue
   8
   9 C: <assoc-heap> assoc-heap
  10
  11 : <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
  12 : <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
  13
  14 M: assoc-heap at* ( key assoc-heap -- value ? )
  15     assoc-heap-assoc at* ;
  16
  17 M: assoc-heap assoc-size ( assoc-heap -- n )
  18     assoc-heap-assoc assoc-size ;
  19
  20 TUPLE: assoc-heap-key-exists ;
  21
  22 : check-key-exists ( key assoc-heap -- )
  23     assoc-heap-assoc key?
  24     [ \ assoc-heap-key-exists construct-empty throw ] when ;
  25
  26 M: assoc-heap set-at ( value key assoc-heap -- )
  27     [ check-key-exists ] 2keep
  28     [ assoc-heap-assoc set-at ] 3keep
  29     assoc-heap-heap swapd heap-push ;
  30
  31 M: assoc-heap heap-empty? ( assoc-heap -- ? )
  32     assoc-heap-assoc assoc-empty? ;
  33
  34 M: assoc-heap heap-length ( assoc-heap -- n )
  35     assoc-heap-assoc assoc-size ;
  36
  37 M: assoc-heap heap-peek ( assoc-heap -- value key )
  38     assoc-heap-heap heap-peek ;
  39
  40 M: assoc-heap heap-push ( value key assoc-heap -- )
  41     set-at ;
  42
  43 M: assoc-heap heap-push-all ( assoc assoc-heap -- )
  44     swap [ rot set-at ] curry* each ;
  45
  46 M: assoc-heap heap-pop ( assoc-heap -- value key )
  47     dup assoc-heap-heap heap-pop swap
  48     rot dupd assoc-heap-assoc delete-at ;