core/combinators/combinators.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov, Daniel Ehrenberg.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs kernel kernel.private math
   4 math.order math.private quotations sequences sequences.private
   5 sets sorting words ;
   6 IN: combinators
   7
   8 ! Most of these combinators have compile-time expansions in
   9 ! the optimizing compiler. See stack-checker.transforms and
  10 ! compiler.tree.propagation.call-effect
  11
  12 <PRIVATE
  13
  14 : call-effect-unsafe ( quot effect -- ) drop call ;
  15
  16 : execute-effect-unsafe ( word effect -- ) drop execute ;
  17
  18 M: object throw
  19     ERROR-HANDLER-QUOT special-object [ die ] or
  20     ( error -- * ) call-effect-unsafe ;
  21
  22 PRIVATE>
  23
  24 ERROR: wrong-values quot call-site ;
  25
  26 ! We can't USE: effects here so we forward reference slots instead
  27 SLOT: in
  28 SLOT: out
  29 SLOT: terminated?
  30
  31 : call-effect ( quot effect -- )
  32     ! Don't use fancy combinators here, since this word always
  33     ! runs unoptimized
  34     2dup [
  35         [ [ get-datastack ] dip dip ] dip
  36         dup terminated?>> [ 2drop f ] [
  37             dup in>> length swap out>> length
  38             check-datastack
  39         ] if
  40     ] 2dip rot
  41     [ 2drop ] [ wrong-values ] if ;
  42
  43 : execute-effect ( word effect -- )
  44     [ [ execute ] curry ] dip call-effect ;
  45
  46 ! cleave
  47 : cleave ( x seq -- )
  48     [ call ] with each ;
  49
  50 : cleave>quot ( seq -- quot )
  51     [ [ keep ] curry ] map concat
  52     [ drop ] [ ] append-as ;
  53
  54 ! 2cleave
  55 : 2cleave ( x y seq -- )
  56     [ 2keep ] each 2drop ;
  57
  58 : 2cleave>quot ( seq -- quot )
  59     [ [ 2keep ] curry ] map concat
  60     [ 2drop ] [ ] append-as ;
  61
  62 ! 3cleave
  63 : 3cleave ( x y z seq -- )
  64     [ 3keep ] each 3drop ;
  65
  66 : 3cleave>quot ( seq -- quot )
  67     [ [ 3keep ] curry ] map concat
  68     [ 3drop ] [ ] append-as ;
  69
  70 ! 4cleave
  71 : 4cleave ( w x y z seq -- )
  72     [ 4keep ] each 4drop ;
  73
  74 : 4cleave>quot ( seq -- quot )
  75     [ [ 4keep ] curry ] map concat
  76     [ 4drop ] [ ] append-as ;
  77
  78 ! spread
  79 : shallow-spread>quot ( seq -- quot )
  80     [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
  81
  82 : deep-spread>quot ( seq -- quot )
  83     [ ] [ [ [ dip ] curry ] dip append ] reduce ;
  84
  85 : spread ( objs... seq -- )
  86     deep-spread>quot call ;
  87
  88 ! cond
  89 ERROR: no-cond ;
  90
  91 : cond ( assoc -- )
  92     [ dup callable? [ drop t ] [ first call ] if ] find nip
  93     [ dup callable? [ call ] [ second call ] if ]
  94     [ no-cond ] if* ;
  95
  96 : alist>quot ( default assoc -- quot )
  97     [ rot \ if 3array [ ] append-as ] assoc-each ;
  98
  99 : cond>quot ( assoc -- quot )
 100     [ dup pair? [ [ t ] swap 2array ] unless ] map
 101     reverse! [ no-cond ] swap alist>quot ;
 102
 103 ! case
 104 ERROR: no-case object ;
 105
 106 : case-find ( obj assoc -- obj' )
 107     [
 108         dup array? [
 109             dupd first dup word? [
 110                 execute
 111             ] [
 112                 dup wrapper? [ wrapped>> ] when
 113             ] if =
 114         ] [ callable? ] if
 115     ] find nip ;
 116
 117 \ case-find t "no-compile" set-word-prop
 118
 119 : case ( obj assoc -- )
 120     case-find {
 121         { [ dup array? ] [ nip second call ] }
 122         { [ dup callable? ] [ call ] }
 123         { [ dup not ] [ drop no-case ] }
 124     } cond ;
 125
 126 : linear-case-quot ( default assoc -- quot )
 127     [
 128         [ 1quotation \ dup prefix \ = suffix ]
 129         [ \ drop prefix ] bi*
 130     ] assoc-map reverse! alist>quot ;
 131
 132 <PRIVATE
 133
 134 : (distribute-buckets) ( buckets pair keys -- )
 135     dup t eq? [
 136         drop [ swap adjoin ] curry each
 137     ] [
 138         [
 139             [ 2dup ] dip hashcode pick length rem rot nth adjoin
 140         ] each 2drop
 141     ] if ;
 142
 143 : <buckets> ( initial length -- array )
 144     next-power-of-2 <iota> swap [ nip clone ] curry map ;
 145
 146 : distribute-buckets ( alist initial quot -- buckets )
 147     swapd [ [ dup first ] dip call 2array ] curry map
 148     [ length <buckets> dup ] keep
 149     [ first2 (distribute-buckets) ] with each ; inline
 150
 151 : hash-case-table ( default assoc -- array )
 152     V{ } [ 1array ] distribute-buckets [
 153         [ [ literalize ] dip ] assoc-map linear-case-quot
 154     ] with map ;
 155
 156 : hash-dispatch-quot ( table -- quot )
 157     [ length 1 - [ fixnum-bitand ] curry ] keep
 158     [ dispatch ] curry append ;
 159
 160 : hash-case-quot ( default assoc -- quot )
 161     hash-case-table hash-dispatch-quot
 162     [ dup hashcode >fixnum ] prepend ;
 163
 164 : contiguous-range? ( keys -- ? )
 165     dup [ fixnum? ] all? [
 166         dup all-unique? [
 167             [ length ] [ supremum ] [ infimum ] tri - - 1 =
 168         ] [ drop f ] if
 169     ] [ drop f ] if ;
 170
 171 : dispatch-case-quot ( default assoc -- quot )
 172     swap [
 173         [ keys [ infimum ] [ supremum ] bi over ]
 174         [ sort-keys values [ >quotation ] map ] bi
 175     ] dip dup '[
 176         dup integer? [
 177             integer>fixnum-strict dup _ _ between? [
 178                 _ - _ dispatch
 179             ] _ if
 180         ] _ if
 181     ] ;
 182
 183 PRIVATE>
 184
 185 : case>quot ( default assoc -- quot )
 186     dup keys {
 187         { [ dup empty? ] [ 2drop ] }
 188         { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] }
 189         { [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
 190         { [ dup [ wrapper? ] none? ] [ drop hash-case-quot ] }
 191         { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
 192         [ drop linear-case-quot ]
 193     } cond ;
 194
 195 : to-fixed-point ( ... object quot: ( ... object(n) -- ... object(n+1) ) -- ... object(n) )
 196     [ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive