Add handling of graphical chars.HEADmaster

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 ))