blob: 7dada025d74c6a2772fe9551ca94bdc16e1aeaa1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
;;
;; pl2ovp.scm
;; (c) Norbert Preining 1997
;; This file is part of the otibet-package.
;;
;; Converting pl to ovp file with a certain shift amount.
;; The FontDesignSize of the ovp-file can be given, also
;; the FONTAT value of the FONTMAP entry
;;
;; IMPORTANT: LIGTABLE will be deleted (at the moment)!!!!!!
;;
;; Provides:
;; (pl->ovp pl-filename ovp-filename shift ovp-designsize pl-at)
;;
;; pl-filename The name (with or without extansion) of the input
;; ovp-filename The name (with or without extension) of the output
;; shift The value a character in pl-filename will be shifted
;; e.g.: in pl: (CHARACTER H 23 ...)
;; shift = (hex->dec "1000")
;; -> in ovp (CHARACTER H 1023 ... SETCHAR H 23 ...)
;; ovp-designsize (DESIGNSIZE ...)
;; pl-at (MAPFONT D 0 ...(FONTAT ...))
;;
(load 'convnum.scm)
(define (convert-to-dec number mode)
(let ((num (if (number? number)
(number->string number)
(symbol->string number))))
(case (string-ref mode 0)
(#\H (hex->dec num))
(#\O (oct->dec num))
(#\C (char->integer (string-ref num 0))))))
(define (list->sentence low)
(if (= (length low) 1)
(if (number? (car low))
(number->string (car low))
(symbol->string (car low)))
(string-append (if (number? (car low))
(number->string (car low))
(symbol->string (car low)))
" "
(list->sentence (cdr low)))))
(define nextitem '())
(define pl-fontdsize "")
;;
;; pl-read-header
;;
;; liest den pl-file header bis zum ersten CHARACTER ein
;; LIGTABLE wird geloescht!!!
(define (pl-read-header inf outf designsize)
(let ((ni (if (= (length nextitem) 0)
(let ((tmp (read inf)))
(if (eof-object? tmp)
(error 'pl-read-header "Cannot read from Infile")
tmp))
nextitem)))
(let ((tag (symbol->string (car ni))))
(cond
((or (string=? tag "FAMILY")
(string=? tag "COMMENT"))
(format outf "~a~%" ni)
(set! nextitem '())
(pl-read-header inf outf designsize))
((string=? tag "FONTDIMEN")
(set! nextitem '())
(format outf "(FONTDIMEN~%~a )~%"
(list-entries->string (cdr ni) " "))
(pl-read-header inf outf designsize))
((string=? tag "DESIGNSIZE")
(set! nextitem '())
(set! pl-fontdsize (number->string (caddr ni)))
(format outf "(DESIGNSIZE R ~a)~%" designsize)
(pl-read-header inf outf designsize))
((string=? tag "CODINGSCHEME")
(format outf "(CODINGSCHEME SHIFTED ~a)~%" (list->sentence (cdr ni)))
(set! nextitem '())
(pl-read-header inf outf designsize))
((string=? tag "CHARACTER")
(set! nextitem ni))
(else
(set! nextitem '())
(pl-read-header inf outf designsize))))))
(define (ovp-write-font-mapping outf fontname fontat fontdsize)
(format outf "(MAPFONT D 0~% (FONTNAME ~a)~% (FONTAT R ~a)~% (FONTDSIZE R ~a)~% )~%" fontname fontat fontdsize))
(define (list-entries->string lst head)
(if (= (length lst) 0)
""
(string-append (format #f "~a~a~%" head (car lst))
(list-entries->string (cdr lst) head))))
(define (pl-read-character inf outf shift)
(let ((ni (if (= (length nextitem) 0)
(read inf)
nextitem)))
(if (eof-object? ni)
#t
(letrec ((tag (symbol->string (car ni)))
(mode (symbol->string (cadr ni)))
(val (caddr ni))
(decval (convert-to-dec val mode))
(rs (if (number? shift) shift
(let ((tmp (string->number shift)))
(if (integer? tmp) tmp
(error 'pl-read-character "Shift not an integer: ~a." shift)))))
(restlst (cdddr ni)))
(if (not (string=? tag "CHARACTER"))
(error 'pl-read-character "Tag ~a wrong, not CHARACTER." tag)
(begin
(format outf
"(~a H ~a~%~a (MAP~% (SELECTFONT D 0)~% (SETCHAR ~a ~a)~% )~% )~%"
tag
(dec->hex (+ decval rs))
(list-entries->string restlst " ")
mode
val)
(set! nextitem '())
(pl-read-character inf outf shift)))))))
(define (basename file ext)
(letrec ((fl (string-length file))
(el (string-length ext))
(bi (- fl el))
(ei fl))
(begin
(if (string=? (substring file bi ei) ext)
(substring file 0 bi)
file))))
;;
;; MAIN FUNCTION
;;
;; pl->ovp pl-filename ovp-filename shift ovp-designsize pl-at
;;
;; pl-filename The name (with or without extansion) of the input
;; ovp-filename The name (with or without extension) of the output
;; shift The value a character in pl-filename will be shifted
;; e.g.: in pl: (CHARACTER H 23 ...)
;; shift = (hex->dec "1000")
;; -> in ovp (CHARACTER H 1023 ... SETCHAR H 23 ...)
;; ovp-designsize (DESIGNSIZE ...)
;; pl-at (MAPFONT D 0 ...(FONTAT ...))
;;
(define (pl->ovp pl-filename ovp-filename shift ovp-designsize pl-at)
(letrec ((ifnb (basename pl-filename ".pl"))
(ofnb (basename ovp-filename ".ovp"))
(ifn (string-append ifnb ".pl"))
(ofn (string-append ofnb ".ovp"))
(inf (open-input-file ifn))
(outf (open-output-file ofn)))
(pl-read-header inf outf ovp-designsize)
(ovp-write-font-mapping outf
ifnb
pl-at
pl-fontdsize)
(pl-read-character inf outf shift)
(close-input-port inf)
(close-output-port outf)))
; eof
|
