steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

big sequences refactoring

cvs
Slava Pestov 2005-07-17 02:16:18 +00:00
parent a1f3680708
commit d9c4a82c7a
42 changed files with 383 additions and 383 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
CHANGES.txt
View File

@ -1,7 +1,11 @@
Factor 0.76:
------------
+ Runtime and core library:
- The main focus of this release was getting the UI framework in a state
where the graphical listener is usable. This goal has largely been
achieved. Many performance problems were fixed, and the listener now
supports styled text output, presentations, and an
automatically-updated data stack display.
- The number of generations used for garbage collection can now be set
with the +G command line switch. You must specify at least 2
@ -10,11 +14,7 @@ Factor 0.76:
- Only 2 generations are used by default now, since there seems to be no
performance benefit to having 3 after running some brief benchmarks.
- New words:
math bitroll ( n s w -- n )
unparser hex-string ( str -- str )
sequences fourth ( seq -- elt )
- Many improvements to the matrices library.
- String input streams.
@ -25,8 +25,6 @@ Factor 0.76:
- Improved inspector. Call it with inspect ( obj -- ).
+ Framework
- md5 hashing algorithm in contrib/crypto/ (Doug Coleman).
Factor 0.75:

8
library/bootstrap/boot-stage1.factor
View File

@ -30,17 +30,19 @@ parser prettyprint sequences io vectors words ;
"/library/math/complex.factor"
"/library/collections/cons.factor"
"/library/collections/assoc.factor"
"/library/collections/lists.factor"
"/library/collections/vectors.factor"
"/library/collections/sequences-epilogue.factor"
"/library/collections/strings.factor"
"/library/collections/sbuf.factor"
"/library/collections/sequences-epilogue.factor"
"/library/collections/assoc.factor"
"/library/collections/lists.factor"
"/library/collections/hashtables.factor"
"/library/collections/namespaces.factor"
"/library/collections/vectors-epilogue.factor"
"/library/collections/sequence-eq.factor"
"/library/collections/slicing.factor"
"/library/collections/strings-epilogue.factor"
"/library/collections/tree-each.factor"
"/library/math/matrices.factor"

2
library/bootstrap/boot-stage2.factor
View File

@ -4,6 +4,8 @@ USING: alien assembler command-line compiler generic hashtables
kernel lists memory namespaces parser sequences io unparser
words ;
\ fiber? t "inline" set-word-prop
: pull-in ( ? list -- )
swap [
[

17
library/collections/assoc.factor
View File

@ -10,13 +10,13 @@ IN: lists USING: kernel sequences ;
: assoc* ( key alist -- [[ key value ]] )
#! Look up a key/value pair.
[ car = ] some-with? car ;
[ car = ] find-with nip ;
: assoc ( key alist -- value ) assoc* cdr ;
: assq* ( key alist -- [[ key value ]] )
#! Looks up a key/value pair using identity comparison.
[ car eq? ] some-with? car ;
[ car eq? ] find-with nip ;
: assq ( key alist -- value ) assq* cdr ;
@ -43,16 +43,3 @@ IN: lists USING: kernel sequences ;
swap [
unswons rot assoc* dup [ cdr call ] [ 2drop ] ifte
] each-with ;
: 2cons ( car1 car2 cdr1 cdr2 -- cons1 cons2 )
rot swons >r cons r> ;
: zip ( list list -- list )
#! Make a new list containing pairs of corresponding
#! elements from the two given lists.
2dup and [ 2uncons zip >r cons r> cons ] [ 2drop [ ] ] ifte ;
: unzip ( assoc -- keys values )
#! Split an association list into two lists of keys and
#! values.
[ uncons >r uncons r> unzip 2cons ] [ [ ] [ ] ] ifte* ;

139
library/collections/cons.factor
View File

@ -8,112 +8,79 @@ IN: lists USING: generic kernel sequences ;
DEFER: cons?
BUILTIN: cons 2 cons? [ 0 "car" f ] [ 1 "cdr" f ] ;
UNION: general-list f cons ;
! We borrow an idiom from Common Lisp. The car/cdr of an empty
! list is the empty list.
M: f car ;
M: f cdr ;
UNION: general-list f cons ;
GENERIC: >list ( seq -- list )
M: general-list >list ( list -- list ) ;
: swons ( cdr car -- [[ car cdr ]] )
#! Push a new cons cell. If the cdr is f or a proper list,
#! has the effect of prepending the car to the cdr.
swap cons ;
: uncons ( [[ car cdr ]] -- car cdr )
#! Push both the head and tail of a list.
dup car swap cdr ;
: unit ( a -- [ a ] )
#! Construct a proper list of one element.
f cons ;
: unswons ( [[ car cdr ]] -- cdr car )
#! Push both the head and tail of a list.
dup cdr swap car ;
: 2car ( cons cons -- car car )
swap car swap car ;
: 2cdr ( cons cons -- car car )
swap cdr swap cdr ;
: 2uncons ( cons1 cons2 -- car1 car2 cdr1 cdr2 )
[ 2car ] 2keep 2cdr ;
: last ( list -- last )
#! Last cons of a list.
dup cdr cons? [ cdr last ] when ;
M: cons peek ( list -- last )
#! Last element of a list.
last car ;
PREDICATE: general-list list ( list -- ? )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
dup [ last cdr ] when not ;
: all? ( list pred -- ? )
#! Push if the predicate returns true for each element of
#! the list.
over [
dup >r swap uncons >r swap call [
r> r> all?
] [
r> drop r> drop f
] ifte
] [
: uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ;
: unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ;
: swons ( cdr car -- [[ car cdr ]] ) swap cons ;
: unit ( a -- [ a ] ) f cons ;
: 2list ( a b -- [ a b ] ) unit cons ;
: 3list ( a b c -- [ a b c ] ) 2list cons ;
: 2unlist ( [ a b ] -- a b ) uncons car ;
: 3unlist ( [ a b c ] -- a b c ) uncons uncons car ;
: 2car ( cons cons -- car car ) swap car swap car ;
: 2cdr ( cons cons -- car car ) swap cdr swap cdr ;
: 2cons ( ca1 ca2 cd1 cd2 -- c1 c2 ) rot swons >r cons r> ;
: 2uncons ( c1 c2 -- ca1 ca2 cd1 cd2 ) [ 2car ] 2keep 2cdr ;
: zip ( list list -- list )
#! Make a new list containing pairs of corresponding
#! elements from the two given lists.
2dup and [ 2uncons zip >r cons r> cons ] [ 2drop [ ] ] ifte ;
: unzip ( assoc -- keys values )
#! Split an association list into two lists of keys and
#! values.
[ uncons >r uncons r> unzip 2cons ] [ [ ] [ ] ] ifte* ;
: unpair ( list -- list1 list2 )
[ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ;
: <queue> ( -- queue )
#! Make a new functional queue.
[[ [ ] [ ] ]] ;
: queue-empty? ( queue -- ? )
uncons or not ;
: enque ( obj queue -- queue )
uncons >r cons r> cons ;
: deque ( queue -- obj queue )
uncons
[ uncons swapd cons ] [ reverse uncons f swons ] ifte* ;
M: cons = ( obj cons -- ? )
2dup eq? [
2drop t
] ifte ; inline
: all-with? ( obj list pred -- ? )
swap [ with rot ] all? 2nip ; inline
: (each) ( list quot -- list quot )
[ >r car r> call ] 2keep >r cdr r> ; inline
M: f each ( list quot -- ) 2drop ;
M: cons each ( list quot -- | quot: elt -- ) (each) each ;
M: cons tree-each ( cons quot -- )
>r uncons r> tuck >r >r tree-each r> r> tree-each ;
: subset ( list quot -- list )
#! Applies a quotation with effect ( X -- ? ) to each
#! element of a list; all elements for which the quotation
#! returned a value other than f are collected in a new
#! list.
over [
over car >r (each)
rot >r subset r> [ r> swons ] [ r> drop ] ifte
] [
drop
] ifte ; inline
: subset-with ( obj list quot -- list )
swap [ with rot ] subset 2nip ; inline
: some? ( list pred -- ? )
#! Apply predicate with stack effect ( elt -- ? ) to each
#! element, return remainder of list from first occurrence
#! where it is true, or return f.
over [
dup >r over >r >r car r> call [
r> r> drop
over cons? [
2dup 2car = >r 2cdr = r> and
] [
r> cdr r> some?
2drop f
] ifte
] [
2drop f
] ifte ; inline
] ifte ;
: some-with? ( obj list pred -- ? )
#! Apply predicate with stack effect ( obj elt -- ? ) to
#! each element, return remainder of list from first
#! occurrence where it is true, or return f.
swap [ with rot ] some? 2nip ; inline
M: f = ( obj f -- ? ) eq? ;
M: cons hashcode ( cons -- hash ) car hashcode ;

112
library/collections/lists.factor
View File

@ -9,25 +9,33 @@ M: cons length cdr length 1 + ;
M: f empty? drop t ;
M: cons empty? drop f ;
: 2list ( a b -- [ a b ] )
unit cons ;
M: cons peek ( list -- last )
#! Last element of a list.
last car ;
: 2unlist ( [ a b ] -- a b )
uncons car ;
: (each) ( list quot -- list quot )
[ >r car r> call ] 2keep >r cdr r> ; inline
: 3list ( a b c -- [ a b c ] )
2list cons ;
M: f each ( list quot -- ) 2drop ;
: 3unlist ( [ a b c ] -- a b c )
uncons uncons car ;
M: cons each ( list quot -- | quot: elt -- ) (each) each ;
M: general-list contains? ( obj list -- ? )
#! Test if a list contains an element equal to an object.
[ = ] some-with? >boolean ;
: (list-find) ( list quot i -- i elt )
pick [
>r 2dup >r >r >r car r> call [
r> car r> drop r> swap
] [
r> cdr r> r> 1 + (list-find)
] ifte
] [
3drop -1 f
] ifte ; inline
: memq? ( obj list -- ? )
#! Test if a list contains an object.
[ eq? ] some-with? >boolean ;
M: general-list find ( list quot -- i elt )
0 (list-find) ;
M: general-list find* ( start list quot -- i elt )
>r tail r> find ;
: partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
rot [ swapd cons ] [ >r cons r> ] ifte ;
@ -61,7 +69,7 @@ M: general-list contains? ( obj list -- ? )
: unique ( elem list -- list )
#! Prepend an element to a list if it does not occur in the
#! list.
2dup contains? [ nip ] [ cons ] ifte ;
2dup member? [ nip ] [ cons ] ifte ;
M: general-list reverse ( list -- list )
[ ] [ swons ] reduce ;
@ -71,38 +79,10 @@ M: f map ( list quot -- list ) drop ;
M: cons map ( list quot -- list | quot: elt -- elt )
(each) rot >r map r> swons ;
: remove ( obj list -- list )
#! Remove all occurrences of objects equal to this one from
#! the list.
[ = not ] subset-with ;
IN: sequences
DEFER: <range>
: remq ( obj list -- list )
#! Remove all occurrences of the object from the list.
[ eq? not ] subset-with ;
: prune ( list -- list )
#! Remove duplicate elements.
dup [ uncons prune unique ] when ;
: fiber? ( list quot -- ? | quot: elt elt -- ? )
#! Check if all elements in the list are equivalent under
#! the relation.
over [ >r uncons r> all-with? ] [ 2drop t ] ifte ; inline
M: cons = ( obj cons -- ? )
2dup eq? [
2drop t
] [
over cons? [
2dup 2car = >r 2cdr = r> and
] [
2drop f
] ifte
] ifte ;
M: f = ( obj f -- ? ) eq? ;
M: cons hashcode ( cons -- hash ) car hashcode ;
IN: lists
: count ( n -- [ 0 ... n-1 ] )
0 swap <range> >list ;
@ -113,6 +93,11 @@ M: cons hashcode ( cons -- hash ) car hashcode ;
: project-with ( elt n quot -- list )
swap [ with rot ] project 2nip ; inline
: seq-transpose ( seq -- list )
#! An example illustrates this word best:
#! [ [ 1 2 3 ] [ 4 5 6 ] ] ==> [ [ 1 2 ] [ 3 4 ] [ 5 6 ] ]
dup first length [ swap [ nth ] map-with ] project-with ;
M: general-list head ( n list -- list )
#! Return the first n elements of the list.
over 0 > [
@ -127,38 +112,3 @@ M: general-list tail ( n list -- tail )
M: general-list nth ( n list -- element )
over 0 number= [ nip car ] [ >r 1 - r> cdr nth ] ifte ;
: intersection ( list list -- list )
#! Make a list of elements that occur in both lists.
[ swap contains? ] subset-with ;
: difference ( list1 list2 -- list )
#! Make a list of elements that occur in list2 but not
#! list1.
[ swap contains? not ] subset-with ;
: diffq ( list1 list2 -- list )
#! Make a list of elements that occur in list2 but not
#! list1.
[ swap memq? not ] subset-with ;
: contained? ( list1 list2 -- ? )
#! Is every element of list1 in list2?
swap [ swap contains? ] all-with? ;
: unpair ( list -- list1 list2 )
[ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ;
: <queue> ( -- queue )
#! Make a new functional queue.
[[ [ ] [ ] ]] ;
: queue-empty? ( queue -- ? )
uncons or not ;
: enque ( obj queue -- queue )
uncons >r cons r> cons ;
: deque ( queue -- obj queue )
uncons
[ uncons swapd cons ] [ reverse uncons f swons ] ifte* ;

2
library/collections/namespaces.factor
View File

@ -144,7 +144,7 @@ SYMBOL: building
make-sbuf >string ; inline
: make-rstring ( quot -- string )
make-sbuf dup nreverse >string ; inline
make-sbuf <reversed> >string ; inline
! Building hashtables, and computing a transitive closure.
SYMBOL: hash-buffer

33
library/collections/sequence-eq.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sequences
USING: kernel kernel-internals lists math strings vectors ;
! Note that the sequence union does not include lists, or user
! defined tuples that respond to the sequence protocol.
UNION: sequence array string sbuf vector ;
: length= ( seq seq -- ? ) length swap length number= ;
: (sequence=) ( seq seq i -- ? )
over length over number= [
3drop t
] [
3dup 2nth = [ 1 + (sequence=) ] [ 3drop f ] ifte
] ifte ;
: sequence= ( seq seq -- ? )
#! Check if two sequences have the same length and elements,
#! but not necessarily the same class.
over general-list? over general-list? or [
swap >list swap >list =
] [
2dup length= [ 0 (sequence=) ] [ 2drop f ] ifte
] ifte ;
M: sequence = ( obj seq -- ? )
2dup eq? [
2drop t
] [
over type over type eq? [ sequence= ] [ 2drop f ] ifte
] ifte ;

212
library/collections/sequences-epilogue.factor
View File

@ -4,39 +4,24 @@ IN: sequences
USING: generic kernel kernel-internals lists math strings
vectors ;
! This is loaded once everything else is available.
! A reversal of an underlying sequence.
TUPLE: reversed ;
C: reversed [ set-delegate ] keep ;
: reversed@ delegate [ length swap - 1 - ] keep ;
M: reversed nth ( n seq -- elt ) reversed@ nth ;
M: reversed set-nth ( elt n seq -- ) reversed@ set-nth ;
! Note that the sequence union does not include lists, or user
! defined tuples that respond to the sequence protocol.
UNION: sequence array string sbuf vector ;
M: object thaw clone ;
M: object like drop ;
M: object empty? ( seq -- ? ) length 0 = ;
: (>list) ( n i seq -- list )
pick pick <= [
3drop [ ]
] [
2dup nth >r >r 1 + r> (>list) r> swons
] ifte ;
M: object >list ( seq -- list ) dup length 0 rot (>list) ;
: 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ;
! A repeated sequence is the same element n times.
TUPLE: repeated length object ;
M: repeated length repeated-length ;
M: repeated nth nip repeated-object ;
! Combinators
M: object each ( quot seq -- )
M: object each ( seq quot -- )
swap dup length [
[ swap nth swap call ] 3keep
] repeat 2drop ;
M: object tree-each call ;
M: sequence tree-each swap [ swap tree-each ] each-with ;
: change-nth ( seq i quot -- )
pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
inline
@ -52,9 +37,6 @@ M: sequence tree-each swap [ swap tree-each ] each-with ;
#! Destructive on seq.
0 swap (nmap) ; inline
: immutable ( seq quot -- seq | quot: seq -- )
swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
M: object map ( seq quot -- seq | quot: elt -- elt )
swap [ swap nmap ] immutable ;
@ -70,26 +52,94 @@ M: object map ( seq quot -- seq | quot: elt -- elt )
M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
swap [ swap 2nmap ] immutable ;
! Operations
: index* ( obj seq i -- n )
#! The index of the object in the sequence, starting from i.
over length over <= [
3drop -1
M: object find* ( i seq quot -- i elt )
pick pick length >= [
3drop -1 f
] [
3dup swap nth = [ 2nip ] [ 1 + index* ] ifte
3dup >r >r >r >r nth r> call [
r> dup r> nth r> drop
] [
r> 1 + r> r> find*
] ifte
] ifte ;
M: object find ( seq quot -- i elt )
0 -rot find* ;
: contains? ( seq quot -- ? )
find drop -1 > ; inline
: contains-with? ( obj seq quot -- ? )
find-with drop -1 > ; inline
: all? ( seq quot -- ? )
#! ForAll(P in X) <==> !Exists(!P in X)
swap [ swap call not ] contains-with? not ; inline
: all-with? ( obj list pred -- ? )
swap [ with rot ] all? 2nip ; inline
: subset ( seq quot -- seq | quot: elt -- ? )
#! all elements for which the quotation returned a value
#! other than f are collected in a new list.
swap [
dup length <vector> -rot [
rot >r 2dup >r >r swap call [
r> r> r> [ push ] keep swap
] [
r> r> drop r> swap
] ifte
] each drop
] keep like ; inline
: subset-with ( obj list quot -- list )
swap [ with rot ] subset 2nip ; inline
: fiber? ( seq quot -- ? | quot: elt elt -- ? )
#! Tests if all elements are equivalent under the relation.
over empty?
[ >r [ first ] keep r> all-with? ] [ 2drop t ] ifte ; inline
! Operations
M: object thaw clone ;
M: object like drop ;
M: object empty? ( seq -- ? ) length 0 = ;
: (>list) ( n i seq -- list )
pick pick <= [
3drop [ ]
] [
2dup nth >r >r 1 + r> (>list) r> swons
] ifte ;
M: object >list ( seq -- list ) dup length 0 rot (>list) ;
: index* ( obj i seq -- n )
#! The index of the object in the sequence, starting from i.
[ = ] find-with* drop ;
: index ( obj seq -- n )
#! The index of the object in the sequence.
0 index* ;
[ = ] find-with drop ;
M: object contains? ( obj seq -- ? )
: member? ( obj seq -- ? )
#! Tests for membership using =.
index -1 > ;
[ = ] contains-with? ;
: push ( element sequence -- )
#! Push a value on the end of a sequence.
dup length swap set-nth ;
: memq? ( obj seq -- ? )
#! Tests for membership using eq?
[ eq? ] contains-with? ;
: remove ( obj list -- list )
#! Remove all occurrences of objects equal to this one from
#! the list.
[ = not ] subset-with ;
: remq ( obj list -- list )
#! Remove all occurrences of the object from the list.
[ eq? not ] subset-with ;
: nappend ( s1 s2 -- )
#! Destructively append s2 to s1.
@ -123,68 +173,36 @@ M: object peek ( sequence -- element )
#! Get value at end of sequence and remove it.
dup peek >r dup length 1 - swap set-length r> ;
: push-new ( elt seq -- )
2dup member? [ 2drop ] [ push ] ifte ;
: prune ( seq -- seq )
[
dup length <vector> swap [ over push-new ] each
] keep like ;
: >pop> ( stack -- stack ) dup pop drop ;
: (exchange) ( seq i j -- seq[i] j seq )
pick >r >r swap nth r> r> ;
M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
: exchange ( seq i j -- )
#! Exchange seq[i] and seq[j].
[ (exchange) ] 3keep swap (exchange) set-nth set-nth ;
! Set theoretic operations
: seq-intersect ( seq seq -- seq )
#! Make a list of elements that occur in both lists.
[ swap member? ] subset-with ;
: (nreverse) ( seq i -- )
#! Swap seq[i] with seq[length-i-1].
over length over - 1 - exchange ;
: seq-diff ( list1 list2 -- list )
#! Make a list of elements that occur in list2 but not
#! list1.
[ swap member? not ] subset-with ;
: nreverse ( seq -- )
#! Destructively reverse seq.
dup length 2 /i [ 2dup (nreverse) ] repeat drop ;
: seq-diffq ( list1 list2 -- list )
#! Make a list of elements that occur in list2 but not
#! list1.
[ swap memq? not ] subset-with ;
M: object reverse ( seq -- seq ) [ nreverse ] immutable ;
! Equality testing
: length= ( seq seq -- ? ) length swap length number= ;
: (sequence=) ( seq seq i -- ? )
over length over number= [
3drop t
] [
3dup 2nth = [
1 + (sequence=)
] [
3drop f
] ifte
] ifte ;
: sequence= ( seq seq -- ? )
#! Check if two sequences have the same length and elements,
#! but not necessarily the same class.
over general-list? over general-list? or [
swap >list swap >list =
] [
2dup length= [ 0 (sequence=) ] [ 2drop f ] ifte
] ifte ;
M: sequence = ( obj seq -- ? )
2dup eq? [
2drop t
] [
over type over type eq? [
sequence=
] [
2drop f
] ifte
] ifte ;
! A repeated sequence is the same element n times.
TUPLE: repeated length object ;
M: repeated length repeated-length ;
M: repeated nth nip repeated-object ;
: seq-transpose ( list -- list )
#! An example illustrates this word best:
#! [ [ 1 2 3 ] [ 4 5 6 ] ] ==> [ [ 1 2 ] [ 3 4 ] [ 5 6 ] ]
0 over nth length [ swap [ nth ] map-with ] project-with ;
: contained? ( list1 list2 -- ? )
#! Is every element of list1 in list2?
swap [ swap member? ] all-with? ;
IN: kernel

28
library/collections/sequences.factor
View File

@ -20,7 +20,6 @@ GENERIC: thaw ( seq -- mutable-seq )
GENERIC: like ( seq seq -- seq )
GENERIC: reverse ( seq -- seq )
GENERIC: peek ( seq -- elt )
GENERIC: contains? ( elt seq -- ? )
GENERIC: head ( n seq -- seq )
GENERIC: tail ( n seq -- seq )
GENERIC: concat ( seq -- seq )
@ -35,12 +34,6 @@ G: each ( seq quot -- | quot: elt -- )
: reduce ( list identity quot -- value | quot: x y -- z )
swapd each ; inline
G: tree-each ( obj quot -- | quot: elt -- )
[ over ] [ type ] ; inline
: tree-each-with ( obj vector quot -- )
swap [ with ] tree-each 2drop ; inline
G: map ( seq quot -- seq | quot: elt -- elt )
[ over ] [ type ] ; inline
@ -53,15 +46,30 @@ G: map ( seq quot -- seq | quot: elt -- elt )
G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
[ over ] [ type ] ; inline
DEFER: <range>
DEFER: append ! remove this when sort is moved from lists to sequences
DEFER: subseq
G: find [ over ] [ type ] ; inline
: find-with ( obj seq quot -- i elt )
swap [ with rot ] find 2swap 2drop ; inline
G: find* [ over ] [ type ] ; inline
: find-with* ( obj i seq quot -- i elt )
-rot [ with rot ] find* 2swap 2drop ; inline
: immutable ( seq quot -- seq | quot: seq -- )
swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
: first 0 swap nth ; inline
: second 1 swap nth ; inline
: third 2 swap nth ; inline
: fourth 3 swap nth ; inline
: push ( element sequence -- )
#! Push a value on the end of a sequence.
dup length swap set-nth ;
: 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ;
: 2unseq ( { x y } -- x y )
dup first swap second ;

6
library/collections/strings.factor
View File

@ -30,7 +30,7 @@ M: string >string ;
string-compare 0 > ;
! Characters
PREDICATE: integer blank " \t\n\r" contains? ;
PREDICATE: integer blank " \t\n\r" member? ;
PREDICATE: integer letter CHAR: a CHAR: z between? ;
PREDICATE: integer LETTER CHAR: A CHAR: Z between? ;
PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
@ -39,7 +39,7 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
: quotable? ( ch -- ? )
#! In a string literal, can this character be used without
#! escaping?
dup printable? swap "\"\\" contains? not and ;
dup printable? swap "\"\\" member? not and ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
@ -47,4 +47,4 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
dup letter?
over LETTER? or
over digit? or
swap "/_?." contains? or ;
swap "/_?." member? or ;

17
library/collections/tree-each.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sequences
USING: generic kernel lists ;
G: tree-each ( obj quot -- | quot: elt -- )
[ over ] [ type ] ; inline
: tree-each-with ( obj vector quot -- )
swap [ with ] tree-each 2drop ; inline
M: object tree-each call ;
M: sequence tree-each swap [ swap tree-each ] each-with ;
M: cons tree-each ( cons quot -- )
>r uncons r> tuck >r >r tree-each r> r> tree-each ;

12
library/collections/vectors-epilogue.factor
View File

@ -26,8 +26,10 @@ M: general-list like drop >list ;
M: vector like drop >vector ;
: 3vector ( x y z -- { x y z } )
3 <vector>
[ >r rot r> push ] keep
[ swapd push ] keep
[ push ] keep ;
: (1vector) [ push ] keep ; inline
: (2vector) [ swapd push ] keep (1vector) ; inline
: (3vector) [ >r rot r> push ] keep (2vector) ; inline
: 1vector ( x -- { x } ) 1 <vector> (1vector) ;
: 2vector ( x y -- { x y } ) 2 <vector> (2vector) ;
: 3vector ( x y z -- { x y z } ) 3 <vector> (3vector) ;

4
library/compiler/optimizer.factor
View File

@ -108,7 +108,7 @@ M: #push can-kill* ( literal node -- ? )
2drop t ;
M: #push kill-node* ( literals node -- )
[ node-out-d diffq ] keep set-node-out-d ;
[ node-out-d seq-diffq ] keep set-node-out-d ;
M: #push useless-node? ( node -- ? )
node-out-d empty? ;
@ -118,7 +118,7 @@ M: #drop can-kill* ( literal node -- ? )
2drop t ;
M: #drop kill-node* ( literals node -- )
[ node-in-d diffq ] keep set-node-in-d ;
[ node-in-d seq-diffq ] keep set-node-in-d ;
M: #drop useless-node? ( node -- ? )
node-in-d empty? ;

18
library/compiler/simplifier.factor
View File

@ -35,7 +35,7 @@ M: tuple simplify-node drop f ;
] with-scope [ simplify ] when ;
: label-called? ( label -- ? )
simplifying get [ calls-label? ] some-with? ;
simplifying get [ calls-label? ] contains-with? ;
M: %label simplify-node ( linear vop -- linear ? )
vop-label label-called? [ f ] [ cdr t ] ifte ;
@ -93,11 +93,11 @@ M: %tag-fixnum simplify-node ( linear vop -- linear ? )
#! current basic block. Outputs a true value if the vreg
#! is not read or written before the end of the basic block.
[
2dup vop-inputs contains? [
2dup vop-inputs member? [
! we are reading the vreg
2drop t f
] [
2dup vop-outputs contains? [
2dup vop-outputs member? [
! we are writing the vreg
2drop f f
] [
@ -172,10 +172,16 @@ M: %replace-d simplify-node ( linear vop -- linear ? )
M: fast-branch simplify-node ( linear vop -- linear ? )
class fast-branch make-fast-branch ;
: ?label ( symbol linear -- ? )
car dup %label? [ vop-label = ] [ 2drop f ] ifte ;
: (find-label) ( label linear -- linear )
dup
[ 2dup ?label [ nip ] [ cdr (find-label) ] ifte ]
[ 2drop f ] ifte ;
: find-label ( label -- rest )
simplifying get [
dup %label? [ vop-label = ] [ 2drop f ] ifte
] some-with? ;
simplifying get (find-label) ;
M: %label next-logical ( linear vop -- linear )
drop cdr dup car next-logical ;

2
library/compiler/xt.factor
View File

@ -124,7 +124,7 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
dup compiled? [
drop t
] [
dup compile-words get contains? [
dup compile-words get member? [
drop t
] [
compiled-xts get assoc

2
library/generic/complement.factor
View File

@ -11,7 +11,7 @@ SYMBOL: complement
complement [
"complement" word-prop builtin-supertypes
num-types count
difference
seq-diff
] "builtin-supertypes" set-word-prop
complement [

2
library/generic/generic.factor
View File

@ -184,7 +184,7 @@ SYMBOL: object
#! Return a class that is a subclass of both, or null in
#! the degenerate case.
swap builtin-supertypes swap builtin-supertypes
intersection lookup-union ;
seq-intersect lookup-union ;
: define-class ( class metaclass -- )
dupd "metaclass" set-word-prop

4
library/httpd/html.factor
View File

@ -29,9 +29,9 @@ sequences strings styles unparser words ;
"color: #" % hex-color, "; " % ;
: style-css, ( flag -- )
dup [ italic bold-italic ] contains?
dup [ italic bold-italic ] member?
[ "font-style: italic; " % ] when
[ bold bold-italic ] contains?
[ bold bold-italic ] member?
[ "font-weight: bold; " % ] when ;
: underline-css, ( flag -- )

4
library/inference/branches.factor
View File

@ -5,10 +5,10 @@ USING: errors generic interpreter kernel lists math namespaces
sequences strings vectors words hashtables prettyprint ;
: longest ( list -- length )
0 swap [ length max ] each ;
[ length ] map 0 [ max ] reduce ;
: computed-value-vector ( n -- vector )
[ drop object <computed> ] project >vector ;
empty-vector [ object <computed> ] map ;
: add-inputs ( count stack -- stack )
#! Add this many inputs to the given stack.

2
library/inference/inference.factor
View File

@ -99,7 +99,7 @@ M: object apply-object apply-literal ;
: handle-terminator ( quot -- )
#! If the quotation throws an error, do not count its stack
#! effect.
[ terminator? ] some? [ terminate ] when ;
[ terminator? ] find drop -1 > [ terminate ] when ;
: infer-quot ( quot -- )
#! Recursive calls to this word are made for nested

2
library/io/directories.factor
View File

@ -20,5 +20,5 @@ sequences strings unparser ;
: directory. ( dir -- )
#! If "doc-root" set, create links relative to it.
dup directory [
dup [ "." ".." ] contains? [ 2drop ] [ file. ] ifte
dup [ "." ".." ] member? [ 2drop ] [ file. ] ifte
] each-with ;

2
library/io/string-streams.factor
View File

@ -22,7 +22,7 @@ M: sbuf stream-read ( count sbuf -- string )
] ifte ;
: <string-reader> ( string -- stream )
>sbuf dup nreverse <line-reader> ;
<reversed> >sbuf <line-reader> ;
: string-in ( str quot -- )
[ swap <string-reader> stdio set call ] with-scope ;

4
library/syntax/parse-numbers.factor
View File

@ -32,12 +32,12 @@ GENERIC: str>number ( str -- num )
M: string str>number 10 base> ;
PREDICATE: string potential-ratio CHAR: / swap contains? ;
PREDICATE: string potential-ratio CHAR: / swap member? ;
M: potential-ratio str>number ( str -- num )
dup CHAR: / swap index swap cut*
swap 10 base> swap 10 base> / ;
PREDICATE: string potential-float CHAR: . swap contains? ;
PREDICATE: string potential-float CHAR: . swap member? ;
M: potential-float str>number ( str -- num )
str>float ;

2
library/syntax/parse-words.factor
View File

@ -76,7 +76,7 @@ global [ string-mode off ] bind
! Used by parsing words
: ch-search ( ch -- index )
"line" get "col" get index* ;
"col" get "line" get index* ;
: (until) ( index -- str )
"col" get swap dup 1 + "col" set "line" get subseq ;

2
library/syntax/unparser.factor
View File

@ -53,7 +53,7 @@ M: ratio unparse ( num -- str )
: fix-float ( str -- str )
#! This is terrible. Will go away when we do our own float
#! output.
CHAR: . over contains? [ ".0" append ] unless ;
CHAR: . over member? [ ".0" append ] unless ;
M: float unparse ( float -- str )
(unparse-float) fix-float ;

2
library/test/compiler/optimizer.factor
View File

@ -28,7 +28,7 @@ USE: sequences
[ t ] [
3 [ 3 over [ ] [ ] ifte drop ] dataflow
kill-set [ value= ] some-with? >boolean
kill-set [ value= ] contains-with?
] unit-test
: literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled

1
library/test/hashtables.factor
View File

@ -6,6 +6,7 @@ USE: math
USE: namespaces
USE: test
USE: vectors
USE: sequences
16 <hashtable> "testhash" set

2
library/test/inference.factor
View File

@ -211,7 +211,7 @@ M: real iterate drop ;
[ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ member? ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test

13
library/test/lists/combinators.factor
View File

@ -10,12 +10,6 @@ USE: sequences
[ [ [ 3 2 1 ] [ 5 4 3 ] [ 6 ] ] ]
[ [ 1 2 3 ] [ 3 4 5 ] [ 6 ] 3list [ reverse ] map ] unit-test
[ f ] [ [ "Hello" { } 4/3 ] [ string? ] all? ] unit-test
[ t ] [ [ ] [ ] all? ] unit-test
[ t ] [ [ "hi" t 1/2 ] [ ] all? ] unit-test
[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test
[ [ 43 "a" [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
[ "fdsfs" [ > ] sort ] unit-test-fails
@ -29,11 +23,4 @@ USE: sequences
[ t ] [ [ 1/2 ] [ = ] fiber? ] unit-test
[ t ] [ [ 1.0 10/10 1 ] [ = ] fiber? ] unit-test
[ f ] [ [ ] [ ] some? ] unit-test
[ t ] [ [ 1 ] [ ] some? >boolean ] unit-test
[ t ] [ [ 1 2 3 ] [ 2 > ] some? >boolean ] unit-test
[ f ] [ [ 1 2 3 ] [ 10 > ] some? ] unit-test
[ [ 2 3 4 ] ] [ 1 [ 1 2 3 ] [ + ] map-with ] unit-test
[ [ 3 ] ] [ 2 [ 1 2 3 ] [ < ] subset-with ] unit-test

7
library/test/lists/lists.factor
View File

@ -10,11 +10,6 @@ USING: kernel lists sequences test ;
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test
[ f ] [ 3 [ ] contains? ] unit-test
[ f ] [ 3 [ 1 2 ] contains? ] unit-test
[ t ] [ 1 [ 1 2 ] contains? >boolean ] unit-test
[ t ] [ 2 [ 1 2 ] contains? >boolean ] unit-test
[ [ 3 ] ] [ [ 3 ] last ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] last ] unit-test
[ [[ 3 4 ]] ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] last ] unit-test
@ -52,7 +47,7 @@ USING: kernel lists sequences test ;
[ f ] [ 3 [ 1 2 3 ] tail ] unit-test
[ [ 3 ] ] [ 2 [ 1 2 3 ] tail ] unit-test
[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] difference ] unit-test
[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] seq-diff ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 4 5 ] contained? ] unit-test
[ f ] [ [ 1 2 3 6 ] [ 1 2 3 4 5 ] contained? ] unit-test

2
library/test/parsing-word.factor
View File

@ -14,5 +14,5 @@ DEFER: foo
! Test > 1 ( ) comment; only the first one should be used.
[ t ] [
CHAR: a "IN: temporary : foo ( a ) ( b ) ;" parse drop word
"stack-effect" word-prop contains?
"stack-effect" word-prop member?
] unit-test

37
library/test/sequences.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: lists math sequences test vectors ;
USING: kernel lists math sequences strings test vectors ;
[ [ 1 2 3 4 ] ] [ 1 5 <range> >list ] unit-test
[ 3 ] [ 1 4 <range> length ] unit-test
@ -19,3 +19,38 @@ USING: lists math sequences test vectors ;
[ [ 1 1 2 6 24 120 720 ] ]
[ [ 1 2 3 4 5 6 7 ] 1 [ * ] accumulate ] unit-test
[ -1 f ] [ [ ] [ ] find ] unit-test
[ 0 1 ] [ [ 1 ] [ ] find ] unit-test
[ 1 "world" ] [ [ "hello" "world" ] [ "world" = ] find ] unit-test
[ 2 3 ] [ [ 1 2 3 ] [ 2 > ] find ] unit-test
[ -1 f ] [ [ 1 2 3 ] [ 10 > ] find ] unit-test
[ 1 CHAR: e ]
[ "aeiou" "hello world" [ swap member? ] find-with ] unit-test
[ 4 CHAR: o ]
[ "aeiou" 3 "hello world" [ swap member? ] find-with* ] unit-test
[ f ] [ 3 [ ] member? ] unit-test
[ f ] [ 3 [ 1 2 ] member? ] unit-test
[ t ] [ 1 [ 1 2 ] member? ] unit-test
[ t ] [ 2 [ 1 2 ] member? ] unit-test
[ t ]
[ [ "hello" "world" ] [ second ] keep memq? ] unit-test
[ 4 ] [ CHAR: x "tuvwxyz" >vector index ] unit-test
[ -1 ] [ CHAR: x 5 "tuvwxyz" >vector index* ] unit-test
[ -1 ] [ CHAR: a 0 "tuvwxyz" >vector index* ] unit-test
[ f ] [ [ "Hello" { } 4/3 ] [ string? ] all? ] unit-test
[ t ] [ [ ] [ ] all? ] unit-test
[ t ] [ [ "hi" t 1/2 ] [ ] all? ] unit-test
[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test
[ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test
[ [ 3 ] ] [ 2 [ 1 2 3 ] [ < ] subset-with ] unit-test

2
library/test/strings.factor
View File

@ -24,7 +24,7 @@ USE: lists
[ "Beginning" ] [ 9 "Beginning and end" head ] unit-test
[ f ] [ CHAR: I "team" contains? ] unit-test
[ f ] [ CHAR: I "team" member? ] unit-test
[ t ] [ "ea" "team" subseq? ] unit-test
[ f ] [ "actore" "Factor" subseq? ] unit-test

4
library/test/vectors.factor
View File

@ -94,8 +94,6 @@ unit-test
[ -1 ] [ 5 { } index ] unit-test
[ 4 ] [ 5 { 1 2 3 4 5 } index ] unit-test
[ { "c" "b" "a" } ] [ { "a" "b" "c" } clone dup 0 2 exchange ] unit-test
[ t ] [
100 count dup >vector dup nreverse >list >r reverse r> =
100 count dup >vector <reversed> >list >r reverse r> =
] unit-test

2
library/ui/buttons.factor
View File

@ -4,7 +4,7 @@ IN: gadgets
USING: generic kernel lists math namespaces prettyprint sdl
sequences io sequences styles ;
: button-down? ( n -- ? ) hand hand-buttons contains? ;
: button-down? ( n -- ? ) hand hand-buttons member? ;
: mouse-over? ( gadget -- ? ) hand hand-gadget child? ;

12
library/ui/gadgets.factor
View File

@ -9,20 +9,20 @@ sequences vectors ;
! delegates to its shape.
TUPLE: gadget paint gestures relayout? root? parent children ;
: gadget-child gadget-children car ;
: gadget-child gadget-children first ;
C: gadget ( -- gadget )
{ 0 0 0 } dup <rectangle> over set-delegate
<namespace> over set-gadget-paint
<namespace> over set-gadget-gestures ;
{ 0 0 0 } dup <rectangle> over set-delegate ;
TUPLE: plain-gadget ;
C: plain-gadget <gadget> over set-delegate ;
C: plain-gadget ( -- gadget )
<gadget> over set-delegate ;
TUPLE: etched-gadget ;
C: etched-gadget <gadget> over set-delegate ;
C: etched-gadget ( -- gadget )
<gadget> over set-delegate ;
DEFER: add-invalid

14
library/ui/hand.factor
View File

@ -6,13 +6,8 @@ prettyprint sdl sequences vectors ;
DEFER: pick-up
: (pick-up) ( point list -- gadget )
dup [
2dup car pick-up dup
[ 2nip ] [ drop cdr (pick-up) ] ifte
] [
2drop f
] ifte ;
: (pick-up) ( point gadget -- gadget )
gadget-children <reversed> [ pick-up ] find nip ;
: pick-up ( point gadget -- gadget )
#! The logic is thus. If the point is definately outside the
@ -20,10 +15,7 @@ DEFER: pick-up
#! in any subgadget. If not, see if it is contained in the
#! box delegate.
2dup inside? [
[
[ translate ] keep
gadget-children reverse (pick-up) dup
] keep ?
[ [ translate ] keep (pick-up) dup ] keep ?
] [
2drop f
] ifte ;

8
library/ui/hierarchy.factor
View File

@ -17,13 +17,15 @@ sequences ;
: clear-gadget ( gadget -- )
dup gadget-children [ f swap set-gadget-parent ] each
f over set-gadget-children relayout ;
0 over gadget-children set-length relayout ;
: ?push ( elt seq/f -- seq )
[ push ] [ 1vector ] ifte* ;
: (add-gadget) ( gadget box -- )
#! This is inefficient.
over unparent
dup pick set-gadget-parent
[ gadget-children swap add ] keep set-gadget-children ;
[ gadget-children ?push ] keep set-gadget-children ;
: add-gadget ( gadget parent -- )
#! Add a gadget to a parent gadget.

4
library/ui/layouts.factor
View File

@ -35,7 +35,7 @@ TUPLE: pack align fill vector ;
2dup packed-dim-2 swap orient ;
: packed-dims ( gadget sizes -- list )
over gadget-children >r (packed-dims) r>
over gadget-children >list >r (packed-dims) r>
zip [ uncons set-gadget-dim ] each ;
: packed-loc-1 ( sizes -- list )
@ -51,7 +51,7 @@ TUPLE: pack align fill vector ;
dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
: packed-locs ( gadget sizes -- )
over gadget-children >r (packed-locs) r>
over gadget-children >list >r (packed-locs) r>
zip [ uncons set-shape-loc ] each ;
: packed-layout ( gadget sizes -- )

2
library/win32/win32-io-internals.factor
View File

@ -35,7 +35,7 @@ SYMBOL: callbacks
: expected-error? ( -- bool )
[
ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS WAIT_TIMEOUT
] contains? ;
] member? ;
: handle-io-error ( -- )
GetLastError expected-error? [ win32-throw-error ] unless ;

2
library/win32/win32-server.factor
View File

@ -41,7 +41,7 @@ SYMBOL: socket
: handle-socket-error ( -- )
WSAGetLastError [
ERROR_IO_PENDING ERROR_SUCCESS
] contains? [
] member? [
win32-error-message throw
] unless ;