PROTOCOL: sequence-protocol
clone clone-like like new new-resizable nth nth-unsafe
- set-nth set-nth-unsafe length immutable set-length lengthen ;
+ set-nth set-nth-unsafe length set-length lengthen ;
PROTOCOL: assoc-protocol
at* assoc-size >alist assoc-find set-at
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
- pick "methods" word-prop at
- [ method-def <method> spin define-method ] [ 3drop ] if*
+ pick "methods" word-prop at dup
+ [ method-def <method> spin define-method ] [ 3drop ] if
] 2curry each ;
: MIMIC:
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
IN: rss
-USING: xml.utilities kernel assocs
+USING: xml.utilities kernel assocs xml.generator
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
http.client namespaces xml.generator hashtables ;
: ?children>string ( tag/f -- string/f )
[ children>string ] [ f ] if* ;
+ : any-tag-named ( tag names -- tag-inside )
+ f -rot [ tag-named nip dup ] curry* find 2drop ;
+
TUPLE: feed title link entries ;
C: <feed> feed
C: <entry> entry
+ : rss1.0-entry ( tag -- entry )
+ [ "title" tag-named children>string ] keep
+ [ "link" tag-named children>string ] keep
+ [ "description" tag-named children>string ] keep
+ f "date" "http://purl.org/dc/elements/1.1/" <name>
+ tag-named ?children>string
+ <entry> ;
+
: rss1.0 ( xml -- feed )
[
"channel" tag-named
[ "title" tag-named children>string ] keep
"link" tag-named children>string
] keep
- "item" tags-named [
- [ "title" tag-named children>string ] keep
- [ "link" tag-named children>string ] keep
- [ "description" tag-named children>string ] keep
- f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named ?children>string
- <entry>
- ] map <feed> ;
+ "item" tags-named [ rss1.0-entry ] map <feed> ;
+
+ : rss2.0-entry ( tag -- entry )
+ [ "title" tag-named children>string ] keep
+ [ "link" tag-named ] keep
+ [ "guid" tag-named dupd ? children>string ] keep
+ [ "description" tag-named children>string ] keep
+ "pubDate" tag-named children>string <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
[ "title" tag-named children>string ] keep
[ "link" tag-named children>string ] keep
- "item" tags-named [
- [ "title" tag-named children>string ] keep
- [ "link" tag-named ] keep
- [ "guid" tag-named dupd ? children>string ] keep
- [ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string <entry>
- ] map <feed> ;
+ "item" tags-named [ rss2.0-entry ] map <feed> ;
+
+ : atom1.0-entry ( tag -- entry )
+ [ "title" tag-named children>string ] keep
+ [ "link" tag-named "href" swap at ] keep
+ [
+ { "content" "summary" } any-tag-named
+ dup tag-children [ string? not ] contains?
+ [ tag-children [ write-chunk ] string-out ]
+ [ children>string ] if
+ ] keep
+ { "published" "updated" "issued" "modified" } any-tag-named
+ children>string <entry> ;
: atom1.0 ( xml -- feed )
[ "title" tag-named children>string ] keep
[ "link" tag-named "href" swap at ] keep
- "entry" tags-named [
- [ "title" tag-named children>string ] keep
- [ "link" tag-named "href" swap at ] keep
- [
- dup "content" tag-named
- [ nip ] [ "summary" tag-named ] if*
- dup tag-children [ tag? ] contains?
- [ tag-children [ write-chunk ] string-out ]
- [ children>string ] if
- ] keep
- dup "published" tag-named
- [ nip ] [ "updated" tag-named ] if*
- children>string <entry>
- ] map <feed> ;
+ "entry" tags-named [ atom1.0-entry ] map <feed> ;
: xml>feed ( xml -- feed )
dup name-tag {
] if ;
! Atom generation
-: simple-tag, ( content name -- )
- [ , ] tag, ;
-
-: simple-tag*, ( content name attrs -- )
- [ , ] tag*, ;
-
: entry, ( entry -- )
- "entry" [
- dup entry-title "title" { { "type" "html" } } simple-tag*,
- "link" over entry-link "href" associate contained*,
- dup entry-pub-date "published" simple-tag,
- entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
- ] tag, ;
+ << entry >> [
+ << title >> [ dup entry-title , ]
+ << link [ dup entry-link ] == href // >>
+ << published >> [ dup entry-pub-date , ]
+ << content >> [ entry-description , ]
+ ] ;
: feed>xml ( feed -- xml )
- "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
- dup feed-title "title" simple-tag,
- "link" over feed-link "href" associate contained*,
- feed-entries [ entry, ] each
- ] make-xml* ;
+ <XML
+ << feed [ "http://www.w3.org/2005/Atom" ] == xmlns >> [
+ << title >> [ dup feed-title , ]
+ << link [ dup feed-link ] == href // >>
+ feed-entries [ entry, ] each
+ ]
+ XML> ;
- : write-feed ( feed -- xml )
+ : write-feed ( feed -- )
feed>xml write-xml ;
- USING: combinators.lib kernel sequences math namespaces
- random sequences.private shuffle ;
+ USING: combinators.lib kernel sequences math namespaces assocs
+ random sequences.private shuffle math.functions mirrors ;
+ USING: arrays math.parser sorting strings ;
IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
+: split-around ( seq quot -- before elem after )
+ dupd find over [ "Element not found" throw ] unless
+ >r cut-slice 1 tail r> swap ; inline
++
+ : (map-until) ( quot pred -- quot )
+ [ dup ] swap 3compose
+ [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
+
+ : map-until ( seq quot pred -- newseq )
+ (map-until) { } make ;
+
+ : take-while ( seq quot -- newseq )
+ [ not ] compose
+ [ find drop [ head-slice ] when* ] curry
+ [ dup ] swap compose keep like ;
+
+ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ <PRIVATE
+ : translate-string ( n alphabet out-len -- seq )
+ [ drop /mod ] curry* map nip ;
+
+ : map-alphabet ( alphabet seq[seq] -- seq[seq] )
+ [ [ swap nth ] curry* map ] curry* map ;
+
+ : exact-number-strings ( n out-len -- seqs )
+ [ ^ ] 2keep [ translate-string ] 2curry map ;
+
+ : number-strings ( n max-length -- seqs )
+ 1+ [ exact-number-strings ] curry* map concat ;
+ PRIVATE>
+
+ : exact-strings ( alphabet length -- seqs )
+ >r dup length r> exact-number-strings map-alphabet ;
+
+ : strings ( alphabet length -- seqs )
+ >r dup length r> number-strings map-alphabet ;
+
+ : nths ( nths seq -- subseq )
+ ! nths is a sequence of ones and zeroes
+ >r [ length ] keep [ nth 1 = ] curry subset r>
+ [ nth ] curry { } map-as ;
+
+ : 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 ;
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
- USING: kernel sequences sequences.private assocs arrays delegate ;
-USING: kernel sequences sequences.private assocs arrays vectors ;
++USING: kernel sequences sequences.private assocs arrays delegate vectors ;
IN: xml.data
TUPLE: name space tag url ;
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 ;
M: attrs new-assoc drop V{ } new <attrs> ;
- M: attrs assoc-find >r delegate r> assoc-find ;
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* ;
tag construct ;
! For convenience, tags follow the assoc protocol too (for attrs)
-M: tag at* tag-attrs at* ;
-M: tag set-at tag-attrs set-at ;
-M: tag new-assoc tag-attrs new-assoc ;
-M: tag >alist tag-attrs >alist ;
-M: tag delete-at tag-attrs delete-at ;
-M: tag clear-assoc tag-attrs clear-assoc ;
-M: tag assoc-size tag-attrs assoc-size ;
-M: tag assoc-like tag-attrs assoc-like ;
-
+CONSULT: assoc-protocol tag tag-attrs ;
INSTANCE: tag assoc
! They also follow the sequence protocol (for children)
-M: tag nth tag-children nth ;
-M: tag nth-unsafe tag-children nth-unsafe ;
-M: tag set-nth tag-children set-nth ;
-M: tag set-nth-unsafe tag-children set-nth-unsafe ;
-M: tag length tag-children length ;
-
+CONSULT: sequence-protocol tag tag-children ;
INSTANCE: tag sequence
! tag with children=f is contained
projects / factor.git / commitdiff