+ "%%Orientation: "
+ (if (eq? (ly:output-def-lookup paper 'landscape) #t)
+ "Landscape\n"
+ "Portrait\n")
+ (ps-document-media paper)
+ (supplies-or-needs paper load-fonts?)
+ "%%EndComments\n"))
+
+(define (procset file-name)
+ (format
+ "%%BeginResource: procset (~a) 1 0
+~a
+%%EndResource
+"
+ file-name (cached-file-contents file-name)))
+
+(define (embed-document file-name)
+ (format "%%BeginDocument: ~a
+~a
+%%EndDocument
+"
+ file-name (cached-file-contents file-name)))
+
+(define (setup-variables paper)
+ (string-append
+ "\n"
+ (define-fonts paper)
+ (output-variables paper)
+ ))
+
+(define (cff-font? font)
+ (let*
+ ((cff-string (ly:otf-font-table-data font "CFF ")))
+ (> (string-length cff-string) 0)))
+
+(define-public (ps-embed-cff body font-set-name version)
+ (let* ((binary-data
+ (string-append
+ (format "/~a ~s StartData " font-set-name (string-length body))
+ body))
+
+ (header
+ (format
+ "%%BeginResource: font ~a
+%!PS-Adobe-3.0 Resource-FontSet
+%%DocumentNeededResources: ProcSet (FontSetInit)
+%%Title: (FontSet/~a)
+%%Version: ~s
+%%EndComments
+%%IncludeResource: ProcSet (FontSetInit)
+%%BeginResource: FontSet (~a)
+/FontSetInit /ProcSet findresource begin
+%%BeginData: ~s Binary Bytes
+"
+ font-set-name font-set-name version font-set-name
+ (string-length binary-data)))
+ (footer "\n%%EndData
+%%EndResource
+%%EndResource\n"))
+
+ (string-append
+ header
+ binary-data
+ footer)))
+
+
+(define (write-preamble paper load-fonts? port)
+ (define (internal-font? file-name)
+ (or (string-startswith file-name "Emmentaler")
+ (string-startswith file-name "emmentaler")
+ (string-startswith file-name "aybabtu")
+ (string-startswith file-name "Aybabtu")))
+ (define (load-font-via-GS font-name-filename)
+ (define (ps-load-file file-name)
+ (if (string? file-name)
+ (if (string-contains file-name (ly:get-option 'datadir))
+ (begin
+ (set! file-name (ly:string-substitute (ly:get-option 'datadir) "" file-name))
+ (format "lilypond-datadir (~a) concatstrings (r) file .loadfont" file-name))
+
+ (format "(~a) (r) file .loadfont\n" file-name))
+ (format "% cannot find font file: ~a\n" file-name)))
+
+ (let* ((font (car font-name-filename))
+ (name (cadr font-name-filename))
+ (file-name (caddr font-name-filename))
+ (bare-file-name (ly:find-file file-name)))
+
+ (cons
+ name
+
+ (if (mac-font? bare-file-name)
+ (handle-mac-font name bare-file-name)
+ (cond
+ ((internal-font? file-name)
+ (ps-load-file (ly:find-file
+ (format "~a.otf" file-name))))
+ ((string? bare-file-name)
+ (ps-load-file file-name))
+ (else
+ (ly:warning (_ "cannot embed ~S=~S") name file-name)
+ "")))
+
+ )))
+
+ (define (dir-join a b)
+ (if (equal? a "")
+ b
+ (string-append a "/" b)))
+
+ (define (dir-listing dir-name)
+ (define (dir-helper dir lst)
+ (let ((e (readdir dir)))
+ (if (eof-object? e) lst (dir-helper dir (cons e lst)))))
+ (reverse (dir-helper (opendir dir-name) '())))
+
+ (define (handle-mac-font name filename)
+ (let*
+ ((dir-name (tmpnam))
+ (files '())
+ (status 0)
+ (embed #f))
+
+ (mkdir dir-name #o700)
+ (set! status (ly:system
+ (format "cd ~a && fondu -force '~a'" dir-name filename)))
+
+ (set! files (dir-listing dir-name))
+
+ (for-each
+ (lambda (f)
+ (let*
+ ((full-name (dir-join dir-name f)))
+
+ (if (and (not embed)
+ (equal? 'regular (stat:type (stat full-name)))
+ (equal? name (ly:ttf-ps-name full-name)))
+
+ (set! embed
+ (font-file-as-ps-string name full-name)))
+
+ (if (or (equal? "." f)
+ (equal? ".." f))
+ #t
+ (delete-file full-name))))
+
+
+ files)
+ (rmdir dir-name)
+
+ (if (not embed)
+ (begin
+ (set! embed "% failed \n")
+ (ly:warning (_ "cannot extract file matching ~a from ~a") name filename)))
+ embed))
+
+ (define (font-file-as-ps-string name file-name)
+ (let*
+ ((downcase-file-name (string-downcase file-name)))
+
+ (cond
+ ((and file-name (string-endswith downcase-file-name ".pfa"))
+ (embed-document file-name))
+ ((and file-name (string-endswith downcase-file-name ".pfb"))
+ (ly:pfb->pfa file-name))
+ ((and file-name (string-endswith downcase-file-name ".ttf"))
+ (ly:ttf->pfa file-name))
+ ((and file-name (string-endswith downcase-file-name ".otf"))
+ (ps-embed-cff (ly:otf->cff file-name) name 0))
+ (else
+ (ly:warning (_ "do not know how to embed ~S=~S") name file-name)
+ ""))))
+
+ (define (mac-font? bare-file-name)
+ (and
+ (eq? PLATFORM 'darwin)
+ bare-file-name
+ (or
+ (string-endswith bare-file-name ".dfont")
+ (= (stat:size (stat bare-file-name)) 0))))
+
+ (define (load-font font-name-filename)
+ (let* ((font (car font-name-filename))
+ (name (cadr font-name-filename))
+ (file-name (caddr font-name-filename))
+ (bare-file-name (ly:find-file file-name)))
+
+ (cons
+ name
+ (cond
+
+ ((mac-font? bare-file-name)
+ (handle-mac-font name bare-file-name))
+
+ ((and font (cff-font? font))
+ (ps-embed-cff (ly:otf-font-table-data font "CFF ")
+ name
+ 0))
+
+ (bare-file-name (font-file-as-ps-string name bare-file-name))
+ (else
+ (ly:warning (_ "do not know how to embed font ~s ~s ~s")
+ name file-name font))))))
+
+
+ (define (load-fonts paper)
+ (let* ((fonts (ly:paper-fonts paper))
+
+ ;; todo - doc format of list.
+ (all-font-names
+ (map
+ (lambda (font)
+ (cond
+ ((string? (ly:font-file-name font))
+ (list (list
+ font
+ (ly:font-name font)
+ (ly:font-file-name font))))
+ ((ly:pango-font? font)
+ (map
+ (lambda (name-psname-pair)
+ (list #f
+ (car name-psname-pair)
+ (cdr name-psname-pair)))
+ (ly:pango-font-physical-fonts font)))
+
+ (else
+ (ly:font-sub-fonts font))))
+
+ fonts))
+ (font-names
+ (uniq-list
+ (sort (apply append all-font-names)
+ (lambda (x y) (string<? (cadr x) (cadr y))))))
+
+ ;; slightly spaghetti-ish: deciding what to load where
+ ;; is smeared out.
+ (font-loader (lambda (name)
+ (cond
+ ((ly:get-option 'gs-load-fonts)
+ (load-font-via-GS name))
+ ((ly:get-option 'gs-load-lily-fonts)
+ (if (or
+ (string-contains (caddr name) (ly:get-option 'datadir))
+ (internal-font? (caddr name)))
+
+ (load-font-via-GS name)
+ (load-font name)))
+ (else (load-font name)))))
+
+ (pfas (map font-loader font-names)))
+ pfas))
+
+ (display "%%BeginProlog\n" port)
+
+ (format port
+ "/lilypond-datadir where {pop} {userdict /lilypond-datadir (~a) put } ifelse"
+ (ly:get-option 'datadir))