diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index f5adccf445..ba2fb055e2 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,5 +1,6 @@ USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors ; +USING: arrays math.parser sorting strings ; IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -104,3 +105,20 @@ PRIVATE> : power-set ( seq -- subsets ) 2 over length exact-number-strings swap [ nths ] curry map ; + +: cut-find ( seq pred -- before after ) + dupd find drop dup [ cut ] when ; + +: cut3 ( seq pred -- first mid last ) + [ cut-find ] keep [ not ] compose cut-find ; + +: (cut-all) ( seq pred quot -- ) + [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep + pick [ (cut-all) ] [ 3drop ] if ; + +: cut-all ( seq pred quot -- first mid last ) + [ (cut-all) ] { } make ; + +: human-sort ( seq -- newseq ) + [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc + sort-values keys ; diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index 2ce4e2b3d3..a86b1c9214 100644 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -120,18 +120,18 @@ M: xml xml-inject >r delegate >r xml-inject ; dup tag? [ names-match? ] [ 2drop f ] if ; : tag-named* ( tag name/string -- matching-tag ) - assure-name swap [ dupd tag-matches? ] xml-find nip ; + assure-name swap [ dupd tag-named? ] xml-find nip ; : tags-named* ( tag name/string -- tags-seq ) - assure-name swap [ dupd tag-matches? ] xml-subset nip ; + assure-name swap [ dupd tag-named? ] xml-subset nip ; : tag-named ( tag name/string -- matching-tag ) ! like get-name-tag but only looks at direct children, ! not all the children down the tree. - assure-name swap [ tag-matches? ] curry* find nip ; + assure-name swap [ tag-named? ] curry* find nip ; : tags-named ( tag name/string -- tags-seq ) - assure-name swap [ tag-matches? ] curry* subset ; + assure-name swap [ tag-named? ] curry* subset ; : assert-tag ( name name -- ) names-match? [ "Unexpected XML tag found" throw ] unless ;