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 (dot x y radius) "") ;; TODO
  89
  90 (define (beam width slope thick)
  91   (string-append
  92    (func "set-line-char" "#")
  93    (func "rline-to" width (* width slope))
  94    ))
  95
  96                                         ; simple flat slurs
  97 (define (bezier-bow l thick)
  98   (let (
  99         (c0 (cadddr l))
 100         (c1 (cadr l))
 101         (c3 (caddr l)))
 102     (let* ((x (car c0))
 103            (dx (- (car c3) x))
 104            (dy (- (cdr c3) (cdr c0)))
 105            (rc (/ dy dx))
 106            (c1-dx (- (car c1) x))
 107            (c1-line-y (+ (cdr c0) (* c1-dx rc)))
 108            (dir (if (< c1-line-y (cdr c1)) 1 -1))
 109            (y (+ -1 (* dir (max (* dir (cdr c0)) (* dir (cdr c3)))))))
 110       (string-append
 111        (func "rmove-to" x y)
 112        (func "put" (if (< 0 dir) "/" "\\\\"))
 113        (func "rmove-to" 1 (if (< 0 dir) 1 0))
 114        (func "set-line-char" "_")
 115        (func "h-line" (- dx 1))
 116        (func "rmove-to" (- dx 1) (if (< 0 dir) -1 0))
 117        (func "put" (if (< 0 dir) "\\\\" "/"))))))
 118
 119
 120 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
 121   ;; width now fixed?
 122   (let ((width 1))
 123     (string-append
 124      (func "rmove-to" (+ width 1) (- (/ height -2) 1))
 125      (func "put" "\\\\")
 126      (func "set-line-char" "|")
 127      (func "rmove-to" 0 1)
 128      (func "v-line" (+ height 1))
 129      (func "rmove-to" 0 (+ height 1))
 130      (func "put" "/")
 131      )))
 132
 133 (define (polygon points blotdiameter) "") ;; TODO
 134
 135 (define (char i)
 136   (func "char" i))
 137
 138 (define (define-origin a b c ) "")
 139
 140 (define (end-output)
 141   (func "end-output"))
 142
 143 (define (experimental-on)
 144   "")
 145
 146 (define (filledbox breapth width depth height)
 147   (let ((dx (+ width breapth))
 148         (dy (+ depth height)))
 149     (string-append
 150      (func "rmove-to" (* -1 breapth) (* -1 depth))
 151      (if (< dx dy)
 152          (string-append
 153           (func "set-line-char"
 154                 (if (<= dx 1) "|" "#"))
 155           (func "v-line" dy))
 156          (string-append
 157           (func "set-line-char"
 158                 (if (<= dy 1) "-" "="))
 159           (func "h-line" dx))))))
 160
 161 (define (roundfilledbox breapth width depth height blot)
 162   (filledbox breapth width depth height))
 163
 164 (define (font-load-command name-mag command)
 165   ;; (display "name-mag: ")
 166   ;; (write name-mag)
 167   ;; (display "command: ")
 168   ;; (write command)
 169   (func "load-font" (car name-mag) (cdr name-mag)))
 170
 171 (define (header creator generate)
 172   (func "header" creator generate))
 173
 174 (define (header-end)
 175   (func "header-end"))
 176
 177 ;; urg: this is good for half of as2text's execution time
 178 (define (xlily-def key val)
 179   (string-append "(define " key " " (arg->string val) ")\n"))
 180
 181 (define (lily-def key val)
 182   (if
 183    ;; let's not have all bloody definitions
 184    (or (equal? key "lilypondpaperlinewidth")
 185        (equal? key "lilypondpaperstaffheight")
 186        (equal? key "lilypondpaperoutputscale"))
 187    (string-append "(define " key " " (arg->string val) ")\n")
 188    ""))
 189
 190 (define (no-origin) "")
 191
 192 (define (placebox x y s)
 193   (let ((ey (inexact->exact y)))
 194     (string-append "(move-to " (number->string (inexact->exact x)) " "
 195                    (if (= 0.5 (- (abs y) (abs ey)))
 196                        (number->string y)
 197                        (number->string ey))
 198                    ")\n" s)))
 199
 200 (define (select-font name-mag-pair)
 201   (let* ((c (assoc name-mag-pair font-name-alist)))
 202     (if (eq? c #f)
 203         (begin
 204           (ly:warn
 205            (string-append
 206             "Programming error: No such font known "
 207             (car name-mag-pair))))
 208         "")                             ; issue no command
 209     (func "select-font" (car name-mag-pair))))
 210
 211 (define (start-system width height)
 212   (func "start-system" width height))
 213
 214 (define (stop-system)
 215   (func "stop-system"))
 216
 217 (define (stop-last-system)
 218   (func "stop-system"))
 219
 220
 221 (define (text s)
 222   (func "text" s))
 223
 224 (define (tuplet ht gap dx dy thick dir) "")
 225