scm/output-ascii-script.scm

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