scripts/as2text.scm

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