;;;; output-ps.scm -- implement Scheme output interface for PostScript
;;;;
;;;;  source file of the GNU LilyPond music typesetter
;;;; 
;;;; (c) 1998--2009 Jan Nieuwenhuizen <address@hidden>
;;;;                 Han-Wen Nienhuys <address@hidden>

;;;; Note: currently misused as testbed for titles with markup, see
;;;;       input/test/title-markup.ly
;;;; 
;;;; TODO:
;;;;   * %% Papersize in (header ...)
;;;;   * text setting, kerning.
;;;;   * document output-interface

(define-module (scm output-ps)
  #:re-export (quote)

  ;; JUNK this -- see lily.scm: ly:all-output-backend-commands
  #:export (unknown
            bezier-sandwich
            char
            circle
            comment
            dashed-line
            dashed-slur
            dot
            draw-line
            ellipse
            embedded-ps
            named-glyph
            no-origin
            oval
            placebox
            polygon
            repeat-slash
            resetcolor
            resetrotation
            round-filled-box
            setcolor
            setrotation
            text
            ))


(use-modules (guile)
             (ice-9 regex)
             (srfi srfi-1)
             (srfi srfi-13)
             (scm framework-ps)
             (lily))

;;; helper functions, not part of output interface
;;;


;; ice-9 format uses a lot of memory
;; using simple-format almost halves lilypond cell usage

(define (set-precision n)
  (if (number? n)
    (let* ((max-decimals 4)
           (k (expt 10.0 max-decimals))
           (float (/ (round (* n k))
                     k)))
      (if (integer? n)
          (inexact->exact n)
          (if (< (abs (- float (round n)))
                 (/ 0.1 k))
              (inexact->exact (round float))
              float)))
        n))

(define (ly:format4 string . args)
  (apply format string (map set-precision args)))

;; It seems this procedure is never called. -MSP
;; Do we need to keep it?
(define (str4 num)
  (if (or (nan? num) (inf? num))
      (begin
        (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
        (if (ly:get-option 'strict-infinity-checking)
            (exit 1))
        "0.0")
      (ly:number->string num)))

(define (number-pair->string4 numpair)
  (ly:format4 "~a ~a" (car numpair)
                      (cdr numpair)))

;;;
;;; Lily output interface, PostScript implementation --- cleanup and docme
;;;

;; two beziers
(define (bezier-sandwich lst thick)
  (ly:format4 "~{~a ~}~a draw_bezier_sandwich" 
	            (map number-pair->string4 (map set-precision lst))
	            thick))

;; It seems this procedure is never called. -MSP
;; Do we need to keep it?
(define (char font i)
  (ly:format "~a (\\~a) show"
   (ps-font-command font)
   (ly:inexact->string i 8)))

(define (circle radius thick fill)
  (ly:format4 "~a ~a ~a draw_circle"
              (if fill "true" "false")
              radius
              thick))

(define (dashed-line thick on off dx dy phase)
  (ly:format4 "~a ~a ~a [ ~a ~a ] ~a draw_dashed_line"
              dx
              dy
              thick
              on
              off
              phase))

;; what the heck is this interface ?
(define (dashed-slur thick on off l)
  (ly:format4
    "~{~a ~}~a [ ~a ~a ] 0 draw_dashed_slur"
    (let ((control-points (append (cddr l)
                                  (list (car l)
                                        (cadr l)))))
      (map number-pair->string4 (map set-precision control-points)))
           thick
           on
           off))

(define (dot x y radius)
  (ly:format4 "~a ~a ~a draw_dot" radius x y))

(define (draw-line thick x1 y1 x2 y2)
  (ly:format4 "~a ~a ~a ~a ~a draw_line"
              (- x2 x1)
              (- y2 y1)
              x1
              y1
              thick))

(define (ellipse x-radius y-radius thick fill)
  (ly:format4 "~a ~a ~a ~a draw_ellipse"
              (if fill "true" "false")
              x-radius
              y-radius
              thick))

(define (embedded-ps string)
  string)

(define (glyph-string postscript-font-name
                      size
                      cid?
                      w-x-y-named-glyphs)
  (define (glyph-spec w x y g)
    (let ((prefix (if (string? g)
                      "/"
                      "")))
      ;; I'm pretty sure it's safe to use ly:format4 -MSP
      (ly:format4 "~a ~a ~a~a"
                  (+ w x)
                  y
                  prefix
                  g)))
  ;; I'm pretty sure it's safe to use ly:format4 -MSP
  (ly:format4
   (if cid?
      (string-append "/~a /CIDFont findresource ~a"
                     "output-scale div scalefont setfont\n"
                     "~a\n"
                     "~a print_glyphs")
      (string-append "/~a ~a output-scale div selectfont\n"
                     "~a\n"
                     "~a print_glyphs"))
   postscript-font-name
   size
   (string-join (map (lambda (x) (apply glyph-spec x))
                     (reverse w-x-y-named-glyphs))
                "\n")
   (length w-x-y-named-glyphs)))

(define (grob-cause offset grob)
  (if (ly:get-option 'point-and-click)
      (let* ((cause (ly:grob-property grob 'cause))
             (music-origin (if (ly:stream-event? cause)
                               (ly:event-property cause 'origin)
                               ;; why no alternate value here? -MSP
                               )))
        (if (ly:input-location? music-origin)
            (let* ((location
                     (ly:input-file-line-char-column music-origin))
                   (raw-file (car location))
                   (file (if (is-absolute? raw-file)
                             raw-file
                             (string-append (ly-getcwd)
                                            "/"
                                            raw-file)))
                   (x-ext (ly:grob-extent grob grob X))
                   (y-ext (ly:grob-extent grob grob Y)))
              (if (and (< 0 (interval-length x-ext))
                       (< 0 (interval-length y-ext)))
                  (ly:format4
                    "~a ~a ~a ~a (textedit://~a:~a:~a:~a) mark_URI\n"
                    (+ (car offset) (car x-ext))
                    (+ (cdr offset) (car y-ext))
                    (+ (car offset) (cdr x-ext))
                    (+ (cdr offset) (cdr y-ext))
                   
                    ;; TODO - full escaping.
                    ;; backslash is interpreted by GS.
                    (ly:string-substitute
                      "\\" "/" (ly:string-substitute " " "%20" file))
                    (cadr location)
                    (caddr location)
                    (cadddr location))
                  ""))
            ""))
      ""))

(define (named-glyph font glyph)
  (ly:format4 "~a /~a glyphshow" ;; removed space at the end -MSP
              (ps-font-command font)
              glyph))

(define (no-origin)
  "")

(define (oval x-radius y-radius thick fill)
  (ly:format4 "~a ~a ~a ~a draw_oval"
              (if fill "true" "false")
              x-radius
              y-radius
              thick))

(define (placebox x y s) 
  (ly:format4 "~a ~a moveto\n~a\n" x y s))

(define (polygon points blot-diameter filled?)
  (ly:format4 "~a ~{~a ~}~a ~a draw_polygon"
              (if filled? "true" "false")
              (map set-precision points)
              (+ -1 (* 1/2 (length points)))
              blot-diameter))

(define (repeat-slash width slope beam-thickness)
  (define (euclidean-length x y)
    (sqrt (+ (* x x) (* y y))))
  (let ((x-width (euclidean-length beam-thickness
                                   (/ beam-thickness slope)))
        (height (* width slope)))
    (ly:format4 "~a ~a ~a draw_repeat_slash"
                x-width
                width
                height)))

(define (round-filled-box left right bottom top blotdiam)
  (let* ((halfblot (/ blotdiam 2))
         (x (- halfblot left))
         (width (- right (+ halfblot x)))
         (y (- halfblot bottom))
         (height (- top (+ halfblot y))))
    (ly:format4 "~a ~a ~a ~a ~a draw_round_box"
                width
                height
                x
                y
                blotdiam)))

;; save current color on stack and set new color
(define (setcolor r g b)
  (ly:format4 "gsave ~a ~a ~a setrgbcolor\n" r g b))

;; restore color from stack
(define (resetcolor) "grestore\n")

;; rotation around given point
(define (setrotation ang x y)
  (ly:format4 "gsave ~a ~a translate ~a rotate ~a ~a translate\n"
              x
              y
              ang
              (* -1 x)
              (* -1 y)))

(define (resetrotation ang x y)
  "grestore ")

(define (text font s)
  ;; (ly:warning (_ "TEXT backend-command encountered in Pango backend"))
  ;; (ly:warning (_ "Arguments: ~a ~a"" font str))
  (let* ((space-length (cdar (ly:text-dimension font " ")))
         (space-move (string-append (number->string space-length)
                                    ;; changed 0.0 to 0 -MSP
                                    " 0 rmoveto "))
         (out-vec (decode-byte-string s)))
    (string-append
      (ps-font-command font)
      " "
      (string-join
        (vector->list
          (vector-for-each
            (lambda (sym)
              (if (eq? sym 'space)
                  space-move
                  (string-append "/"
                                 (symbol->string sym)
                                 " glyphshow")))
            out-vec))))))

(define (unknown)
  "\n unknown\n")

(define (url-link url x y)
  (ly:format4
   (string-append "~a ~a currentpoint vector_add "
                  "~a ~a currentpoint vector_add (~a) mark_URI")
   (car x)
   (car y)
   (cdr x)
   (cdr y)
   url))

(define (utf-8-string pango-font-description string)
  (ly:warning (_ "utf-8-string encountered in PS backend")))

(define (path thickness exps)
  (define (convert-path-exps exps)
    (if (pair? exps)
              (let* ((head (car exps))
                     (rest (cdr exps))
                     (arity 
                      (cond
                       ((memq head '(rmoveto rlineto lineto moveto)) 2)
                       ((memq head '(rcurveto curveto)) 6)
                       (else 1)))
                     (args (take rest arity)))
                ;; WARNING: this is a vulnerability:
                ;; a user can output arbitrary PS code here.
                (cons (ly:format4 "~{~a ~}~a "
                            (map set-precision args)
                            head)
                            (convert-path-exps (drop rest arity))))
              '()))
  (ly:format4 "1 setlinecap ~a setlinewidth\n~{~a ~} stroke"
              thickness
              (map set-precision (convert-path-exps exps))))