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