aboutsummaryrefslogtreecommitdiff
path: root/script.scm
blob: c2027b1fbd583adfc2b4b578030b79c2dc10c3fb (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#!/usr/bin/guile \
-e main -s
!#

(use-modules (sxml simple)
             (sxml match)
             (ice-9 match)
             (srfi srfi-1))

(define (setmode . args)
  "Sets display mode"
  (with-output-to-string
    (lambda ()
     (for-each display
               `(#\escape #\[ ,@args #\m)))))


(define* (deffunc name idx
           #:optional (func-pre '#{}#) (mode-pre ""))
  (let ((str (gensym)))
    `(define (,(symbol-append func-pre name) . ,str)
       (string-append 
        (setmode ,mode-pre ,idx)
        #; (string #\escape #\[ #\K)
        (string-concatenate ,str)
        (setmode 0)))))

(define-macro (create-modes modes)
  `(begin
     ,@(map deffunc
            modes
            (iota (length modes)))))

(define-macro (create-colors modes)
  `(begin
     ,@(apply append
              (map (lambda (itm idx)
                     (list (deffunc itm idx 'fg- "0;3")
                           (deffunc itm idx 'bg- "0;4")))
                   modes
                   (iota (length modes))))))

(create-modes (off bold dim slant underline))
(create-colors (black red green yellow blue purple cyan white))

(define classmap
  (match-lambda ("B"   fg-blue)
                ("bgB" bg-blue)
                ("Y"   fg-yellow)
                ("C"   fg-cyan)
                ("DH"  bold)
                (_ identity)))

(define (class-handlers class-str)
  (fold compose identity
        (map classmap (string-split class-str #\space))))

(define (fmt-sub nodes)
  (string-concatenate (map fmt-tag nodes)))

(define (fmt-tag tag)
  (sxml-match tag
              [(a #; (@ (class ,class)) ,text)
               (underline text)]

              [(h1 (@ (class ,class)) ,nodes ...)
               ((class-handlers class)
                (bold (fmt-sub nodes)))]

              [(span (@ (class ,class)) ,nodes ...)
               ((class-handlers class)
                (fmt-sub nodes))]

              [,str (guard (string? str)) str]

              [,default (format #f "[|~a|]" default)]
              ))

(define (parse-doc sxml)
  (sxml-match sxml
              [(*TOP* (div #; (span (@ (class "toprow")) ,top-row ...)
                           ,spans ...))
               spans
               ]))

(define (main args)
  (define d (call-with-input-file "100-2.html" xml->sxml))
  (display (string-concatenate (map fmt-tag (parse-doc d))))
  (newline))