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-superscript-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 ;; todo: fix negative space
 201 (define (hspace-markup grob props . rest)
 202   "Syntax: \\hspace NUMBER."
 203   (let*
 204       ((amount (car rest)))
 205     (if (> amount 0)
 206         (ly:make-molecule "" (cons 0 amount) '(-1 . 1) )
 207         (ly:make-molecule "" (cons amount amount) '(-1 . 1)))
 208   ))
 209
 210 (define-public (override-markup grob props . rest)
 211   "Tack the 1st arg in REST onto PROPS, e.g.
 212
 213 \override #'(font-family . married) \"bla\"
 214
 215 "
 216
 217   (interpret-markup grob (cons (list (car rest)) props)
 218                     (cadr rest)))
 219
 220 (define-public (smaller-markup  grob props . rest)
 221   "Syntax: \\smaller MARKUP"
 222   (let*
 223       (
 224        (fs (cdr (chain-assoc 'font-relative-size props)))
 225        (entry (cons 'font-relative-size (- fs 1)))
 226        )
 227   (interpret-markup
 228    grob (cons (list entry) props)
 229    (car rest))
 230
 231   ))
 232
 233 (define-public (bigger-markup  grob props . rest)
 234   "Syntax: \\bigger MARKUP"
 235   (let*
 236       (
 237        (fs (cdr (chain-assoc 'font-relative-size props)))
 238        (entry (cons 'font-relative-size (+ fs 1)))
 239        )
 240   (interpret-markup
 241    grob (cons (list entry) props)
 242    (car rest))
 243   ))
 244
 245 (define (markup-signature-to-keyword sig)
 246   " (A B C) -> a0-b1-c2 "
 247
 248   (let* ((count  0))
 249     (string->symbol (string-join
 250
 251      (map
 252      (lambda (func)
 253        (set! count (+ count 1))
 254        (string-append
 255
 256         ;; for reasons I don't get,
 257         ;; (case func ((markup?) .. )
 258         ;; doesn't work.
 259         (cond
 260           ((eq? func markup?) "markup")
 261           ((eq? func markup-list?) "markup-list")
 262           (else "scheme")
 263           )
 264         (number->string (- count 1))
 265         ))
 266
 267      sig)
 268      "-"))
 269
 270   ))
 271
 272
 273 (define (markup-function? x)
 274   (object-property x 'markup-signature)
 275   )
 276
 277 (define (markup-list? arg)
 278   (define (markup-list-inner? l)
 279     (if (null? l)
 280         #t
 281         (and (markup? (car l)) (markup-list-inner? (cdr l)))
 282     )
 283   )
 284   (and (list? arg) (markup-list-inner? arg)))
 285
 286 (define (markup-argument-list? signature arguments)
 287   "Typecheck argument list."
 288   (if (and (pair? signature) (pair? arguments))
 289       (and ((car signature) (car arguments))
 290            (markup-argument-list? (cdr signature) (cdr arguments)))
 291       (and (null? signature) (null? arguments)))
 292   )
 293
 294
 295 (define (markup-argument-list-error signature arguments number)
 296   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 297 #f is no error found.
 298 "
 299   (if (and (pair? signature) (pair? arguments))
 300       (if (not ((car signature) (car arguments)))
 301           (list number (type-name (car signature)) (car arguments))
 302           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 303       #f
 304   ))
 305
 306 ;;
 307 ;; full recursive typecheck.
 308 ;;
 309 (define (markup-typecheck? arg)
 310   (and (pair? arg)
 311        (markup-function? (car arg))
 312        (markup-argument-list?
 313         (object-property (car arg) 'markup-signature)
 314         (cdr arg))
 315   ))
 316
 317 ;;
 318 ;; typecheck, and throw an error when something amiss.
 319 ;;
 320 (define (markup-thrower-typecheck arg)
 321   (cond
 322    ((not (pair? arg))
 323     (throw 'markup-format "Not a pair" arg)
 324     )
 325    ((not (markup-function? (car arg)))
 326     (throw 'markup-format "Not a markup function " (car arg)))
 327
 328
 329    ((not (markup-argument-list?
 330           (object-property (car arg) 'markup-signature)
 331           (cdr arg)))
 332     (throw 'markup-format "Arguments failed  typecheck for " arg)))
 333    #t
 334   )
 335
 336
 337 ;;
 338 ;; good enough if you only  use make-XXX-markup functions.
 339 ;;
 340 (define (cheap-markup? x)
 341   (and (pair? x)
 342        (markup-function? (car x)))
 343 )
 344
 345 ;;
 346 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 347 ;;
 348 (define markup?  cheap-markup?)
 349
 350
 351 (define markup-function-list
 352   (list
 353
 354    ;; abs size
 355    (cons teeny-markup (list markup?))
 356    (cons tiny-markup (list markup?))
 357    (cons small-markup (list markup?))
 358    (cons dynamic-markup (list markup?))
 359    (cons large-markup (list markup?))
 360
 361    (cons huge-markup (list markup?))
 362
 363    ;; size
 364    (cons smaller-markup (list markup?))
 365    (cons bigger-markup (list markup?))
 366
 367    ;;
 368    (cons sub-markup (list markup?))
 369    (cons super-markup (list markup?))
 370
 371    (cons bold-markup (list markup?))
 372    (cons italic-markup (list markup?))
 373
 374    (cons number-markup (list markup?))
 375
 376    (cons column-markup (list markup-list?))
 377    (cons line-markup  (list markup-list?))
 378
 379    (cons combine-markup (list markup? markup?))
 380    (cons simple-markup (list string?))
 381    (cons musicglyph-markup (list scheme?))
 382
 383    (cons translate-markup (list number-pair? markup?))
 384    (cons override-markup (list pair? markup?))
 385    (cons char-markup (list integer?))
 386    (cons lookup-markup (list string?))
 387
 388    (cons hspace-markup (list number?))
 389
 390    (cons raise-markup (list number? markup?))
 391    (cons magnify-markup (list number? markup?))
 392    (cons fontsize-markup (list number? markup?))
 393    )
 394   )
 395
 396
 397 (define markup-module (current-module))
 398
 399 (map (lambda (x)
 400        (set-object-property! (car x) 'markup-signature (cdr x))
 401        (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x)))
 402        )
 403      markup-function-list)
 404
 405
 406 ;; construct a
 407 ;;
 408 ;; make-FOO-markup function that typechecks its arguments.
 409 ;;
 410 ;; TODO: should construct a message says
 411 ;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args)
 412 ;;
 413 ;; right now, you get the entire argument list.
 414
 415
 416 (define (make-markup-maker  entry)
 417   (let*
 418         ((foo-markup (car entry))
 419          (signature (cons 'list (cdr entry)))
 420          (name (symbol->string (procedure-name foo-markup)))
 421          (make-name  (string-append "make-" name))
 422          )
 423
 424       `(define (,(string->symbol make-name) . args)
 425          (let*
 426              (
 427               (arglen (length  args))
 428               (siglen (length ,signature))
 429               (error-msg
 430                (if (and (> 0 siglen) (> 0 arglen))
 431                    (markup-argument-list-error ,signature args 1)))
 432
 433               )
 434
 435          (if (or (not (= arglen siglen)) (< siglen 0) (< 0 arglen))
 436              (scm-error 'markup-format ,make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 437                         (list (length ,signature)
 438                               ,make-name
 439                               (length args)
 440                               args) #f))
 441          (if error-msg
 442              (scm-error 'markup-format ,make-name "Invalid argument in position ~A\n Expect: ~A\nFound: ~S." error-msg #f)
 443
 444              (cons ,foo-markup args)
 445              )))
 446     )
 447 )
 448
 449
 450
 451 (define (make-markup markup-function make-name signature args)
 452
 453   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
 454 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 455 "
 456
 457   (let*
 458       (
 459        (arglen (length args))
 460        (siglen (length signature))
 461        (error-msg
 462         (if (and (> siglen 0) (> arglen 0))
 463             (markup-argument-list-error signature args 1)))
 464        )
 465
 466
 467     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
 468         (scm-error 'markup-format make-name "Expect ~A arguments for ~A. Found ~A: ~S"
 469                    (list siglen
 470                          make-name
 471                          arglen
 472                          args) #f))
 473
 474     (if error-msg
 475         (scm-error 'markup-format make-name "Invalid argument in position ~A\nExpect: ~A\nFound: ~S." error-msg #f)
 476
 477         (cons markup-function  args)
 478         )))
 479
 480 (define (make-markup-maker entry)
 481   (let* (
 482          (name (symbol->string (procedure-name (car entry))))
 483          (make-name  (string-append "make-" name))
 484          (signature (object-property (car entry) 'markup-signature))
 485          )
 486
 487     `(define (,(string->symbol make-name) . args)
 488        (make-markup ,(car entry) ,make-name ,(cons 'list signature)  args)
 489        ))
 490   )
 491
 492 (eval
 493  (cons 'begin (map make-markup-maker markup-function-list))
 494  markup-module
 495  )
 496
 497 (define-public (lookup-markup-command code)
 498   (let*
 499       ( (sym (string->symbol (string-append code "-markup")))
 500         (var (module-local-variable markup-module sym))
 501         )
 502     (if (eq? var #f)
 503         #f
 504         (cons (variable-ref var) (object-property  (variable-ref var) 'markup-keyword))
 505     )
 506   ))
 507
 508
 509 (define-public (brew-new-markup-molecule grob)
 510   (interpret-markup grob
 511                     (Font_interface::get_property_alist_chain grob)
 512                     (ly:get-grob-property grob 'text)
 513                     )
 514   )
 515
 516 (define-public empty-markup `(,simple-markup ""))
 517
 518 (define (interpret-markup  grob props markup)
 519   (let*
 520       (
 521        (func (car markup))
 522        (args (cdr markup))
 523        )
 524
 525     (apply func (cons grob (cons props args)) )
 526     ))
 527
 528
 529 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 530
 531 (if #f
 532    (define (typecheck-with-error x)
 533      (catch
 534       'markup-format
 535       (lambda () (markup? x))
 536       (lambda (key message arg)
 537         (display "\nERROR: markup format error: \n")
 538         (display message)
 539         (newline)
 540         (write arg (current-output-port))
 541         )
 542       )))
 543
 544 ;; test make-foo-markup functions
 545 (if #f
 546     (begin
 547       (newline)
 548       (newline)
 549       (display (make-line-markup (list (make-simple-markup "FOO"))))
 550
 551       (make-line-markup (make-simple-markup "FOO"))
 552       (make-line-markup (make-simple-markup "FOO") (make-simple-markup "foo"))
 553       (make-raise-markup "foo" (make-simple-markup "foo"))
 554       )
 555     )
 556
 557
 558 ;;
 559 ;; test typecheckers. Not wholly useful, because errors are detected
 560 ;; in other places than they're made.
 561 ;;
 562 (if #f
 563  (begin
 564
 565    ;; To get error messages, see above to install the alternate
 566    ;; typecheck routine for markup?.
 567
 568
 569
 570    (display (typecheck-with-error `(,simple-markup "foobar")))
 571    (display (typecheck-with-error `(,simple-markup "foobar")))
 572    (display (typecheck-with-error `(,simple-markup 1)))
 573    (display
 574     (typecheck-with-error  `(,line-markup ((,simple-markup "foobar"))
 575                                           (,simple-markup 1))))
 576    (display
 577     (typecheck-with-error  `(,line-markup (,simple-markup "foobar")
 578                                          (,simple-markup "bla"))))
 579
 580    ))