scm/ascii-script.scm

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