scm/new-markup.scm

   1
   2 "
   3 Internally markup is stored as lists, whose head is a function.
   4
   5   (FUNCTION ARG1 ARG2 ... )
   6
   7 When the markup is formatted, then FUNCTION is called as follows
   8
   9   (FUNCTION GROB PROPS ARG1 ARG2 ... )
  10
  11 GROB is the current grob, PROPS is a list of alists, and ARG1.. are
  12 the rest of the arguments.
  13
  14 The function should return a molecule (i.e. a formatted, ready to
  15 print object).
  16
  17
  18
  19 To add a function,
  20
  21 1. It should be named  COMMAND-markup
  22
  23 2. It should have an object property set that describes it's
  24 signature. This is to allow the parser to figure out how many
  25 arguments to expect:
  26
  27   (set-object-property! COMMAND-markup  scm0-markup1)
  28
  29 (insert in the list below).
  30
  31 3. The command is now available in markup mode, e.g.
  32
  33
  34   \markup { .... \COMMAND #1 argument ... }
  35
  36
  37 BUGS:
  38
  39 At present, markup functions must be defined in this
  40 file. Implementing user-access for markup functions is an excercise
  41 for the reader.
  42
  43
  44
  45
  46 " ; "
  47
  48 (define-public (simple-markup grob props . rest)
  49   (Text_item::text_to_molecule grob props (car rest))
  50   )
  51
  52
  53 (define-public (stack-molecule-line space molecules)
  54   (if (pair? molecules)
  55       (if (pair? (cdr molecules))
  56           (let* (
  57                  (tail (stack-molecule-line  space (cdr molecules)))
  58                  (head (car molecules))
  59                  (xoff (+ space (cdr (ly:molecule-get-extent head X))))
  60                  )
  61
  62             (ly:molecule-add
  63              head
  64              (ly:molecule-translate-axis tail xoff X))
  65           )
  66           (car molecules))
  67       '())
  68   )
  69
  70 (define-public (line-markup grob props . rest)
  71   (stack-molecule-line
  72    (cdr (chain-assoc 'word-space props))
  73    (map (lambda (x) (interpret-markup grob props x)) (car rest)))
  74   )
  75
  76
  77 (define-public (combine-markup grob props . rest)
  78   (ly:molecule-add
  79    (interpret-markup grob props (car rest))
  80    (interpret-markup grob props (cadr rest))))
  81
  82 (define (font-markup qualifier value)
  83   (lambda (grob props . rest)
  84     (interpret-markup grob (cons (cons `(,qualifier . ,value) (car props)) (cdr props)) (car rest))
  85
  86   ))
  87
  88
  89 (define-public (set-property-markup qualifier)
  90   (lambda (grob props . rest  )
  91     (interpret-markup grob
  92                       (cons (cons `(,qualifier . ,(car rest))
  93                                   (car props)) (cdr props))
  94                       (cadr rest))
  95     ))
  96
  97
  98 (define-public (finger-markup grob props . rest)
  99   (interpret-markup grob
 100                     (cons (list '(font-relative-size . -3)
 101                                 '(font-family . number))
 102                                 props)
 103                     (car rest)))
 104
 105
 106 (define-public fontsize-markup (set-property-markup 'font-relative-size))
 107 (define-public magnify-markup (set-property-markup 'font-magnification))
 108
 109 (define-public bold-markup
 110   (font-markup 'font-series 'bold))
 111 (define-public number-markup
 112   (font-markup 'font-family 'number))
 113 (define-public roman-markup
 114   (font-markup 'font-family 'roman))
 115
 116
 117 (define-public huge-markup
 118   (font-markup 'font-relative-size 2))
 119 (define-public large-markup
 120   (font-markup 'font-relative-size 1))
 121 (define-public small-markup
 122   (font-markup 'font-relative-size -1))
 123 (define-public tiny-markup
 124   (font-markup 'font-relative-size -2))
 125 (define-public teeny-markup
 126   (font-markup 'font-relative-size -3))
 127 (define-public dynamic-markup
 128   (font-markup 'font-family 'dynamic))
 129 (define-public italic-markup
 130   (font-markup 'font-shape 'italic))
 131
 132
 133 ;; TODO: baseline-skip should come from the font.
 134 (define-public (column-markup grob props . rest)
 135   (stack-lines
 136    -1 0.0 (cdr (chain-assoc 'baseline-skip props))
 137    (map (lambda (x) (interpret-markup grob props x)) (car rest)))
 138   )
 139
 140 (define-public (dir-column-markup grob props . rest)
 141   "Make a column of args, going up or down, depending on DIRECTION."
 142   (let*
 143       (
 144        (dir (cdr (chain-assoc 'direction props)))
 145        )
 146     (stack-lines
 147      (if (number? dir) dir -1)
 148      0.0 (cdr (chain-assoc 'baseline-skip props))
 149      (map (lambda (x) (interpret-markup grob props x)) (car rest)))
 150     ))
 151
 152 (define-public (center-markup grob props . rest)
 153   (let*
 154     (
 155      (mols (map (lambda (x) (interpret-markup grob props x)) (car rest)))
 156      (cmols (map (lambda (x) (ly:molecule-align-to! x X CENTER)) mols))
 157      )
 158
 159     (stack-lines
 160      -1 0.0 (cdr (chain-assoc 'baseline-skip props))
 161      mols)
 162     ))
 163
 164 (define-public (musicglyph-markup grob props . rest)
 165   (ly:find-glyph-by-name
 166    (ly:get-font grob (cons '((font-family . music)) props))
 167    (car rest))
 168   )
 169
 170
 171 (define-public (lookup-markup grob props . rest)
 172   "Lookup a glyph by name."
 173   (ly:find-glyph-by-name
 174    (ly:get-font grob props)
 175    (car rest))
 176   )
 177
 178 (define-public (char-markup grob props . rest)
 179   "Syntax: \\char NUMBER. "
 180   (ly:get-glyph  (ly:get-font grob props) (car rest))
 181   )
 182
 183 (define-public (raise-markup grob props  . rest)
 184   "Syntax: \\raise AMOUNT MARKUP. "
 185   (ly:molecule-translate-axis (interpret-markup
 186                                grob
 187                                props
 188                                (cadr rest))
 189                               (car rest) Y)
 190   )
 191
 192
 193 (define-public (note-markup grob props . rest)
 194   "Syntax: \\note #LOG #DOTS #DIR. "
 195   (let*
 196       (
 197        (log (car rest))
 198        (dot-count (cadr rest))
 199        (dir (caddr rest))
 200        (font (ly:get-font grob (cons '((font-family .  music)) props)))
 201        (stemlen (max 3 (- log 1)))
 202        (headgl
 203         (ly:find-glyph-by-name font (string-append "noteheads-" (number->string (min log 2)))))
 204
 205        (stemth 0.13)
 206        (stemy (* dir stemlen))
 207        (attachx (if (> dir 0) (- (cdr (ly:molecule-get-extent headgl X)) stemth)
 208                     0))
 209        (attachy (* dir 0.28))
 210        (stemgl (if (> log 0)
 211                    (ly:round-filled-box (cons
 212                                      (cons attachx (+ attachx  stemth))
 213                                      (cons (min stemy attachy)
 214                                            (max stemy attachy)))
 215                                     (/ stemth 3)
 216                                     ) #f))
 217        (dot (ly:find-glyph-by-name font "dots-dot"))
 218        (dotwid  (interval-length (ly:molecule-get-extent dot X)))
 219        (dots (if (> dot-count 0)
 220                  (apply ly:molecule-add
 221                   (map (lambda (x)
 222                          (ly:molecule-translate-axis
 223                           dot  (* (+ 1 (* 2 x)) dotwid) X) )
 224                        (iota dot-count 1)))
 225                  #f))
 226
 227        (flaggl (if (> log 2)
 228                    (ly:molecule-translate
 229                     (ly:find-glyph-by-name
 230                      font
 231                      (string-append "flags-"
 232                                     (if (> dir 0) "u" "d")
 233                                     (number->string log)
 234                                     ))
 235                     (cons (+ attachx (/ stemth 2)) stemy))
 236
 237                     #f)))
 238
 239     (if flaggl
 240         (set! stemgl (ly:molecule-add flaggl stemgl)))
 241
 242     (if (ly:molecule? stemgl)
 243         (set! stemgl (ly:molecule-add stemgl headgl))
 244         (set! stemgl headgl)
 245         )
 246
 247     (if (ly:molecule? dots)
 248         (set! stemgl
 249               (ly:molecule-add
 250                (ly:molecule-translate-axis
 251                 dots
 252                 (+
 253                  (if (and (> dir 0) (> log 2))
 254                      (* 1.5 dotwid) 0)
 255                  ;; huh ? why not necessary?
 256                 ;(cdr (ly:molecule-get-extent headgl X))
 257                       dotwid
 258                  )
 259                 X)
 260                stemgl
 261                )
 262               ))
 263
 264     stemgl
 265     ))
 266
 267 (define-public (normal-size-super-markup grob props . rest)
 268   (ly:molecule-translate-axis (interpret-markup
 269                                grob
 270                                props (car rest))
 271                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 272                               Y)
 273   )
 274
 275 (define-public (super-markup grob props  . rest)
 276   "Syntax: \\super MARKUP. "
 277   (ly:molecule-translate-axis (interpret-markup
 278                                grob
 279                                (cons '((font-relative-size . -2)) props) (car rest))
 280                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 281                               Y)
 282   )
 283
 284 (define-public (translate-markup grob props . rest)
 285   "Syntax: \\translate OFFSET MARKUP. "
 286   (ly:molecule-translate (interpret-markup  grob props (cadr rest))
 287                          (car rest))
 288
 289   )
 290
 291 (define-public (sub-markup grob props  . rest)
 292   "Syntax: \\sub MARKUP."
 293   (ly:molecule-translate-axis (interpret-markup
 294                                grob
 295                                (cons '((font-relative-size . -2)) props)
 296                                (car rest))
 297                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 298                               Y)
 299   )
 300
 301 (define-public (normal-size-sub-markup grob props . rest)
 302   (ly:molecule-translate-axis (interpret-markup
 303                                grob
 304                                props (car rest))
 305                               (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 306                               Y)
 307   )
 308
 309 (define-public (hbracket-markup grob props . rest)
 310   (let*
 311       (
 312        (th 0.1) ;; todo: take from GROB.
 313        (m (interpret-markup grob props (car rest)))
 314        )
 315
 316     (bracketify-molecule m X th (* 2.5 th) th)
 317 ))
 318
 319 (define-public (bracket-markup grob props . rest)
 320   (let*
 321       (
 322        (th 0.1) ;; todo: take from GROB.
 323        (m (interpret-markup grob props (car rest)))
 324        )
 325
 326     (bracketify-molecule m Y th (* 2.5 th) th)
 327 ))
 328
 329
 330 ;; todo: fix negative space
 331 (define (hspace-markup grob props . rest)
 332   "Syntax: \\hspace NUMBER."
 333   (let*
 334       ((amount (car rest)))
 335     (if (> amount 0)
 336         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 337         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 338   ))
 339
 340 (define-public (override-markup grob props . rest)
 341   "Tack the 1st arg in REST onto PROPS, e.g.
 342
 343 \override #'(font-family . married) \"bla\"
 344
 345 "
 346
 347   (interpret-markup grob (cons (list (car rest)) props)
 348                     (cadr rest)))
 349
 350 (define-public (smaller-markup  grob props . rest)
 351   "Syntax: \\smaller MARKUP"
 352   (let*
 353       (
 354        (fs (cdr (chain-assoc 'font-relative-size props)))
 355        (entry (cons 'font-relative-size (- fs 1)))
 356        )
 357     (interpret-markup
 358      grob (cons (list entry) props)
 359      (car rest))
 360     ))
 361
 362 (define-public (bigger-markup  grob props . rest)
 363   "Syntax: \\bigger MARKUP"
 364   (let*
 365       (
 366        (fs (cdr (chain-assoc 'font-relative-size props)))
 367        (entry (cons 'font-relative-size (+ fs 1)))
 368        )
 369   (interpret-markup
 370    grob (cons (list entry) props)
 371    (car rest))
 372   ))
 373
 374 (define-public (box-markup grob props . rest)
 375   "Syntax: \\box MARKUP"
 376   (let*
 377       (
 378        (th 0.1)
 379        (pad 0.2)
 380        (m (interpret-markup grob props (car rest)))
 381        )
 382     (box-molecule m th pad)
 383   ))
 384
 385 (define (markup-signature-to-keyword sig)
 386   " (A B C) -> a0-b1-c2 "
 387
 388   (let* ((count  0))
 389     (string->symbol (string-join
 390
 391      (map
 392      (lambda (func)
 393        (set! count (+ count 1))
 394        (string-append
 395
 396         ;; for reasons I don't get,
 397         ;; (case func ((markup?) .. )
 398         ;; doesn't work.
 399         (cond
 400           ((eq? func markup?) "markup")
 401           ((eq? func markup-list?) "markup-list")
 402           (else "scheme")
 403           )
 404         (number->string (- count 1))
 405         ))
 406
 407      sig)
 408      "-"))
 409
 410   ))
 411
 412
 413 (define (markup-function? x)
 414   (object-property x 'markup-signature)
 415   )
 416
 417 (define (markup-list? arg)
 418   (define (markup-list-inner? l)
 419     (if (null? l)
 420         #t
 421         (and (markup? (car l)) (markup-list-inner? (cdr l)))
 422     )
 423   )
 424   (and (list? arg) (markup-list-inner? arg)))
 425
 426 (define (markup-argument-list? signature arguments)
 427   "Typecheck argument list."
 428   (if (and (pair? signature) (pair? arguments))
 429       (and ((car signature) (car arguments))
 430            (markup-argument-list? (cdr signature) (cdr arguments)))
 431       (and (null? signature) (null? arguments)))
 432   )
 433
 434
 435 (define (markup-argument-list-error signature arguments number)
 436   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 437 #f is no error found.
 438 "
 439   (if (and (pair? signature) (pair? arguments))
 440       (if (not ((car signature) (car arguments)))
 441           (list number (type-name (car signature)) (car arguments))
 442           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 443       #f
 444   ))
 445
 446 ;;
 447 ;; full recursive typecheck.
 448 ;;
 449 (define (markup-typecheck? arg)
 450   (or (string? arg)
 451       (and (pair? arg)
 452        (markup-function? (car arg))
 453        (markup-argument-list?
 454         (object-property (car arg) 'markup-signature)
 455         (cdr arg))
 456   ))
 457 )
 458
 459 ;;
 460 ;; typecheck, and throw an error when something amiss.
 461 ;;
 462 (define (markup-thrower-typecheck arg)
 463   (cond
 464    ((string? arg) #t)
 465    ((not (pair? arg))
 466     (throw 'markup-format "Not a pair" arg)
 467     )
 468    ((not (markup-function? (car arg)))
 469     (throw 'markup-format "Not a markup function " (car arg)))
 470
 471
 472    ((not (markup-argument-list?
 473           (object-property (car arg) 'markup-signature)
 474           (cdr arg)))
 475     (throw 'markup-format "Arguments failed  typecheck for " arg)))
 476    #t
 477   )
 478
 479 ;;
 480 ;; good enough if you only  use make-XXX-markup functions.
 481 ;;
 482 (define (cheap-markup? x)
 483   (or (string? x)
 484       (and (pair? x)
 485            (markup-function? (car x))))
 486 )
 487
 488 ;;
 489 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 490 ;;
 491 (define markup?  cheap-markup?)
 492
 493 (define markup-functions-and-signatures
 494   (list
 495
 496    ;; abs size
 497    (cons teeny-markup (list markup?))
 498    (cons tiny-markup (list markup?))
 499    (cons small-markup (list markup?))
 500    (cons dynamic-markup (list markup?))
 501    (cons large-markup (list markup?))
 502
 503    (cons huge-markup (list markup?))
 504
 505    ;; size
 506    (cons smaller-markup (list markup?))
 507    (cons bigger-markup (list markup?))
 508
 509    ;;
 510    (cons sub-markup (list markup?))
 511    (cons normal-size-sub-markup (list markup?))
 512
 513    (cons super-markup (list markup?))
 514    (cons normal-size-super-markup (list markup?))
 515
 516    (cons finger-markup (list markup?))
 517    (cons bold-markup (list markup?))
 518    (cons italic-markup (list markup?))
 519    (cons roman-markup (list markup?))
 520    (cons number-markup (list markup?))
 521    (cons hbracket-markup  (list markup?))
 522    (cons bracket-markup  (list markup?))
 523    (cons note-markup (list integer? integer? ly:dir?))
 524
 525    (cons column-markup (list markup-list?))
 526    (cons dir-column-markup (list markup-list?))
 527    (cons center-markup (list markup-list?))
 528    (cons line-markup  (list markup-list?))
 529
 530    (cons combine-markup (list markup? markup?))
 531    (cons simple-markup (list string?))
 532    (cons musicglyph-markup (list scheme?))
 533    (cons translate-markup (list number-pair? markup?))
 534    (cons override-markup (list pair? markup?))
 535    (cons char-markup (list integer?))
 536    (cons lookup-markup (list string?))
 537
 538    (cons hspace-markup (list number?))
 539
 540    (cons raise-markup (list number? markup?))
 541    (cons magnify-markup (list number? markup?))
 542    (cons fontsize-markup (list number? markup?))
 543
 544    (cons box-markup  (list markup?))
 545    )
 546   )
 547
 548
 549 (define markup-module (current-module))
 550
 551 (map (lambda (x)
 552        (set-object-property! (car x) 'markup-signature (cdr x))
 553        (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x)))
 554        )
 555      markup-functions-and-signatures)
 556
 557 (define-public markup-function-list (map car markup-functions-and-signatures))
 558
 559
 560 ;; construct a
 561 ;;
 562 ;; make-FOO-markup function that typechecks its arguments.
 563 ;;
 564 ;; TODO: should construct a message says
 565 ;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args)
 566 ;;
 567 ;; right now, you get the entire argument list.
 568
 569
 570 (define (make-markup-maker  entry)
 571   (let*
 572         ((foo-markup (car entry))
 573          (signature (cons 'list (cdr entry)))
 574          (name (symbol->string (procedure-name foo-markup)))
 575          (make-name  (string-append "make-" name))
 576          )
 577
 578       `(define (,(string->symbol make-name) . args)
 579          (let*
 580              (
 581               (arglen (length  args))
 582               (siglen (length ,signature))
 583               (error-msg
 584                (if (and (> 0 siglen) (> 0 arglen))
 585                    (markup-argument-list-error ,signature args 1)))
 586
 587               )
 588
 589          (if (or (not (= arglen siglen)) (< siglen 0) (< 0 arglen))
 590              (scm-error 'markup-format ,make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 591                         (list (length ,signature)
 592                               ,make-name
 593                               (length args)
 594                               args) #f))
 595          (if error-msg
 596              (scm-error 'markup-format ,make-name "Invalid argument in position ~A\n Expect: ~A\nFound: ~S." error-msg #f)
 597
 598              (cons ,foo-markup args)
 599              )))
 600     )
 601 )
 602
 603
 604
 605 (define (make-markup markup-function make-name signature args)
 606
 607   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
 608 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 609 "
 610
 611   (let*
 612       (
 613        (arglen (length args))
 614        (siglen (length signature))
 615        (error-msg
 616         (if (and (> siglen 0) (> arglen 0))
 617             (markup-argument-list-error signature args 1)))
 618        )
 619
 620
 621     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
 622         (scm-error 'markup-format make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 623                    (list siglen
 624                          make-name
 625                          arglen
 626                          args) #f))
 627
 628     (if error-msg
 629         (scm-error 'markup-format make-name "Invalid argument in position ~A\nExpect: ~A\nFound: ~S." error-msg #f)
 630
 631         (cons markup-function  args)
 632         )))
 633
 634 (define (make-markup-maker entry)
 635   (let* (
 636          (name (symbol->string (procedure-name (car entry))))
 637          (make-name  (string-append "make-" name))
 638          (signature (object-property (car entry) 'markup-signature))
 639          )
 640
 641     `(define-public (,(string->symbol make-name) . args)
 642        (make-markup ,(car entry) ,make-name ,(cons 'list signature)  args)
 643        ))
 644   )
 645
 646 (eval
 647  (cons 'begin (map make-markup-maker markup-functions-and-signatures))
 648  markup-module
 649  )
 650
 651 (define-public (lookup-markup-command code)
 652   (let*
 653       ( (sym (string->symbol (string-append code "-markup")))
 654         (var (module-local-variable markup-module sym))
 655         )
 656     (if (eq? var #f)
 657         #f
 658         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-keyword))
 659     )
 660   ))
 661
 662
 663 (define-public (brew-new-markup-molecule grob)
 664   (let*
 665       ((t (ly:get-grob-property grob 'text))
 666        (chain (Font_interface::get_property_alist_chain grob)))
 667     (if (markup? t)
 668         (interpret-markup grob  chain t)
 669         (Text_item::text_to_molecule grob t chain)
 670         )))
 671
 672 (define-public empty-markup (make-simple-markup ""))
 673
 674 (define (interpret-markup  grob props markup)
 675   (if (string? markup)
 676       (simple-markup grob props markup)
 677       (let*
 678           (
 679            (func (car markup))
 680            (args (cdr markup))
 681            )
 682
 683         (apply func (cons grob (cons props args)) )
 684         )))
 685
 686
 687 ;;;;;;;;;;;;;;;;
 688 ;; utility
 689
 690 (define (markup-join markups sep)
 691   "Return line-markup of MARKUPS, joining them with markup SEP"
 692   (if (pair? markups)
 693       (make-line-markup (list-insert-separator markups sep))
 694       empty-markup))
 695
 696
 697 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 698
 699 (if #f
 700    (define (typecheck-with-error x)
 701      (catch
 702       'markup-format
 703       (lambda () (markup? x))
 704       (lambda (key message arg)
 705         (display "\nERROR: markup format error: \n")
 706         (display message)
 707         (newline)
 708         (write arg (current-output-port))
 709         )
 710       )))
 711
 712 ;; test make-foo-markup functions
 713 (if #f
 714     (begin
 715       (newline)
 716       (newline)
 717       (display (make-line-markup (list (make-simple-markup "FOO"))))
 718
 719       (make-line-markup (make-simple-markup "FOO"))
 720       (make-line-markup (make-simple-markup "FOO") (make-simple-markup "foo"))
 721       (make-raise-markup "foo" (make-simple-markup "foo"))
 722       )
 723     )
 724
 725
 726 ;;
 727 ;; test typecheckers. Not wholly useful, because errors are detected
 728 ;; in other places than they're made.
 729 ;;
 730 (if #f
 731  (begin
 732
 733    ;; To get error messages, see above to install the alternate
 734    ;; typecheck routine for markup?.
 735
 736
 737
 738    (display (typecheck-with-error `(,simple-markup "foobar")))
 739    (display (typecheck-with-error `(,simple-markup "foobar")))
 740    (display (typecheck-with-error `(,simple-markup 1)))
 741    (display
 742     (typecheck-with-error  `(,line-markup ((,simple-markup "foobar"))
 743                                           (,simple-markup 1))))
 744    (display
 745     (typecheck-with-error  `(,line-markup (,simple-markup "foobar")
 746                                          (,simple-markup "bla"))))
 747
 748    ))