From ebb16d1dabedfdc3fc392b8c36f46a486ee3549f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Fri, 9 Nov 2018 23:26:42 +0100
Subject: Initial commit.t

---
 script.scm | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 89 insertions(+)
 create mode 100755 script.scm

(limited to 'script.scm')

diff --git a/script.scm b/script.scm
new file mode 100755
index 0000000..c2027b1
--- /dev/null
+++ b/script.scm
@@ -0,0 +1,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))
-- 
cgit v1.2.3