View of /lisp/test/searchprim.l

Parent Directory

Revision Log

change to CVS wadalab font project

(defun kanjisym ((oblist (oblist)))
  (do ((l oblist (cdr l))(ret))
    ((atom l)ret)
    (cond ((or (plusp (logand 128 (sref (car l) 0)))
	       (and (= (string-length (car l)) 7)
		    (string-equal "1-" (substring (car l) 0 2))))
	   (push (car l) ret)))))
(defun sortkanji (l)
  (sort l 'string-lessp))

(setq primvec (vector 100))
(defun make-primlist ()
  (do ((l (sortkanji (kanjisym (oblist))) (cdr l))(sym)(val)(ret))
    ((atom l)(setq kanjiprim ret))
    (setq sym (car l))
    (cond ((and (boundp sym)
		(or
		 (stringp (setq val (eval sym)))
		 (and (consp val)
		      (or
		       (stringp (car val))
		       (consp (car val))))))
	   (setq aprim (applykanji sym))
	   (setq ellen (length (cadr aprim)))
	   (vset primvec ellen `(,sym .,(vref primvec ellen)))))))
(make-primlist)
(setq ellist 
      '(tate yoko hidari tasuki migi tatehidari tatehane 
	     tsukurihane kokoro sanzui migiue ten kozato 
	     magaritate kagi shin-nyuu))
(defun elgt (x y)
  (> (length (member x ellist))(length (member y ellist))))

(defun searchprim (elements)
  (lets ((ellen (length elements))
	 (el1 (sort elements #'elgt)))
    (do ((l (vref primvec ellen) (cdr l))(ret)(aprim))
      ((atom l)(nreverse ret))
      (setq aprim (applykanji (car l)))
      (setq el2 (sort (mapcar (cadr aprim) #'(lambda (x)(car x))) #'elgt))
      (and (equal el1 el2) (push (car l) ret)))))

(defun jointkanji ()
  (do ((l (kanjisym (oblist)) (cdr l))(ret))
    ((atom l)ret)
    (and (get (car l) 'mincho-patch)(push (car l) ret))))