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