extra/sequences/seq/seq.factor

   1 ! Copyright (C) 2022 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: kernel math sequences sequences.private ;
   4 IN: sequences.seq
   5
   6 ! Experimental: possibly more natural implementation of some sequence words.
   7
   8 GENERIC#: seq-lengthen 1 ( seq n -- seq )
   9 GENERIC#: seq-shorten 1 ( seq n -- seq )
  10
  11 : seq-set-length ( seq n -- seq ) [ swap set-length ] keepd ; inline
  12
  13 M: sequence seq-lengthen 2dup lengthd < [ seq-set-length ] [ drop ] if ; inline
  14 M: sequence seq-shorten 2dup lengthd > [ seq-set-length ] [ drop ] if ; inline
  15
  16 : seq-push ( seq elt -- seq ) [ dup length ] dip set-nth-of ;
  17
  18 : seq-grow-copy ( dst n -- dst dst-n )
  19     [ over length + seq-lengthen ] keep 1 - ; inline
  20
  21 : seq-copy-unsafe ( dst dst-i src -- dst )
  22     0 over length check-length copy-loop ; inline
  23
  24 : seq-push-all ( dst src -- dst ) [ length seq-grow-copy ] keep seq-copy-unsafe ; inline
  25
  26 : check-grow-copy ( dst n src -- dst src n )
  27     over [ lengthd + lengthen ] 2keep ; inline
  28
  29 : seq-copy ( dst dst-n src -- dst ) check-grow-copy seq-copy-unsafe ; inline
  30
  31 <PRIVATE
  32
  33 : (seq-append) ( accum seq1 seq2 -- accum )
  34     [
  35         [ 0 ] dip [ seq-copy-unsafe ] [ length ] bi
  36     ] dip seq-copy-unsafe ; inline
  37
  38 PRIVATE>
  39
  40 : seq-append-as ( seq1 seq2 exemplar -- newseq )
  41     [ 2dup 2length + ] dip
  42     [ -rot (seq-append) ] new-like ; inline
  43
  44 GENERIC: seq-bounds-check? ( seq n -- ? )
  45
  46 M: integer seq-bounds-check?
  47     tuck lengthd > [ 0 >= ] [ drop f ] if ; inline
  48
  49 : seq-bounds-check ( seq n -- seq n )
  50     2dup seq-bounds-check? [ swap bounds-error ] unless ; inline
  51