#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do xout)' -s $0 "$@" # -*-scheme-*-
!#
;;; xout

;; Copyright (C) 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: xout [options] [args ...]
;;
;; Display ARGS (text) in an X window.  Options are:
;;
;; -f, --file FILENAME  -- Take first ARG to be a filename; display
;;                         its (text) contents.  If FILENAME is "-"
;;                         (a single hyphen), read from stdin.
;;
;;     --font NAME      -- Use font NAME (default: "fixed").
;;
;; -U, --utf8           -- Decode text as UTF-8 (default: LATIN-1).
;;
;; Actually, the "default encoding LATIN-1" really means no decoding.
;; Keyboard commands are:
;;
;;  SPC            -- next page
;;  backspace      -- previous page
;;  i              -- speckle (uses GetImage/PutImage, may be slow)
;;  ESC, Q, C-q    -- quit

;;; Code:

(define-module (ttn-do xout)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((srfi srfi-1) #:select (split-at
                                        lset-intersection))
  #:use-module ((srfi srfi-11) #:select (let-values))
  #:use-module ((srfi srfi-13) #:select (reverse-list->string
                                         string-delete
                                         string-join))
  #:use-module ((srfi srfi-14) #:select (char-set))
  #:use-module ((ttn-do zz sys linux-gnu) #:select (gethostname))
  #:use-module ((ttn-do zzz subprocess) #:select (port-lines
                                                  file-lines))
  #:use-module ((ttn-do zzz personally) #:select (fso fs))
  #:use-module ((ttn-do zzz x-protocol) #:select ((-x . zx)))
  #:use-module ((ttn-do zzz x-umbrages) #:select (n<-window-class
                                                  n<-event-mask
                                                  n-from-enum
                                                  n<-color-name
                                                  connection
                                                  atom-manager
                                                  set-icccm-properties!
                                                  drawing
                                                  pixel-width-proc))
  #:use-module ((ttn-do zzz x-kbgrunge) #:select (kthx-core))
  #:use-module ((ttn-do zzz emacsdream) #:select (utf8-reader)))

(define clean
  (let ((no-thanks (char-set #\newline #\cr)))
    (lambda (s)
      (string-delete s no-thanks))))

(define ORIGIN-MODE ((n-from-enum 'CoordMode) 'Origin))

(define LOCAL #f)

(define (xout font-name lines)
  (let* ((vlines (list->vector lines))
         (conn (connection))
         (fdes (conn #:fdes))
         (setup (conn #:setup))
         (screen-geom (cons (zx '(roots 0 width-in-pixels) setup)
                            (zx '(roots 0 height-in-pixels) setup)))
         (io (conn #:io))
         (q (conn #:q))
         (kthx (kthx-core conn))
         (amgr (atom-manager conn))
         (dmgr (drawing conn))
         (font-info (dmgr #:open-font font-name))
         (fi: (lambda (x)
                (zx x font-info)))
         (line-height (+ (fi: '(max-bounds ascent))
                         (fi: '(max-bounds descent))))
         (lines/page (quotient (inexact->exact
                                (* 0.8 (cdr screen-geom)))
                               line-height))
         (npages (1+ (quotient (vector-length vlines) lines/page)))
         (page 0)
         (line-widths (map (pixel-width-proc font-info) lines))
         (window-geom (cons (apply max line-widths)
                            (* line-height (min (length lines) lines/page))))
         (xwid (dmgr #:create-window
                     #:parent (zx '(roots 0 root) setup)
                     #:class (n<-window-class
                              'InputOutput)
                     #:width (car window-geom) #:height (cdr window-geom)
                     #:value-list (list 'BackPixel 0
                                        'EventMask (n<-event-mask
                                                    '(Exposure
                                                      KeyPress)))))
         (gcontext (dmgr #:create-gc xwid
                         (list 'Foreground (n<-color-name "sienna")
                               'Font (fi: 'xfid)))))

    (define (clear!)
      (io 'ClearArea
          #:window xwid
          #:x 1 #:y 1
          #:width (- (car window-geom) 2) #:height (- (cdr window-geom) 2)))

    (define (frame!)
      (io 'PolyLine
          #:coordinate-mode ORIGIN-MODE
          #:drawable xwid
          #:gc gcontext
          #:points (let ((R (- (car window-geom) 1))
                         (B (- (cdr window-geom) 1)))
                     (vector (list #:x 0 #:y 0)
                             (list #:x 0 #:y B)
                             (list #:x R #:y B)
                             (list #:x R #:y 0)
                             (list #:x 0 #:y 0)))))

    (define (draw!)
      (set! LOCAL #f)
      (let* ((beg (* page lines/page))
             (end (min (+ beg lines/page) (vector-length vlines))))
        (let loop ((i beg))
          (or (= i end)
              (let ((line (vector-ref vlines i)))
                (or (string-null? line)
                    (io 'PolyText8
                        #:drawable xwid #:gc gcontext
                        #:x 0 #:y (+ (fi: '(max-bounds ascent))
                                     (* (- i beg) line-height))
                        #:items (let ((len (string-length line)))
                                  (or (> 255 len)
                                      (error "too long:" line))
                                  (fs "~A~A~A"
                                      (integer->char len)
                                      (integer->char 0)
                                      line))))
                (loop (1+ i)))))))

    (define (handle-event ev)
      (define (adjacent-page direction)
        (set! page (modulo (+ direction page) npages))
        (clear!)
        (draw!))
      (case (cadr ev)
        ((KeyPress)
         (let ((press (cdr (kthx #:keypress<-event ev))))
           (and (pair? press)
                (set-cdr! press (lset-intersection
                                 eq? (cdr press)
                                 '(shift control meta alt super hyper))))
           (cond
            ((member press '((Escape) (Q) (q control)))
             (throw 'done))
            ((equal? '(space) press)
             (adjacent-page 1))
            ((equal? '(BackSpace) press)
             (adjacent-page -1))
            ((equal? '(i) press)
             (let* ((ZPixmap ((n-from-enum 'ImageFormat) 'ZPixmap))
                    (w (car window-geom))
                    (h (cdr window-geom))
                    (im #f) (depth #f) (xfer #f) (data #f))
               (or LOCAL
                   (let* ((im (q 'GetImage
                                 #:format ZPixmap
                                 #:drawable xwid
                                 #:x 0 #:y 0 #:width w #:height h
                                 #:plane-mask #xffffff))
                          (xfer (zx 'data im))
                          (data (make-uniform-array 1 h w)))
                     (fso "im[~Ax~A]: depth ~A, visual ~A, ~S bytes~%"
                          w h (zx 'depth im) (zx 'visual im)
                          (* 4 (zx '%reply-length im)))
                     (uniform-array-read! data (open-input-string xfer))
                     (set! LOCAL (values im (zx 'depth im)
                                         (string-copy xfer)
                                         data))))
               (let-values (((a b c d) LOCAL))
                 (set! im a)
                 (set! depth b)
                 (set! xfer c)
                 (set! data d))
               (let loop ((i 999))
                 (or (zero? i)
                     (let ((x (random w))
                           (y (random h)))
                       (array-set! data (random #x1000000) y x)
                       (loop (1- i)))))
               (set! xfer
                     (let* ((p (open-output-string))
                            (end (* w h))
                            (flat (make-shared-array
                                   data (lambda (i)
                                          (list (quotient i w)
                                                (remainder i w)))
                                   end)))
                       (do ((i 0 (1+ i)))
                           ((= end i))
                         (uniform-vector-write flat p i (1+ i)))
                       (get-output-string p)))
               (q 'PutImage
                  #:format ZPixmap
                  #:drawable xwid
                  #:gc gcontext
                  #:dst-x 0 #:dst-y 0 #:width w #:height h
                  #:depth depth
                  #:data xfer)))
            (else
             (fso "press: ~S~%" press)))))
        ((Expose)
         (draw!) (frame!)
         (fso "ev: ~A~%" (cadr ev)))
        ((ClientMessage)
         (let-values (((head rest) (split-at ev 3)))
           (let ((data (zx 'data rest)))
             (case (amgr #:symbolic (zx 'type rest))
               ((WM_PROTOCOLS)
                (let ((protocol (amgr #:symbolic (car data)))
                      (timestamp/UNUSED (cadr data)))
                  (case protocol
                    ((WM_DELETE_WINDOW)
                     (fso "~A: bye!~%" protocol)
                     (throw 'done))
                    (else
                     (fso "unrecognized wm protocol: ~A ~S~%" protocol rest)))))
               (else
                (fso "unrecognized client message: ~A ~S~%" type rest))))))
        (else
         (fso "ev: ~S~%" ev))))

    ;; Set properties for the window manager.
    (set-icccm-properties!
     conn xwid
     'WM_NAME (fs "xout (~AL ~AP ~AL/P)"
                  (length lines) npages lines/page)
     'WM_ICON_NAME "xout"
     'WM_NORMAL_HINTS (list 'min-size window-geom
                            'max-size window-geom
                            'resize-inc (cons (fi: '(max-bounds
                                                     character-width))
                                              line-height)
                            'gravity 'SouthEast)
     'WM_HINTS (list 'input #t
                     'initial-state 'normal)
     'WM_CLASS '("xout" . "XOut")
     ;; n/a: 'WM_TRANSIENT_FOR
     'WM_PROTOCOLS 'WM_DELETE_WINDOW
     'WM_COLORMAP_WINDOWS xwid
     'WM_CLIENT_MACHINE (gethostname))
    ;; Loop, handling events.
    (catch
     'done
     (lambda ()
       (io #:set-external-event-queue! handle-event)
       (q 'MapWindow #:window xwid)
       (let loop ()
         (io #:flush!)
         (select (list fdes) '() '())
         (io #:gobble!)
         (loop)))
     (lambda x
       (fso "done~%")))
    ;; Shut down.
    (dmgr #:drop gcontext (fi: 'xfid) xwid)
    (conn #:bye)))

(define (as-utf8 line)
  (let* ((r (utf8-reader line))
         (rvbox (r #:rvbox))
         (acc '()))
    (let loop ()
      (cond ((r) (set! acc (cons (integer->char (cdr rvbox)) acc)) (loop))))
    (reverse-list->string acc)))

(define (xout/qop qop)
  (xout (or (qop 'font) "fixed")
        (map (if (qop 'utf8)
                 as-utf8
                 identity)
             (map clean
                  (or (qop 'file (lambda (filename)
                                   (if (string=? "-" filename)
                                       (port-lines (current-input-port))
                                       (file-lines filename))))
                      (let ((words (qop '())))
                        (if (null? words)
                            (error "missing message")
                            (list (string-join words " "))))))))
  #t)

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.2")
                   (help . commentary)))
  (setvbuf (current-error-port) _IONBF)
  (setvbuf (current-output-port) _IONBF)
  (xout/qop
   (qop<-args
    args '((font (value #t))
           (utf8 (single-char #\U))
           (file (single-char #\f) (value #t))))))

;;; xout ends here