#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do imgtxtlink)' -s $0 "$@" # -*-scheme-*-
!#
;;; imgtxtlink
;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version. There is NO WARRANTY. See file COPYING for details.
;;; Commentary:
;; Usage: imgtxtlink [options...] image
;;
;; Covert IMAGE file to text and decorate it with hyperlinks.
;; Recognized options (defaults in square braces):
;;
;; -o, --output FILENAME -- write to FILENAME [IMAGE.html]
;; -s, --scale SPEC -- pass SPEC to pnmscale
;; -i, --invert -- include pnminvert(1) in processing
;; --bgcolor COLOR -- page background color
;; --text COLOR -- page text color
;; -l, --links FILENAME -- look in FILENAME for urls
;; [single url: ttn-do homepage]
;;
;; This program uses commands from Netpbm for image manipulation.
;;; Code:
(define-module (ttn-do imgtxtlink)
#:export (string<-image-command
randomly-hyperlinked
main)
#:use-module ((ttn-do zzz banalities) #:select (check-hv
qop<-args))
#:use-module ((ice-9 regex) #:select (match:start
match:end
match:substring))
#:use-module ((srfi srfi-13) #:select (substring/shared))
#:use-module ((ttn-do zzz personally) #:select (accumulator
fs))
#:use-module ((ttn-do zzz subprocess) #:select (shell-command->string
file-lines))
#:use-module ((ttn-do zzz publishing) #:select (flatten-to
css-tree
:NULL))
#:use-module ((ttn-do zzz xhtml-tree) #:select (~simple-strict-xhtml
~head ~title
~link ~style
~body
~pre ~a ~tt)))
;; Concatentate @var{source}, a shell command that writes image data
;; to stdout, with a series of shell commands from the Netpbm package.
;; Optional arg @var{invert?} non-@code{#f} means to include a call to
;; @file{pnminvert} in the pipeline.
;;
;; Execute the pipeline in a subshell and return its output as a string.
;;
;;-args: (- 1 0 invert?)
;;
(define (string<-image-command source . opts)
(let ((invert? (and (not (null? opts))
(car opts))))
(shell-command->string
(fs "~A | anytopnm~A | ~A | ~A | ~A | ~A"
source
(if invert? " | pnminvert" "")
"ppmtopgm"
"pgmtopbm"
"pbmtoascii -2x4"
"tr '<&>' 'L87'"))))
(define *rx-vec* (list->vector
(map (lambda (i)
(make-regexp
(fs "([ ~%]+)|(~A)"
(apply string-append
(make-list i "[^ \n]")))))
(iota 8))))
;; Profile @var{string} for small non-whitespace intervals to be
;; ``marked up'' as the text of an @acronym{HTML} @code{A} element, with
;; reference taken randomly from @var{list-of-links} (list of strings).
;; As as special case, if the @sc{car} of @var{list-of-links} is the
;; symbol @code{file-lines}, then the @sc{cadr} is taken to be a
;; filename which must contain one link (URL) per line.
;;
;; Return an html-data tree (nested list of strings). Optional third
;; arg @var{link-tree} specifies a procedure to use instead of
;; @var{href} (@pxref{zzz xhtml-tree}) to construct hyperlink references.
;; It should take arguments @var{url} and @var{text} (both strings),
;; and return a tree (nested list of strings).
;;
;;-args: (- 1 0 link-tree)
;;
(define (randomly-hyperlinked string list-of-links . opts)
(let* ((link-tree (or (and (not (null? opts))
(car opts))
(lambda (url text)
(~a 'href url text))))
(len (string-length string))
(lol (cond ((and (pair? list-of-links)
(eq? 'file-lines (car list-of-links)))
(file-lines (cadr list-of-links)))
(else
list-of-links)))
(lvec (list->vector lol))
(llen (vector-length lvec))
(tree (accumulator)))
(define (sub b e)
(substring/shared string b e))
(define (hi! s)
(tree (link-tree (vector-ref lvec (random llen)) s)))
(let loop ((idx 0))
(cond ((regexp-exec (vector-ref *rx-vec* (+ 2 (random 6))) string idx)
=> (lambda (m)
(let* ((b (match:start m))
(e (match:end m)))
(or (= idx b)
(tree (sub idx b)))
((if (and (match:substring m 2) ; non-space
(< 0 llen))
hi!
tree)
(sub b e))
(loop e))))
(else
(or (= idx len)
(tree (sub idx len))))))
(tree)))
(define (main/qop qop)
(let* ((scale (or (qop 'scale (lambda (n)
(string-append " | pnmscale " n)))
:NULL))
(bgcolor (qop 'bgcolor))
(text (qop 'text))
(filename (if (null? (qop '()))
(error "no image file specified")
(car (qop '()))))
(invert? (qop 'invert))
(links (or (qop 'links (lambda (f) (list 'file-lines f)))
'("http://www.gnuvola.org/software/ttn-do/"))))
(define (ART)
(randomly-hyperlinked
(string<-image-command (fs "anytopnm ~A~A " filename scale) invert?)
links
(lambda (url text)
(~a 'href url text))))
(define (spew! . x)
(call-with-output-file (or (qop 'output)
(string-append filename ".html"))
(lambda (port)
(flatten-to port (~simple-strict-xhtml x)))))
(spew!
(~head (~title filename)
(~style 'type "text/css"
(map css-tree
'(("a" text-decoration "none")
("a:hover" text-decoration "underline"))))
(~link 'href filename))
(~body 'bgcolor bgcolor
'text text
(~pre (~tt (ART)))))))
(define (main args)
(check-hv args '((package . "ttn-do")
(version . "1.1")
(help . commentary)))
(main/qop
(qop<-args
args '((output (single-char #\o) (value #t))
(scale (single-char #\s) (value #t))
(invert (single-char #\i))
(bgcolor (value #t))
(text (value #t))
(links (single-char #\l) (value #t))))))
;;; imgtxtlink ends here