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