core/collections/sequences-epilogue.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: sequences
   4 USING: arrays errors generic kernel kernel-internals math
   5 sequences-internals strings vectors words ;
   6
   7 : first2 ( seq -- first second )
   8     1 swap bounds-check nip first2-unsafe ;
   9
  10 : first3 ( seq -- first second third )
  11     2 swap bounds-check nip first3-unsafe ;
  12
  13 : first4 ( seq -- first second third fourth )
  14     3 swap bounds-check nip first4-unsafe ;
  15
  16 : index ( obj seq -- n )
  17     [ = ] find-with drop ;
  18
  19 : index* ( obj i seq -- n )
  20     [ = ] find-with* drop ;
  21
  22 : last-index ( obj seq -- n )
  23     [ = ] find-last-with drop ;
  24
  25 : last-index* ( obj i seq -- n )
  26     [ = ] find-last-with* drop ;
  27
  28 : member? ( obj seq -- ? )
  29     [ = ] contains-with? ;
  30
  31 : memq? ( obj seq -- ? )
  32     [ eq? ] contains-with? ;
  33
  34 : remove ( obj seq -- newseq )
  35     [ = not ] subset-with ;
  36
  37 : (subst) ( newseq oldseq elt -- new/elt )
  38     [ swap index ] keep
  39     over -1 > [ drop swap nth ] [ 2nip ] if ;
  40
  41 : subst ( newseq oldseq seq -- )
  42     [ >r 2dup r> (subst) ] inject 2drop ;
  43
  44 : move ( m n seq -- )
  45     pick pick number=
  46     [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
  47
  48 : (delete) ( elt store scan seq -- elt store scan seq )
  49     2dup length < [
  50         3dup move
  51         [ nth pick = ] 2keep rot
  52         [ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
  53     ] when ;
  54
  55 : delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
  56
  57 : push-new ( elt seq -- ) [ delete ] 2keep push ;
  58
  59 : prune ( seq -- newseq )
  60     [ V{ } clone swap [ over push-new ] each ] keep like ;
  61
  62 : nappend ( dest src -- )
  63     >r [ length ] keep r> copy-into ; inline
  64
  65 : ((append)) ( seq1 seq2 accum -- accum )
  66     [ >r over length r> rot copy-into ] keep
  67     [ 0 swap rot copy-into ] keep ; inline
  68
  69 : (3append) ( seq1 seq2 seq3 exemplar -- newseq )
  70     [
  71         >r pick length pick length pick length + + r> new
  72         [ >r pick length pick length + r> rot copy-into ] keep
  73         ((append))
  74     ] keep like ;
  75
  76 : 3append ( seq1 seq2 seq3 -- newseq )
  77     pick (3append) ; inline
  78
  79 : (append) ( seq1 seq2 exemplar -- newseq )
  80     [
  81         >r over length over length + r> new ((append))
  82     ] keep like ;
  83
  84 : append ( seq1 seq2 -- newseq )
  85     over (append) ; inline
  86
  87 : add ( seq elt -- newseq ) 1array append ; inline
  88
  89 : add* ( seq elt -- newseq ) 1array swap dup (append) ; inline
  90
  91 : concat ( seq -- newseq )
  92     dup empty? [
  93         [ 0 [ length + ] accumulate ] keep
  94         rot over first new -rot
  95         [ >r over r> copy-into ] 2each
  96     ] unless ;
  97
  98 : diff ( seq1 seq2 -- newseq )
  99     [ swap member? not ] subset-with ;
 100
 101 : peek ( seq -- elt ) dup length 1- swap nth ;
 102
 103 : pop* ( seq -- ) dup length 1- swap set-length ;
 104
 105 : pop ( seq -- elt )
 106     dup length 1- swap [ nth ] 2keep set-length ;
 107
 108 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
 109
 110 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
 111
 112 : (mismatch) ( seq1 seq2 n -- i )
 113     [ >r 2dup r> 2nth-unsafe = not ] find drop 2nip ; inline
 114
 115 : mismatch ( seq1 seq2 -- i )
 116     2dup min-length (mismatch) ;
 117
 118 : flip ( matrix -- newmatrix )
 119     dup empty? [
 120         dup first [ length [ <column> dup like ] map-with ] keep
 121         like
 122     ] unless ;
 123
 124 : unpair ( assoc -- keys values )
 125     flip dup empty? [ drop { } { } ] [ first2 ] if ;
 126
 127 : exchange ( m n seq -- )
 128     pick over bounds-check 2drop 2dup bounds-check 2drop
 129     exchange-unsafe ;
 130
 131 : assoc ( key assoc -- value )
 132     [ first = ] find-with nip second ;
 133
 134 : rassoc ( value assoc -- key )
 135     [ second = ] find-with nip first ;
 136
 137 : last/first ( seq -- pair ) dup peek swap first 2array ;
 138
 139 : padding ( seq n elt -- newseq )
 140     >r swap length [-] r> <array> ;
 141
 142 : pad-left ( seq n elt -- padded )
 143     pick >r pick >r padding r> append r> like ;
 144
 145 : pad-right ( seq n elt -- padded )
 146     pick >r padding r> swap append ;
 147
 148 : sequence= ( seq1 seq2 -- ? )
 149     2dup [ length ] 2apply tuck number=
 150     [ (mismatch) -1 number= ] [ 3drop f ] if ; inline
 151
 152 M: array equal?
 153     over array? [ sequence= ] [ 2drop f ] if ;
 154
 155 M: quotation equal?
 156     over quotation? [ sequence= ] [ 2drop f ] if ;
 157
 158 M: sbuf equal?
 159     over sbuf? [ sequence= ] [ 2drop f ] if ;
 160
 161 M: vector equal?
 162     over vector? [ sequence= ] [ 2drop f ] if ;
 163
 164 UNION: sequence array string sbuf vector quotation ;
 165
 166 M: sequence hashcode
 167     dup empty? [ drop 0 ] [ first hashcode ] if ;
 168
 169 IN: kernel
 170
 171 M: object <=>
 172     2dup mismatch dup -1 =
 173     [ drop [ length ] 2apply - ] [ 2nth-unsafe <=> ] if ;
 174
 175 : depth ( -- n ) datastack length ;
 176
 177 TUPLE: no-cond ;
 178 : no-cond ( -- * ) <no-cond> throw ;
 179
 180 : cond ( assoc -- )
 181     [ first call ] find nip dup [ second call ] [ no-cond ] if ;
 182
 183 : unix? ( -- ? )
 184     os { "freebsd" "linux" "macosx" "solaris" } member? ;