From dda8b325b562d957250c05a26a702f4536d5601e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 2 Aug 2022 20:19:42 +0200 Subject: Add handling of graphical chars. --- README | 20 +++++ fmt-stack.scm | 44 ++++++++--- img-parse.scm | 81 ++++++++++++++++++++ main.scm | 236 +++++++++++++++++++++++++++++++++++++++++----------------- v3.scm | 41 ++++++++++ 5 files changed, 344 insertions(+), 78 deletions(-) create mode 100644 img-parse.scm create mode 100644 v3.scm 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) +;; ".gif": #\x +(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 () + (x getter: x init-keyword: x:) + (y getter: y init-keyword: y:) + (z getter: z init-keyword: z:)) + +(define (v3 x y z) + (make x: x y: y z: z)) + +(define-generic +) +(define-generic -) +(define-generic *) +(define-generic abs) + +(define-method (+ (v ) (u )) + (v3 (+ (x v) (x u)) + (+ (y v) (y u)) + (+ (z v) (z u)))) + +(define-method (- (v )) + (v3 (- (x v)) + (- (y v)) + (- (z v)))) + +(define-method (- (v ) (u )) + (+ v (- u))) + +(define-method (* (v ) (u )) + (+ (* (x v) (x u)) + (* (y v) (y u)) + (* (z v) (z u)))) + +(define-method (abs (v )) + (sqrt (* v v))) + +(define-method (write (v ) port) + (write `(v3 ,(x v) ,(y v) ,(z v)) port )) -- cgit v1.2.3