1 (define-module (scm ascii-script)
4 (define this-module (current-module))
6 (define-public (as-output-expression expr port)
7 (display (eval expr this-module) port)
11 (debug-enable 'backtrace)
12 (define (tex-encoded-fontswitch name-mag)
13 (let* ((iname-mag (car name-mag))
14 (ename-mag (cdr name-mag)))
17 (string-append "magfont"
18 (string-encode-integer
19 (hashq (car ename-mag) 1000000))
21 (string-encode-integer
22 (inexact->exact (* 1000 (cdr ename-mag)))))))))
24 (define (fontify name-mag-pair exp)
25 (string-append (select-font name-mag-pair)
29 (define (define-fonts internal-external-name-mag-pairs)
30 (set! font-name-alist (map tex-encoded-fontswitch
31 internal-external-name-mag-pairs))
34 (font-load-command (car x) (cdr x)))
35 (map cdr font-name-alist))))
37 (define as-font-alist-alist
43 (feta-nummer6 . as-number1)
44 (feta-nummer8 . as-number1)
45 (feta-braces16 . as-braces9)
54 (feta-nummer4 . as-number1)
55 (feta-nummer8 . as-number4)
56 (feta-braces16 . as-braces9)
64 (define (as-properties-to-font-name size fonts properties-alist-list)
65 (let* ((feta-name (properties-to-font-name fonts properties-alist-list))
66 (as-font-alist (cdr (assoc size as-font-alist-alist)))
67 (font (assoc (string->symbol feta-name) as-font-alist)))
68 (if font (symbol->string (cdr font))
69 (let ((e (current-error-port)))
71 (display "can't find font: " e)
73 ;;(symbol->string size)
77 ;; FIXME: making a full style-sheet is a pain, so we parasite on
78 ;; paper16 and translate the result.
80 (define (as-make-style-sheet size)
81 (let ((sheet (make-style-sheet 'paper16)))
82 (assoc-set! sheet 'properties-to-font
83 (lambda (x y) (as-properties-to-font-name size x y)))
87 (define (beam width slope thick)
89 (func "set-line-char" "#")
90 (func "rline-to" width (* width slope))
94 (define (bezier-sandwich l thick)
101 (dy (- (cdr c3) (cdr c0)))
103 (c1-dx (- (car c1) x))
104 (c1-line-y (+ (cdr c0) (* c1-dx rc)))
105 (dir (if (< c1-line-y (cdr c1)) 1 -1))
106 (y (+ -1 (* dir (max (* dir (cdr c0)) (* dir (cdr c3)))))))
108 (func "rmove-to" x y)
109 (func "put" (if (< 0 dir) "/" "\\\\"))
110 (func "rmove-to" 1 (if (< 0 dir) 1 0))
111 (func "set-line-char" "_")
112 (func "h-line" (- dx 1))
113 (func "rmove-to" (- dx 1) (if (< 0 dir) -1 0))
114 (func "put" (if (< 0 dir) "\\\\" "/"))))))
117 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
121 (func "rmove-to" (+ width 1) (- (/ height -2) 1))
123 (func "set-line-char" "|")
124 (func "rmove-to" 0 1)
125 (func "v-line" (+ height 1))
126 (func "rmove-to" 0 (+ height 1))
133 (define (define-origin a b c ) "")
138 (define (experimental-on)
141 (define (filledbox breapth width depth height)
142 (let ((dx (+ width breapth))
143 (dy (+ depth height)))
145 (func "rmove-to" (* -1 breapth) (* -1 depth))
148 (func "set-line-char"
149 (if (<= dx 1) "|" "#"))
152 (func "set-line-char"
153 (if (<= dy 1) "-" "="))
154 (func "h-line" dx))))))
156 (define (font-load-command name-mag command)
157 ;; (display "name-mag: ")
159 ;; (display "command: ")
161 (func "load-font" (car name-mag) (cdr name-mag)))
163 (define (header creator generate)
164 (func "header" creator generate))
169 ;; urg: this is good for half of as2text's execution time
170 (define (xlily-def key val)
171 (string-append "(define " key " " (arg->string val) ")\n"))
173 (define (lily-def key val)
175 ;; let's not have all bloody definitions
176 (or (equal? key "lilypondpaperlinewidth")
177 (equal? key "lilypondpaperstaffheight")
178 (equal? key "lilypondpaperoutputscale"))
179 (string-append "(define " key " " (arg->string val) ")\n")
182 (define (no-origin) "")
184 (define (placebox x y s)
185 (let ((ey (inexact->exact y)))
186 (string-append "(move-to " (number->string (inexact->exact x)) " "
187 (if (= 0.5 (- (abs y) (abs ey)))
192 (define (select-font name-mag-pair)
193 (let* ((c (assoc name-mag-pair font-name-alist)))
198 "Programming error: No such font known "
199 (car name-mag-pair))))
200 "") ; issue no command
201 (func "select-font" (car name-mag-pair))))
203 (define (start-line height)
204 (func "start-line" height))
209 (define (stop-last-line)
216 (define (tuplet ht gap dx dy thick dir) "")
218 (define (volta h w thick vert-start vert-end)
221 (func "set-line-char" "|")
222 (func "rmove-to" 0 -4)
223 ;; definition strange-way around
227 (func "rmove-to" 1 h)
228 (func "set-line-char" "_")
229 (func "h-line" (- w 1))
230 (func "set-line-char" "|")
233 (func "rmove-to" (- w 1) (* -1 h))
234 (func "v-line" (* -1 h)))