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