aboutsummaryrefslogtreecommitdiff
path: root/script.scm
diff options
context:
space:
mode:
Diffstat (limited to 'script.scm')
-rwxr-xr-xscript.scm136
1 files changed, 0 insertions, 136 deletions
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))