Merge http://littledan.onigirihouse.com/factor

core/sequences/sequences.factor

@@ -221,7 +221,8 @@ TUPLE: column seq col ;
 C: <column> column
 
 M: column virtual-seq column-seq ;
-M: column virtual@ dup column-col -rot column-seq nth ;
+M: column virtual@
+    dup column-col -rot column-seq nth bounds-check ;
 M: column length column-seq length ;
 
 INSTANCE: column virtual-sequence
@@ -546,11 +547,6 @@ M: sequence <=>
 
 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
 
-: flip ( matrix -- newmatrix )
-    dup empty? [
-        dup first length [ <column> dup like ] curry* map
-    ] unless ;
-
 : exchange ( m n seq -- )
     pick over bounds-check 2drop 2dup bounds-check 2drop
     exchange-unsafe ;
@@ -667,7 +663,19 @@ PRIVATE>
 : infimum ( seq -- n ) dup first [ min ] reduce ;
 : supremum ( seq -- n ) dup first [ max ] reduce ;
 
+: flip ( matrix -- newmatrix )
+    dup empty? [
+        dup [ length ] map infimum
+        [ <column> dup like ] curry* map
+    ] unless ;
+
+: sequence-hashcode-step ( oldhash newpart -- newhash )
+    swap [
+        dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
+        fixnum+fast fixnum+fast
+    ] keep bitxor ; inline
+
 : sequence-hashcode ( n seq -- x )
     0 -rot [
-        hashcode* >fixnum swap 31 fixnum*fast fixnum+fast
+        hashcode* >fixnum sequence-hashcode-step
     ] curry* each ; inline

extra/faq/faq.factor

@@ -9,7 +9,7 @@ IN: faq
     over >r find r> rot 1+ tail ; inline
 
 : tag-named? ( tag name -- ? )
-    assure-name swap (get-tag) ;
+    assure-name swap tag-named? ;
 
 ! Questions
 TUPLE: q/a question answer ;

extra/xml/data/data.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences sequences.private assocs arrays ;
+USING: kernel sequences sequences.private assocs arrays vectors ;
 IN: xml.data
 
 TUPLE: name space tag url ;
@@ -60,7 +60,8 @@ M: attrs set-at
     2dup attr@ nip [
         2nip set-second
     ] [
-        >r assure-name swap 2array r> push
+        [ >r assure-name swap 2array r> ?push ] keep
+        set-delegate
     ] if* ;
 
 M: attrs assoc-size length ;
@@ -68,14 +69,15 @@ M: attrs new-assoc drop V{ } new <attrs> ;
 M: attrs >alist delegate >alist ;
 
 : >attrs ( assoc -- attrs )
-    V{ } assoc-clone-like
-    [ >r assure-name r> ] assoc-map
-    <attrs> ;
+    dup [
+        V{ } assoc-clone-like
+        [ >r assure-name r> ] assoc-map
+    ] when <attrs> ;
 M: attrs assoc-like
     drop dup attrs? [ >attrs ] unless ;
 
 M: attrs clear-assoc
-    delete-all ;
+    f swap set-delegate ;
 M: attrs delete-at
     tuck attr@ drop [ swap delete-nth ] [ drop ] if* ;
 

extra/xml/utilities/utilities.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces sequences words io assocs
 quotations strings parser arrays xml.data xml.writer debugger
-splitting ;
+splitting vectors ;
 IN: xml.utilities
 
 ! * System for words specialized on tag names
@@ -36,14 +36,16 @@ M: process-missing error.
 ! * Common utility functions
 
 : build-tag* ( items name -- tag )
-    "" swap "" <name>
-    swap >r { } r> <tag> ;
+    assure-name swap >r f r> <tag> ;
 
 : build-tag ( item name -- tag )
     >r 1array r> build-tag* ;
 
+: standard-prolog ( -- prolog )
+    T{ prolog f "1.0" "iso-8859-1" f } ;
+
 : build-xml ( tag -- xml )
-    T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
+    standard-prolog { } rot { } <xml> ;
 
 : children>string ( tag -- string )
     tag-children
@@ -111,30 +113,54 @@ M: object xml-inject 2drop ;
 M: xml xml-inject >r delegate >r xml-inject ;
 
 ! * Accessing part of an XML document
+! for tag- words, a start means that it searches all children
+! and no star searches only direct children
 
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
-    swap [
-        dup tag?
-        [ "id" swap at over = ]
-        [ drop f ] if
-    ] xml-find nip ;
-
-: (get-tag) ( name elem -- ? )
+: tag-named? ( name elem -- ? )
     dup tag? [ names-match? ] [ 2drop f ] if ;
 
 : tag-named* ( tag name/string -- matching-tag )
-    assure-name swap [ dupd (get-tag) ] xml-find nip ;
+    assure-name swap [ dupd tag-matches? ] xml-find nip ;
 
 : tags-named* ( tag name/string -- tags-seq )
-    assure-name swap [ dupd (get-tag) ] xml-subset nip ;
+    assure-name swap [ dupd tag-matches? ] 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 [ (get-tag) ] curry* find nip ;
+    assure-name swap [ tag-matches? ] curry* find nip ;
 
 : tags-named ( tag name/string -- tags-seq )
-    assure-name swap [ (get-tag) ] curry* subset ;
+    assure-name swap [ tag-matches? ] curry* subset ;
 
 : assert-tag ( name name -- )
     names-match? [ "Unexpected XML tag found" throw ] unless ;
+
+: insert-children ( children tag -- )
+    dup tag-children [ push-all ]
+    [ >r V{ } like r> set-tag-children ] if ;
+
+: insert-child ( child tag -- )
+    >r 1vector r> insert-children ;
+
+: tag-with-attr? ( elem attr-value attr-name -- ? )
+    rot dup tag? [ at = ] [ drop f ] if ;
+
+: tag-with-attr ( tag attr-value attr-name -- matching-tag )
+    assure-name [ tag-with-attr? ] 2curry find nip ;
+
+: tags-with-attr ( tag attr-value attr-name -- tags-seq )
+    assure-name [ tag-with-attr? ] 2curry subset ;
+
+: tag-with-attr* ( tag attr-value attr-name -- matching-tag )
+    assure-name [ tag-with-attr? ] 2curry xml-find nip ;
+
+: tags-with-attr* ( tag attr-value attr-name -- tags-seq )
+    assure-name [ tag-with-attr? ] 2curry xml-subset ;
+
+: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
+    "id" tag-with-attr ;
+
+: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )
+    >r >r tags-named* r> r> tags-with-attr ;
+