diff --git a/CHANGES.txt b/CHANGES.txt index 9c883422c2..01f9428dce 100644 --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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: diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 0854903ed8..090ffe6142 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -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" diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 3e3ba54c6f..e2fca26979 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -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 [ [ diff --git a/library/collections/assoc.factor b/library/collections/assoc.factor index a839fcb4f5..fa44e5f7e8 100644 --- a/library/collections/assoc.factor +++ b/library/collections/assoc.factor @@ -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* ; diff --git a/library/collections/cons.factor b/library/collections/cons.factor index 33a3671cad..03bbf6dd11 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -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 ) + #! 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 ; diff --git a/library/collections/lists.factor b/library/collections/lists.factor index 08c4469d7a..3e2d1b51f3 100644 --- a/library/collections/lists.factor +++ b/library/collections/lists.factor @@ -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: -: 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 >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 ) - #! 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* ; diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor index 8ed2389e68..eda61bb37e 100644 --- a/library/collections/namespaces.factor +++ b/library/collections/namespaces.factor @@ -144,7 +144,7 @@ SYMBOL: building make-sbuf >string ; inline : make-rstring ( quot -- string ) - make-sbuf dup nreverse >string ; inline + make-sbuf >string ; inline ! Building hashtables, and computing a transitive closure. SYMBOL: hash-buffer diff --git a/library/collections/sequence-eq.factor b/library/collections/sequence-eq.factor new file mode 100644 index 0000000000..cc132010d1 --- /dev/null +++ b/library/collections/sequence-eq.factor @@ -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 ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 3b27908a34..c8724359bc 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -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 -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 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 ) [ ] 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 diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index 2bd8016bf4..68dfa13bcb 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -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: -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 ; diff --git a/library/collections/strings.factor b/library/collections/strings.factor index 21da5aed49..e1d23fb8f4 100644 --- a/library/collections/strings.factor +++ b/library/collections/strings.factor @@ -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 ; diff --git a/library/collections/tree-each.factor b/library/collections/tree-each.factor new file mode 100644 index 0000000000..11c8d57ba3 --- /dev/null +++ b/library/collections/tree-each.factor @@ -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 ; diff --git a/library/collections/vectors-epilogue.factor b/library/collections/vectors-epilogue.factor index 9f6da2254c..391b71b637 100644 --- a/library/collections/vectors-epilogue.factor +++ b/library/collections/vectors-epilogue.factor @@ -26,8 +26,10 @@ M: general-list like drop >list ; M: vector like drop >vector ; -: 3vector ( x y z -- { x y z } ) - 3 - [ >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 (1vector) ; +: 2vector ( x y -- { x y } ) 2 (2vector) ; +: 3vector ( x y z -- { x y z } ) 3 (3vector) ; diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor index da555e4d11..6a6d98d855 100644 --- a/library/compiler/optimizer.factor +++ b/library/compiler/optimizer.factor @@ -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? ; diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index 08139aa1a3..fa00f69942 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -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 ; diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index b61570e5ea..bff5a08e3c 100644 --- a/library/compiler/xt.factor +++ b/library/compiler/xt.factor @@ -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 diff --git a/library/generic/complement.factor b/library/generic/complement.factor index 5f03cee86f..ca9152fa03 100644 --- a/library/generic/complement.factor +++ b/library/generic/complement.factor @@ -11,7 +11,7 @@ SYMBOL: complement complement [ "complement" word-prop builtin-supertypes num-types count - difference + seq-diff ] "builtin-supertypes" set-word-prop complement [ diff --git a/library/generic/generic.factor b/library/generic/generic.factor index f88beaf445..b3bc571fb9 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -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 diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 3e1a4b8924..01324480ac 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -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 -- ) diff --git a/library/inference/branches.factor b/library/inference/branches.factor index e7dfc2d1f8..a35f86bc53 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -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 ] project >vector ; + empty-vector [ object ] map ; : add-inputs ( count stack -- stack ) #! Add this many inputs to the given stack. diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 9a0479eae4..66e2c8df47 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -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 diff --git a/library/io/directories.factor b/library/io/directories.factor index 399e6d1f95..8fa633c284 100644 --- a/library/io/directories.factor +++ b/library/io/directories.factor @@ -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 ; diff --git a/library/io/string-streams.factor b/library/io/string-streams.factor index d6c664a2a2..69ac725da9 100644 --- a/library/io/string-streams.factor +++ b/library/io/string-streams.factor @@ -22,7 +22,7 @@ M: sbuf stream-read ( count sbuf -- string ) ] ifte ; : ( string -- stream ) - >sbuf dup nreverse ; + >sbuf ; : string-in ( str quot -- ) [ swap stdio set call ] with-scope ; diff --git a/library/syntax/parse-numbers.factor b/library/syntax/parse-numbers.factor index 825fa91b27..f487b97b03 100644 --- a/library/syntax/parse-numbers.factor +++ b/library/syntax/parse-numbers.factor @@ -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 ; diff --git a/library/syntax/parse-words.factor b/library/syntax/parse-words.factor index 0a712d3e51..64f9deee22 100644 --- a/library/syntax/parse-words.factor +++ b/library/syntax/parse-words.factor @@ -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 ; diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index 7a23759f95..0eb75e303b 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -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 ; diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 0e6f40353a..de0fe83399 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -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 diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index af75d5c795..158c0e5221 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -6,6 +6,7 @@ USE: math USE: namespaces USE: test USE: vectors +USE: sequences 16 "testhash" set diff --git a/library/test/inference.factor b/library/test/inference.factor index 9aead67c17..de4287966d 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -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 diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor index ade9a86c3b..d340fca0dd 100644 --- a/library/test/lists/combinators.factor +++ b/library/test/lists/combinators.factor @@ -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 diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index f02a2bdfac..580978042b 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -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 diff --git a/library/test/parsing-word.factor b/library/test/parsing-word.factor index 2b568a25e4..dd708331f1 100644 --- a/library/test/parsing-word.factor +++ b/library/test/parsing-word.factor @@ -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 diff --git a/library/test/sequences.factor b/library/test/sequences.factor index be909c1559..2d53dcd7eb 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -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 >list ] unit-test [ 3 ] [ 1 4 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 diff --git a/library/test/strings.factor b/library/test/strings.factor index 66e7a77267..bdda2e0030 100644 --- a/library/test/strings.factor +++ b/library/test/strings.factor @@ -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 diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 256d44b1af..0bd1591bec 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -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 >list >r reverse r> = ] unit-test diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor index bed5476630..cedfc7d955 100644 --- a/library/ui/buttons.factor +++ b/library/ui/buttons.factor @@ -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? ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index d369a7fd47..ce38472348 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -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 over set-delegate - over set-gadget-paint - over set-gadget-gestures ; + { 0 0 0 } dup over set-delegate ; TUPLE: plain-gadget ; -C: plain-gadget over set-delegate ; +C: plain-gadget ( -- gadget ) + over set-delegate ; TUPLE: etched-gadget ; -C: etched-gadget over set-delegate ; +C: etched-gadget ( -- gadget ) + over set-delegate ; DEFER: add-invalid diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 33c979de0c..96d63efe61 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -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 [ 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 ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 047befa672..3f95024740 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -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. diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 90cfa1467a..f8b7fbc55e 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -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 -- ) diff --git a/library/win32/win32-io-internals.factor b/library/win32/win32-io-internals.factor index a838a33485..e5938df814 100644 --- a/library/win32/win32-io-internals.factor +++ b/library/win32/win32-io-internals.factor @@ -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 ; diff --git a/library/win32/win32-server.factor b/library/win32/win32-server.factor index 2d66efe595..83fb9ca671 100644 --- a/library/win32/win32-server.factor +++ b/library/win32/win32-server.factor @@ -41,7 +41,7 @@ SYMBOL: socket : handle-socket-error ( -- ) WSAGetLastError [ ERROR_IO_PENDING ERROR_SUCCESS - ] contains? [ + ] member? [ win32-error-message throw ] unless ;