4 ;;;; as2text.scm -- Translate AsciiScript to Text
6 ;;;; source file of the GNU LilyPond music typesetter
8 ;;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
18 (define program-name "as2text")
20 (define lily-home "/usr/share/lilypond")
21 (define cur-output-name "-")
22 (define cur-output-file '())
24 (define subst-version "@TOPLEVEL_VERSION@")
26 (define program-version
27 (if (eq? subst-version (string-append "@" "TOPLEVEL_VERSION" "@"))
31 (define (show-version port)
32 (display (string-append
33 program-name " - LilyPond version " program-version "\n")
37 (display "Convert AsciiScript to text.
40 Usage: as2text [OPTION]... AS-FILE
44 -o,--output=FILE set output file
45 -v,--version show version
48 (define (gulp-file name)
49 (let ((port (if (equal? name "-")
51 (catch 'system-error (lambda () (open-file name "r"))
55 (display (string-append "[" name) (current-error-port))
56 (let ((content (let loop ((text ""))
57 (let ((line (read-line port)))
58 (if (or (eof-object? line)
61 (loop (string-append text line "\n")))))))
63 (display "]" (current-error-port))
67 (string-append "warning: no such file: " name "\n")
71 (define (with-extention name ext)
72 (if (or (equal? name "-")
73 (equal? ext (substring name (max 0 (- (string-length name)
74 (string-length ext))))))
76 (string-append name ext)))
78 (define (do-file file-name output-name)
79 (let ((ascii-script (gulp-file (with-extention file-name ".as"))))
81 (set! cur-output-name output-name)
82 (eval-string ascii-script)))
84 ;;; Script entry point
86 (set! lily-home (string-append
87 (dirname (dirname (car args)))
89 (let ((options (getopt-long args
90 `((output (single-char #\o)
92 (help (single-char #\h))
93 (version (single-char #\v))))))
94 (define (opt tag default)
95 (let ((pair (assq tag options)))
96 (if pair (cdr pair) default)))
98 (if (assq 'help options)
99 (begin (show-version (current-output-port)) (show-help) (exit 0)))
101 (if (assq 'version options)
102 (begin (show-version (current-output-port)) (exit 0)))
104 (show-version (current-error-port))
105 (let ((output-name (opt 'output "-"))
106 (files (let ((foo (opt '() '())))
110 (do-file (car files) output-name))))
113 ;;;; Ascii Script plotting
118 ;; Ascii-Art signature
119 (define tag-line "lily")
121 (define first-line #t)
128 (define canvas-width 65)
129 (define canvas-height 20)
138 (define line-char "-")
141 (define half-char-kludge #f)
143 ;; the plotting fields
146 ;; make-uniform array of characters,
147 ;; or 1-dim array of strings?
148 ;; (set! canvas (make-array " " canvas-height canvas-width))
150 ;; urg, this kind of naming costs too much indenting
151 (define (split c s r)
152 (separate-fields-discarding-char c s r))
155 (sans-surrounding-whitespace s))
160 (define (af-gulp-file name)
162 (let ((old-load-path %load-path))
165 (or (getenv 'LILYPONDPREFIX) ".") "/mf")
166 (cons (string-append lily-home "/mf") %load-path)))
167 (let* ((path (%search-load-path name))
171 (set! %load-path old-load-path)
174 (define (char-width c)
175 (let ((bbox (car c)))
176 (inexact->exact (* .001 (caddr bbox)))))
178 ;; urg: use smart table
179 (define (xmerge-chars old new)
180 (cond ((equal? new " ") old)
181 ((and (equal? old "|") (equal? new "-")) "+")
182 ((and (equal? old "-") (equal? new "|")) "+")
185 (define (merge-chars old new)
186 (cond ((equal? new " ") old)
190 (let ((ny (- (* -1 y) 1)))
191 (if (array-in-bounds? canvas ny x)
192 (array-set! canvas (merge-chars (array-ref canvas ny x) c) ny x)
193 (display (string-append "ouch: " (number->string x) ","
194 (number->string ny) "\n")))))
196 (define (plot-char c)
199 ;; BBox: (llx lly urx ury) * 1000
200 (let ((dx (inexact->exact (* .001 (car bbox))))
201 ;(dy (inexact->exact (* .001 (cadr bbox))))
202 (dy (inexact->exact (- (* .001 (cadddr bbox)) 1)))
203 (len (length glyph)))
204 ;;(display "Bbox: ") (display bbox) (newline)
205 ;;(display "dy: ") (display dy) (newline)
206 (do ((line glyph (cdr line))
209 (plot-string (+ cur-x dx) (+ (- cur-y i) dy) (car line))))))
211 (define (plot-string x y s)
213 ((= i (string-length s)))
214 (plot (+ x i) y (substring s i (+ i 1)))))
216 (define (show-char char)
219 (define (show-font name)
220 (let ((font (assoc name fonts)))
221 (map (lambda (x) (show-char x)) font)))
226 (inexact->exact (/ x (abs x)))))
228 (define (generate-default-font)
229 (let loop ((chars '()) (i 0))
233 (cons (list i '(0 0 1000 1000)
234 (list (make-string 1 (integer->char i))))
238 (define (get-font name)
240 (if (equal? name "as-dummy")
242 (let ((entry (assoc name fonts)))
247 (string-append "warning: no such font: " name "\n")
248 (current-error-port))
249 (get-font "default"))))))
251 (define (get-char font n)
252 (let ((entry (assoc n font)))
257 (string-append "warning: no such char: ("
260 (number->string n ) ")\n")
261 (current-error-port))
265 ;;; AsciiScript commands
268 (let* ((font (get-font cur-font))
270 (if (and half-char-kludge
271 (assoc (+ n 0.5) font))
272 (get-char font (+ n 0.5))
278 (display (string-append
280 (- canvas-width (string-length tag-line)) #\space)
283 (close cur-output-file)
284 (set! cur-output-file '()))
287 (let ((step (sign len)))
288 (do ((i 0 (+ i step)))
290 (plot (+ cur-x i) cur-y line-char))))
293 (let ((step (sign len)))
294 (do ((i 0 (+ i step)))
295 ((= i len)) (plot cur-x (+ cur-y i) line-char))))
298 ;(display (string-append x y "\n") (current-error-port))
301 (define (header-end) "")
303 (define (rline-to dx dy)
304 (plot (inexact->exact cur-x) (inexact->exact cur-y) line-char)
305 (plot (inexact->exact (+ cur-x dx)) (inexact->exact (+ cur-y dy)) line-char)
306 (if (or (> (abs dx) 1) (> (abs dy) 1))
312 (plot (inexact->exact (+ cur-x hx)) (inexact->exact (+ cur-y hy)) line-char)
319 (define (dissect-char text)
320 (let* ((char (split #\nl text list))
322 (code (string->number
325 (+ (string-index id #\C) 1)
326 (string-index id #\;)))))
327 (bbox (map string->number
328 (split #\space (strip (substring
330 (+ (string-rindex id #\B) 1)
331 (string-rindex id #\;)))
333 (list (list code bbox (cdr char)))))
335 (define (load-font name mag)
336 ;; urg: don't load dummy font
337 (if (not (equal? name "as-dummy"))
338 (let ((text (af-gulp-file (string-append name ".af"))))
339 (if (< 0 (string-length text))
340 (let* ((char-list (cdr
342 (regexp-substitute/global
343 #f "\t[^\n]*\n" text 'pre "" 'post)
345 (font (apply append (map dissect-char char-list))))
346 (if (< 0 (length font))
347 (set! fonts (cons (cons name font) fonts))))))))
349 (define (number->rounded-exact x)
350 (* (sign x) (inexact->exact (abs x))))
352 (define (move-to x y)
354 (let ((ey (number->rounded-exact y)))
355 (if (= 0.5 (- (abs ey) (abs y)))
356 (set! half-char-kludge #t)
357 (set! half-char-kludge #f))
361 (plot cur-x cur-y c))
363 (define (rmove-to dx dy)
364 (set! cur-x (+ cur-x dx))
365 (set! cur-y (+ cur-y dy)))
367 (define (select-font name)
368 (set! cur-font name))
370 (define (set-line-char c)
373 (define (start-line height)
376 (set! fonts (cons (cons "default" (generate-default-font)) fonts))
377 (display "\n" (current-error-port))
378 (if (defined? 'mudelapaperlinewidth)
380 (inexact->exact (string->number mudelapaperlinewidth))))))
381 (set! canvas-height height)
382 (set! canvas (make-array " " canvas-height canvas-width)))
386 (let ((output-file (if (equal? cur-output-name "-")
387 (current-output-port)
388 (open-file cur-output-name "w")))
389 (output-name (if (equal? cur-output-name "-")
393 (set! cur-output-file output-file)
394 (display (string-append "text output to " output-name "...\n")
395 (current-error-port))))
398 (map (lambda (x) (string-append (apply string-append x) "\n"))
399 (array->list canvas)))
403 (let ((n (string-length s))
404 (font (get-font cur-font)))
407 (let* ((n (char->integer (string-ref s i)))
408 (c (get-char font n)))
410 (rmove-to (char-width c) 0)))))