1 ! Copyright (C) 2012 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors ascii assocs calendar colors.constants
5 formatting html.parser html.parser.analyzer html.parser.printer
6 http.client io io.streams.string io.styles kernel make
7 namespaces regexp sequences splitting urls wrap.strings xml
8 xml.data xml.traversal ;
9 FROM: xml.data => tag? ;
14 "en" language set-global
16 : with-language ( str quot -- )
17 language swap with-variable ; inline
21 : wikipedia-url ( path -- url )
22 language get swap "http://%s.wikipedia.org/wiki/%s" sprintf >url ;
24 : header. ( string -- )
25 H{ { font-size 20 } { font-style bold } } format nl ;
27 : link ( tag -- tag/f )
28 "a" assure-name over tag-named? [ "a" deep-tag-named ] unless ;
31 [ deep-children>string ] [ attrs>> "href" of ] bi
33 { font-name "monospace" }
34 { foreground COLOR: blue }
35 } [ write-object ] with-style ;
40 dup link [ link. drop ] [ children>string write ] if*
41 ] [ [ write ] unless-empty ] if
45 children-tags [ item. ] each nl ;
47 : historical-url ( timestamp -- url )
48 [ month-name ] [ day>> ] bi "%s_%s" sprintf wikipedia-url ;
50 : (historical-events) ( timestamp -- seq )
51 historical-url http-get nip string>xml "ul" deep-tags-named ;
53 : items>sequence ( tag -- seq )
54 children-tags [ deep-children>string ] map ;
58 : historical-events ( timestamp -- events )
59 (historical-events) second items>sequence ;
61 : historical-events. ( timestamp -- )
62 (historical-events) "Events" header. second items. ;
64 : historical-births ( timestamp -- births )
65 (historical-events) third items>sequence ;
67 : historical-births. ( timestamp -- )
68 (historical-events) "Births" header. third items. ;
70 : historical-deaths ( timestamp -- births )
71 (historical-events) fourth items>sequence ;
73 : historical-deaths. ( timestamp -- )
74 (historical-events) "Deaths" header. fourth items. ;
76 : article. ( name -- )
77 wikipedia-url http-get nip parse-html
78 "content" find-by-id-between
79 [ html-text. ] with-string-writer string-lines
80 [ [ blank? ] trim ] map harvest [
81 R/ </ "<" re-replace
82 R/ >/ ">" re-replace
83 R/ &/ "&" re-replace
84 72 wrap-string print nl