;; guile-present
;; Copyright (C) 2007, 2009, 2010, 2011, 2012, 2014 Andy Wingo <wingo at pobox dot com>

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, see
;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Routines to render SXML documents from the presentation vocabulary
;; using the Cairo graphics library.
;;
;;; Code:

(define-module (present cairo)
  #:use-module (cairo)
  #:use-module (present fold)
  #:use-module (ice-9 match)
  #:export (presentation-render-cairo))

(define rsvg-handle-render-cairo #f)
(define rsvg-handle-new-from-file #f)
(define rsvg-handle-get-dimensions #f)

(cond
 ((resolve-module '(rsvg) #:ensure #f)
  => (lambda (mod)
       (set! rsvg-handle-render-cairo
             (module-ref mod 'rsvg-handle-render-cairo))
       (set! rsvg-handle-new-from-file
             (module-ref mod 'rsvg-handle-new-from-file))
       (set! rsvg-handle-get-dimensions
             (module-ref mod 'rsvg-handle-get-dimensions))))
 (else
  (let ()
    (define (no-rsvg . args)
      (warn "SVG support not available.  Install guile-rsvg."))
    (set! rsvg-handle-render-cairo no-rsvg)
    (set! rsvg-handle-new-from-file no-rsvg)
    (set! rsvg-handle-get-dimensions no-rsvg))))

(define jpeg-dimensions #f)
(define jpeg->rgb #f)
(define interleaved-image-buffer #f)

(cond
 ((resolve-module '(jpeg) #:ensure #f)
  => (lambda (mod)
       (set! jpeg-dimensions (eval 'jpeg-dimensions mod))
       (set! jpeg->rgb (eval 'jpeg->rgb mod))
       (set! interleaved-image-buffer (eval 'interleaved-image-buffer mod))))
 (else
  (let ()
    (define (no-jpeg . args)
      (warn "JPEG support not available.  Install guile-jpeg."))
    (set! jpeg-dimensions no-jpeg)
    (set! jpeg->rgb no-jpeg)
    (set! interleaved-image-buffer no-jpeg))))

(define (fold-cairo cr tree bindings params layout stylesheet)
  (define (munge-bindings bindings)
    (define (munge-post-proc p)
      (lambda (tag params layout klayout kids)
        (values (p cr tag params layout klayout)
                (if (null? (car params))
                    (cons tag kids)
                    (cons* tag (cons '@ (car params)) kids)))))
    (define (munge-pre-layout-proc p)
      (lambda (tag params layout)
        (p cr tag params layout)))
    (define (munge-text-proc p)
      (lambda (text params layout)
        (values (p cr text params layout)
                text)))
    (define (munge-handler h)
      (case (car h)
        ((post) (cons 'post (munge-post-proc (cdr h))))
        ((pre-layout) (cons 'pre-layout (munge-pre-layout-proc (cdr h))))
        ((bindings) (cons 'bindings (munge-bindings (cdr h))))
        (else h)))
    (define (munge-binding b)
      (case (car b)
        ((*text*) (cons '*text* (munge-text-proc (cdr b))))
        (else (cons (car b) (map munge-handler (cdr b))))))
    (map munge-binding bindings))
  (call-with-values
      (lambda () (fold-layout tree (munge-bindings bindings)
                              params layout stylesheet))
    (lambda (ret layout)
      layout)))

;; Probably, more of this could be public.

(define* (lookup params key
                 #:optional (default-thunk
                              (lambda ()
                                (error "unbound param" key))))
  (cond ((null? params) (default-thunk))
        ((assq key (car params)) => cadr)
        (else (lookup (cdr params) key default-thunk))))

(define-syntax let-params
  (syntax-rules ()
    ((_ (param-exp ...) (k ...) b b* ...)
     (let ((p (param-exp ...)))
       (let-params p (k ...) b b* ...)))
    ((_ params () b b* ...)
     (begin b b* ...))
    ((_ params ((k default) k* ...) b b* ...)
     (let ((k (lookup params 'k (lambda () default))))
       (let-params params (k* ...) b b* ...)))
    ((_ params (k k* ...) b b* ...)
     (let ((k (lookup params 'k)))
       (let-params params (k* ...) b b* ...)))))

(define* (make-layout left top x line-height #:optional (space 0))
  (vector left top x line-height space))

(define (layout-left layout)
  (vector-ref layout 0))

(define (layout-top layout)
  (vector-ref layout 1))

(define (layout-x layout)
  (vector-ref layout 2))

(define (layout-line-height layout)
  (vector-ref layout 3))

(define (layout-space layout)
  (vector-ref layout 4))

(define (layout-beginning-of-line? layout)
  (= (layout-x layout) (layout-left layout)))

(define (layout-indent layout indent)
  (make-layout (+ (layout-left layout) indent) (layout-top layout)
               (+ (layout-left layout) indent) (layout-line-height layout)))

(define (layout-scroll layout scroll)
  (make-layout (layout-left layout) (+ (layout-top layout) scroll)
               (layout-left layout) (layout-line-height layout)))

(define (layout-next-line layout line-spacing)
  (layout-scroll layout (* (layout-line-height layout) line-spacing)))

(define (layout-enter layout line-height)
  (make-layout (layout-left layout) (layout-top layout)
               (layout-left layout) line-height))

(define (layout-return layout block-spacing line-spacing)
  (if (layout-beginning-of-line? layout)
      layout
      (layout-next-line layout (* block-spacing line-spacing))))

(define* (layout-advance layout dx #:optional (space 0))
  (make-layout (layout-left layout) (layout-top layout)
               (+ (layout-x layout) dx) (layout-line-height layout)
               space))

(define (layout-ensure-space layout space)
  (if (layout-beginning-of-line? layout)
      layout
      (layout-advance layout 0 (max (layout-space layout) space))))

(define (layout-apply-space layout)
  (layout-advance layout (layout-space layout)))

(define (default-pre-layout cr tree params layout)
  (let-params params (inline? absolute? margin-left margin-top
                              text-height text-scaling)
    (cond
     (inline? layout)
     (absolute? (make-layout margin-left margin-top margin-left
                             (* text-height text-scaling)))
     (else (and layout (layout-enter layout (* text-height text-scaling)))))))

(define (default-post cr tag params old-layout layout)
  (let-params params (inline? absolute? block-spacing line-spacing)
    (cond
     (inline? layout)
     (absolute? old-layout)
     (else (layout-return layout block-spacing line-spacing)))))

(define (specialize-param params k v)
  (cons (list (list k v)) params))

(define (text-x-advance cr text)
  (cairo-text-extents:x-advance (cairo-text-extents cr text)))

(define *punctuation*
  '(("``" . "“")
    ("''" . "”")
    ("`" . "‘")
    ("'" . "’")
    ("---" . "—")
    ("--" . "–")))

(define (prettify-punctuation word)
  (let lp ((word word) (punctuation *punctuation*))
    (match punctuation
      (() word)
      (((needle . replacement) . punctuation)
       (cond
        ((string-contains word needle)
         => (lambda (pos)
              (lp (string-append
                   (substring word 0 pos)
                   replacement
                   (substring word (+ pos (string-length needle))))
                  punctuation)))
        (else (lp word punctuation)))))))

(define *subword-charset* (char-set #\/ #\- ))

(define (find-subword-right word end)
  (let ((tail (string-index-right word
                                  (char-set-complement *subword-charset*)
                                  0 end)))
    (and tail
         (and=> (string-index-right word *subword-charset* 0 tail)
                1+))))

(define* (next-subword cr word available #:optional (end (string-length word)))
  (let* ((subword-end (find-subword-right word end))
         (end (or subword-end end)))
    (let* ((subword (substring word 0 end))
           (width (text-x-advance cr subword)))
      (if (or (< width available) (not subword-end))
          (values subword width)
          (next-subword cr word available end)))))

(define (terminal? word)
  (case (string-ref word (1- (string-length word)))
    ((#\. #\! #\?) #t)
    (else #f)))

(define (flow-text cr params layout text)
  (let-params params (text-height text-scaling font-family line-spacing width
                      margin-right font-weight font-slant pretty-punctuation?
                      can-end-sentence?)
    (define (maybe-prettify word)
      (if pretty-punctuation?
          (prettify-punctuation word)
          word))
    (cairo-select-font-face cr font-family font-slant font-weight)
    (cairo-set-font-size cr (* text-height text-scaling))
    (let ((space-width (text-x-advance cr " ")))
      (let render ((text text)
                   (layout layout))
        (cond
         ((string-null? text)
          ;; Done.
          layout)
         ((char-whitespace? (string-ref text 0))
          ;; Interword space.
          (render (substring text 1) (layout-ensure-space layout space-width)))
         ;; Print a word at a time.  Ignore whitespace; interword spacing
         ;; is uniform, except a little bit more after a terminator (.?!).
         (else
          (let* ((word-end (or (string-index text char-whitespace?)
                               (string-length text)))
                 (word (maybe-prettify (substring text 0 word-end))))
            (let retry ((word word)
                        (subword? #f)
                        (text (substring text word-end))
                        (word-width (text-x-advance cr word))
                        (layout (layout-apply-space layout))
                        (force? #f))
              (cond
               ((and (> (+ (layout-x layout) word-width) (- width margin-right))
                     (not force?))
                ;; Word doesn't fit.
                (let ((available (- width margin-right (layout-x layout))))
                  (call-with-values (lambda ()
                                      (next-subword cr word available))
                    (lambda (subword subword-width)
                      (if (or (layout-beginning-of-line? layout)
                              (< subword-width available)
                              (string-every char-set:punctuation word))
                          (let ((tail (substring word (string-length subword))))
                            (retry subword #t (string-append tail text)
                                   subword-width layout #t))
                          (retry word subword? text word-width
                                 (layout-next-line layout line-spacing)
                                 #f))))))
               (else
                (cairo-move-to cr (layout-x layout)
                               (+ (layout-top layout)
                                  (layout-line-height layout)))
                (cairo-show-text cr word)
                (render text
                        (layout-advance layout
                                        word-width
                                        (cond
                                         ((or subword? (string-null? text)) 0)
                                         ((and can-end-sentence?
                                               (terminal? word))
                                          (* 1.5 space-width))
                                         (else space-width))))))))))))))

(define (verbatim-text cr params layout text)
  (let-params params (text-height text-scaling font-family line-spacing
                      font-weight font-slant)
    (cairo-select-font-face cr font-family font-slant font-weight)
    (cairo-set-font-size cr (* text-height text-scaling))
    (let lp ((lines (string-split text #\newline)) (layout layout))
      (cairo-move-to cr (layout-x layout)
                     (+ (layout-top layout)
                        (layout-line-height layout)))
      (cairo-show-text cr (car lines))
      (if (null? (cdr lines))
          (layout-advance layout (text-x-advance cr (car lines)))
          (lp (cdr lines) (layout-next-line layout line-spacing))))))

(define (text-handler cr text params layout) 
  (let-params params (verbatim?)
    ((if verbatim? verbatim-text flow-text)
     cr params layout text)))

(define (ul-pre-layout cr tree params layout)
  (let-params params (indent-width text-height text-scaling)
    (layout-enter (layout-indent layout indent-width)
                  (* text-height text-scaling))))

(define (ul-post cr tag params old-layout layout)
  (let-params params (indent-width block-spacing line-spacing)
    (layout-return (layout-indent layout (- indent-width))
                   block-spacing line-spacing)))

(define (make-bullet cr params layout)
  (let-params params (bullet-string bullet-font-family)
    (flow-text cr (specialize-param params 'font-family bullet-font-family)
               layout bullet-string)))

(define (li-post cr tag params old-layout layout)
  (let-params params (indent-width)
    (make-bullet cr params (layout-indent old-layout (- indent-width)))
    (default-post cr tag params old-layout layout)))

(define (title-pre-layout cr tree params layout)
  (let-params params (margin-top text-height text-scaling)
    ;; go to the middle of the page?
    (layout-enter (layout-scroll layout margin-top)
                  (* text-height text-scaling))))

(define (image-width-for-height filename target-height)
  (cond
   ((string-suffix? ".svg" (string-downcase filename))
    (call-with-values
        (lambda ()
          (rsvg-handle-get-dimensions (rsvg-handle-new-from-file
                                       filename)))
      (lambda (width height em ex)
        (* target-height 1.0 (/ width height)))))
   ((string-suffix? ".png" (string-downcase filename))
    (let ((surf (cairo-image-surface-create-from-png filename)))
      (* target-height 1.0 (/ (cairo-image-surface-get-width surf)
                              (cairo-image-surface-get-height surf)))))
   ((or (string-suffix? ".jpg" (string-downcase filename))
        (string-suffix? ".jpeg" (string-downcase filename)))
    (call-with-values (lambda () (jpeg-dimensions filename))
      (lambda (width height)
        (* target-height 1.0 (/ width height)))))
   (else
    (error "unknown image type" filename))))

(define (create-image-surface filename target-width target-height)
  (cond
   ((string-suffix? ".svg" (string-downcase filename))
    (let ((surf (cairo-image-surface-create 'argb32 target-width target-height)))
      (let ((cr (cairo-create surf)))
        (rsvg-handle-render-cairo
         (rsvg-handle-new-from-file filename) cr)
        (cairo-surface-flush surf)
        (values surf target-width target-height))))
   ((string-suffix? ".png" (string-downcase filename))
    (let ((surf (cairo-image-surface-create-from-png filename)))
      (values surf
              (cairo-image-surface-get-width surf)
              (cairo-image-surface-get-height surf))))
   ((or (string-suffix? ".jpg" (string-downcase filename))
        (string-suffix? ".jpeg" (string-downcase filename)))
    (call-with-values (lambda () (jpeg-dimensions filename))
      (lambda (width height)
        (let* ((stride (cairo-format-stride-for-width 'rgb24 width))
               (rgb (jpeg->rgb filename #:argb? #t
                               #:stride-for-width (lambda (_) stride))))
          (values (cairo-image-surface-create-for-data
                      (interleaved-image-buffer rgb)
                      'rgb24 width height stride)
                  width
                  height)))))
   (else
    (warn "unknown image type" filename)
    (values #f #f #f))))

(define* (paint-image cr filename x0 y0 width height #:key stretch?
                      (center-horizontally? #t) (center-vertically? #t))
  (define (scale-dimensions aspect)
    (cond
     (stretch?
      (values x0 y0 width height))
     ((< aspect (/ width height))
      ;; Tall source.
      (let ((new-width (* height aspect)))
        (values (if center-horizontally?
                    (+ x0 (/ (- width new-width) 2))
                    x0)
                y0
                new-width height)))
     (else
      ;; Wide source.
      (let ((new-height (/ width aspect)))
        (values x0
                (if center-vertically?
                    (+ y0 (/ (- height new-height) 2))
                    y0)
                width new-height)))))
  (call-with-values (lambda () (create-image-surface filename width height))
    (lambda (surface swidth sheight)
      (if surface
          (call-with-values (lambda () (scale-dimensions (/ swidth 1.0 sheight)))
            (lambda (x0 y0 width height)
              (cairo-save cr)
              (cairo-translate cr x0 y0)
              (cairo-scale cr (/ width swidth) (/ height sheight))
              (cairo-set-source-surface cr surface 0 0)
              (cairo-pattern-set-filter (cairo-get-source cr) 'best)
              (cairo-rectangle cr 0 0 swidth sheight)
              (cairo-fill cr)
              (cairo-restore cr)
              (values width height)))
          (values 0 0)))))

(define (image-post cr tag params old-layout layout)
  (let-params params (image-filename (image-width #f) (image-height #f)
                      height width margin-right margin-bottom inline?
                      text-height text-scaling line-spacing)
    (cond
     (inline?
      ;; An image in a text block: restrict to the line height.
      (let* ((layout (layout-apply-space layout))
             (avail-x (- width margin-right (layout-x layout)))
             (width-for-height
              (image-width-for-height image-filename
                                      (* text-height text-scaling)))
             (layout (if (< avail-x width-for-height)
                         (layout-next-line layout line-spacing)
                         layout)))
        (paint-image cr image-filename
                     (layout-x layout) (layout-top layout)
                     width-for-height (* text-height text-scaling)
                     #:stretch? #t)
        (layout-advance layout width-for-height)))
     (else
      ;; An image at the top level: horizontally center in available
      ;; space.
      (let* ((avail-x (- width margin-right (layout-x layout)))
             (avail-y (- height (layout-top layout) margin-bottom))
             (max-width (or image-width avail-x))
             (max-height (or image-height avail-y))
             (x0 (+ (layout-x layout) (/ (- avail-x max-width) 2.0))))
        (call-with-values
            (lambda ()
              (paint-image cr image-filename
                           x0 (layout-top layout)
                           max-width max-height
                           #:center-vertically? #f))
          (lambda (width height)
            (layout-scroll layout height))))))))

(define (set-source-rgb cr rgb)
  (cairo-set-source-rgb cr
                        (/ (logand (ash rgb -16) #xff) 255.0)
                        (/ (logand (ash rgb -8) #xff) 255.0)
                        (/ (logand (ash rgb 0) #xff) 255.0)))

(define (slide-pre-layout cr tree params layout)
  (let-params params (margin-left margin-top background background-color
                      foreground-color width height text-height text-scaling)
    (set-source-rgb cr background-color)
    (cairo-rectangle cr 0 0 width height)
    (cairo-fill cr)
    (when background
      (paint-image cr background 0 0 width height))
    (set-source-rgb cr foreground-color)
    (make-layout margin-left margin-top margin-left
                 (* text-height text-scaling))))

(define (slide-post cr tag params old-layout layout)
  (cairo-show-page cr)
  old-layout)

(define (presentation-post cr tag params old-layout layout)
  old-layout)

(define *presentation->svg-rules*
  `((presentation
     (post . ,presentation-post))
    (slide
     (pre-layout . ,slide-pre-layout)
     (post . ,slide-post))
    (title
     (pre-layout . ,title-pre-layout))
    (image
     (post . ,image-post))
    (ul
     (pre-layout . ,ul-pre-layout)
     (post . ,ul-post))
    (li
     (post . ,li-post))
    (*text* . ,text-handler)
    (*default*
     (pre-layout . ,default-pre-layout)
     (post . ,default-post))))

(define *default-params*
  '((indent-width 64)
    (margin-left 64)
    (margin-right 64)
    (margin-top 64)
    (margin-bottom 64)
    (line-spacing 1.1)
    (inline? #f)
    (absolute? #f)
    (can-end-sentence? #t)
    (verbatim? #f)
    (pretty-punctuation? #t)
    (block-spacing 1.4)
    (font-family "Serif")
    (font-slant normal)
    (font-weight normal)
    (bullet-string "❧")
    (bullet-font-family "Sans")
    (text-height 42)
    (text-scaling 1/1)
    (background #f)
    (background-color #xFFFFFF)
    (foreground-color #x000000)
    (width 1024)
    (height 768)))

(define *null-layout* #f)

(define *presentation-stylesheet*
  '((title (text-height 96))
    (header (text-height 64))
    (tt (font-family "Monospace") (inline? #t)
        (can-end-sentence? #f) (pretty-punctuation? #f) (text-height 36))
    (pre (font-family "Monospace") (verbatim? #t) (pretty-punctuation? #f) (text-height 36) (line-spacing 1.2))
    (span (inline? #t))
    (image (inline? #t))
    (i (font-slant italic) (inline? #t))
    (b (font-weight bold) (inline? #t))))

(define (adjoin-stylesheets presentation stylesheet)
  (define (adjoin tag key value stylesheet)
    (match stylesheet
      (() `((,tag (,key ,value))))
      (((t . params) . stylesheet)
       (if (eq? t tag)
           `((,t (,key ,value) . ,params) . ,stylesheet)
           (acons t params (adjoin tag key value stylesheet))))))
  (match presentation
    (('presentation ('@ . params) . body)
     (let lp ((in params) (out '()) (stylesheet stylesheet))
       (match in
         (() (values `(presentation (@ ,@(reverse out)) . ,body)
                     stylesheet))
         (((and param (tag key value)) . in)
          (lp in out (adjoin tag key value stylesheet)))
         ((param . in)
          (lp in (cons param out) stylesheet)))))
    (_ (values presentation stylesheet))))

(define (presentation-render-cairo presentation cr)
  "Convert an SXML document in the @code{presentation} vocabulary to a
multi-layered SVG.

The result will still be a document in SXML format, so if you want to
write it to disk, use @code{sxml->xml}. @xref{sxml simple,(sxml
simple),(sxml simple),guile-library,Guile Library}, for more
information.

The resulting SVG will be written with annotations readable by Inkscape,
a vector graphics editor, which help to make the SVG easily editable. If
your toolchain does not understand namespaces, you might want to filter
out elements that start with @samp{sodipodi:}, @samp{xmlns:}, and
@samp{inkscape:}.
"
  (call-with-values (lambda ()
                      (adjoin-stylesheets presentation
                                          *presentation-stylesheet*))
    (lambda (presentation stylesheet)
      (fold-cairo cr presentation *presentation->svg-rules* *default-params*
                  *null-layout* stylesheet))))