extra/wikipedia/wikipedia.factor

   1 ! Copyright (C) 2012 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors ascii assocs calendar colors combinators
   5 command-line eval formatting html.entities html.parser
   6 html.parser.analyzer html.parser.printer http.client io
   7 io.styles kernel namespaces parser regexp sequences splitting
   8 urls wrap.strings xml xml.data xml.traversal ;
   9 FROM: xml.data => tag? ;
  10
  11 IN: wikipedia
  12
  13 SYMBOL: language
  14 language [ "en" ] initialize
  15
  16 : with-language ( str quot -- )
  17     language swap with-variable ; inline
  18
  19 <PRIVATE
  20
  21 : wikipedia-url ( path -- url )
  22     language get swap "http://%s.wikipedia.org/%s" sprintf >url ;
  23
  24 : header. ( string -- )
  25     H{ { font-size 20 } { font-style bold } } format nl ;
  26
  27 : subheader. ( string -- )
  28     H{ { font-size 16 } { font-style bold } } format nl ;
  29
  30 : link ( tag -- tag/f )
  31     "a" assure-name over tag-named? [ "a" deep-tag-named ] unless ;
  32
  33 : link. ( tag -- )
  34     [ deep-children>string ] [ attrs>> "href" of ] bi
  35     wikipedia-url H{
  36         { font-name "monospace" }
  37         { foreground COLOR: blue }
  38     } [ write-object ] with-style ;
  39
  40 : item. ( tag -- )
  41     children>> [
  42         dup tag? [
  43             dup link [
  44                 link. drop
  45             ] [
  46                 children>string write
  47             ] if*
  48         ] [
  49             [ R/ \s+/ " " re-replace write ] unless-empty
  50         ] if
  51     ] each nl ;
  52
  53 : items. ( seq -- )
  54     children-tags [ item. ] each nl ;
  55
  56 : items>sequence ( tag -- seq )
  57     children-tags [ deep-children>string ] map ;
  58
  59 : sections. ( alist -- )
  60     [ [ subheader. ] [ items. ] bi* ] assoc-each nl ;
  61
  62 : sections>sequence ( alist -- alist )
  63     [ items>sequence ] assoc-map ;
  64
  65 : historical-url ( timestamp -- url )
  66     "wiki/%B_%d" strftime wikipedia-url ;
  67
  68 : historical-get ( timestamp -- xml )
  69     historical-url http-get nip string>xml ;
  70
  71 : historical-get-events ( timestamp -- alist )
  72     historical-get "ul" deep-tags-named
  73     [ second items>sequence ] [ 4 7 rot subseq ] bi zip ;
  74
  75 : historical-get-births ( timestamp -- alist )
  76     historical-get "ul" deep-tags-named
  77     [ third items>sequence ] [ 7 10 rot subseq ] bi zip ;
  78
  79 : historical-get-deaths ( timestamp -- alist )
  80     historical-get "ul" deep-tags-named
  81     [ fourth items>sequence ] [ 10 13 rot subseq ] bi zip ;
  82
  83 PRIVATE>
  84
  85 : historical-events ( timestamp -- events )
  86     historical-get-events sections>sequence ;
  87
  88 : historical-events. ( timestamp -- )
  89     [ "%B %d - Events" strftime header. ]
  90     [ historical-get-events sections. ] bi ;
  91
  92 : historical-births ( timestamp -- births )
  93     historical-get-births sections>sequence ;
  94
  95 : historical-births. ( timestamp -- )
  96     [ "%B %d - Births" strftime header. ]
  97     [ historical-get-births sections. ] bi ;
  98
  99 : historical-deaths ( timestamp -- births )
 100     historical-get-deaths sections>sequence ;
 101
 102 : historical-deaths. ( timestamp -- )
 103     [ "%B %d - Deaths" strftime header. ]
 104     [ historical-get-deaths sections. ] bi ;
 105
 106 : article. ( name -- )
 107     "wiki/" prepend wikipedia-url http-get nip parse-html
 108     "content" find-by-id-between
 109     html-text split-lines
 110     [ [ ascii:blank? ] trim ] map harvest [
 111         html-unescape 72 wrap-string print nl
 112     ] each ;
 113
 114 <PRIVATE
 115
 116 : eval-timestamp ( seq -- timestamp )
 117     [ today ] [
 118         " " join t auto-use? [ eval( -- timestamp ) ] with-variable
 119     ] if-empty ;
 120
 121 PRIVATE>
 122
 123 : wikipedia-main ( -- )
 124     command-line get [
 125         unclip {
 126             { "events" [ eval-timestamp historical-events. ] }
 127             { "births" [ eval-timestamp historical-births. ] }
 128             { "deaths" [ eval-timestamp historical-deaths. ] }
 129             { "article" [ [ article. ] each ] }
 130             [ "ERROR: Unknown command: " write print drop ]
 131         } case
 132     ] unless-empty ;
 133
 134 MAIN: wikipedia-main