unmaintained/heap/heap.factor

   1 ! Binary Min Heap
   2 ! Copyright 2007 Ryan Murphy
   3 ! See http://factorcode.org/license.txt for BSD license.
   4
   5 USING: kernel math sequences ;
   6 IN: heap
   7
   8 : [comp] ( elt elt -- ? ) <=> 0 > ;
   9
  10 : <heap> ( -- heap ) V{ } clone ;
  11
  12 : left ( index -- index ) ! left child
  13     2 * 1 + ;
  14
  15 : leftv ( heap index -- value )
  16     left swap nth ;
  17
  18 : right ( index -- index ) ! right child
  19     2 * 2 + ;
  20
  21 : rightv ( heap index -- value )
  22     right swap nth ;
  23
  24 : l-oob ( i heap -- ? ) swap left swap length >= ;
  25 : r-oob ( i heap -- ? ) swap right swap length >= ;
  26
  27 : up ( index -- index ) ! parent node
  28     1 -  2 /i ;
  29
  30 : upv ( heap index -- value ) ! parent's value
  31     up swap nth ;
  32
  33 : lasti ( seq -- index ) length 1 - ;
  34
  35 : swapup ( heap index -- ) dup up rot exchange ;
  36
  37 : (farchild) ( heap index -- index ) tuck 2dup leftv -rot rightv [comp] [ right ] [ left ] if ;
  38
  39 : farchild ( heap index -- index ) dup right pick length >= [ nip left ] [ (farchild) ] if ;
  40
  41 : farchildv ( heap index -- value ) dupd farchild swap nth ;
  42
  43 : swapdown ( heap index -- ) 2dup farchild rot exchange ;
  44
  45 : upheap ( heap -- )
  46     dup dup lasti upv over peek [comp]
  47     [ dup lasti 2dup swapup up 1 + head-slice upheap ] [ drop ] if ;
  48
  49 : add ( elt heap -- )
  50     tuck push upheap ;
  51
  52 : add-many ( seq heap -- )
  53     swap [ swap add ] each-with ;
  54
  55 DEFER: (downheap)
  56
  57 : (downheap2) ( i heap -- )
  58     2dup nth -rot
  59     2dup swap farchild dup pick nth 2swap
  60     >r >r
  61     swapd [comp]
  62     [ r> r> tuck swap swapdown (downheap) ] [ drop r> r> 2drop ] if ;
  63
  64 : (downheap) ( i heap -- )
  65     over left over length >= [ 2drop ] [ (downheap2) ] if ;
  66
  67 : downheap ( heap -- )
  68     0 swap (downheap) ;
  69
  70 : bump ( heap -- )
  71     dup peek 0 pick set-nth dup pop* downheap ;
  72
  73 : gbump ( heap -- first )
  74     dup first swap bump ;