View of /lisp/skeledit.l

Parent Directory

Revision Log

change to CVS wadalab font project

(cond ((definedp 'init_window))
      (t (code-load "/home/misa/kanji/lib/window.o" "-lX11")))
;(exfile (string-append system_lib_path "lisplib/readmacro.l"))
;(cond ((definedp 'init_window))
;      (t (exfile "/home/misa/kanji/lib/new/window.l")))
;(defun readsharp ()
;  (let ((r (read)))
;    (cond ((listp r)(vector (length r) r))
;	  ((symbolp r)(character r))
;	  (t r))))
;(readmacro 35 'readsharp)

(declare (marksize marksize1 linknumber linkpoints partlist nolinkpoints) special)
(declare (linkthresh) special)
(setq marksize 3 marksize1 3)
(defun sankaku (x y)
  (drawline x (- y marksize1)(+ x marksize)(+ y marksize1))
  (drawline x (- y marksize1)(- x marksize)(+ y marksize1))
  (drawline (+ x marksize)(+ y marksize1)(- x marksize)(+ y marksize1)))
(defun shikaku (x y)
  (drawline (- x marksize)(- y marksize)(+ x marksize)(- y marksize))
  (drawline (+ x marksize)(- y marksize)(+ x marksize)(+ y marksize))
  (drawline (+ x marksize)(+ y marksize)(- x marksize)(+ y marksize))
  (drawline (- x marksize)(+ y marksize)(- x marksize)(- y marksize)))

(defun hex2 (l)
  (string-append (string (sref "0123456789abcdef" (logand 15 (logshift l -4))))
		 (string (sref "0123456789abcdef" (logand 15 l)))))
(defun setlinkpoint (x y)
  (push (list 'link linknumber x y) linkpoints)
  (setq linknumber (1+ linknumber)))

(defun metric (x0 y0 x y)
  (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y))))

(defun bestlink (x y)
  (do ((min 1000000)
       (ret nil)
       (met nil)
       (l linkpoints (cdr l)))
      ((atom l)(cond (ret)
		     (t (push (list 'link linknumber x y) linkpoints)
			(car linkpoints))))
      (setq met (metric x y (caddr (car l))(cadddr (car l))))
      (cond ((< met min)
	     (setq ret (car l) min met)))))

(defun bestpoint (x y)
  (lets ((min 1000000)
	 (ret nil)
	 (met nil))
	(do ((l linkpoints (cdr l))(met nil))
	    ((atom l))
	    (setq met (metric x y (caddr (car l))(cadddr (car l))))
	    (cond ((< met min)
		   (setq ret (car l) min met))))
	(do ((l partlist (cdr l)))
	    ((atom l))
	    (do ((ll (cdar l)(cdr ll)))
		((atom ll))
		(setq met (metric x y (point-x (car ll))(point-y (car ll))))
		(cond ((< met min)
		       (setq ret (car ll) min met)))))
	(cond ((eq 'link (car ret))(cddr ret))
	      (ret))))


(defun movepoint (fromx fromy tox toy)
  (cond ;((and (null partlist)linkpoints))
	(t
	 (let ((point (bestpoint fromx fromy)))
	   (rplaca point (+ (car point)(- tox fromx)))
	   (rplaca (cdr point)(+ (cadr point)(- toy fromy)))))))
(defun neighbor (point)
  (do ((l partlist (cdr l))
       (ret nil))
    ((atom l)ret)
    (do ((ll (cdar l)(cdr ll))
	 (last nil))
      ((atom (cdr ll)))
      (cond ((eq point (cddar ll))
	     (push (cddadr ll) ret))
	    ((eq point (cddadr ll))
	     (push (cddar ll) ret))))))
(defun yokosoroe ()
  (let ((event nil)
	(fromx nil)
	(fromy nil)
	(neighbor nil)
	(point nil))
    (loop
     (setq event (checkevent))
     (match event
       (('ButtonPress 'button1 x y)
	(setq fromx x fromy y)
	(exit))))
    (setq point (bestpoint fromx fromy))
    (setq neighbor (neighbor point))
    (do ((l neighbor (cdr l))
	 (miny 20)
	 (y fromy))
      ((atom l)(rplaca (cdr point)y))
      (cond ((> miny (abs (- fromy (cadr (car l)))))
	     (setq miny (abs (- fromy (cadr (car l)))))
	     (setq y (cadr (car l))))))))
(defun tatesoroe ()
  (let ((event nil)
	(fromx nil)
	(fromy nil)
	(neighbor nil)
	(point nil))
    (loop
     (setq event (checkevent))
     (match event
       (('ButtonPress 'button1 x y)
	(setq fromx x fromy y)
	(exit))))
    (setq point (bestpoint fromx fromy))
    (setq neighbor (neighbor point))
    (do ((l neighbor (cdr l))
	 (minx 20)
	 (x fromx))
      ((atom l)(rplaca point x))
      (cond ((> minx (abs (- fromx (car (car l)))))
	     (setq minx (abs (- fromx (car (car l)))))
	     (setq x (car (car l))))))))
(defun set-link ()
  (let ((event nil)
	(fromx nil)
	(fromy nil)
	(point nil))
    (loop
     (setq event (checkevent))
     (match event
       (('ButtonPress 'button1 x y)
	(setq fromx x fromy y)
	(exit))))
    (setq point (bestpoint fromx fromy))
    (cond ((memq point nolinkpoints)
	   (setq nolinkpoints (remq point nolinkpoints)))
	  (t (push point nolinkpoints)))))
(defun delete ()
  (let ((x nil)(y nil)(point nil))
    (do ((event (checkevent)(checkevent)))
	((eq (car event) 'ButtonPress)
	 (setq x (caddr event) y (cadddr event))))
    (setq point (bestpoint x y))))
    
(defun concat ()
  (let ((fromx nil)(fromy nil)(tox nil)(toy nil)(p0 nil)(p1 nil))
    (do ((event (checkevent)(checkevent)))
	()
	(match event
	       (('ButtonPress 'button1 x y)
		(setq fromx x fromy y)(exit))))
    (do ((event (checkevent)(checkevent)))
	()
	(match event
	       (('ButtonPress 'button1 x y)
		(setq tox x toy y)(exit))))
    (setq p0 (bestlink fromx fromy) p1 (bestlink tox toy))))
    
    

(defun newpart (sym)
  (push (ncons sym) partlist)
  (do ((i 0)
       (npoints (get sym 'npoint))
       (points nil)
       (event (checkevent)(checkevent)))
      ((>= i npoints))
      (match event
	     (('KeyPress #r)
	      (setq points nil)
	      (setq partlist (cons nil (cdr partlist)))
	      (setq i -1))
	     (('KeyPress #q)
	      (setq partlist (cdr partlist))
	      (exit))
	     (('ButtonPress 'button1 x y)
	      (push (bestlink x y)points)
	      (setq i (1+ i))))
      (setq partlist (cons (cons sym (reverse points)) (cdr partlist)))
      (disp)))

(defun point-x (l)
  (cond ((eq 'link (car l))
	 (caddr l))
	(t (car l))))

(defun point-y (l)
  (cond ((eq 'link (car l))
	 (cadddr l))
	(t (cadr l))))

(setq nolinkpoints nil)
(defun disp ()
  (copybg)
  (do ((l linkpoints (cdr l)))
      ((atom l))
      (cond ((memq (cddr (car l)) nolinkpoints)
	     (sankaku (caddr (car l))(cadddr (car l))))
	    (t
	     (shikaku (caddr (car l))(cadddr (car l))))))
  (do ((l partlist (cdr l)))
      ((atom l))
      (do ((ll (cdar l)(cdr ll))
	   (npoints (get (caar l) 'npoint))
	   (i 0 (1+ i)))
	  ((or (atom ll)(>= i npoints)))
	  (cond ((neq (caar ll) 'link)
		 (sankaku (caar ll)(cadar ll))))
	  (cond ((and (neq i (1- npoints))(cdr ll))
		 (drawline (point-x (car ll))(point-y (car ll))
			   (point-x (cadr ll))(point-y (cadr ll)))))))
  (redraw))

(defun skeledit (symbol (code)(fonttype 'mincho))
  (princ ";")
  (print (list symbol code))
  (init_window 400 400)
;  (cond (code
;	 (cond ((= 2 (string-length code))
;		(setq code (string-append (hex2 (logand 127 (sref code 0)))
;					  (hex2 (logand 127 (sref code 1)))))))
;	 (loadpbm (string-append "/home/misa/kanji/pbm/mincho/" code ".pbm"))))
  (cond (code
	 (cond ((= 2 (string-length code))
		(setq code (string-append (hex2 (logand 127 (sref code 0)))
					  (hex2 (logand 127 (sref code 1)))))))
	 (loadjis code)))
  (setq partlist nil)
  (setq linkpoints nil)
  (setq nolinkpoints nil)
  (setq linknumber 0)
  (do ((event (checkevent)(checkevent))
       (curx nil)(cury nil))
      ()
;      (print event)
      (match event
	     (('KeyPress code)
	      (selectq code
		       (#\t
			(do ((event (checkevent)(checkevent)))
			    ()
			    (match event
				   (('KeyPress #\s)(newpart 'tasuki)(exit))
				   (('KeyPress #\l)(newpart 'tatehidari)(exit))
				   (('KeyPress #\h)(newpart 'tatehane)(exit)))))
		       (#\k
			(do ((event (checkevent)(checkevent)))
			    ()
			    (match event
				   (('KeyPress #\z)(newpart 'kozato)(exit))
				   (('KeyPress #\k)(newpart 'kokoro)(exit))
				   (('KeyPress #\g)(newpart 'kagi)(exit)))))
		       (#\p (newpart 'ten))
		       (#\b (newpart 'tate))
		       (#\y (newpart 'yoko))
		       (#\u (newpart 'migiue))
		       (#\l (newpart 'hidari))
		       (#\r (newpart 'migi))
		       (#\h (newpart 'tsukurihane))
		       (#\s (newpart 'sanzui))
		       (#\m (newpart 'magaritate))
		       (#\n (newpart 'shin-nyuu))
		       (#\c (concat))
		       (#\q (close_window)
			   (prind `(setq ,symbol ',(convskelton1 (convskelton (add-link partlist)))))(exit))
;		       (#\r (reset))
		       (#\i (setq partlist nil linkpoints nil)
			   (setq  nolinkpoints nil linknumber 0))
		       (#\f (set-link))
		       (#\x (yokosoroe))
		       (#\z (tatesoroe))
		       (#\d (showfill fonttype))
		       (#\d (delete))))
	     (('ButtonPress 'button1 x y)
	      (setlinkpoint x y))
	     (('ButtonPress 'button2 x y)
	      (setq curx x cury y))
	     (('ButtonRelease 'button2 x y)
	      (movepoint curx cury x y)))
      (disp)))
(defun showfill (fonttype)
  (fill1 (convskelton1 (convskelton (add-link partlist))) fonttype))
(defun fill1 (l tag)
  (let ((outline nil))
    (setq outline (skelton2list (applykanji l) tag))
    (mapcar outline '(lambda (x)(fillpolygon (setpart1 x))))
    (redraw)
    (checkevent)))

;(print (list (vref readtable 35)(vref macrotable 35)))

(defprop ten 2 npoint)
(defprop tate 2 npoint)
(defprop yoko 2 npoint)
(defprop migiue 3 npoint)
(defprop hidari 3 npoint)
(defprop tatehidari 4 npoint)
(defprop migi 3 npoint)
(defprop kozato 3 npoint)
(defprop tatehane 3 npoint)
(defprop tsukurihane 4 npoint)
(defprop sanzui 2 npoint)
(defprop kokoro 4 npoint)
(defprop tasuki 4 npoint)
(defprop magaritate 3 npoint)
(defprop kagi 3 npoint)
(defprop shin-nyuu 3 npoint)

(defun convskelton (prim)
  (let ((linkpoints nil)
	(points nil)
	(linkcount 0)
	(p nil)(as nil)(pp nil)
	(lines nil))
    (do ((l prim (cdr l)))
      ((atom l)
       `(,(nreverse points) ,(nreverse lines) nil nil))
      (do ((ll (cdar l)(cdr ll))
	   (line nil)
	   (link nil)
	   (pointnmb 0)
	   (i 0 (1+ i))
	   (npoints (get (caar l) 'npoint)))
	((atom ll)
;	 (print link)
	 (push (cons (caar l)(cons (nreverse line) (nreverse link))) lines))
	(setq p (car ll))
	(cond ((eq 'link (car p))
	       (setq as (assq (cadr p) linkpoints))
	       (cond ((null as)
		      (push (cons (cadr p) linkcount) linkpoints)
		      (setq pointnmb linkcount)
		      (cond ((null (cddr p))
			     (push nil points))
			    (t
			     (push (cons (caddr p)(cadddr p)) points)))
		      (setq linkcount (1+ linkcount)))
		     (t
		      (setq pointnmb (cdr as))
		      (setq pp (nthcdr (- linkcount pointnmb 1) points))
		      (cond ((and (cddr p)(null (car pp)))
			     (rplaca pp (cons (caddr p)(cadddr p))))))))
	      (t
	       (setq pointnmb linkcount)
	       (push (cons (car p)(cadr p))points)
	       (setq linkcount (1+ linkcount))))
	(cond ((>= i npoints)
	       (push pointnmb link)
;	       (print link)
	       )
	      (t
	       (push pointnmb line)))))))

(defun convskelton1(prim)
  (cond 
   ((atom prim)prim)
   (t
    (lets ((points (car prim))
	   (lines (cadr prim))
	   (alist (caddr prim))
	   (newpoints nil)
	   (newlines nil))
      (do ((l points (cdr l)))
	((atom l))
	(push (list (caar l)(cdar l)) newpoints))
      (do ((l lines (cdr l))
	   (line nil))
	((atom l)`(,(nreverse newpoints) ,(nreverse newlines) .,alist))
	(setq line (car l))
	(cond ((cddr line)
	       (push `(,(car line),(cadr line)(link .,(cddr line))) newlines))
	      (t
	       (push line newlines))))))))
(setq linkthresh 10.0)
(defun add-link (body)
  (lets ((newbody nil)
	 (linkpoints nil)
	 (pointhist (make-hist body))
	 (tmpdist nil)
	 (kouho (find-kouho body pointhist)))
	(setq linkpoints nil)
	(do ((l kouho (cdr l))
	     (curpoint nil)
	     (ret nil))
	    ((atom l)
	     (do ((ll body (cdr ll)))
		 ((atom ll)(setq body (reverse newbody)))
;		 (print (car ll))
		 (do ((lll ret (cdr lll))
		      (newline nil))
		     ((atom lll)
		      (push (append (car ll)newline) newbody)
;		      (print newbody)
		      )
		     (cond ((eq (cdar lll)(car ll))
			    (push (caar lll) newline))))))
	    (setq curpoint (car l))
	    (do ((ll body (cdr ll))
		 (curlink nil)
		 (minlink nil)
		 (mindist 1000.0))
		((atom ll)
		 (cond ((<$ mindist linkthresh)
			(push (cons curpoint minlink) ret))))
		(setq curlink (car ll))
;		(print curlink)
		(cond ((member-point curpoint curlink))
		      (t
		       (do ((lll (cdr curlink) (cdr lll)))
			   ((atom (cdr lll)))
			   (setq tmpdist (calcdist-old curpoint (car lll)(cadr lll)))
;			   (print tmpdist)
			   (cond ((<$ tmpdist mindist)
				  (setq mindist tmpdist)
				  (setq minlink curlink))))))))))

(defun member-point (point link)
  (cond ((atom link)nil)
	((eq point (car link))t)
	((member-point point (cdr link)))))

(defun difffloat2-old (a b)
  (list (-$ (float(point-x a))(float (point-x b)))
	(-$ (float(point-y a))(float(point-y b)))))

(defun calcdist-old (point p0 p1)
  (lets ((v0 (difffloat2-old p1 p0))
	 (len0 (length2 v0))
	 (v1 (difffloat2-old point p0))
	 (len1 (length2 v1))
	 (naiseki (mul2 v0 v1))
	 (len2 (//$ naiseki len0))
	 (v3 (normlen2 len2 v0)))
;	(prind (list v0 len0 v1 len1 naiseki len2 v3))
	(cond ((<=$ 0.0 len2 len0)(length2 (diff2 v3 v1)))
	      (t 1000.0))))

(defun make-hist (x)
  (do ((l x (cdr l))
       (alist nil))
      ((atom l)alist)
      (do ((ll (cdar l) (cdr ll))
	   (pnumber nil)
	   (ptr nil))
	  ((atom ll))
	  (setq pnumber (cadar ll))
	  (setq ptr (assq pnumber alist))
	  (cond (ptr (rplacd ptr (1+ (cdr ptr))))
		(t (push (cons pnumber 1) alist))))))

(defun find-kouho (x hist)
  (do ((l x (cdr l))
       (npoint nil)
       (ret nil))
      ((atom l)ret)
      (setq npoint (get (caar l) 'npoint))
      (cond ((and (= 1 (cdr (assq (cadr (cadar l)) hist)))
		  (not (memq (cddr (cadar l)) nolinkpoints)))
;	     (prind (cadar l))
	     (push (cadar l) ret)))
      (cond ((and(= 1 (cdr (assq (cadar (last (car l))) hist)))
		 (not (memq (cddr (car (last (car l)))) nolinkpoints)))
;	     (prind (car (last (car l))))
	     (push (car (last (car l))) ret)))))

;(exfile 'disp.l)
;(exfile 'mincho.l)
;(exfile 'lib.l)