View of /lisp/test/toukei.l

Parent Directory

Revision Log

change to CVS wadalab font project

(defun allprim ((all (oblist)))
  (do ((l all (cdr l))
       (tmp)
       (ret))
    ((atom l)ret)
    (and (0< (logand 128 (sref (car l) 0)))
	 (boundp (car l))
	 (consp (setq tmp (eval (car l))))
	 (consp (car tmp))
	 (push (car l) ret))))

(defun allkanjiprim ((all (oblist)))
  (do ((l all (cdr l))
       (tmp)
       (ret))
    ((atom l)ret)
    (and (0< (logand 128 (sref (car l) 0)))
	 (or (greaterp (string-length (car l)) 2)
	     (< 47 (logand 127 (sref (car l) 0))))
	 (boundp (car l))
	 (consp (setq tmp (eval (car l))))
	 (consp (car tmp))
	 (push (car l) ret))))
(defun allprimkanji ((all (oblist)))
  (do ((l all (cdr l))
       (tmp)
       (ret))
    ((atom l)ret)
    (and (equal (string-length (car l)) 2)
	 (< (plus 47 128)(sref (car l) 0))
	 (push (car l) ret))))

; º¸Ê§¤¤, ±¦Ê§¤¤Åù¤ÎÅý·×¤ò¤È¤ë. 
;
(defun toukei3 (list type)
  (do ((l list (cdr l))
       (points)(elements)
       (ret nil))
    ((atom l)ret)
    (setq val (eval (car l)))
    (setq points (car val) elements (cadr val))
    (do ((ll elements (cdr ll))
	 (plist)(p0)(p1)(p2)(diff0)(diff1)(len0)(len1))
      ((atom ll))
      (cond ((eq (caar ll) type)
	     (setq plist (cadar ll))
	     (setq p0 (nth (first plist) points))
	     (setq p1 (nth (second plist) points))
	     (setq p2 (nth (third plist) points))
	     (setq diff0 (diff2 p1 p0) diff1 (diff2 p2 p1))
	     (setq len0 (length2 diff0) len1 (length2 diff1))
	     (push `(,(quotient len1 len0)
		     .,(theta diff0 diff1))
		   ret))))))
;
(defun findpairmax (list)
  (do ((l (cdr list) (cdr l))
       (max0 (caar list))
       (min0 (caar list))
       (max1 (cdar list))
       (min1 (cdar list))
       (val0)(val1))
    ((atom l)`(,min0 ,min1 ,max0 ,max1))
    (setq val0 (caar l) val1 (cdar l))
    (cond ((lessp val0 min0)(setq min0 val0))
	  ((greaterp val0 max0)(setq max0 val0)))
    (cond ((lessp val1 min1)(setq min1 val1))
	  ((greaterp val1 max1)(setq max1 val1)))))
;
(defun makegraph (filename list maxabs)
  (let ((standard-output (outopen (stream filename))))
    (format "%!/n")
    (format "0 setlinewidth/n")
    (format "72 72 scale 4 5 translate 0.001 0.001 scale/n")
    (format "newpath -3000 0 moveto 3000 0 lineto stroke/n")
    (format "newpath 0 -3000 moveto 0 3000 lineto stroke/n")
    (do ((l list (cdr l))
	 (x)(y))
      ((atom l))
      (setq x (fix (times 1000 (caar l))))
      (setq y (fix (times 1000 (cdar l))))
      (format "newpath /c /c moveto/n" (- x 3)(- y 3))
      (format "6 0 rlineto 0 6 rlineto -6 0 rlineto closepath fill/n"))
    (format "showpage")))
;
(defun make-pair (prim)
  (lets ((eprim (applykanji 'prim)))
    `(,(length (car eprim)) ,(length (cadr eprim)) ,prim)))
;
(defun average (list)
  (do ((l list (cdr l))
       (sum 0.0)
       (i 0 (1+ i)))
    ((atom l)(//$ sum (float i)))
    (setq sum (plus sum (float (car l))))))
;
(defun gmax (list (getfunc 'car) (compfunc 'lessp))
  (do ((l list (cdr l))
       (maxl)(maxv))
    ((atom l)maxl)
    (cond ((or (null maxv) (funcall compfunc maxv
				   (funcall getfunc (car l))))
	   (setq maxv (funcall getfunc (car l)))
	   (setq maxl (ncons (car l))))
	  ((equal maxv(funcall getfunc (car l)))
	   (push (car l) maxl)))))
;
(defun carmin (list)
  (do ((l list (cdr l))
       (min))
    ((atom l)min)
    (cond ((or (null min) (greaterp (car min) (car (car l))))
	   (setq min (car l))))))
;
(defun cadrmax (list)
  (do ((l list (cdr l))
       (max))
    ((atom l)max)
    (cond ((or (null max) (lessp (cadr max) (cadr (car l))))
	   (setq max (car l))))))
;
(defun cadrmin (list)
  (do ((l list (cdr l))
       (min))
    ((atom l)min)
    (cond ((or (null min) (greaterp (cadr min) (cadr (car l))))
	   (setq min (car l))))))
;
(defun number-of-primitive (kanji)
  (and (symbolp kanji)(setq kanji (eval kanji)))
  (cond ((atom kanji) 0)
	((consp (car kanji)) 1) ; primitive itself
	(t
	 (do ((l (cdr kanji)(cdr l))(ret 0))
	   ((atom l)ret)
	   (setq ret (plus ret (number-of-primitive (car l))))))))
;
(defun number-of-element (kanji)
  (and (symbolp kanji)(setq kanji (eval kanji)))
  (cond ((atom kanji) 0)
	((consp (car kanji)) (length (cadr kanji))) ; primitive itself
	(t
	 (do ((l (cdr kanji)(cdr l))(ret 0))
	   ((atom l)ret)
	   (setq ret (plus ret (number-of-element (car l))))))))
;
(defun checkeach (list func)
  (do ((l list (cdr l))(c 0 (1+ c))(s 0))
    ((atom l)(list s (//$ (float s)(float c))))
    (setq s (plus s (funcall func (car l))))))
;
(defun jis3-ku (kustr)
  (do ((i 1 (1+ i))
       (dig2 (make-string 2))
       (ret))
    ((> i 94)(nreverse ret))
    (sset dig2 0 (+ 48 (quotient i 10)))
    (sset dig2 1 (+ 48 (remainder i 10)))
    (push (intern (symbol (string-append "1-" kustr "-" dig2))) ret)))
;
(defun allkanji ()
  (lets ((ret))
    (do ((i #x30 (1+ i)))
      ((greaterp i #x4e))
      (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
	((greaterp j #x7e))
	(sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
	(push (intern (symbol str)) ret)))
    (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
      ((greaterp j #x53))
      (sset str 0 (logor #x80 #x4f))(sset str 1 (logor #x80 j))
      (push (intern (symbol str)) ret))
    (do ((i #x50 (1+ i)))
      ((greaterp i #x73))
      (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
	((greaterp j #x7e))
	(sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
	(push (intern (symbol str)) ret)))
    (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
      ((greaterp j #x24))
      (sset str 0 (logor #x80 #x74))(sset str 1 (logor #x80 j))
      (push (intern (symbol str)) ret))
    (push '£Ê£µ ret)
    (push '£Ê£¶ ret)
    (nreverse ret)))
;
(defun elnum (x)
  (lets ((sym (cadr x))
	 (body (cadr (caddr x)))
	 (points (car body))
	 (elements (cadr body))
	 (outline-mincho (skelton2list (applykanji body 'mincho-patch) 'mincho-patch))
	 (outline-gothic (skelton2list (applykanji body 'gothic) 'gothic)))
    (format "((sym /c)(points /c)(elements /c)(min-points /c)(min-elements /c)(goth-points /c)(goth-elements /c))/n"
	    sym (length points)(length elements)
	    (outpoints outline-mincho)(outelements outline-mincho)
	    (outpoints outline-gothic)(outelements outline-gothic))))
(defun outpoints(x)
  (do ((l x (cdr l))
       (ret 0))
    ((atom l)ret)
    (setq ret (plus ret (length (car l))))))
(defun outelements(x)
;  (prind x)
  (do ((l x (cdr l))
       (ret 0))
    ((atom l)ret)
    (do ((ll (car l)(cdr ll)))
      ((atom ll))
      (and (eq (caar ll) 'angle)(setq ret (1+ ret))))))
(defun elnumfile (filename)
  (let ((s (inopen (stream filename)))
	(err:end-of-file #'(lambda (x (y))(throw 'eof))))
    (catch 'eof 
       (loop 
	(elnum (read s))))))
(defun elnumfiles (outfile infiles)
  (let ((standard-output (outopen (stream outfile))))
    (do ((l infiles (cdr l)))
      ((atom l)(close standard-output))
      (elnumfile (car l)))))

(defun elnumtest()
  (elnumfiles "/rmnt/tomo.home/kanji/tmp/toukei9.l" 
	      '(
		"/rmnt/tomo.home/kanji/tmp/exp8.l"
		"/rmnt/tomo.home/kanji/tmp/expand9.l"
		"/rmnt/tomo.home/kanji/tmp/expand10.l"
		"/rmnt/tomo.home/kanji/tmp/expand11.l"
		"/rmnt/tomo.home/kanji/tmp/expand12.l")))
(defun toukeifile (filename)
  (lets ((s (inopen (stream filename)))
	 (err:end-of-file 
	  #'(lambda (x (y))
	      (throw 'eof
		     `(,points ,elements ,min-points ,min-elements
				   ,goth-points ,goth-elements))))
	 (points 0)(elements 0)(min-points 0)(min-elements 0)
	 (goth-points 0)(goth-elements 0)(x))
    (catch 'eof 
       (loop 
	(setq x (read s))
	(setq points (plus points (cadr (assq 'points x))))
	(setq elements (plus elements (cadr (assq 'elements x))))
	(setq min-points (plus min-points (cadr (assq 'min-points x))))
	(setq min-elements (plus min-elements (cadr (assq 'min-elements x))))
	(setq goth-points (plus goth-points (cadr (assq 'goth-points x))))
	(setq goth-elements (plus goth-elements (cadr (assq 'goth-elements x))))))))