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 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 regex))
  16
  17 ;;; Script stuff
  18 (define program-name "as2text")
  19
  20 (define lily-home "/usr/share/lilypond")
  21 (define cur-output-name "-")
  22 (define cur-output-file '())
  23
  24 (define subst-version "@TOPLEVEL_VERSION@")
  25
  26 (define program-version
  27   (if (eq? subst-version (string-append "@" "TOPLEVEL_VERSION" "@"))
  28       "unknown"
  29       subst-version))
  30
  31 (define (show-version port)
  32   (display (string-append
  33             program-name " - LilyPond version " program-version "\n")
  34            port))
  35
  36 (define (show-help)
  37   (display "Convert AsciiScript to text.
  38
  39
  40 Usage: as2text [OPTION]... AS-FILE
  41
  42 Options:
  43   -h,--help          this help
  44   -o,--output=FILE   set output file
  45   -v,--version       show version
  46 "))
  47
  48 (define (gulp-file name)
  49   (let ((port (if (equal? name "-")
  50                   (current-input-port)
  51                   (catch 'system-error (lambda () (open-file name "r"))
  52                          (lambda args #f)))))
  53         (if port
  54             (begin
  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)
  59                                               (not line))
  60                                           text
  61                                           (loop (string-append text line "\n")))))))
  62                   (close port)
  63                   (display "]" (current-error-port))
  64                   content))
  65             (begin
  66              (display
  67               (string-append "warning: no such file: " name "\n")
  68               (current-error-port))
  69              ""))))
  70
  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))))))
  75       name
  76       (string-append name ext)))
  77
  78 (define (do-file file-name output-name)
  79   (let ((ascii-script (gulp-file (with-extention file-name ".as"))))
  80        ;; urg
  81        (set! cur-output-name output-name)
  82        (eval-string ascii-script)))
  83
  84 ;;; Script entry point
  85 (define (main args)
  86   (set! lily-home (string-append
  87                      (dirname (dirname (car args)))
  88                      "/share/lilypond"))
  89   (let ((options (getopt-long args
  90                               `((output (single-char #\o)
  91                                           (value #t))
  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)))
  97
  98     (if (assq 'help options)
  99         (begin (show-version (current-output-port)) (show-help) (exit 0)))
 100
 101     (if (assq 'version options)
 102         (begin (show-version (current-output-port)) (exit 0)))
 103
 104     (show-version (current-error-port))
 105     (let ((output-name (opt 'output "-"))
 106           (files (let ((foo (opt '() '())))
 107                       (if (null? foo)
 108                           (list "-")
 109                           foo))))
 110          (do-file (car files) output-name))))
 111
 112 ;;;;
 113 ;;;; Ascii Script plotting
 114 ;;;;
 115
 116 ;;; Global variables
 117
 118 ;; Ascii-Art signature
 119 (define tag-line "lily")
 120
 121 (define first-line #t)
 122
 123 ;; cursor
 124 (define cur-x 0)
 125 (define cur-y 0)
 126
 127 ;; canvas dimensions
 128 (define canvas-width 65)
 129 (define canvas-height 20)
 130
 131 ;; font database
 132 (define fonts '())
 133
 134 ;; current font
 135 (define cur-font "")
 136
 137 ;;
 138 (define line-char "-")
 139
 140 ;;
 141 (define half-char-kludge #f)
 142
 143 ;; the plotting fields
 144 (define canvas 0)
 145 ;; urg:
 146 ;; make-uniform array of characters,
 147 ;; or 1-dim array of strings?
 148 ;; (set! canvas (make-array " " canvas-height canvas-width))
 149
 150 ;; urg, this kind of naming costs too much indenting
 151 (define (split c s r)
 152   (separate-fields-discarding-char c s r))
 153
 154 (define (strip s)
 155   (sans-surrounding-whitespace s))
 156
 157
 158 ;;; Helper functions
 159
 160 (define (af-gulp-file name)
 161   ;; urg
 162   (let ((old-load-path %load-path))
 163        (set! %load-path
 164              (cons (string-append
 165                     (or (getenv 'LILYPONDPREFIX) ".") "/mf")
 166                    (cons (string-append lily-home "/mf") %load-path)))
 167        (let* ((path (%search-load-path name))
 168               (text (if path
 169                         (gulp-file path)
 170                         (gulp-file name))))
 171              (set! %load-path old-load-path)
 172              text)))
 173
 174 (define (char-width c)
 175   (let ((bbox (car c)))
 176        (inexact->exact (* .001 (caddr bbox)))))
 177
 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 "|")) "+")
 183         (else new)))
 184
 185 (define (merge-chars old new)
 186   (cond ((equal? new " ") old)
 187         (else new)))
 188
 189 (define (plot x y c)
 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")))))
 195
 196 (define (plot-char c)
 197   (let ((bbox (car c))
 198         (glyph (cadr 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))
 207                  (i 0 (+ i 1)))
 208                 ((= i len))
 209                 (plot-string (+ cur-x dx) (+ (- cur-y i) dy) (car line))))))
 210
 211 (define (plot-string x y s)
 212   (do ((i 0 (+ i 1)))
 213       ((= i (string-length s)))
 214       (plot (+ x i) y (substring s i (+ i 1)))))
 215
 216 (define (show-char char)
 217   (display char))
 218
 219 (define (show-font name)
 220         (let ((font (assoc name fonts)))
 221              (map (lambda (x) (show-char x)) font)))
 222
 223 (define (sign x)
 224   (if (= x 0)
 225       1
 226       (inexact->exact (/ x (abs x)))))
 227
 228 (define (generate-default-font)
 229   (let loop ((chars '()) (i 0))
 230        (if (= 256 i)
 231            chars
 232            (loop
 233             (cons (list i '(0 0 1000 1000)
 234                         (list (make-string 1 (integer->char i))))
 235                   chars)
 236             (+ i 1)))))
 237
 238 (define (get-font name)
 239   ;; urg
 240   (if (equal? (substring name 0 (min (string-length name) 8)) "as-dummy")
 241       (get-font "default")
 242       (let ((entry (assoc name fonts)))
 243            (if entry
 244                (cdr entry)
 245                (begin
 246                 (display
 247                  (string-append "warning: no such font: " name "\n")
 248                  (current-error-port))
 249                 (get-font "default"))))))
 250
 251 (define (get-char font n)
 252   (let ((entry (assoc n font)))
 253        (if entry
 254            (cdr entry)
 255            (begin
 256             (display
 257              (string-append "warning: no such char: ("
 258                             cur-font
 259                             ", "
 260                             (number->string n ) ")\n")
 261              (current-error-port))
 262             '()))))
 263
 264
 265 ;;; AsciiScript commands
 266
 267 (define (char n)
 268   (let* ((font (get-font cur-font))
 269          (c
 270           (if (and half-char-kludge
 271                    (assoc (+ n 0.5) font))
 272               (get-char font (+ n 0.5))
 273               (get-char font n))))
 274          (if c
 275              (plot-char c))))
 276
 277 (define (end-output)
 278   (display (string-append
 279             (make-string
 280              (- canvas-width (string-length tag-line)) #\space)
 281             tag-line "\n")
 282            cur-output-file)
 283   (close cur-output-file)
 284   (set! cur-output-file '()))
 285
 286 (define (h-line len)
 287   (let ((step (sign len)))
 288        (do ((i 0 (+ i step)))
 289            ((= i len))
 290            (plot (+ cur-x i) cur-y line-char))))
 291
 292 (define (v-line len)
 293   (let ((step (sign len)))
 294        (do ((i 0 (+ i step)))
 295            ((= i len)) (plot cur-x (+ cur-y i) line-char))))
 296
 297 (define (header x y)
 298   ;(display (string-append x y "\n") (current-error-port))
 299   "")
 300
 301 (define (header-end) "")
 302
 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))
 307       (let ((x cur-x)
 308             (y cur-y)
 309             (hx (/ dx 2))
 310             (hy (/ dy 2))
 311             )
 312            (plot (inexact->exact (+ cur-x hx)) (inexact->exact (+ cur-y hy)) line-char)
 313            (rline-to hx hy)
 314            (move-to x y)
 315            (rmove-to hx hy)
 316            (rline-to hx hy)
 317            )))
 318
 319 (define (dissect-char text)
 320   (let* ((char (split #\nl text list))
 321          (id (car char))
 322          (code (string->number
 323                 (strip
 324                  (substring id
 325                             (+ (string-index id #\C) 1)
 326                             (string-index id #\;)))))
 327          (bbox (map string->number
 328                     (split #\space (strip (substring
 329                                            id
 330                                            (+ (string-rindex id #\B) 1)
 331                                            (string-rindex id #\;)))
 332                            list))))
 333         (list (list code bbox (cdr char)))))
 334
 335 (define (load-font name mag)
 336   ;; urg: don't load dummy font
 337   (if (not (equal? (substring name 0 (min (string-length name) 8)) "as-dummy"))
 338       (let ((text (af-gulp-file (string-append name ".af"))))
 339            (if (< 0 (string-length text))
 340                (let* ((char-list (cdr
 341                                   (split #\np
 342                                          (regexp-substitute/global
 343                                           #f "\t[^\n]*\n" text 'pre "" 'post)
 344                                          list)))
 345                       (font (apply append (map dissect-char char-list))))
 346                      (if (< 0 (length font))
 347                          (set! fonts (cons (cons name font) fonts))))))))
 348
 349 (define (number->rounded-exact x)
 350   (* (sign x) (inexact->exact (abs x))))
 351
 352 (define (move-to x y)
 353   (set! cur-x x)
 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))
 358     (set! cur-y ey)))
 359
 360 (define (put c)
 361   (plot cur-x cur-y c))
 362
 363 (define (rmove-to dx dy)
 364   (set! cur-x (+ cur-x dx))
 365   (set! cur-y (+ cur-y dy)))
 366
 367 (define (select-font name)
 368   (set! cur-font name))
 369
 370 (define (set-line-char c)
 371   (set! line-char c))
 372
 373 (define (start-line height)
 374   (if first-line
 375       (begin
 376        (set! fonts (cons (cons "default" (generate-default-font)) fonts))
 377        (display "\n" (current-error-port))
 378        (if (and (defined? 'mudelapaperlinewidth)
 379                 (> (string->number mudelapaperlinewidth) 0))
 380            (set! canvas-width
 381                  (inexact->exact (string->number mudelapaperlinewidth))))))
 382   (set! canvas-height height)
 383   (set! canvas (make-array " " canvas-height canvas-width)))
 384
 385 (define (stop-line)
 386   (if first-line
 387       (let ((output-file (if (equal? cur-output-name "-")
 388                               (current-output-port)
 389                               (open-file cur-output-name "w")))
 390              (output-name (if (equal? cur-output-name "-")
 391                               "<stdout>"
 392                               cur-output-name)))
 393             (set! first-line #f)
 394             (set! cur-output-file output-file)
 395             (display (string-append "text output to " output-name "...\n")
 396                      (current-error-port))))
 397   (display
 398    (apply string-append
 399           (map (lambda (x) (string-append (apply string-append x) "\n"))
 400                (array->list canvas)))
 401    cur-output-file))
 402
 403 (define (text s)
 404   (let ((n (string-length s))
 405         (font (get-font cur-font)))
 406        (do ((i 0 (+ i 1)))
 407            ((= i n))
 408             (let* ((n (char->integer (string-ref s i)))
 409                    (c (get-char font n)))
 410                   (plot-char c)
 411                   (rmove-to (char-width c) 0)))))
 412