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))
|