Doug Coleman 2007-12-18 16:04:57 -06:00
commit 8899f07721
4 changed files with 66 additions and 30 deletions

View File

@ -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

View File

@ -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 ;

View File

@ -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* ;

View File

@ -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 ;