aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--README20
-rw-r--r--fmt-stack.scm44
-rw-r--r--img-parse.scm81
-rwxr-xr-xmain.scm236
-rw-r--r--v3.scm41
5 files changed, 344 insertions, 78 deletions
diff --git a/README b/README
index 1044c1a..4792b01 100644
--- a/README
+++ b/README
@@ -2,3 +2,23 @@ Dependencies
------------
- guile-gumbo
- guile-json
+
+### Vendored
+- scheme-monad
+
+### Implicit
+- guile-util (through calp)
+
+### "Optional"
+- guile-cv
+
+TODO
+----
+- "Bl├Ąddersidor" (245)
+
+Kul sidor
+---------
+- 245 (ett hus)
+- 401 V├Ądret
+- 777 Teknisk Provsida
+
diff --git a/fmt-stack.scm b/fmt-stack.scm
index e1aaca4..11c3cdd 100644
--- a/fmt-stack.scm
+++ b/fmt-stack.scm
@@ -1,7 +1,9 @@
(define-module (fmt-stack)
#:export (get-attr
set-fg set-bg set-style
+ get-bg get-fg get-style
make-fmt-frame empty-fmt-frame
+ get-frame
fmt-frame->ansi-esc)
#:use-module (monad)
@@ -20,19 +22,38 @@
(define (empty-fmt-frame)
(make-fmt-frame #f #f #f))
+;; B - blue
+;; BL - black
+;; C - cyan
+;; G - green
+;; M - magenta
+;; R - red
+;; W - white
+;; Y - yellow
+
(define (fmt-frame->ansi-esc frame)
(string-append
"\x1b[m"
(case (get-fg frame)
((B) "\x1b[0;34m")
- ((Y) "\x1b[0;33m")
- ((C) "\x1b[0;36m")
+ ((BL) "\x1b[0;30m")
+ ((C) "\x1b[0;96m")
+ ((G) "\x1b[0;32m")
+ ((M) "\x1b[0;35m")
+ ((R) "\x1b[0;31m")
+ ((W) "\x1b[0;97m")
+ ((Y) "\x1b[0;93m")
(else ""))
(case (get-bg frame)
((B) "\x1b[44m")
- ((Y) "\x1b[43m")
- ((C) "\x1b[46m")
+ ((BL) "\x1b[40m")
+ ((C) "\x1b[106m")
+ ((G) "\x1b[42m")
+ ((M) "\x1b[45m")
+ ((R) "\x1b[41m")
+ ((W) "\x1b[107m")
+ ((Y) "\x1b[103m")
(else ""))
(case (get-style frame)
@@ -41,13 +62,16 @@
((bold) "\x1b[1m")
(else ""))))
-(define (get-attr)
+(define (get-frame)
(do stack <- (get)
(return-state
- (fmt-frame->ansi-esc
- (make-fmt-frame
- (get-style (find get-style stack))
- (get-fg (find get-fg stack))
- (get-bg (find get-bg stack)))))))
+ (make-fmt-frame
+ (get-style (find get-style stack))
+ (get-fg (find get-fg stack))
+ (get-bg (find get-bg stack))))
+ ))
+
+(define (get-attr)
+ (<$> fmt-frame->ansi-esc (get-frame)))
diff --git a/img-parse.scm b/img-parse.scm
new file mode 100644
index 0000000..4033c41
--- /dev/null
+++ b/img-parse.scm
@@ -0,0 +1,81 @@
+(define-module (img-parse)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-88)
+ :use-module (v3)
+ :use-module (hnh util)
+ :use-module (cv)
+ :export (parse-immage
+ parse-image-file
+ lookup-table))
+
+
+(define colors
+ `((B . ,(v3 0 0 255))
+ (BL . ,(v3 0 0 0))
+ (C . ,(v3 0 255 255))
+ (G . ,(v3 0 255 0))
+ (M . ,(v3 255 0 255))
+ (R . ,(v3 255 0 0))
+ (W . ,(v3 255 255 255))
+ (Y . ,(v3 255 255 0))))
+
+
+(define (parse-image img)
+ (reverse
+ (map (lambda (pair)
+ (let ((v (apply v3
+ (map (lambda (i) (im-ref img (car pair) (cadr pair) i))
+ (iota 3)))))
+ (car
+ (find-min
+ (map (lambda (c) (cons (car c) (abs (- v (cdr c)))))
+ colors)
+ cdr))))
+ (cross-product
+ (list 0 (floor-quotient (im-height img) 2) (1- (im-height img)))
+ (list 0 (1- (im-width img)))))))
+
+(define parse-image-file (compose parse-image im-load))
+
+;; (parse-image img)
+;; => (W W W W B W)
+;; A B
+;; C D
+;; E F
+
+
+;; (define img (im-load "/home/hugo/.cache/texttv/img/15963642.gif"))
+
+
+;; bas 16
+;; 1 2
+;; 4 8
+;; 10 20
+
+(define (range from to)
+ (iota (1+ (- to from)) from))
+
+
+;; scheme@(img-parse) [5]> (map (lambda (x) (cons x (vector-ref v x))) (iota (vector-length v)))
+
+(define lookup-table
+ (let ((v (make-vector (expt 2 6))))
+
+ (vector-set! v 0 #\space)
+ ;; right half block
+ (vector-set! v #x15 (integer->char #x2590))
+ ;; left half block, should technically be U+2586, but the API
+ ;; works on the assumption that that character doesn't exist,
+ ;; and instead outputs an inverted right half block
+ (vector-set! v #x2a (integer->char #x2590))
+ ;; Full block, same argument about inversion as above
+ (vector-set! v #x3f #\space) ; but inverted
+
+ (for-each (lambda (x) (vector-set! v x (integer->char (+ x -1 #x1fb00))))
+ (range 1 #x14))
+ (for-each (lambda (x) (vector-set! v x (integer->char (+ x -2 #x1fb00))))
+ (range #x16 #x29))
+ (for-each (lambda (x) (vector-set! v x (integer->char (+ x -3 #x1fb00))))
+ (range #x2b #x3e))
+
+ v))
diff --git a/main.scm b/main.scm
index 9d23614..ef968b6 100755
--- a/main.scm
+++ b/main.scm
@@ -11,6 +11,7 @@
(srfi srfi-1)
(srfi srfi-43) ; Vector iteration
+ ((srfi srfi-60) :select (list->integer))
(srfi srfi-71)
(ice-9 regex)
@@ -26,32 +27,38 @@
(monad stack)
(fmt-stack)
+ (img-parse)
+
(sxml gumbo)
(json parser)
((xdg basedir) :prefix xdg-))
-(define-macro (regex-case str . cases)
- `(cond
- ,@(map (lambda (case)
- (let ((pattern (car case))
- (rest (cdr case)))
- (if (eq? pattern 'else)
- `(else ,@rest)
- `((string-match ,pattern ,str) ,@rest))))
- cases)))
+(define-syntax regex-case
+ (syntax-rules (else)
+ ((_ str var (else body ...))
+ (begin body ...))
-(define (substr-1 match)
- (match:substring match 1))
+ ((_ str var (pat body ...) rest ...)
+ (cond ((string-match pat str)
+ => (lambda (var) body ...))
+ (else (regex-case str var rest ...))))))
(define (class-handlers class)
(fold (lambda (cl obj)
(regex-case
- cl
- ("^DH$" (set-style obj 'bold))
- ("^bg([BYC])$" => (lambda (m) (->> (substr-1 m) string->symbol (set-bg obj))))
- ("^([BYC])$" => (lambda (m) (->> (substr-1 m) string->symbol (set-fg obj))))
+ cl m
+ ("^DH$" (set-style obj 'bold))
+ ("^bgImg$" obj)
+ ("^bg([BCGMRWY]|Bl)$" (->> (match:substring m 1)
+ string-upcase
+ string->symbol
+ (set-bg obj)))
+ ("^([BCGMRWY]|bl)$" (->> (match:substring m 1)
+ string-upcase
+ string->symbol
+ (set-fg obj)))
(else obj)))
(empty-fmt-frame)
(string-split class #\space)))
@@ -60,12 +67,68 @@
;;; TODO Every clause should return a string, in the state context of a state.
-(define (handle-h1-or-span class nodes)
+;; "<id>.gif": #\x<num>
+(define bg-cache (make-hash-table))
+
+(define (save-bg-cache)
+ (with-output-to-file (cache-file "bg.scm")
+ (lambda ()
+ (write (hash-map->list list bg-cache))
+ (newline))))
+
+(define (load-bg-cache)
+ (define file (cache-file "bg.scm"))
+ (when (file-exists? file)
+ (let ((forms (call-with-input-file file read)))
+ (when (list? forms)
+ (for-each (lambda (form) (apply hash-set! bg-cache form))
+ forms)))))
+
+
+(define bg-img-url "https://l.texttv.nu/storage/chars")
+
+(define (get-bg-image-char frame img)
+ (or (and=> (hash-ref bg-cache img) string)
+ (let ((img-file (cache-file (path-append "img" img))))
+ (unless (file-exists? img-file)
+ (download-file (format #f "~a/~a" bg-img-url img)
+ img-file))
+
+ (let ((char
+ (->> (map (lambda (x)
+ (cond ((eq? x (get-fg frame)) #t)
+ ((eq? x (get-bg frame)) #f)
+ (else (scm-error 'misc-error "get-bg-image-char"
+ "Color neither foreground or background. fg: ~s, bg: ~s, file: ~s"
+ (list (get-fg frame) (get-bg frame)
+ img-file)
+ #f))))
+ (parse-image-file img-file))
+ list->integer
+ (vector-ref lookup-table))))
+ (hash-set! bg-cache img char)
+ (return-state (string char))))))
+
+
+(define bg-rx (make-regexp (format #f "background: url\\(~a/([^)]*)\\)" bg-img-url)))
+
+(define (handle-h1-or-span class style nodes)
+ (define (err fmt . args)
+ (scm-error 'misc-error "handle-h1-or-span"
+ fmt args
+ #f))
+
(do fmt-before <- (get-attr)
(push (class-handlers class))
fmt-with <- (get-attr)
+ frame <- (get-frame)
ret <- (<$> (lambda (s) (string-append fmt-with s fmt-before))
- (<$> string-concatenate (sequence (map fmt-tag nodes))))
+ (if (member "bgImg" (string-split class #\space))
+ (cond ((regexp-exec bg-rx style)
+ => (lambda (m) (get-bg-image-char frame (match:substring m 1))))
+ (else (err "bgImg without background image style")))
+ (<$> string-concatenate (sequence (map fmt-tag nodes)))))
+
(pop)
(return-state ret)))
@@ -78,29 +141,29 @@
tag
[(a ,body ...)
(do fmt-before <- (get-attr)
- (push (make-fmt-frame 'underline 'B #f))
+ (push (make-fmt-frame 'underline #f #f))
fmt-with <- (get-attr)
(pop)
(return-state
(string-append fmt-with (car body) fmt-before)))]
- [(h1 (@ (class ,class)) ,nodes ...)
- (handle-h1-or-span class nodes)]
+ [(h1 (@ (class ,class) (style (,style ""))) ,nodes ...)
+ (handle-h1-or-span class style nodes)]
- [(span (@ (class ,class)) ,nodes ...)
- (handle-h1-or-span class nodes)]
+ [(span (@ (class ,class) (style (,style ""))) ,nodes ...)
+ (handle-h1-or-span class style nodes)]
[,str (guard (string? str)) (return-state str)]
- ;; Just ignore tags without children
[,default
(match default
- ((tag ('@ args ..) node nodes ...)
- (<$> string-concatenate (sequence (map fmt-tag (cons node nodes)))))
- ((tag node nodes ...)
- (<$> string-concatenate (sequence (map fmt-tag (cons node nodes)))))
((tag) (return-state ""))
+ ((tag ('@ args ...)) (return-state ""))
+ ((tag ('@ args ...) nodes ...)
+ (<$> string-concatenate (sequence (map fmt-tag nodes))))
+ ((tag nodes ...)
+ (<$> string-concatenate (sequence (map fmt-tag nodes))))
(default (return-state (format #f "[|~a|]" default))))]))
(define (text-for-num j int)
@@ -130,47 +193,84 @@
(make-string (- 60 trnc) #\-)
(truncate (* 100 progress)))))
+(define (build-cache-dir)
+ (unless (file-exists? (cache-path))
+ (mkdir (cache-path)))
+
+ (let ((last-updated (cache-file "last-updated")))
+ (unless (file-exists? last-updated)
+ (with-output-to-file last-updated
+ (lambda () (display 0)))))
+
+ (unless (file-exists? (cache-file "img"))
+ (mkdir (cache-file "img")))
+
+ (unless (file-exists? (cache-file "rendered"))
+ (mkdir (cache-file "rendered")))
+
+ )
+
+(define (render-page file el)
+ (with-output-to-file file
+ (lambda ()
+ (-> el
+ (assoc-ref "content")
+ (vector-ref 0)
+ (html->sxml #:trim-whitespace? #f
+ #:full-document? #f)
+ fmt-tag
+ (run-state (list (make-fmt-frame "" "" "")))
+ car
+ display))))
+
+
+;; Render all pages in vector
+(define (render-pages vect)
+ (define (status i)
+ (display-status-bar i (vector-length vect) (current-error-port)))
+
+ (format (current-error-port) "~%Rendering HTML~%")
+
+ (vector-for-each
+ (lambda (i el)
+ (status i)
+ (render-page (cache-file (path-append
+ "rendered"
+ (format #f "~a.ansi" (assoc-ref el "num"))))
+ el))
+ vect)
+
+ (display-status-bar 1 1 (current-error-port))
+ (newline (current-error-port)))
+
+(define (download-file url destination)
+ (system* "curl"
+ "-s" url
+ "-o" destination))
+
(define (main args)
- (let* ((self filename pagestr (apply values args))
+ (let* ((self base-filename pagestr (apply values args))
+ (json-cache (cache-file base-filename))
(page (string->number pagestr)))
- (unless (file-exists? (cache-path))
- (mkdir (cache-path))
- (with-output-to-file (cache-file "last-updated")
- (lambda () (display 0))))
-
- (let ((last-updated (call-with-input-file (cache-file "last-updated") read)))
- (when (> (- (current-time) last-updated) 10000)
- (display "Downloading new data, please stand by...")
- (system* "curl"
- "-s" "http://api.texttv.nu/api/get/100-999?app=hugonikanor"
- "-o" (cache-file filename))
-
- (let* ((json (call-with-input-file (cache-file filename) json->scm))
- (update (max-date json)))
-
- (with-output-to-file (cache-file "last-updated") (lambda () (display update)))
-
- (let ((vlen (vector-length json)))
- (format (current-error-port)
- "~%Rendering HTML~%")
- (vector-for-each
- (lambda (i el)
- (let ((num (assoc-ref el "num"))
- (text (-> el (assoc-ref "content") (vector-ref 0))))
- (with-output-to-file (cache-file (format #f "~a.ansi" num))
- (lambda ()
- (display-status-bar i vlen (current-error-port))
- (-> (html->sxml text
- #:trim-whitespace? #f
- #:full-document? #f)
- fmt-tag
- (run-state (list (make-fmt-frame "" "" "")))
- car display)))))
- json))
- (display-status-bar 1 1 (current-error-port))
- (newline (current-error-port))))
-
- (let ((p1 (cache-file (format #f "~a.ansi" page)))
- (p2 (cache-file (format #f "~a.ansi" (1+ page)))))
- (system* "paste" p1 p2)))))
+ (build-cache-dir)
+ (load-bg-cache)
+
+ (let ((last-updated
+ (call-with-input-file (cache-file "last-updated") read)))
+ (when (> (- (current-time) last-updated) 10000)
+ (display "Downloading new data, please stand by...")
+ (download-file "http://api.texttv.nu/api/get/100-999?app=hugonikanor"
+ json-cache)
+ (newline)
+
+ (let ((page-data (call-with-input-file json-cache json->scm)))
+ (with-output-to-file (cache-file "last-updated")
+ (lambda () (write (max-date page-data)) (newline)))
+ (render-pages page-data))))
+
+ (let ((p1 (cache-file (path-append "rendered" (format #f "~a.ansi" page))))
+ (p2 (cache-file (path-append "rendered" (format #f "~a.ansi" (1+ page))))))
+ (system* "paste" p1 p2))
+
+ (save-bg-cache)))
diff --git a/v3.scm b/v3.scm
new file mode 100644
index 0000000..b2bc523
--- /dev/null
+++ b/v3.scm
@@ -0,0 +1,41 @@
+(define-module (v3)
+ :use-module (oop goops)
+ :re-export (+ - * abs)
+ :export (v3))
+
+(define-class <v3> ()
+ (x getter: x init-keyword: x:)
+ (y getter: y init-keyword: y:)
+ (z getter: z init-keyword: z:))
+
+(define (v3 x y z)
+ (make <v3> x: x y: y z: z))
+
+(define-generic +)
+(define-generic -)
+(define-generic *)
+(define-generic abs)
+
+(define-method (+ (v <v3>) (u <v3>))
+ (v3 (+ (x v) (x u))
+ (+ (y v) (y u))
+ (+ (z v) (z u))))
+
+(define-method (- (v <v3>))
+ (v3 (- (x v))
+ (- (y v))
+ (- (z v))))
+
+(define-method (- (v <v3>) (u <v3>))
+ (+ v (- u)))
+
+(define-method (* (v <v3>) (u <v3>))
+ (+ (* (x v) (x u))
+ (* (y v) (y u))
+ (* (z v) (z u))))
+
+(define-method (abs (v <v3>))
+ (sqrt (* v v)))
+
+(define-method (write (v <v3>) port)
+ (write `(v3 ,(x v) ,(y v) ,(z v)) port ))