Annotation of /lisp/test/searchprim.lAnnotation of /lisp/test/searchprim.l
Parent Directory
| 
Revision Log
Revision: 1.1.1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | (defun kanjisym ((oblist (oblist))) |
| 2 : | (do ((l oblist (cdr l))(ret)) | ||
| 3 : | ((atom l)ret) | ||
| 4 : | (cond ((or (plusp (logand 128 (sref (car l) 0))) | ||
| 5 : | (and (= (string-length (car l)) 7) | ||
| 6 : | (string-equal "1-" (substring (car l) 0 2)))) | ||
| 7 : | (push (car l) ret))))) | ||
| 8 : | (defun sortkanji (l) | ||
| 9 : | (sort l 'string-lessp)) | ||
| 10 : | |||
| 11 : | (setq primvec (vector 100)) | ||
| 12 : | (defun make-primlist () | ||
| 13 : | (do ((l (sortkanji (kanjisym (oblist))) (cdr l))(sym)(val)(ret)) | ||
| 14 : | ((atom l)(setq kanjiprim ret)) | ||
| 15 : | (setq sym (car l)) | ||
| 16 : | (cond ((and (boundp sym) | ||
| 17 : | (or | ||
| 18 : | (stringp (setq val (eval sym))) | ||
| 19 : | (and (consp val) | ||
| 20 : | (or | ||
| 21 : | (stringp (car val)) | ||
| 22 : | (consp (car val)))))) | ||
| 23 : | (setq aprim (applykanji sym)) | ||
| 24 : | (setq ellen (length (cadr aprim))) | ||
| 25 : | (vset primvec ellen `(,sym .,(vref primvec ellen))))))) | ||
| 26 : | (make-primlist) | ||
| 27 : | (setq ellist | ||
| 28 : | '(tate yoko hidari tasuki migi tatehidari tatehane | ||
| 29 : | tsukurihane kokoro sanzui migiue ten kozato | ||
| 30 : | magaritate kagi shin-nyuu)) | ||
| 31 : | (defun elgt (x y) | ||
| 32 : | (> (length (member x ellist))(length (member y ellist)))) | ||
| 33 : | |||
| 34 : | (defun searchprim (elements) | ||
| 35 : | (lets ((ellen (length elements)) | ||
| 36 : | (el1 (sort elements #'elgt))) | ||
| 37 : | (do ((l (vref primvec ellen) (cdr l))(ret)(aprim)) | ||
| 38 : | ((atom l)(nreverse ret)) | ||
| 39 : | (setq aprim (applykanji (car l))) | ||
| 40 : | (setq el2 (sort (mapcar (cadr aprim) #'(lambda (x)(car x))) #'elgt)) | ||
| 41 : | (and (equal el1 el2) (push (car l) ret))))) | ||
| 42 : | |||
| 43 : | (defun jointkanji () | ||
| 44 : | (do ((l (kanjisym (oblist)) (cdr l))(ret)) | ||
| 45 : | ((atom l)ret) | ||
| 46 : | (and (get (car l) 'mincho-patch)(push (car l) ret)))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |