lilypond-common-includes/book_include.ly

\version "2.18"

#(define song-list '())

#(define (files-in-directory dirname)
      ;;; Generate list containing filenames
      (let ((dir (opendir dirname)))
        (let next ((f (readdir dir))
    	       (files '()))
          (cond ((eof-object? f)
    	     (closedir dir)
    	     files)
    	    (else
    	     (next (readdir dir) (if (string-match "^(0|\\.)" f) files (cons f files))))))))

#(define (file-to-stats filename)
   (set! song-list (cons filename song-list)))


#(define additional-page-switch-label-list '())
#(define additional-page-numbers #f)

normalPageNumbers =
#(define-void-function (parser location) ()
  (set! additional-page-numbers #f)
)
additionalPageNumbers =
#(define-void-function (parser location) ()
  (set! additional-page-numbers #t)
)

#(define (real-page-number layout label)
  (let ((table (ly:output-def-lookup layout 'label-page-table)))
        (if (list? table)
            (assoc-get label table)
            #f))
  )

#(define display-pages-list '())
#(define (build-display-pages-list layout)
  (if (null? display-pages-list)
    (let calculate-display-page ((switch-label-list additional-page-switch-label-list))
      (let* ((label (caar switch-label-list))
             (is-additional (cdar switch-label-list))
             (real-page (real-page-number layout label))
             (rest-switch-label-list (cdr switch-label-list))
             (display-page (if (null? rest-switch-label-list)
               (if is-additional (- real-page 1) real-page)
               (let* ((previous-label (caar rest-switch-label-list))
                      (previous-is-additional (cdar rest-switch-label-list))
                      (previous-display-page (calculate-display-page rest-switch-label-list)))
                  (+ previous-display-page
                    (if previous-is-additional
                      (if is-additional 0 1)
                      (if is-additional
                          (- (- real-page (real-page-number layout previous-label)) 1)
                          (- real-page (real-page-number layout previous-label)))
                    )
                  )
               )
             ))
      )
      (set! display-pages-list (acons label display-page display-pages-list))
      display-page
    )))
  display-pages-list
)


#(define-markup-command (custom-page-number layout props label real-current-page-number)
  (symbol? number?)
  #:category other
  "
@cindex referencing page number, in text

Reference to a page number.  @var{label} is the label set on the referenced
page (using the @code{\\label} command), @var{gauge} a markup used to estimate
the maximum width of the page number, and @var{default} the value to display
when @var{label} is not found.

(If the current book or bookpart is set to use roman numerals for page numbers,
the reference will be formatted accordingly -- in which case the @var{gauge}'s
width may require additional tweaking.)"
  (let* ((gauge-stencil (interpret-markup layout props "XXX"))
         (x-ext (ly:stencil-extent gauge-stencil X))
         (y-ext (ly:stencil-extent gauge-stencil Y)))
    (ly:stencil-outline
     (ly:make-stencil
      `(delay-stencil-evaluation
        ,(delay (ly:stencil-expr
                 (let* ((display-page (assq-ref (build-display-pages-list layout) label))
                        (real-current-page (if (negative? real-current-page-number) (real-page-number layout label) real-current-page-number))
                        (page-markup
                          (if (assq-ref additional-page-switch-label-list label)
                              (make-concat-markup (list (number-format 'arabic display-page)
                                (make-char-markup (+ 97 (- real-current-page (real-page-number layout
                                  (let find-earliest-additional-label
                                       ((rest-additional-page-switch-label-list (member (cons label #t) additional-page-switch-label-list)))
                                       (if (cdadr rest-additional-page-switch-label-list)
                                           (find-earliest-additional-label (cdr rest-additional-page-switch-label-list))
                                           (caar rest-additional-page-switch-label-list)))
                                ))))))
                              (number-format 'arabic (+ display-page (- real-current-page (real-page-number layout label))))
                          ))
                        (page-stencil (interpret-markup layout props page-markup))
                        (gap (- (interval-length x-ext)
                                (interval-length (ly:stencil-extent page-stencil X)))))
                   (interpret-markup layout props
                                     (make-line-markup
                                      (list
                                       (make-hspace-markup gap)
                                       page-markup)))))))
      x-ext
      y-ext)
     (make-filled-box-stencil x-ext y-ext))))


includeSong =
#(define-void-function (parser location textproc filename) ((procedure?) string?)
     #{
     \bookOutputName #filename
     #}
    (ly:parser-parse-string (if (< (list-ref (ly:version) 1) 19) (ly:parser-clone parser) (ly:parser-clone))
      (ly:format "\\include \"~a/~a/~a.ly\"" songPath filename filename))
    (let ((label (gensym "index")))
      (set! additional-page-switch-label-list
        (acons label additional-page-numbers additional-page-switch-label-list))
      (set! song-list
        (acons (string->symbol filename)
          (acons 'label label (acons 'header HEADER (acons 'music MUSIC (acons 'layout LAYOUT (acons 'text #{ \markuplist \setsongfilename $filename $(if textproc (textproc TEXT) TEXT) #} '())))))
          song-list))
    ))

blankpage =
#(define-void-function (parser location) ()
    (set! song-list
      (acons 'emptyPage
        '()
        song-list)))

imagepage =
#(define-void-function (parser location xsize filename) (number? string?)
    (set! song-list
      (acons 'imagePage
        (acons 'xsize xsize (acons 'filename filename '()))
        song-list)))

#(define-markup-command (pagecenter layout props stuff)(markup?)
   (interpret-markup layout props
     (let ((halfpaperheight (/ (ly:output-def-lookup layout 'paper-height) 2))
           (halfstuffheight (/ (interval-length (ly:stencil-extent (interpret-markup layout props stuff) Y)) 2)))
       (make-fill-line-markup (list (make-pad-to-box-markup '(0 . 0) (cons (- (- halfpaperheight halfstuffheight)) (+ halfpaperheight halfstuffheight)) stuff)))
   )))

songs =
#(define-void-function (parser location) ()
 (for-each (lambda (songitems)
   (ly:book-add-bookpart! (if (< (list-ref (ly:version) 1) 19) (ly:parser-lookup parser '$current-book) (ly:parser-lookup '$current-book))
    (let ((filename (car songitems))
          (songvars (cdr songitems)))
      (if (eq? filename 'emptyPage)
          #{ \bookpart { \markup { \null } } #}
      (if (eq? filename 'imagePage)
          (let ((xsize (assq-ref songvars 'xsize))
                (filename (ly:format "~a/~a" imagePagePath (assq-ref songvars 'filename))))
          #{ \bookpart {
               \paper {
                 %{
                 inner-margin = 0
                 outer-margin = 0
                 binding-offset = 0
                 top-margin = 0
                 bottom-margin = 0
                 %}
                 print-page-number = ##f
                 last-bottom-spacing = #'((basic-distance . 0) (minimum-distance . 0) (padding . 0))
                 page-count = 1
              }
              \markup { \pagecenter { \epsfile #X #xsize #filename } }
          } #}
          )
          (let ((header #{ \bookpart { $(assq-ref songvars 'header) \header {
                  songfilename = $(symbol->string filename)
                  myindexlabel = #(assq-ref songvars 'label)
                } } #})
                ;(header (assq-ref songvars 'header))
                (music (assq-ref songvars 'music))
                (layout (assq-ref songvars 'layout))
                (text (assq-ref songvars 'text))
                (label (assq-ref songvars 'label)))
            #{
              \bookpart {
                $header
                \headerToTOC #header #label
                \score { $music \layout { $layout } }
                $text
              }
            #}))))))
   (reverse song-list)
   ))

#(define (boernel-stats)
   (let (
          (songs (map (lambda (song) (symbol->string (car song))) (alist-delete 'emptyPage song-list)))
          (opticalline "---------------------------------------------------------"))
   (ly:warning (string-join (list
     opticalline
     (string-concatenate (list "Inkludiert: " (number->string (length songs)) " Lieder\n"))
     ;(string-join songs "\n")
     "Nicht inkludiert:"
     opticalline
     (string-join (sort-list (lset-difference string=? (files-in-directory songPath) songs) string<?) "\n")
     opticalline
     ) "\n" )
)))

#(define (writeTOCtoCSV)
  (let ((song-lines (map (lambda (song)
          (list
            (symbol->string (car song))
          ))
          (alist-delete 'imagePage (alist-delete 'emptyPage song-list)))))
  (call-with-output-file "toc.csv"
    (lambda (port)
     (csv-write (cons '("filename") song-lines) port))
)))

%% https://github.com/NalaGinrut/guile-csv/blob/master/csv/csv.scm

#(define* (sxml->csv sxml port #:key (delimiter #\,))
  (let* ((d (string delimiter))
         (csv (map (lambda (l) (string-join l d)) sxml)))
    (for-each (lambda (l)
                (format port "~a~%" l))
              csv)))

#(define csv-write sxml->csv)

%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Include Images once and reference them:
#(define bbox-regexp
  (ly:make-regex "%%BoundingBox:[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)"))

#(define (get-postscript-bbox string)
  "Extract the bbox from STRING, or return #f if not present."
  (let*
      ((match (ly:regex-exec bbox-regexp string)))

    (if match
        (map (lambda (x)
               (string->number (ly:regex-match-substring match x)))
             (cdr (iota 5)))

        #f)))


#(define eps-references '())

#(define-public (eps-file-ref->stencil axis size just-embed file-name)
  (let*
      ((already-embedded (assq (string->symbol file-name) eps-references))
       (counter (if already-embedded (cadr already-embedded) (if (null-list? eps-references) 1 (+ 1 (cadar eps-references)))))
       (form-name (ly:format "IDForm~a" counter))
       (data-name (ly:format "ImageData~a" counter))
       (eps-content (ly:gulp-file file-name))
       (contents (ly:format "~a execform" form-name))
       (bbox (if already-embedded (cddr already-embedded) (get-postscript-bbox (car (string-split eps-content #\nul)))))
       (bbox-size (if (= axis X)
                      (- (list-ref bbox 2) (list-ref bbox 0))
                      (- (list-ref bbox 3) (list-ref bbox 1))
                      ))
       (factor (if (< 0 bbox-size)
                   (exact->inexact (/ size bbox-size))
                   0))
       (scaled-bbox
        (map (lambda (x) (* factor x)) bbox))
       ;; We need to shift the whole eps to (0,0), otherwise it will appear
       ;; displaced in lilypond (displacement will depend on the scaling!)
       (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
       (clip-rect-string (ly:format
                          "~a ~a ~a ~a rectclip"
                          (list-ref bbox 0)
                          (list-ref bbox 1)
                          (- (list-ref bbox 2) (list-ref bbox 0))
                          (- (list-ref bbox 3) (list-ref bbox 1)))))

    (if (not already-embedded) (set! eps-references
                                     (acons (string->symbol file-name) (cons counter bbox) eps-references)))
    (if bbox
        (ly:make-stencil
         (list
          'embedded-ps
          (string-append
           (if (and already-embedded (not just-embed)) "" (ly:format
            "
/~a
currentfile
<< /Filter /SubFileDecode
   /DecodeParms << /EODCount 0 /EODString (*EOD*) >>
>> /ReusableStreamDecode filter
~a
*EOD*
def

/~a
<< /FormType 1
   /BBox [~a ~a ~a ~a]
   /Matrix [ 1 0 0 1 0 0]
   /PaintProc
   { pop
       /ostate save def
         /showpage {} def
         /setpagedevice /pop load def
         ~a 0 setfileposition ~a cvx exec
       ostate restore
   } bind
>> def
" data-name eps-content form-name (list-ref bbox 0) (list-ref bbox 1) (list-ref bbox 2) (list-ref bbox 3) data-name data-name))
           (if just-embed "" (ly:format
            "
gsave
currentpoint translate
BeginEPSF
~a dup scale
~a
~a
%%BeginDocument: ~a
~a
%%EndDocument
EndEPSF
grestore
"         factor translate-string  clip-rect-string file-name contents
))))
         ;; Stencil starts at (0,0), since we have shifted the eps, and its
         ;; size is exactly the size of the scaled bounding box
         (if just-embed '(0 . 0) (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0))))
         (if just-embed '(0 . 0) (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1)))))

        (ly:make-stencil "" '(0 . 0) '(0 . 0)))
    ))

#(define-markup-command (epsfileref layout props axis size file-name)
  (number? number? string?)
  #:category graphic
  "
@cindex inlining an Encapsulated PostScript image

Inline an EPS image.  The image is scaled along @var{axis} to
@var{size}.

@lilypond[verbatim,quote]
\\markup {
  \\general-align #Y #DOWN {
    \\epsfile #X #20 #\"context-example.eps\"
    \\epsfile #Y #20 #\"context-example.eps\"
  }
}
@end lilypond"
  (if (ly:get-option 'safe)
      (interpret-markup layout props "not allowed in safe")
      (eps-file-ref->stencil axis size #f file-name)
      ))

#(define-markup-command (epsfileembed layout props file-name)
  (string?)
  #:category graphic
  "
@cindex inlining an Encapsulated PostScript image

Inline an EPS image.  The image is scaled along @var{axis} to
@var{size}.

@lilypond[verbatim,quote]
\\markup {
  \\general-align #Y #DOWN {
    \\epsfile #X #20 #\"context-example.eps\"
    \\epsfile #Y #20 #\"context-example.eps\"
  }
}
@end lilypond"
  (if (ly:get-option 'safe)
      (interpret-markup layout props "not allowed in safe")
      (eps-file-ref->stencil X 30 #t file-name)
      ))