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)
13 (define (tex-encoded-fontswitch name-mag)
14 (let* ((iname-mag (car name-mag))
15 (ename-mag (cdr name-mag)))
18 (string-append "magfont"
19 (string-encode-integer
20 (hashq (car ename-mag) 1000000))
22 (string-encode-integer
23 (inexact->exact (* 1000 (cdr ename-mag)))))))))
25 (define (fontify name-mag-pair exp)
26 (string-append (select-font name-mag-pair)
30 (define (define-fonts internal-external-name-mag-pairs)
31 (set! font-name-alist (map tex-encoded-fontswitch
32 internal-external-name-mag-pairs))
35 (font-load-command (car x) (cdr x)))
36 (map cdr font-name-alist))))
38 (define as-font-alist-alist
44 (feta-nummer6 . as-number1)
45 (feta-nummer8 . as-number1)
46 (feta-braces16 . as-braces9)
55 (feta-nummer4 . as-number1)
56 (feta-nummer8 . as-number4)
57 (feta-braces16 . as-braces9)
65 (define (as-properties-to-font-name size fonts properties-alist-list)
66 (let* ((feta-name (properties-to-font-name fonts properties-alist-list))
67 (as-font-alist (cdr (assoc size as-font-alist-alist)))
68 (font (assoc (string->symbol feta-name) as-font-alist)))
69 (if font (symbol->string (cdr font))
70 (let ((e (current-error-port)))
72 (display "can't find font: " e)
74 ;;(symbol->string size)
78 ;; FIXME: making a full style-sheet is a pain, so we parasite on
79 ;; paper16 and translate the result.
81 (define (as-make-style-sheet size)
82 (let ((sheet (make-style-sheet 'paper16)))
83 (assoc-set! sheet 'properties-to-font
84 (lambda (x y) (as-properties-to-font-name size x y)))
88 (define (beam width slope thick)
90 (func "set-line-char" "#")
91 (func "rline-to" width (* width slope))
95 (define (bezier-bow l thick)
102 (dy (- (cdr c3) (cdr c0)))
104 (c1-dx (- (car c1) x))
105 (c1-line-y (+ (cdr c0) (* c1-dx rc)))
106 (dir (if (< c1-line-y (cdr c1)) 1 -1))
107 (y (+ -1 (* dir (max (* dir (cdr c0)) (* dir (cdr c3)))))))
109 (func "rmove-to" x y)
110 (func "put" (if (< 0 dir) "/" "\\\\"))
111 (func "rmove-to" 1 (if (< 0 dir) 1 0))
112 (func "set-line-char" "_")
113 (func "h-line" (- dx 1))
114 (func "rmove-to" (- dx 1) (if (< 0 dir) -1 0))
115 (func "put" (if (< 0 dir) "\\\\" "/"))))))
118 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
122 (func "rmove-to" (+ width 1) (- (/ height -2) 1))
124 (func "set-line-char" "|")
125 (func "rmove-to" 0 1)
126 (func "v-line" (+ height 1))
127 (func "rmove-to" 0 (+ height 1))
134 (define (define-origin a b c ) "")
139 (define (experimental-on)
142 (define (filledbox breapth width depth height)
143 (let ((dx (+ width breapth))
144 (dy (+ depth height)))
146 (func "rmove-to" (* -1 breapth) (* -1 depth))
149 (func "set-line-char"
150 (if (<= dx 1) "|" "#"))
153 (func "set-line-char"
154 (if (<= dy 1) "-" "="))
155 (func "h-line" dx))))))
157 (define (roundfilledbox breapth width depth height blot)
158 (filledbox breapth width depth height))
160 (define (font-load-command name-mag command)
161 ;; (display "name-mag: ")
163 ;; (display "command: ")
165 (func "load-font" (car name-mag) (cdr name-mag)))
167 (define (header creator generate)
168 (func "header" creator generate))
173 ;; urg: this is good for half of as2text's execution time
174 (define (xlily-def key val)
175 (string-append "(define " key " " (arg->string val) ")\n"))
177 (define (lily-def key val)
179 ;; let's not have all bloody definitions
180 (or (equal? key "lilypondpaperlinewidth")
181 (equal? key "lilypondpaperstaffheight")
182 (equal? key "lilypondpaperoutputscale"))
183 (string-append "(define " key " " (arg->string val) ")\n")
186 (define (no-origin) "")
188 (define (placebox x y s)
189 (let ((ey (inexact->exact y)))
190 (string-append "(move-to " (number->string (inexact->exact x)) " "
191 (if (= 0.5 (- (abs y) (abs ey)))
196 (define (select-font name-mag-pair)
197 (let* ((c (assoc name-mag-pair font-name-alist)))
202 "Programming error: No such font known "
203 (car name-mag-pair))))
204 "") ; issue no command
205 (func "select-font" (car name-mag-pair))))
207 (define (start-system height)
208 (func "start-system" height))
210 (define (stop-system)
211 (func "stop-system"))
213 (define (stop-last-system)
214 (func "stop-system"))
220 (define (tuplet ht gap dx dy thick dir) "")