From 7352d1932e15b6da85774853e6953c0b390fd75b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 18 Mar 2019 14:57:14 +0100
Subject: Working.

---
 script.scm | 136 -------------------------------------------------------------
 1 file changed, 136 deletions(-)
 delete mode 100755 script.scm

(limited to 'script.scm')

diff --git a/script.scm b/script.scm
deleted file mode 100755
index b43428d..0000000
--- a/script.scm
+++ /dev/null
@@ -1,136 +0,0 @@
-#!/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 (push item stack) (cons item stack))
-(define (pop stack) (unless (null? stack)
-                      (car+cdr stack)))
-(define (peek stack) (if (null? stack) '() (car stack)))
-
-(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 (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
-               ]))
-
-'(span (@ (class "B"))
-      "A"
-      (span (@ (class "G"))
-            "B")
-      "C")
-
-;; => (blue A (green B) C)
-;; => set-blue A set-green B unset-green/set-blue C unset-blue
-
-;; push blue : print-esc
-;; print A
-;; push green : print-esc
-;; print B
-;; pop : print-esc
-;; print C
-;; pop : print-esc
-
-
-
-
-(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