scripts/as2text.scm

   1 #!@GUILE@ \
   2 -e main -s
   3 !#
   4 ;;;; as2text.scm -- Translate AsciiScript to Text
   5 ;;;;
   6 ;;;; source file of the GNU LilyPond music typesetter
   7 ;;;;
   8 ;;;; (c)  2000--2003 Jan Nieuwenhuizen <janneke@gnu.org>
   9
  10 ;;;; library funtions
  11 (use-modules
  12  (ice-9 debug)
  13  (ice-9 getopt-long)
  14  (ice-9 string-fun)
  15  (ice-9 rdelim)
  16  (ice-9 regex))
  17
  18 ;;; Script stuff
  19 (define program-name "as2text")
  20
  21 (define lily-home "/usr/share/lilypond")
  22 (define cur-output-name "-")
  23 (define cur-output-file '())
  24
  25 (define subst-version "@TOPLEVEL_VERSION@")
  26
  27 (define program-version
  28   (if (eq? subst-version (string-append "@" "TOPLEVEL_VERSION" "@"))
  29       "unknown"
  30       subst-version))
  31
  32 (define (show-version port)
  33   (display (string-append
  34             program-name " - LilyPond version " program-version "\n")
  35            port))
  36
  37 (define (show-help)
  38   (display "Convert AsciiScript to text.
  39
  40 Usage: as2text [OPTIONS]... AS-FILE
  41
  42 Options:
  43   -h,--help          show this help
  44   -o,--output=FILE   set output file
  45   -v,--version       show version
  46
  47 "))
  48
  49 ;;
  50 ;; FIXME: use (separate-fields-discarding-char) and (read-delimited "")
  51 ;;
  52 (define (gulp-file name)
  53   (let ((port (if (equal? name "-")
  54                   (current-input-port)
  55                   (catch 'system-error (lambda () (open-file name "r"))
  56                          (lambda args #f)))))
  57         (if port
  58             (begin
  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)
  63                                               (not line))
  64                                           text
  65                                           (loop (string-append text line "\n")))))))
  66                   (close port)
  67                   (display "]" (current-error-port))
  68                   content))
  69             (begin
  70              (display
  71               (string-append "warning: no such file: " name "\n")
  72               (current-error-port))
  73              ""))))
  74
  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))))))
  79       name
  80       (string-append name ext)))
  81
  82 (define (do-file file-name output-name)
  83   (let ((ascii-script (gulp-file (with-extention file-name ".as"))))
  84        ;; urg
  85        (set! cur-output-name output-name)
  86        (eval-string ascii-script)))
  87
  88 ;;; Script entry point
  89 (define (main args)
  90   (set! lily-home (string-append
  91                      (dirname (dirname (car args)))
  92                      "/share/lilypond"))
  93   (let ((options (getopt-long args
  94                               `((output (single-char #\o)
  95                                           (value #t))
  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)))
 101
 102     (if (assq 'help options)
 103         (begin (show-version (current-output-port)) (show-help) (exit 0)))
 104
 105     (if (assq 'version options)
 106         (begin (show-version (current-output-port)) (exit 0)))
 107
 108     (show-version (current-error-port))
 109     (let ((output-name (opt 'output "-"))
 110           (files (let ((foo (opt '() '())))
 111                       (if (null? foo)
 112                           (list "-")
 113                           foo))))
 114          (do-file (car files) output-name))))
 115
 116 ;;;;
 117 ;;;; Ascii Script plotting
 118 ;;;;
 119
 120 ;;; Global variables
 121
 122 ;; Ascii-Art signature
 123 (define tag-line "lily")
 124
 125 (define first-line #t)
 126
 127 (define scaling 1)
 128
 129 ;; cursor
 130 (define cur-x 0)
 131 (define cur-y 0)
 132
 133 ;; canvas dimensions
 134 (define canvas-width 65)
 135 (define canvas-height 20)
 136
 137 ;; font database
 138 (define fonts '())
 139
 140 ;; current font
 141 (define cur-font "")
 142
 143 ;;
 144 (define line-char "-")
 145
 146 ;;
 147 (define half-char-kludge #f)
 148
 149 ;; the plotting fields
 150 (define canvas 0)
 151 ;; urg:
 152 ;; make-uniform array of characters,
 153 ;; or 1-dim array of strings?
 154 ;; (set! canvas (make-array " " canvas-height canvas-width))
 155
 156 ;; urg, this kind of naming costs too much indenting
 157 (define (split c s r)
 158   (separate-fields-discarding-char c s r))
 159
 160 (define (strip s)
 161   (sans-surrounding-whitespace s))
 162
 163
 164 ;;; Helper functions
 165
 166 (define (af-gulp-file name)
 167   ;; urg
 168   (let ((old-load-path %load-path))
 169        (set! %load-path
 170              (cons (string-append
 171                     (or (getenv "LILYPONDPREFIX") ".") "/mf")
 172                    (cons (string-append lily-home "/mf") %load-path)))
 173        (let* ((path (%search-load-path name))
 174               (text (if path
 175                         (gulp-file path)
 176                         (gulp-file name))))
 177              (set! %load-path old-load-path)
 178              text)))
 179
 180 (define (char-width c)
 181   (let ((bbox (car c)))
 182        (inexact->exact (* .001 (caddr bbox)))))
 183
 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 "|")) "+")
 189         (else new)))
 190
 191 (define (merge-chars old new)
 192   (cond ((equal? new " ") old)
 193         (else new)))
 194
 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))))
 201
 202 (define (plot x neg-y c)
 203   (let ((y (- (* -1 neg-y) 1)))
 204     (plot-raw (inexact->exact x) (inexact->exact y) c)))
 205
 206 (define (plot-char c)
 207   (let ((bbox (car c))
 208         (glyph (cadr 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))
 219            (i 0 (+ i 1)))
 220           ((= i len))
 221         (plot-string (+ scur-x dx) (+ (- scur-y i) dy) (car line))))))
 222
 223 (define (plot-string x y s)
 224   (do ((i 0 (+ i 1)))
 225       ((= i (string-length s)))
 226     (plot (+ x i) y (substring s i (+ i 1)))))
 227
 228 (define (show-char char)
 229   (display char))
 230
 231 (define (show-font name)
 232         (let ((font (assoc name fonts)))
 233              (map (lambda (x) (show-char x)) font)))
 234
 235 (define (sign x)
 236   (if (= x 0)
 237       1
 238       (inexact->exact (/ x (abs x)))))
 239
 240 (define (generate-default-font)
 241   (let loop ((chars '()) (i 0))
 242        (if (= 256 i)
 243            chars
 244            (loop
 245             (cons (list i '(0 0 1000 1000)
 246                         (list (make-string 1 (integer->char i))))
 247                   chars)
 248             (+ i 1)))))
 249
 250 (define (get-font name)
 251   ;; urg
 252   (if (equal? (substring name 0 (min (string-length name) 8)) "as-dummy")
 253       (get-font "default")
 254       (let ((entry (assoc name fonts)))
 255            (if entry
 256                (cdr entry)
 257                (begin
 258                 (display
 259                  (string-append "warning: no such font: " name "\n")
 260                  (current-error-port))
 261                 (get-font "default"))))))
 262
 263 (define (get-char font n)
 264   (let ((entry (assoc n font)))
 265        (if entry
 266            (cdr entry)
 267            (begin
 268             (display
 269              (string-append "warning: no such char: ("
 270                             cur-font
 271                             ", "
 272                             (number->string n ) ")\n")
 273              (current-error-port))
 274             '()))))
 275
 276
 277 ;;; AsciiScript commands
 278
 279 (define (char n)
 280   (let* ((font (get-font cur-font))
 281          (c
 282           (if (and half-char-kludge
 283                    (assoc (+ n 0.5) font))
 284               (get-char font (+ n 0.5))
 285               (get-char font n))))
 286          (if (pair? c)
 287              (plot-char c))))
 288
 289 (define (end-output)
 290   (display (string-append
 291             (make-string
 292              (- canvas-width (string-length tag-line)) #\space)
 293             tag-line "\n")
 294            cur-output-file)
 295   (close cur-output-file)
 296   (set! cur-output-file '()))
 297
 298 ;; use plot-string
 299 (define (h-line len)
 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)))
 305               ((= i slen))
 306             (plot (+ scur-x i) scur-y line-char)))))
 307
 308 (define (v-line len)
 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)))
 314           ((= i len))
 315         (plot scur-x (+ scur-y i) line-char)))))
 316
 317 (define (header x y)
 318   ;(display (string-append x y "\n") (current-error-port))
 319   "")
 320
 321 (define (header-end) "")
 322
 323 ;; FIXME: scale
 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))
 328       (let ((x cur-x)
 329             (y cur-y)
 330             (hx (/ dx 2))
 331             (hy (/ dy 2))
 332             )
 333            (plot (inexact->exact (+ cur-x hx)) (inexact->exact (+ cur-y hy)) line-char)
 334            (rline-to hx hy)
 335            (move-to x y)
 336            (rmove-to hx hy)
 337            (rline-to hx hy)
 338            )))
 339
 340 (define (dissect-char text)
 341   (let* ((char (split #\nl text list))
 342          (id (car char))
 343          (code (string->number
 344                 (strip
 345                  (substring id
 346                             (+ (string-index id #\C) 1)
 347                             (string-index id #\;)))))
 348          (bbox (map string->number
 349                     (split #\space (strip (substring
 350                                            id
 351                                            (+ (string-rindex id #\B) 1)
 352                                            (string-rindex id #\;)))
 353                            list))))
 354         (list (list code bbox (cdr char)))))
 355
 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
 362                                   (split #\np
 363                                          (regexp-substitute/global
 364                                           #f "\t[^\n]*\n" text 'pre "" 'post)
 365                                          list)))
 366                       (font (apply append (map dissect-char char-list))))
 367                      (if (< 0 (length font))
 368                          (set! fonts (cons (cons name font) fonts))))))))
 369
 370 (define (number->rounded-exact x)
 371   (* (sign x) (inexact->exact (abs x))))
 372
 373 (define (move-to x y)
 374   (set! cur-x x)
 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))
 379     (set! cur-y ey)))
 380
 381 (define (put c)
 382   (plot cur-x cur-y c))
 383
 384 (define (rmove-to dx dy)
 385   (set! cur-x (+ cur-x dx))
 386   (set! cur-y (+ cur-y dy)))
 387
 388 (define (select-font name)
 389   (set! cur-font name))
 390
 391 (define (set-line-char c)
 392   (set! line-char c))
 393
 394 (define (start-system width height)
 395   (if first-line
 396       (begin
 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))))
 404              (if (> width 0)
 405                  (set! canvas-width width)
 406                  ;; need long line...
 407                  ;;(set! canvas-width 200)
 408                  (set! canvas-width 80)
 409                  )))
 410        ))
 411   (set! canvas-height (inexact->exact (* scaling height)))
 412   (set! canvas (make-array " " canvas-height canvas-width)))
 413
 414 (define (stop-system)
 415   (if first-line
 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 "-")
 420                               "<stdout>"
 421                               cur-output-name)))
 422             (set! first-line #f)
 423             (set! cur-output-file output-file)
 424             (display (string-append "text output to " output-name "...\n")
 425                      (current-error-port))))
 426   (display
 427    (apply string-append
 428           (map (lambda (x) (string-append (apply string-append x) "\n"))
 429                (array->list canvas)))
 430    cur-output-file))
 431
 432 (define (text s)
 433   (let ((n (string-length s))
 434         (font (get-font cur-font)))
 435        (do ((i 0 (+ i 1)))
 436            ((= i n))
 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)))))
 441