4 ;;;; as2text.scm -- Translate AsciiScript to Text
6 ;;;; source file of the GNU LilyPond music typesetter
8 ;;;; (c) 2000--2003 Jan Nieuwenhuizen <janneke@gnu.org>
19 (define program-name "as2text")
21 (define lily-home "/usr/share/lilypond")
22 (define cur-output-name "-")
23 (define cur-output-file '())
25 (define subst-version "@TOPLEVEL_VERSION@")
27 (define program-version
28 (if (eq? subst-version (string-append "@" "TOPLEVEL_VERSION" "@"))
32 (define (show-version port)
33 (display (string-append
34 program-name " - LilyPond version " program-version "\n")
38 (display "Convert AsciiScript to text.
40 Usage: as2text [OPTIONS]... AS-FILE
43 -h,--help show this help
44 -o,--output=FILE set output file
45 -v,--version show version
50 ;; FIXME: use (separate-fields-discarding-char) and (read-delimited "")
52 (define (gulp-file name)
53 (let ((port (if (equal? name "-")
55 (catch 'system-error (lambda () (open-file name "r"))
59 (display (string-append "[" name) (current-error-port))
60 (let ((content (let loop ((text ""))
61 (let ((line (read-line port)))
62 (if (or (eof-object? line)
65 (loop (string-append text line "\n")))))))
67 (display "]" (current-error-port))
71 (string-append "warning: no such file: " name "\n")
75 (define (with-extention name ext)
76 (if (or (equal? name "-")
77 (equal? ext (substring name (max 0 (- (string-length name)
78 (string-length ext))))))
80 (string-append name ext)))
82 (define (do-file file-name output-name)
83 (let ((ascii-script (gulp-file (with-extention file-name ".as"))))
85 (set! cur-output-name output-name)
86 (eval-string ascii-script)))
88 ;;; Script entry point
90 (set! lily-home (string-append
91 (dirname (dirname (car args)))
93 (let ((options (getopt-long args
94 `((output (single-char #\o)
96 (help (single-char #\h))
97 (version (single-char #\v))))))
98 (define (opt tag default)
99 (let ((pair (assq tag options)))
100 (if pair (cdr pair) default)))
102 (if (assq 'help options)
103 (begin (show-version (current-output-port)) (show-help) (exit 0)))
105 (if (assq 'version options)
106 (begin (show-version (current-output-port)) (exit 0)))
108 (show-version (current-error-port))
109 (let ((output-name (opt 'output "-"))
110 (files (let ((foo (opt '() '())))
114 (do-file (car files) output-name))))
117 ;;;; Ascii Script plotting
122 ;; Ascii-Art signature
123 (define tag-line "lily")
125 (define first-line #t)
134 (define canvas-width 65)
135 (define canvas-height 20)
144 (define line-char "-")
147 (define half-char-kludge #f)
149 ;; the plotting fields
152 ;; make-uniform array of characters,
153 ;; or 1-dim array of strings?
154 ;; (set! canvas (make-array " " canvas-height canvas-width))
156 ;; urg, this kind of naming costs too much indenting
157 (define (split c s r)
158 (separate-fields-discarding-char c s r))
161 (sans-surrounding-whitespace s))
166 (define (af-gulp-file name)
168 (let ((old-load-path %load-path))
171 (or (getenv "LILYPONDPREFIX") ".") "/mf")
172 (cons (string-append lily-home "/mf") %load-path)))
173 (let* ((path (%search-load-path name))
177 (set! %load-path old-load-path)
180 (define (char-width c)
181 (let ((bbox (car c)))
182 (inexact->exact (* .001 (caddr bbox)))))
184 ;; urg: use smart table
185 (define (xmerge-chars old new)
186 (cond ((equal? new " ") old)
187 ((and (equal? old "|") (equal? new "-")) "+")
188 ((and (equal? old "-") (equal? new "|")) "+")
191 (define (merge-chars old new)
192 (cond ((equal? new " ") old)
195 (define (plot-raw x y c)
196 (if (array-in-bounds? canvas y x)
197 (array-set! canvas (merge-chars (array-ref canvas y x) c) y x)
198 (display (string-append "ouch: " (number->string x) ","
199 (number->string y) "\n")
200 (current-error-port))))
202 (define (plot x neg-y c)
203 (let ((y (- (* -1 neg-y) 1)))
204 (plot-raw (inexact->exact x) (inexact->exact y) c)))
206 (define (plot-char c)
209 (scur-x (* scaling cur-x))
210 (scur-y (* scaling cur-y)))
211 ;; BBox: (llx lly urx ury) * 1000
212 (let ((dx (inexact->exact (* .001 (car bbox))))
213 ;;(dy (inexact->exact (* .001 (cadr bbox))))
214 (dy (inexact->exact (- (* .001 (cadddr bbox)) 1)))
215 (len (length glyph)))
216 ;;(display "Bbox: ") (display bbox) (newline)
217 ;;(display "dy: ") (display dy) (newline)
218 (do ((line glyph (cdr line))
221 (plot-string (+ scur-x dx) (+ (- scur-y i) dy) (car line))))))
223 (define (plot-string x y s)
225 ((= i (string-length s)))
226 (plot (+ x i) y (substring s i (+ i 1)))))
228 (define (show-char char)
231 (define (show-font name)
232 (let ((font (assoc name fonts)))
233 (map (lambda (x) (show-char x)) font)))
238 (inexact->exact (/ x (abs x)))))
240 (define (generate-default-font)
241 (let loop ((chars '()) (i 0))
245 (cons (list i '(0 0 1000 1000)
246 (list (make-string 1 (integer->char i))))
250 (define (get-font name)
252 (if (equal? (substring name 0 (min (string-length name) 8)) "as-dummy")
254 (let ((entry (assoc name fonts)))
259 (string-append "warning: no such font: " name "\n")
260 (current-error-port))
261 (get-font "default"))))))
263 (define (get-char font n)
264 (let ((entry (assoc n font)))
269 (string-append "warning: no such char: ("
272 (number->string n ) ")\n")
273 (current-error-port))
277 ;;; AsciiScript commands
280 (let* ((font (get-font cur-font))
282 (if (and half-char-kludge
283 (assoc (+ n 0.5) font))
284 (get-char font (+ n 0.5))
290 (display (string-append
292 (- canvas-width (string-length tag-line)) #\space)
295 (close cur-output-file)
296 (set! cur-output-file '()))
300 (let ((scur-x (* scaling cur-x))
301 (scur-y (* scaling cur-y))
302 (slen (* scaling len)))
303 (let ((step (sign len)))
304 (do ((i 0 (+ i step)))
306 (plot (+ scur-x i) scur-y line-char)))))
309 (let ((scur-x (* scaling cur-x))
310 (scur-y (* scaling cur-y))
311 (slen (* scaling len)))
312 (let ((step (sign len)))
313 (do ((i 0 (+ i step)))
315 (plot scur-x (+ scur-y i) line-char)))))
318 ;(display (string-append x y "\n") (current-error-port))
321 (define (header-end) "")
324 (define (rline-to dx dy)
325 (plot (inexact->exact cur-x) (inexact->exact cur-y) line-char)
326 (plot (inexact->exact (+ cur-x dx)) (inexact->exact (+ cur-y dy)) line-char)
327 (if (or (> (abs dx) 1) (> (abs dy) 1))
333 (plot (inexact->exact (+ cur-x hx)) (inexact->exact (+ cur-y hy)) line-char)
340 (define (dissect-char text)
341 (let* ((char (split #\nl text list))
343 (code (string->number
346 (+ (string-index id #\C) 1)
347 (string-index id #\;)))))
348 (bbox (map string->number
349 (split #\space (strip (substring
351 (+ (string-rindex id #\B) 1)
352 (string-rindex id #\;)))
354 (list (list code bbox (cdr char)))))
356 (define (load-font name mag)
357 ;; urg: don't load dummy font
358 (if (not (equal? (substring name 0 (min (string-length name) 8)) "as-dummy"))
359 (let ((text (af-gulp-file (string-append name ".af"))))
360 (if (< 0 (string-length text))
361 (let* ((char-list (cdr
363 (regexp-substitute/global
364 #f "\t[^\n]*\n" text 'pre "" 'post)
366 (font (apply append (map dissect-char char-list))))
367 (if (< 0 (length font))
368 (set! fonts (cons (cons name font) fonts))))))))
370 (define (number->rounded-exact x)
371 (* (sign x) (inexact->exact (abs x))))
373 (define (move-to x y)
375 (let ((ey (number->rounded-exact y)))
376 (if (= 0.5 (- (abs ey) (abs y)))
377 (set! half-char-kludge #t)
378 (set! half-char-kludge #f))
382 (plot cur-x cur-y c))
384 (define (rmove-to dx dy)
385 (set! cur-x (+ cur-x dx))
386 (set! cur-y (+ cur-y dy)))
388 (define (select-font name)
389 (set! cur-font name))
391 (define (set-line-char c)
394 (define (start-system width height)
397 (set! fonts (cons (cons "default" (generate-default-font)) fonts))
398 (display "\n" (current-error-port))
399 (if (defined? 'lilypondpaperoutputscale)
400 (set! scaling (inexact->exact (string->number lilypondpaperoutputscale))))
401 (if (defined? 'lilypondpaperlinewidth)
402 (let ((width (inexact->exact
403 (string->number lilypondpaperlinewidth))))
405 (set! canvas-width width)
407 ;;(set! canvas-width 200)
408 (set! canvas-width 80)
411 (set! canvas-height (inexact->exact (* scaling height)))
412 (set! canvas (make-array " " canvas-height canvas-width)))
414 (define (stop-system)
416 (let ((output-file (if (equal? cur-output-name "-")
417 (current-output-port)
418 (open-file cur-output-name "w")))
419 (output-name (if (equal? cur-output-name "-")
423 (set! cur-output-file output-file)
424 (display (string-append "text output to " output-name "...\n")
425 (current-error-port))))
428 (map (lambda (x) (string-append (apply string-append x) "\n"))
429 (array->list canvas)))
433 (let ((n (string-length s))
434 (font (get-font cur-font)))
437 (let* ((n (char->integer (string-ref s i)))
438 (c (get-char font n)))
439 (if (pair? c) (plot-char c))
440 (rmove-to (char-width c) 0)))))