scm/ascii-script.scm

   1 (debug-enable 'backtrace)
   2
   3 ; (define cmr-alist
   4 ;   '(("bold" . "as-dummy")
   5 ;     ("brace" . "as-braces")
   6 ;     ("dynamic" . "as-dummy")
   7 ;     ("default" . "as-dummy")
   8 ;     ("feta" . "feta")
   9 ;     ("feta-1" . "feta")
  10 ;     ("feta-2" . "feta")
  11 ;     ("finger" . "as-number")
  12 ;     ("typewriter" . "as-dummy")
  13 ;     ("italic" . "as-dummy")
  14 ;     ("roman" . "as-dummy")
  15 ;     ("script" . "as-dummy")
  16 ;     ("large" . "as-dummy")
  17 ;     ("Large" . "as-dummy")
  18 ;     ("mark" . "as-number")
  19 ;     ("number" . "as-number")
  20 ;     ("timesig" . "as-number")
  21 ;     ("volta" . "as-number"))
  22 ; )
  23
  24
  25 (define as-font-alist-alist
  26   '(
  27     (as5 .
  28          (
  29           (feta16 . as5)
  30           (feta20 . as5)
  31           (feta-nummer6 . as-number1)
  32           (feta-nummer8 . as-number1)
  33           (feta-braces16 . as-braces9)
  34           (cmr7 . as-dummy)
  35           (cmr8 . as-dummy)
  36           (cmr10 . as-dummy)
  37           ))
  38     (as9 .
  39          (
  40           (feta16 . as9)
  41           (feta20 . as9)
  42           (feta-nummer4 . as-number1)
  43           (feta-nummer8 . as-number4)
  44           (feta-braces16 . as-braces9)
  45           (cmr7 . as-dummy)
  46           (cmr8 . as-dummy)
  47           (cmr10 . as-dummy)
  48           (cmr12 . as-dummy)
  49          ))
  50   ))
  51
  52 (define (as-properties-to-font-name size fonts properties-alist-list)
  53   (let* ((feta-name (properties-to-font-name fonts properties-alist-list))
  54          (as-font-alist (cdr (assoc size as-font-alist-alist)))
  55          (font (assoc (string->symbol feta-name) as-font-alist)))
  56     (if font (symbol->string (cdr font))
  57         (let ((e (current-error-port)))
  58           (newline e)
  59           (display "can't find font: " e)
  60           (write feta-name e)
  61           ;;(symbol->string size)
  62           "as-dummy"
  63           ))))
  64
  65 ;; FIXME: making a full style-sheet is a pain, so we parasite on
  66 ;; paper16 and translate the result.
  67 ;;
  68 (define (as-make-style-sheet size)
  69   (let ((sheet (make-style-sheet 'paper16)))
  70     (assoc-set! sheet 'properties-to-font
  71                 (lambda (x y) (as-properties-to-font-name size x y)))
  72     sheet))
  73
  74 ;;;; AsciiScript as  -- ascii art output
  75 (define (as-scm action-name)
  76
  77   (define (beam width slope thick)
  78           (string-append
  79            (func "set-line-char" "#")
  80            (func "rline-to" width (* width slope))
  81            ))
  82
  83   ; simple flat slurs
  84   (define (bezier-sandwich l thick)
  85           (let (
  86                 (c0 (cadddr l))
  87                 (c1 (cadr l))
  88                 (c3 (caddr l)))
  89                (let* ((x (car c0))
  90                       (dx (- (car c3) x))
  91                       (dy (- (cdr c3) (cdr c0)))
  92                       (rc (/ dy dx))
  93                       (c1-dx (- (car c1) x))
  94                       (c1-line-y (+ (cdr c0) (* c1-dx rc)))
  95                       (dir (if (< c1-line-y (cdr c1)) 1 -1))
  96                       (y (+ -1 (* dir (max (* dir (cdr c0)) (* dir (cdr c3)))))))
  97                      (string-append
  98                       (func "rmove-to" x y)
  99                       (func "put" (if (< 0 dir) "/" "\\\\"))
 100                       (func "rmove-to" 1 (if (< 0 dir) 1 0))
 101                       (func "set-line-char" "_")
 102                       (func "h-line" (- dx 1))
 103                       (func "rmove-to" (- dx 1) (if (< 0 dir) -1 0))
 104                       (func "put" (if (< 0 dir) "\\\\" "/"))))))
 105
 106
 107   (define (bracket arch_angle arch_width arch_height height arch_thick thick)
 108     ;; width now fixed?
 109     (let ((width 1))
 110           (string-append
 111            (func "rmove-to" (+ width 1) (- (/ height -2) 1))
 112            (func "put" "\\\\")
 113            (func "set-line-char" "|")
 114            (func "rmove-to" 0 1)
 115            (func "v-line" (+ height 1))
 116            (func "rmove-to" 0 (+ height 1))
 117            (func "put" "/")
 118            )))
 119
 120   (define (char i)
 121     (func "char" i))
 122
 123   (define (define-origin a b c ) "")
 124
 125   (define (end-output)
 126     (func "end-output"))
 127
 128   (define (experimental-on)
 129           "")
 130
 131   (define (filledbox breapth width depth height)
 132           (let ((dx (+ width breapth))
 133                 (dy (+ depth height)))
 134                (string-append
 135                 (func "rmove-to" (* -1 breapth) (* -1 depth))
 136                 (if (< dx dy)
 137                     (string-append
 138                      (func "set-line-char"
 139                            (if (<= dx 1) "|" "#"))
 140                      (func "v-line" dy))
 141                     (string-append
 142                      (func "set-line-char"
 143                            (if (<= dy 1) "-" "="))
 144                     (func "h-line" dx))))))
 145
 146   (define (font-load-command name-mag command)
 147    ;; (display "name-mag: ")
 148    ;; (write name-mag)
 149    ;; (display "command: ")
 150    ;; (write command)
 151     (func "load-font" (car name-mag) (cdr name-mag)))
 152
 153   (define (header creator generate)
 154     (func "header" creator generate))
 155
 156   (define (header-end)
 157     (func "header-end"))
 158
 159   ;; urg: this is good for half of as2text's execution time
 160   (define (xlily-def key val)
 161           (string-append "(define " key " " (arg->string val) ")\n"))
 162
 163   (define (lily-def key val)
 164     (if
 165      ;; let's not have all bloody definitions
 166      (or (equal? key "lilypondpaperlinewidth")
 167          (equal? key "lilypondpaperstaffheight")
 168          (equal? key "lilypondpaperoutputscale"))
 169      (string-append "(define " key " " (arg->string val) ")\n")
 170      ""))
 171
 172   (define (no-origin) "")
 173
 174   (define (placebox x y s)
 175     (let ((ey (inexact->exact y)))
 176           (string-append "(move-to " (number->string (inexact->exact x)) " "
 177                          (if (= 0.5 (- (abs y) (abs ey)))
 178                              (number->string y)
 179                              (number->string ey))
 180                          ")\n" s)))
 181
 182   (define (select-font name-mag-pair)
 183     (let* ((c (assoc name-mag-pair font-name-alist)))
 184       (if (eq? c #f)
 185           (begin
 186             (ly-warn
 187              (string-append
 188               "Programming error: No such font known "
 189               (car name-mag-pair))))
 190             "")                         ; issue no command
 191           (func "select-font" (car name-mag-pair))))
 192
 193   (define (start-line height)
 194           (func "start-line" height))
 195
 196   (define (stop-line)
 197           (func "stop-line"))
 198
 199   (define (text s)
 200           (func "text" s))
 201
 202   (define (tuplet ht gap dx dy thick dir) "")
 203
 204   (define (volta h w thick vert-start vert-end)
 205           ;; urg
 206           (string-append
 207            (func "set-line-char" "|")
 208            (func "rmove-to" 0 -4)
 209            ;; definition strange-way around
 210            (if (= 0 vert-start)
 211               (func "v-line" h)
 212                "")
 213            (func "rmove-to" 1 h)
 214            (func "set-line-char" "_")
 215            (func "h-line" (- w 1))
 216            (func "set-line-char" "|")
 217            (if (= 0 vert-end)
 218                (string-append
 219                 (func "rmove-to" (- w 1) (* -1 h))
 220                 (func "v-line" (* -1 h)))
 221                "")))
 222
 223 (cond ((eq? action-name 'all-definitions)
 224          `(begin
 225             (define beam ,beam)
 226             (define bracket ,bracket)
 227             (define char ,char)
 228             (define define-origin ,define-origin)
 229             ;;(define crescendo ,crescendo)
 230             (define bezier-sandwich ,bezier-sandwich)
 231             ;;(define dashed-slur ,dashed-slur)
 232             ;;(define decrescendo ,decrescendo)
 233             (define end-output ,end-output)
 234             (define experimental-on ,experimental-on)
 235             (define filledbox ,filledbox)
 236             ;;(define font-def ,font-def)
 237             (define font-load-command ,font-load-command)
 238             ;;(define font-switch ,font-switch)
 239             (define header ,header)
 240             (define header-end ,header-end)
 241             (define lily-def ,lily-def)
 242             ;;(define invoke-char ,invoke-char)
 243             ;;(define invoke-dim1 ,invoke-dim1)
 244             (define no-origin ,no-origin)
 245             (define placebox ,placebox)
 246             (define select-font ,select-font)
 247             (define start-line ,start-line)
 248             ;;(define stem ,stem)
 249             (define stop-line ,stop-line)
 250             (define stop-last-line ,stop-line)
 251             (define text ,text)
 252             (define tuplet ,tuplet)
 253             (define volta ,volta)
 254             ))
 255         ((eq? action-name 'tuplet) tuplet)
 256         ;;((eq? action-name 'beam) beam)
 257         ;;((eq? action-name 'bezier-sandwich) bezier-sandwich)
 258         ;;((eq? action-name 'bracket) bracket)
 259         ((eq? action-name 'char) char)
 260         ;;((eq? action-name 'crescendo) crescendo)
 261         ;;((eq? action-name 'dashed-slur) dashed-slur)
 262         ;;((eq? action-name 'decrescendo) decrescendo)
 263         ;;((eq? action-name 'experimental-on) experimental-on)
 264         ((eq? action-name 'filledbox) filledbox)
 265         ((eq? action-name 'select-font) select-font)
 266         ;;((eq? action-name 'volta) volta)
 267         (else (error "unknown tag -- MUSA-SCM " action-name))
 268         )
 269   )
 270
 271 (define (scm-as-output)
 272   (primitive-eval (as-scm 'all-definitions)))