1 ! Copyright (C) 2007 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: xml kernel sequences xml.utilities combinators.lib
4 math xml.data arrays assocs xml.generator xml.writer namespaces
5 math.parser io accessors ;
8 : find-after ( seq quot -- elem after )
9 over >r find r> rot 1+ tail ; inline
11 : tag-named*? ( tag name -- ? )
12 assure-name swap tag-named? ;
15 TUPLE: q/a question answer ;
18 : li>q/a ( li -- q/a )
19 [ "br" tag-named*? not ] filter
20 [ "strong" tag-named*? ] find-after
21 >r children>> r> <q/a> ;
23 : q/a>li ( q/a -- li )
24 [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
25 answer>> append "li" build-tag* ;
27 : xml>q/a ( xml -- q/a )
28 [ "question" tag-named children>> ] keep
29 "answer" tag-named children>> <q/a> ;
31 : q/a>xml ( q/a -- xml )
32 [ question>> "question" build-tag* ] keep
33 answer>> "answer" build-tag*
34 "\n" swap 3array "qa" build-tag* ;
37 TUPLE: question-list title seq ;
38 C: <question-list> question-list
40 : xml>question-list ( list -- question-list )
41 [ "title" swap at ] keep
42 children>> [ tag? ] filter [ xml>q/a ] map
45 : question-list>xml ( question-list -- list )
46 [ seq>> [ q/a>xml "\n" swap 2array ]
47 map concat "list" build-tag* ] keep
48 title>> [ "title" pick set-at ] when* ;
50 : html>question-list ( h3 ol -- question-list )
51 >r [ children>string ] [ f ] if* r>
52 children-tags [ li>q/a ] map <question-list> ;
54 : question-list>h3 ( id question-list -- h3 )
57 swap number>string "id" pick set-at
60 : question-list>html ( question-list start id -- h3/f ol )
61 -rot >r [ question-list>h3 ] keep
62 seq>> [ q/a>li ] map "ol" build-tag* r>
63 number>string "start" pick set-at
64 "margin-left: 5em" "style" pick set-at ;
67 TUPLE: faq header lists ;
70 : html>faq ( div -- faq )
71 unclip swap { "h3" "ol" } [ tags-named ] with map
72 first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
76 lists>> first 1 -1 question-list>html nip , ;
81 : toc-link, ( question-list number -- )
82 number>string "#" prepend "href" swap 2array 1array
83 "a" swap [ title>> , ] tag*, br, ;
86 "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
87 "strong" [ "The big questions" , ] tag, br,
88 lists>> rest dup length [ toc-link, ] 2each
91 : faq-sections, ( question-lists -- )
92 unclip seq>> length 1+ dupd
93 [ seq>> length + ] accumulate nip
94 0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
96 : faq>html ( faq -- div )
100 lists>> faq-sections,
103 : xml>faq ( xml -- faq )
104 [ "header" tag-named children>string ] keep
105 "list" tags-named [ xml>question-list ] map <faq> ;
107 : faq>xml ( faq -- xml )
109 "header" [ dup header>> , ] tag,
110 lists>> [ question-list>xml , nl, ] each
113 : read-write-faq ( xml-stream -- )
114 read-xml xml>faq faq>html write-xml ;