From 9b0a6093cedb1c5125e5be940b6a17b886ca9400 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 23 Nov 2007 23:54:56 -0500 Subject: [PATCH 1/8] New hashcode function --- core/sequences/sequences.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index de10e5c2e4..ae531b5b7f 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -667,7 +667,14 @@ PRIVATE> : infimum ( seq -- n ) dup first [ min ] reduce ; : supremum ( seq -- n ) dup first [ max ] reduce ; +! : sequence-hashcode ( n seq -- x ) +! 0 -rot [ +! hashcode* >fixnum swap 31 fixnum*fast fixnum+fast +! ] curry* each ; inline + : sequence-hashcode ( n seq -- x ) 0 -rot [ - hashcode* >fixnum swap 31 fixnum*fast fixnum+fast + hashcode* >fixnum swap + [ -2 shift fixnum+fast ] keep [ 5 shift fixnum+fast ] keep + bitxor ] curry* each ; inline From c726962a7a106eb4474875d9edb3084028958e2f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 15 Dec 2007 16:20:32 -0500 Subject: [PATCH 2/8] Fixing insufficient safety in flip and M: column virtual@ --- core/sequences/sequences.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index de10e5c2e4..c580bbe118 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -221,7 +221,8 @@ TUPLE: column seq col ; C: 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 [ dup like ] curry* map - ] unless ; - : exchange ( m n seq -- ) pick over bounds-check 2drop 2dup bounds-check 2drop exchange-unsafe ; @@ -667,6 +663,12 @@ PRIVATE> : infimum ( seq -- n ) dup first [ min ] reduce ; : supremum ( seq -- n ) dup first [ max ] reduce ; +: flip ( matrix -- newmatrix ) + dup empty? [ + dup [ length ] map infimum + [ dup like ] curry* map + ] unless ; + : sequence-hashcode ( n seq -- x ) 0 -rot [ hashcode* >fixnum swap 31 fixnum*fast fixnum+fast From cd86eb8febeb04120c601c314cbff2159743ce7a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 17 Dec 2007 00:42:41 -0500 Subject: [PATCH 3/8] Sequence hashcode --- core/sequences/sequences.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 01443716e7..92e160f3bf 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -674,9 +674,13 @@ PRIVATE> ! hashcode* >fixnum swap 31 fixnum*fast fixnum+fast ! ] curry* each ; inline +: sequence-hashcode-step ( oldhash newpart -- newhash ) + swap [ + dup -2 shift swap 5 shift + fixnum+fast fixnum+fast + ] keep bitxor ; + : sequence-hashcode ( n seq -- x ) 0 -rot [ - hashcode* >fixnum swap - [ -2 shift fixnum+fast ] keep [ 5 shift fixnum+fast ] keep - bitxor + hashcode* >fixnum sequence-hashcode-step ] curry* each ; inline From d6e445df1f77dfec5e8b311f133722a24373a45c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 17 Dec 2007 15:29:21 -0500 Subject: [PATCH 4/8] XML attrs --- extra/xml/data/data.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index 58ff2a3f6c..725d6da3cc 100644 --- a/extra/xml/data/data.factor +++ b/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 ; M: attrs >alist delegate >alist ; : >attrs ( assoc -- attrs ) - V{ } assoc-clone-like - [ >r assure-name r> ] assoc-map - ; + dup [ + V{ } assoc-clone-like + [ >r assure-name r> ] assoc-map + ] when ; 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* ; From 5fb4d9cbb99c849ff970fa56ab616535b6f55f60 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 17 Dec 2007 15:31:10 -0500 Subject: [PATCH 5/8] XML utilities --- extra/xml/utilities/utilities.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index 303de4295e..2bd37dc104 100644 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -36,14 +36,16 @@ M: process-missing error. ! * Common utility functions : build-tag* ( items name -- tag ) - "" swap "" - swap >r { } r> ; + assure-name swap >r f r> ; : 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 { } ; + standard-prolog { } rot { } ; : children>string ( tag -- string ) tag-children @@ -138,3 +140,10 @@ M: xml xml-inject >r delegate >r xml-inject ; : 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 ; From 416556ce63ca4e163c772ab2caaf5406ff5dad23 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 17 Dec 2007 15:46:55 -0500 Subject: [PATCH 6/8] New hashcode function --- core/sequences/sequences.factor | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 92e160f3bf..2902f574eb 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -669,16 +669,11 @@ PRIVATE> [ dup like ] curry* map ] unless ; -! : sequence-hashcode ( n seq -- x ) -! 0 -rot [ -! hashcode* >fixnum swap 31 fixnum*fast fixnum+fast -! ] curry* each ; inline - : sequence-hashcode-step ( oldhash newpart -- newhash ) swap [ - dup -2 shift swap 5 shift + dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum fixnum+fast fixnum+fast - ] keep bitxor ; + ] keep bitxor ; inline : sequence-hashcode ( n seq -- x ) 0 -rot [ From 72a164e4189f73462f61e93f8c402a7913df7a7e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 17 Dec 2007 18:26:10 -0500 Subject: [PATCH 7/8] XML utilities --- extra/xml/utilities/utilities.factor | 43 +++++++++++++++++++--------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index 2bd37dc104..2ce4e2b3d3 100644 --- a/extra/xml/utilities/utilities.factor +++ b/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 @@ -113,30 +113,25 @@ 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 ; @@ -147,3 +142,25 @@ M: xml xml-inject >r delegate >r xml-inject ; : 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 ; + From 315f7319fb1840afe9baa83ac280e7b7819cf85e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 18 Dec 2007 00:43:13 -0500 Subject: [PATCH 8/8] FAQ fix --- extra/faq/faq.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 9f39b33dc6..f10e6481fa 100644 --- a/extra/faq/faq.factor +++ b/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 ;