[wadalabfont-kit] / lisp / test / toukei.l  

Annotation of /lisp/test/toukei.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 (defun allprim ((all (oblist)))
2 :     (do ((l all (cdr l))
3 :     (tmp)
4 :     (ret))
5 :     ((atom l)ret)
6 :     (and (0< (logand 128 (sref (car l) 0)))
7 :     (boundp (car l))
8 :     (consp (setq tmp (eval (car l))))
9 :     (consp (car tmp))
10 :     (push (car l) ret))))
11 :    
12 :     (defun allkanjiprim ((all (oblist)))
13 :     (do ((l all (cdr l))
14 :     (tmp)
15 :     (ret))
16 :     ((atom l)ret)
17 :     (and (0< (logand 128 (sref (car l) 0)))
18 :     (or (greaterp (string-length (car l)) 2)
19 :     (< 47 (logand 127 (sref (car l) 0))))
20 :     (boundp (car l))
21 :     (consp (setq tmp (eval (car l))))
22 :     (consp (car tmp))
23 :     (push (car l) ret))))
24 :     (defun allprimkanji ((all (oblist)))
25 :     (do ((l all (cdr l))
26 :     (tmp)
27 :     (ret))
28 :     ((atom l)ret)
29 :     (and (equal (string-length (car l)) 2)
30 :     (< (plus 47 128)(sref (car l) 0))
31 :     (push (car l) ret))))
32 :    
33 :     ; º¸Ê§¤¤, ±¦Ê§¤¤Åù¤ÎÅý·×¤ò¤È¤ë.
34 :     ;
35 :     (defun toukei3 (list type)
36 :     (do ((l list (cdr l))
37 :     (points)(elements)
38 :     (ret nil))
39 :     ((atom l)ret)
40 :     (setq val (eval (car l)))
41 :     (setq points (car val) elements (cadr val))
42 :     (do ((ll elements (cdr ll))
43 :     (plist)(p0)(p1)(p2)(diff0)(diff1)(len0)(len1))
44 :     ((atom ll))
45 :     (cond ((eq (caar ll) type)
46 :     (setq plist (cadar ll))
47 :     (setq p0 (nth (first plist) points))
48 :     (setq p1 (nth (second plist) points))
49 :     (setq p2 (nth (third plist) points))
50 :     (setq diff0 (diff2 p1 p0) diff1 (diff2 p2 p1))
51 :     (setq len0 (length2 diff0) len1 (length2 diff1))
52 :     (push `(,(quotient len1 len0)
53 :     .,(theta diff0 diff1))
54 :     ret))))))
55 :     ;
56 :     (defun findpairmax (list)
57 :     (do ((l (cdr list) (cdr l))
58 :     (max0 (caar list))
59 :     (min0 (caar list))
60 :     (max1 (cdar list))
61 :     (min1 (cdar list))
62 :     (val0)(val1))
63 :     ((atom l)`(,min0 ,min1 ,max0 ,max1))
64 :     (setq val0 (caar l) val1 (cdar l))
65 :     (cond ((lessp val0 min0)(setq min0 val0))
66 :     ((greaterp val0 max0)(setq max0 val0)))
67 :     (cond ((lessp val1 min1)(setq min1 val1))
68 :     ((greaterp val1 max1)(setq max1 val1)))))
69 :     ;
70 :     (defun makegraph (filename list maxabs)
71 :     (let ((standard-output (outopen (stream filename))))
72 :     (format "%!/n")
73 :     (format "0 setlinewidth/n")
74 :     (format "72 72 scale 4 5 translate 0.001 0.001 scale/n")
75 :     (format "newpath -3000 0 moveto 3000 0 lineto stroke/n")
76 :     (format "newpath 0 -3000 moveto 0 3000 lineto stroke/n")
77 :     (do ((l list (cdr l))
78 :     (x)(y))
79 :     ((atom l))
80 :     (setq x (fix (times 1000 (caar l))))
81 :     (setq y (fix (times 1000 (cdar l))))
82 :     (format "newpath /c /c moveto/n" (- x 3)(- y 3))
83 :     (format "6 0 rlineto 0 6 rlineto -6 0 rlineto closepath fill/n"))
84 :     (format "showpage")))
85 :     ;
86 :     (defun make-pair (prim)
87 :     (lets ((eprim (applykanji 'prim)))
88 :     `(,(length (car eprim)) ,(length (cadr eprim)) ,prim)))
89 :     ;
90 :     (defun average (list)
91 :     (do ((l list (cdr l))
92 :     (sum 0.0)
93 :     (i 0 (1+ i)))
94 :     ((atom l)(//$ sum (float i)))
95 :     (setq sum (plus sum (float (car l))))))
96 :     ;
97 :     (defun gmax (list (getfunc 'car) (compfunc 'lessp))
98 :     (do ((l list (cdr l))
99 :     (maxl)(maxv))
100 :     ((atom l)maxl)
101 :     (cond ((or (null maxv) (funcall compfunc maxv
102 :     (funcall getfunc (car l))))
103 :     (setq maxv (funcall getfunc (car l)))
104 :     (setq maxl (ncons (car l))))
105 :     ((equal maxv(funcall getfunc (car l)))
106 :     (push (car l) maxl)))))
107 :     ;
108 :     (defun carmin (list)
109 :     (do ((l list (cdr l))
110 :     (min))
111 :     ((atom l)min)
112 :     (cond ((or (null min) (greaterp (car min) (car (car l))))
113 :     (setq min (car l))))))
114 :     ;
115 :     (defun cadrmax (list)
116 :     (do ((l list (cdr l))
117 :     (max))
118 :     ((atom l)max)
119 :     (cond ((or (null max) (lessp (cadr max) (cadr (car l))))
120 :     (setq max (car l))))))
121 :     ;
122 :     (defun cadrmin (list)
123 :     (do ((l list (cdr l))
124 :     (min))
125 :     ((atom l)min)
126 :     (cond ((or (null min) (greaterp (cadr min) (cadr (car l))))
127 :     (setq min (car l))))))
128 :     ;
129 :     (defun number-of-primitive (kanji)
130 :     (and (symbolp kanji)(setq kanji (eval kanji)))
131 :     (cond ((atom kanji) 0)
132 :     ((consp (car kanji)) 1) ; primitive itself
133 :     (t
134 :     (do ((l (cdr kanji)(cdr l))(ret 0))
135 :     ((atom l)ret)
136 :     (setq ret (plus ret (number-of-primitive (car l))))))))
137 :     ;
138 :     (defun number-of-element (kanji)
139 :     (and (symbolp kanji)(setq kanji (eval kanji)))
140 :     (cond ((atom kanji) 0)
141 :     ((consp (car kanji)) (length (cadr kanji))) ; primitive itself
142 :     (t
143 :     (do ((l (cdr kanji)(cdr l))(ret 0))
144 :     ((atom l)ret)
145 :     (setq ret (plus ret (number-of-element (car l))))))))
146 :     ;
147 :     (defun checkeach (list func)
148 :     (do ((l list (cdr l))(c 0 (1+ c))(s 0))
149 :     ((atom l)(list s (//$ (float s)(float c))))
150 :     (setq s (plus s (funcall func (car l))))))
151 :     ;
152 :     (defun jis3-ku (kustr)
153 :     (do ((i 1 (1+ i))
154 :     (dig2 (make-string 2))
155 :     (ret))
156 :     ((> i 94)(nreverse ret))
157 :     (sset dig2 0 (+ 48 (quotient i 10)))
158 :     (sset dig2 1 (+ 48 (remainder i 10)))
159 :     (push (intern (symbol (string-append "1-" kustr "-" dig2))) ret)))
160 :     ;
161 :     (defun allkanji ()
162 :     (lets ((ret))
163 :     (do ((i #x30 (1+ i)))
164 :     ((greaterp i #x4e))
165 :     (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
166 :     ((greaterp j #x7e))
167 :     (sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
168 :     (push (intern (symbol str)) ret)))
169 :     (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
170 :     ((greaterp j #x53))
171 :     (sset str 0 (logor #x80 #x4f))(sset str 1 (logor #x80 j))
172 :     (push (intern (symbol str)) ret))
173 :     (do ((i #x50 (1+ i)))
174 :     ((greaterp i #x73))
175 :     (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
176 :     ((greaterp j #x7e))
177 :     (sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
178 :     (push (intern (symbol str)) ret)))
179 :     (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
180 :     ((greaterp j #x24))
181 :     (sset str 0 (logor #x80 #x74))(sset str 1 (logor #x80 j))
182 :     (push (intern (symbol str)) ret))
183 :     (push '£Ê£µ ret)
184 :     (push '£Ê£¶ ret)
185 :     (nreverse ret)))
186 :     ;
187 :     (defun elnum (x)
188 :     (lets ((sym (cadr x))
189 :     (body (cadr (caddr x)))
190 :     (points (car body))
191 :     (elements (cadr body))
192 :     (outline-mincho (skelton2list (applykanji body 'mincho-patch) 'mincho-patch))
193 :     (outline-gothic (skelton2list (applykanji body 'gothic) 'gothic)))
194 :     (format "((sym /c)(points /c)(elements /c)(min-points /c)(min-elements /c)(goth-points /c)(goth-elements /c))/n"
195 :     sym (length points)(length elements)
196 :     (outpoints outline-mincho)(outelements outline-mincho)
197 :     (outpoints outline-gothic)(outelements outline-gothic))))
198 :     (defun outpoints(x)
199 :     (do ((l x (cdr l))
200 :     (ret 0))
201 :     ((atom l)ret)
202 :     (setq ret (plus ret (length (car l))))))
203 :     (defun outelements(x)
204 :     ; (prind x)
205 :     (do ((l x (cdr l))
206 :     (ret 0))
207 :     ((atom l)ret)
208 :     (do ((ll (car l)(cdr ll)))
209 :     ((atom ll))
210 :     (and (eq (caar ll) 'angle)(setq ret (1+ ret))))))
211 :     (defun elnumfile (filename)
212 :     (let ((s (inopen (stream filename)))
213 :     (err:end-of-file #'(lambda (x (y))(throw 'eof))))
214 :     (catch 'eof
215 :     (loop
216 :     (elnum (read s))))))
217 :     (defun elnumfiles (outfile infiles)
218 :     (let ((standard-output (outopen (stream outfile))))
219 :     (do ((l infiles (cdr l)))
220 :     ((atom l)(close standard-output))
221 :     (elnumfile (car l)))))
222 :    
223 :     (defun elnumtest()
224 :     (elnumfiles "/rmnt/tomo.home/kanji/tmp/toukei9.l"
225 :     '(
226 :     "/rmnt/tomo.home/kanji/tmp/exp8.l"
227 :     "/rmnt/tomo.home/kanji/tmp/expand9.l"
228 :     "/rmnt/tomo.home/kanji/tmp/expand10.l"
229 :     "/rmnt/tomo.home/kanji/tmp/expand11.l"
230 :     "/rmnt/tomo.home/kanji/tmp/expand12.l")))
231 :     (defun toukeifile (filename)
232 :     (lets ((s (inopen (stream filename)))
233 :     (err:end-of-file
234 :     #'(lambda (x (y))
235 :     (throw 'eof
236 :     `(,points ,elements ,min-points ,min-elements
237 :     ,goth-points ,goth-elements))))
238 :     (points 0)(elements 0)(min-points 0)(min-elements 0)
239 :     (goth-points 0)(goth-elements 0)(x))
240 :     (catch 'eof
241 :     (loop
242 :     (setq x (read s))
243 :     (setq points (plus points (cadr (assq 'points x))))
244 :     (setq elements (plus elements (cadr (assq 'elements x))))
245 :     (setq min-points (plus min-points (cadr (assq 'min-points x))))
246 :     (setq min-elements (plus min-elements (cadr (assq 'min-elements x))))
247 :     (setq goth-points (plus goth-points (cadr (assq 'goth-points x))))
248 :     (setq goth-elements (plus goth-elements (cadr (assq 'goth-elements x))))))))
249 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help