From 893bad8bd29e60c1e9601deea74f05a06472e2bb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Dec 2022 18:23:10 -0600 Subject: [PATCH] sequences: Move some words to sequences.seq in extra. Ideally we would have the `foo` and `swap foo` versions of words like `push`, `push-all`, etc. Other words, like `seq-copy-loop`, seem more natural with this ordering. Punt on merging in core til .100 (if at all) --- core/sequences/sequences.factor | 46 -------------------------- extra/sequences/seq/authors.txt | 1 + extra/sequences/seq/seq.factor | 58 +++++++++++++++++++++++++++++++++ 3 files changed, 59 insertions(+), 46 deletions(-) create mode 100644 extra/sequences/seq/authors.txt create mode 100644 extra/sequences/seq/seq.factor diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f5ea188a91..7db35f65f9 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -34,16 +34,9 @@ GENERIC: shorten ( n seq -- ) M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline -GENERIC#: seq-lengthen 1 ( seq n -- seq ) -GENERIC#: seq-shorten 1 ( seq n -- seq ) - -: seq-set-length ( seq n -- seq ) [ swap set-length ] keepd ; inline : nth-of ( seq n -- elt ) swap nth ; inline : set-nth-of ( seq n elt -- seq ) spin [ set-nth ] keep ; inline -M: sequence seq-lengthen 2dup lengthd < [ seq-set-length ] [ drop ] if ; inline -M: sequence seq-shorten 2dup lengthd > [ seq-set-length ] [ drop ] if ; inline - : 2length ( seq1 seq2 -- n1 n2 ) [ length ] bi@ ; inline : 3length ( seq1 seq2 seq3 -- n1 n2 n3 ) [ length ] tri@ ; inline @@ -69,8 +62,6 @@ M: sequence seq-shorten 2dup lengthd > [ seq-set-length ] [ drop ] if ; inline : push ( elt seq -- ) [ length ] [ set-nth ] bi ; -: seq-push ( seq elt -- seq ) [ dup length ] dip set-nth-of ; - ERROR: bounds-error index seq ; GENERIC#: bounds-check? 1 ( n seq -- ? ) @@ -78,17 +69,9 @@ GENERIC#: bounds-check? 1 ( n seq -- ? ) M: integer bounds-check? dupd length < [ 0 >= ] [ drop f ] if ; inline -GENERIC: seq-bounds-check? ( seq n -- ? ) - -M: integer seq-bounds-check? - tuck lengthd > [ 0 >= ] [ drop f ] if ; inline - : bounds-check ( n seq -- n seq ) 2dup bounds-check? [ bounds-error ] unless ; inline -: seq-bounds-check ( seq n -- seq n ) - 2dup seq-bounds-check? [ swap bounds-error ] unless ; inline - MIXIN: immutable-sequence ERROR: immutable element index sequence ; @@ -362,16 +345,6 @@ C: copier [ 1 - ] dip [ copy-nth-unsafe ] [ (copy) ] 2bi ] if ; inline recursive -: seq-copy-loop ( dst dst-i src src-i src-stop -- dst ) - 2dup >= [ - 4drop - ] [ - [ - [ copy-nth-of-unsafe ] 4keep - [ 1 + ] 2dip 1 + - ] dip seq-copy-loop - ] if ; inline recursive - : subseq>copy ( from to seq -- n copy ) [ over - check-length swap ] dip 3dup nip new-sequence 0 swap ; inline @@ -382,15 +355,9 @@ C: copier : check-grow-copy ( dst n src -- dst src n ) over [ lengthd + lengthen ] 2keep ; inline -: seq-grow-copy ( dst n -- dst dst-n ) - [ over length + seq-lengthen ] keep 1 - ; inline - : copy-unsafe ( src i dst -- ) [ [ length check-length 0 ] keep ] 2dip (copy) drop ; inline -: seq-copy-unsafe ( dst dst-i src -- dst ) - 0 over length check-length seq-copy-loop ; inline - : subseq-unsafe-as ( from to seq exemplar -- subseq ) [ subseq>copy (copy) ] dip like ; inline @@ -422,8 +389,6 @@ PRIVATE> [ swap length + ] dip lengthen copy-unsafe ; inline -: seq-copy ( dst dst-n src -- dst ) check-grow-copy seq-copy-unsafe ; inline - M: sequence clone-like dupd new-sequence-like [ 0 swap copy-unsafe ] keep ; inline @@ -431,8 +396,6 @@ M: immutable-sequence clone-like like ; inline : push-all ( src dst -- ) [ length ] [ copy ] bi ; inline -: seq-push-all ( dst src -- dst ) [ length seq-grow-copy ] keep seq-copy-unsafe ; inline - -: seq-append-as ( seq1 seq2 exemplar -- newseq ) - [ 2dup 2length + ] dip - [ -rot (seq-append) ] new-like ; inline - : append-as ( seq1 seq2 exemplar -- newseq ) [ 2dup 2length + ] dip [ (append) ] new-like ; inline diff --git a/extra/sequences/seq/authors.txt b/extra/sequences/seq/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/sequences/seq/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/sequences/seq/seq.factor b/extra/sequences/seq/seq.factor new file mode 100644 index 0000000000..cd48133484 --- /dev/null +++ b/extra/sequences/seq/seq.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2022 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences sequences.private ; +IN: sequences.seq + +! Experimental: possibly more natural implementation of some sequence words. + +GENERIC#: seq-lengthen 1 ( seq n -- seq ) +GENERIC#: seq-shorten 1 ( seq n -- seq ) + +: seq-set-length ( seq n -- seq ) [ swap set-length ] keepd ; inline + +M: sequence seq-lengthen 2dup lengthd < [ seq-set-length ] [ drop ] if ; inline +M: sequence seq-shorten 2dup lengthd > [ seq-set-length ] [ drop ] if ; inline + +: seq-push ( seq elt -- seq ) [ dup length ] dip set-nth-of ; + +: seq-grow-copy ( dst n -- dst dst-n ) + [ over length + seq-lengthen ] keep 1 - ; inline + +: seq-copy-loop ( dst dst-i src src-i src-stop -- dst ) + 2dup >= [ + 4drop + ] [ + [ + [ copy-nth-of-unsafe ] 4keep + [ 1 + ] 2dip 1 + + ] dip seq-copy-loop + ] if ; inline recursive + +: seq-copy-unsafe ( dst dst-i src -- dst ) + 0 over length check-length seq-copy-loop ; inline + +: seq-push-all ( dst src -- dst ) [ length seq-grow-copy ] keep seq-copy-unsafe ; inline + +: seq-copy ( dst dst-n src -- dst ) check-grow-copy seq-copy-unsafe ; inline + + + +: seq-append-as ( seq1 seq2 exemplar -- newseq ) + [ 2dup 2length + ] dip + [ -rot (seq-append) ] new-like ; inline + +GENERIC: seq-bounds-check? ( seq n -- ? ) + +M: integer seq-bounds-check? + tuck lengthd > [ 0 >= ] [ drop f ] if ; inline + +: seq-bounds-check ( seq n -- seq n ) + 2dup seq-bounds-check? [ swap bounds-error ] unless ; inline + -- 2.34.1