scm/ascii-script.scm

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