core/combinators/combinators.factor

   1 ! Copyright (C) 2006, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: combinators
   4 USING: arrays sequences sequences.private math.private
   5 kernel kernel.private math assocs quotations vectors ;
   6
   7 <PRIVATE
   8
   9 : dispatch ( n array -- ) array-nth (call) ;
  10
  11 PRIVATE>
  12
  13 TUPLE: no-cond ;
  14
  15 : no-cond ( -- * ) \ no-cond construct-empty throw ;
  16
  17 : cond ( assoc -- )
  18     [ first call ] find nip dup [ second call ] [ no-cond ] if ;
  19
  20 TUPLE: no-case ;
  21
  22 : no-case ( -- * ) \ no-case construct-empty throw ;
  23
  24 : case ( obj assoc -- )
  25     [ dup array? [ dupd first = ] [ quotation? ] if ] find nip
  26     {
  27         { [ dup array? ] [ nip second call ] }
  28         { [ dup quotation? ] [ call ] }
  29         { [ dup not ] [ no-case ] }
  30     } cond ;
  31
  32 : with-datastack ( stack quot -- newstack )
  33     datastack >r
  34     >r >array set-datastack r> call
  35     datastack r> swap add set-datastack 2nip ; inline
  36
  37 : recursive-hashcode ( n obj quot -- code )
  38     pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
  39
  40 M: sequence hashcode*
  41     [
  42         0 -rot [ hashcode* bitxor ] curry* each
  43     ] recursive-hashcode ;
  44
  45 : alist>quot ( default assoc -- quot )
  46     [ rot \ if 3array append [ ] like ] assoc-each ;
  47
  48 : cond>quot ( assoc -- quot )
  49     reverse [ no-cond ] swap alist>quot ;
  50
  51 : case>quot ( default assoc -- quot )
  52     [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
  53     alist>quot ;
  54
  55 : (distribute-buckets) ( buckets pair keys -- )
  56     dup t eq? [
  57         drop [ swap push-new ] curry each
  58     ] [
  59         [
  60             >r 2dup r> hashcode pick length rem rot nth push-new
  61         ] each 2drop
  62     ] if ;
  63
  64 : <buckets> ( initial length -- array )
  65     next-power-of-2 swap [ nip clone ] curry map ;
  66
  67 : distribute-buckets ( assoc initial quot -- buckets )
  68     swap rot [ length <buckets> ] keep
  69     [ >r 2dup r> dup first roll call (distribute-buckets) ] each
  70     nip ; inline
  71
  72 : hash-case-table ( default assoc -- array )
  73     V{ } [ 1array ] distribute-buckets
  74     [ case>quot ] curry* map ;
  75
  76 : hash-dispatch-quot ( table -- quot )
  77     [ length 1- [ fixnum-bitand ] curry ] keep
  78     [ dispatch ] curry append ;
  79
  80 : hash-case>quot ( default assoc -- quot )
  81     dup empty? [
  82         drop
  83     ] [
  84         hash-case-table hash-dispatch-quot
  85         [ dup hashcode >fixnum ] swap append
  86     ] if ;