1 (define-module (scm output-ascii-script)
7 (define this-module (current-module))
9 (define font-name-alist '())
11 (define-public (as-output-expression expr port)
12 (display (eval expr this-module) port)
16 (debug-enable 'backtrace)
18 (define (tex-encoded-fontswitch name-mag)
19 (let* ((iname-mag (car name-mag))
20 (ename-mag (cdr name-mag)))
23 (string-append "magfont"
24 (string-encode-integer
25 (hashq (car ename-mag) 1000000))
27 (string-encode-integer
28 (inexact->exact (* 1000 (cdr ename-mag)))))))))
30 (define (fontify name-mag-pair exp)
31 (string-append (select-font name-mag-pair)
35 (define (define-fonts internal-external-name-mag-pairs)
36 (set! font-name-alist (map tex-encoded-fontswitch
37 internal-external-name-mag-pairs))
40 (font-load-command (car x) (cdr x)))
41 (map cdr font-name-alist))))
43 (define (dot x y radius) "") ;; TODO
45 (define (beam width slope thick)
47 (func "set-line-char" "#")
48 (func "rline-to" width (* width slope))
52 (define (bezier-sandwich thick)
59 (dy (- (cdr c3) (cdr c0)))
61 (c1-dx (- (car c1) x))
62 (c1-line-y (+ (cdr c0) (* c1-dx rc)))
63 (dir (if (< c1-line-y (cdr c1)) 1 -1))
64 (y (+ -1 (* dir (max (* dir (cdr c0)) (* dir (cdr c3)))))))
67 (func "put" (if (< 0 dir) "/" "\\\\"))
68 (func "rmove-to" 1 (if (< 0 dir) 1 0))
69 (func "set-line-char" "_")
70 (func "h-line" (- dx 1))
71 (func "rmove-to" (- dx 1) (if (< 0 dir) -1 0))
72 (func "put" (if (< 0 dir) "\\\\" "/"))))))
75 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
79 (func "rmove-to" (+ width 1) (- (/ height -2) 1))
81 (func "set-line-char" "|")
83 (func "v-line" (+ height 1))
84 (func "rmove-to" 0 (+ height 1))
88 (define (polygon points blotdiameter) "") ;; TODO
93 (define (define-origin a b c ) "")
98 (define (experimental-on)
101 (define (horizontal-line x1 x2 th)
102 (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th )))
105 (define (filledbox breapth width depth height)
106 (let ((dx (+ width breapth))
107 (dy (+ depth height)))
109 (func "rmove-to" (* -1 breapth) (* -1 depth))
112 (func "set-line-char"
113 (if (<= dx 1) "|" "#"))
116 (func "set-line-char"
117 (if (<= dy 1) "-" "="))
118 (func "h-line" dx))))))
120 (define (roundfilledbox breapth width depth height blot)
121 (filledbox breapth width depth height))
123 (define (draw-line thick x1 y1 x2 y2)
127 (func ("rmove-to" x1 y1))
128 (filledbox 0 dx 0 dy))))
130 (define (font-load-command name-mag command)
131 ;; (display "name-mag: ")
133 ;; (display "command: ")
135 (func "load-font" (car name-mag) (cdr name-mag)))
137 (define (header creator generate)
138 (func "header" creator generate))
143 ;; urg: this is good for half of as2text's execution time
144 (define (xlily-def key val)
145 (string-append "(define " key " " (arg->string val) ")\n"))
147 (define (lily-def key val)
149 ;; let's not have all bloody definitions
150 (or (equal? key "lilypondpaperlinewidth")
151 (equal? key "lilypondpaperstaffheight")
152 (equal? key "lilypondpaperoutputscale"))
153 (string-append "(define " key " " (arg->string val) ")\n")
156 (define (no-origin) "")
158 (define (placebox x y s)
159 (let ((ey (inexact->exact y)))
160 (string-append "(move-to " (number->string (inexact->exact x)) " "
161 (if (= 0.5 (- (abs y) (abs ey)))
166 (define (select-font name-mag-pair)
167 (let* ((c (assoc name-mag-pair font-name-alist)))
172 "Programming error: No such font known "
173 (car name-mag-pair))))
174 "") ; issue no command
175 (func "select-font" (car name-mag-pair))))
177 (define (start-system width height)
178 (func "start-system" width height))
180 (define (stop-system)
181 (func "stop-system"))
183 (define (stop-last-system)
184 (func "stop-system"))
190 (define (tuplet ht gap dx dy thick dir) "")