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
- 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.
- Improved inspector. Call it with inspect ( obj -- ).
-+ Framework
-
- md5 hashing algorithm in contrib/crypto/ (Doug Coleman).
Factor 0.75:
"/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"
kernel lists memory namespaces parser sequences io unparser\r
words ;\r
\r
+\ fiber? t "inline" set-word-prop\r
+\r
: pull-in ( ? list -- )\r
swap [\r
[\r
: 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 ;
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* ;
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
- ] [
- 2drop t
- ] ifte ; inline
+: 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 ;
-: all-with? ( obj list pred -- ? )
- swap [ with rot ] all? 2nip ; inline
+: unzip ( assoc -- keys values )
+ #! Split an association list into two lists of keys and
+ #! values.
+ [ uncons >r uncons r> unzip 2cons ] [ [ ] [ ] ] ifte* ;
-: (each) ( list quot -- list quot )
- [ >r car r> call ] 2keep >r cdr r> ; inline
+: unpair ( list -- list1 list2 )
+ [ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ;
-M: f each ( list quot -- ) 2drop ;
+: <queue> ( -- queue )
+ #! Make a new functional queue.
+ [[ [ ] [ ] ]] ;
-M: cons each ( list quot -- | quot: elt -- ) (each) each ;
+: queue-empty? ( queue -- ? )
+ uncons or not ;
-M: cons tree-each ( cons quot -- )
- >r uncons r> tuck >r >r tree-each r> r> tree-each ;
+: enque ( obj queue -- queue )
+ uncons >r cons r> cons ;
-: 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
+: deque ( queue -- obj queue )
+ uncons
+ [ uncons swapd cons ] [ reverse uncons f swons ] ifte* ;
+
+M: cons = ( obj cons -- ? )
+ 2dup eq? [
+ 2drop t
] [
- 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
-
-: 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
+ ] ifte ;
+
+M: f = ( obj f -- ? ) eq? ;
+
+M: cons hashcode ( cons -- hash ) car hashcode ;
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
+
+M: general-list find ( list quot -- i elt )
+ 0 (list-find) ;
-: memq? ( obj list -- ? )
- #! Test if a list contains an object.
- [ eq? ] some-with? >boolean ;
+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 ;
: 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 ;
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 ;
-
-: 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? ;
+IN: sequences
+DEFER: <range>
-M: cons hashcode ( cons -- hash ) car hashcode ;
+IN: lists
: count ( n -- [ 0 ... n-1 ] )
0 swap <range> >list ;
: 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 > [
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* ;
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
--- /dev/null
+! 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 ;
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
#! 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 ;
M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
swap [ swap 2nmap ] immutable ;
+M: object find* ( i seq quot -- i elt )
+ pick pick length >= [
+ 3drop -1 f
+ ] [
+ 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
-: index* ( obj seq i -- n )
- #! The index of the object in the sequence, starting from i.
- over length over <= [
- 3drop -1
+M: object thaw clone ;
+
+M: object like drop ;
+
+M: object empty? ( seq -- ? ) length 0 = ;
+
+: (>list) ( n i seq -- list )
+ pick pick <= [
+ 3drop [ ]
] [
- 3dup swap nth = [ 2nip ] [ 1 + index* ] ifte
+ 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.
#! Get value at end of sequence and remove it.
dup peek >r dup length 1 - swap set-length r> ;
-: >pop> ( stack -- stack ) dup pop drop ;
-
-: (exchange) ( seq i j -- seq[i] j seq )
- pick >r >r swap nth r> r> ;
+: push-new ( elt seq -- )
+ 2dup member? [ 2drop ] [ push ] ifte ;
-: exchange ( seq i j -- )
- #! Exchange seq[i] and seq[j].
- [ (exchange) ] 3keep swap (exchange) set-nth set-nth ;
+: prune ( seq -- seq )
+ [
+ dup length <vector> swap [ over push-new ] each
+ ] keep like ;
-: (nreverse) ( seq i -- )
- #! Swap seq[i] with seq[length-i-1].
- over length over - 1 - exchange ;
-
-: nreverse ( seq -- )
- #! Destructively reverse seq.
- dup length 2 /i [ 2dup (nreverse) ] repeat drop ;
-
-M: object reverse ( seq -- seq ) [ nreverse ] immutable ;
+: >pop> ( stack -- stack ) dup pop drop ;
-! Equality testing
-: length= ( seq seq -- ? ) length swap length number= ;
+M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
-: (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 ;
+! Set theoretic operations
+: seq-intersect ( seq seq -- seq )
+ #! Make a list of elements that occur in both lists.
+ [ swap member? ] subset-with ;
-M: sequence = ( obj seq -- ? )
- 2dup eq? [
- 2drop t
- ] [
- over type over type eq? [
- sequence=
- ] [
- 2drop f
- ] ifte
- ] ifte ;
+: seq-diff ( list1 list2 -- list )
+ #! Make a list of elements that occur in list2 but not
+ #! list1.
+ [ swap member? not ] subset-with ;
-! 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-diffq ( list1 list2 -- list )
+ #! Make a list of elements that occur in list2 but not
+ #! list1.
+ [ swap memq? not ] subset-with ;
-: 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
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 )
: 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
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 ;
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? ;
: 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
dup letter?
over LETTER? or
over digit? or
- swap "/_?." contains? or ;
+ swap "/_?." member? or ;
--- /dev/null
+! 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 ;
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) ;
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? ;
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? ;
] 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 ;
#! 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
] [
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 ;
dup compiled? [
drop t
] [
- dup compile-words get contains? [
+ dup compile-words get member? [
drop t
] [
compiled-xts get assoc
complement [
"complement" word-prop builtin-supertypes
num-types count
- difference
+ seq-diff
] "builtin-supertypes" set-word-prop
complement [
#! 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
"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 -- )
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.
: 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
: 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 ;
] 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 ;
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 ;
! 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 ;
: 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 ;
[ 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
USE: namespaces
USE: test
USE: vectors
+USE: sequences
16 <hashtable> "testhash" set
[ [[ 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
[ [ [ 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
[ 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
[ [ 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
[ 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
! 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
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
[ [ 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
[ "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
[ -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
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? ;
! 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
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
#! 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 ;
: 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.
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 )
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 -- )
: 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 ;
: handle-socket-error ( -- )
WSAGetLastError [
ERROR_IO_PENDING ERROR_SUCCESS
- ] contains? [
+ ] member? [
win32-error-message throw
] unless ;
projects / factor.git / commitdiff