View of /lisp/newedit.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")))
(defun readsharp ()
  (let ((r (read)))
    (cond ((listp r)(vector (length r) r))
	  ((symbolp r)(character r))
	  (t r))))
(readmacro 35 'readsharp)
(defun bez (x0 y0 x1 y1 x2 y2 x3 y3)
  (let ((maxx (max x0 x1 x2 x3))
	(maxy (max y0 y1 y2 y3))
	(minx (min x0 x1 x2 x3))
	(miny (min y0 y1 y2 y3))
	(tempx 0)(tempy 0))
    (cond ((or (< (- maxx minx) 2)(< (- maxy miny) 2))
	   `((,x3 . ,y3)))
	  (t 
	   (setq tempx (// (+ x0 (* 3 x1)(* 3 x2) x3) 8))
	   (setq tempy (// (+ y0 (* 3 y1)(* 3 y2) y3) 8))
	   (append
	    (bez x0 y0 (// (+ x0 x1) 2)(// (+ y0 y1) 2)
		 (// (+ x0 x1 x1 x2) 4)(// (+ y0 y1 y1 y2) 4)
		 tempx tempy)
	    (bez tempx tempy (// (+ x3 x2 x2 x1) 4)(// (+ y3 y2 y2 y1) 4)
		 (// (+ x3 x2) 2)(// (+ y3 y2) 2) x3 y3))))))
(defun setpart (l)
  (do ((ret nil ret)
       (curl l (cdr curl)))
      ((atom curl)ret)
      (match (car curl)
	     (('move x0 y0)
	      (setq curx x0 cury y0)
	      (setq ret `((,(* mag x0) . ,(* mag y0)))))
	     (('line x0 y0)
	      (setq curx x0 cury y0)
	      (nconc ret `((,(* mag x0) . ,(* mag y0)))))
	     (('bezier x0 y0 x1 y1 x2 y2)
	      (nconc ret (bez (* mag curx) (* mag cury) (* mag x0) (* mag y0) (* mag  x1) (* mag y1) (* mag x2)(* mag  y2)))
	      (setq curx x2)(setq cury y2))
	     (any (print "not matched")(break)))))
(defun drawpoints0 (l)
  (do ((first t nil)
       (curl l (next-point curl)))
      ((and (null first)(eq l curl)))
      (cond ((null l)(exit)))
      (match (car curl)
	     (('angle x0 y0)
	      (shikaku x0 y0))
	     (('smooth x0 y0)
	      (sankaku x0 y0))
	     (('bezier x0 y0)
	      (batsu x0 y0))
	     (any (print "not matched")(break)))))
(setq marksize 3 marksize1 3)
(defun batsu (x y)
  (drawline (- x marksize)y(+ x marksize)y)
  (drawline x(- y marksize)x(+ y marksize)))
(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 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)))

(setq mag 1)
(setq width (* mag 110))
(setq height (* mag 300))

(defun link-to-out (l)
  (do ((ll l)
       (first t nil)
       (ret nil))
      ((and (null first)(eq ll l))(nreverse ret))
;      (print ll)
      (match ll
	     (((angle-or-smooth x y) pre next)
	      (cond ((eq first t)
		     (push `(move ,x ,y) ret)))
	      (cond 
	       ((eq (caar next) 'bezier)
		(push 
		 `(bezier ,(cadar next) 
			   ,(caddar next)
			   ,(cadar (next-point next)) 
			   ,(caddar (next-point next))
			   ,(cadar (next-point (next-point next)))
			   ,(caddar (next-point (next-point  next))))
		 ret)
		(setq ll (next-point (next-point next)))
		)
	       (t (push `(line ,(cadar next) ,(caddar next)) ret)
		  (setq ll next)))))))

(defun link-to-list (l)
  (do ((ll l (next-point ll))
       (first t nil)
       (ret nil))
      ((and (null first)(eq ll l))(nreverse ret))
      (push (car ll) ret)))

(defun list-to-link (l)
  (do ((ll l (cdr ll))
       (tmp nil)
       (ret nil))
      ((atom ll)ret)
      (cond ((null ret)
	     (setq ret `(,(car ll) nil nil))
	     (setq tmp ret)
	     (rplaca (cdr ret) ret)
	     (rplaca (cddr ret) ret))
	    (t (insert-after tmp `(,(car ll) nil nil))
	       (setq tmp (next-point tmp))))))

(defun disp (l ll)
  (let ((outline (mapcar l '(lambda (x) (link-to-out (find-no-bezier x)))))
	(currentline (link-to-out ll)))
    (copybg)
;    (print outline)
    (mapcar outline '(lambda (x) (drawlines (setpart x))))
    (drawpoints0 ll)
    (redraw)))
  
(defun metric (x0 y0 x y)
  (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y))))

(defun find-point-in-group (group x y)
  (do ((l group (next-point l))
       (first t nil)
       (min 1000000)
       (near nil))
      ((and (eq l group)(null first))near)
      (setq x0 (cadar l) y0 (caddar l))
      (cond ((> min (metric x y x0 y0))
	     (setq min (metric x y x0 y0))
	     (setq near l)))))

(defun find-no-bezier (l)
  (do ((ll l (next-point ll))
       (first t nil))
      ((or (neq (point-type ll) 'bezier)
	   (and (null first)(eq l ll)))
       ll)))
(defun find-group (outline x y)
;  (print outline)
  (do ((l outline (cdr l))
       (near nil)
       (min 1000000))
      ((atom l)near)
      (setq ll (find-no-bezier(find-point-in-group (car l) x  y)))
      (setq val (metric x y (cadar ll)(caddar ll)))
;      (print ll)(print val)
      (cond ((> min val)
	     (setq min val)
	     (setq near ll)))))

(defun movepoint (group curpoint x y)
  (cond ((null outline))
	(t
  (lets ((point (find-point-in-group group (car curpoint) (cdr curpoint)))
	 (dx (- x (car curpoint)))
	 (dy (- y (cdr curpoint))))
	(cond 
	 ((null point))
	 (t
	  (setq xx (point-x point) yy (point-y point))
	  (set-x point (+ xx dx))
	  (set-y point (+ yy dy))
	  (cond 
	   ((and (eq 'smooth (point-type point))
		 (eq 'bezier (point-type (next-point point)))
		 (eq 'bezier (point-type (previous-point point))))
	    (lets ((next (next-point point))
		   (previous (previous-point point))
		  (set-x next (+ (point-x next) dx))
		  (set-y next (+ (point-y next) dy))
		  (set-x previous (+ (point-x previous) dx))
		  (set-y previous (+ (point-y previous) dy)))))
	   ((or (and (eq 'bezier (point-type point))
		     (setq next (next-point point))
		     (eq 'smooth (point-type next))
		     (setq nextnext (next-point next))
		     (eq 'bezier (point-type nextnext)))
		(and (eq 'bezier (point-type point))
		     (setq next (previous-point point))
		     (eq 'smooth (point-type next))
		     (setq nextnext (previous-point next))
		     (eq 'bezier (point-type nextnext))))
	    (lets ((x0 (point-x point))(y0 (point-y point))
		   (x1 (point-x next))(y1 (point-y next))
		   (x2 (point-x nextnext))(y2 (point-y nextnext))
		   (len0 (metric x0 y0 x1 y1))
		   (len1 (metric x1 y1 x2 y2))
		   (tt (sqrt (//$ (float len1)(float len0))))
		   (x3 (+ x1 (fix (*$ (float (- x1 x0)) tt))))
		   (y3 (+ y1 (fix (*$ (float (- y1 y0)) tt)))))
		  (set-x nextnext x3)(set-y nextnext y3)))
	   ((or (and (eq 'bezier (point-type point))
		     (setq next (next-point point))
		     (eq 'smooth (point-type next))
		     (setq nextnext (next-point next))
		     (neq 'bezier (point-type nextnext)))
		(and (eq 'bezier (point-type point))
		     (setq next (previous-point point))
		     (eq 'smooth (point-type next))
		     (setq nextnext (previous-point next))
		     (neq 'bezier (point-type nextnext))))
	    (lets ((x0 (point-x point))(y0 (point-y point))
		   (x1 (point-x next))(y1 (point-y next))
		   (x2 (point-x nextnext))(y2 (point-y nextnext))
		   (len0 (metric x0 y0 x1 y1))
		   (len1 (metric x1 y1 x2 y2))
		   (tt (sqrt (//$ (float len0)(float len1))))
		   (x3 (+ x1 (fix (*$ (float (- x1 x2)) tt))))
		   (y3 (+ y1 (fix (*$ (float (- y1 y2)) tt)))))
		  (set-x point x3)(set-y point y3))))))))))
  
(defun loadoutline (filename)
  (catch 'ioerr
    (lets ((err:open-close '(lambda (x (y))(throw 'ioerr nil)))
	  (s (inopen (stream filename)))
	  (l (read s)))
      (close s)
;      (print l)
;      (print (mapcar l '(lambda (x)(list-to-link x))))
      (throw 'ioerr (mapcar l '(lambda (x)(list-to-link x)))))))
(defun saveoutline (filename outline)
  (let ((s (outopen (stream filename)))
	(printlevel 0)
	(printlength 0))
    (print (mapcar outline '(lambda (x)(link-to-list x))) s)
    (close s)))

(defun loadbushu ()
  (catch 'ioerr
    (let ((err:open-close '(lambda (x (y))(throw 'ioerr nil)))
	  (err:end-of-file '(lambda (x (y))(throw 'ioerr ret)))
	  (s (inopen (stream "/home/misa/kanji/bushutable")))
	  (ret nil))
      (loop (push (read s) ret)))))
       
(defun hex2 (x)
  (let ((str (make-string 2)))
    (sset str 0 (hex-image-char (logand 7 (logshift (logand x 127) -1))))
    (sset str 1 (hex-image-char (logand x 15)))
    str))

(defun kanji2jis (str)
  (cond ((symbolp str)(setq str (pname str))))
  (cond 
   ((<> (string-length str) 2))
   (t (string-append (hex2 (sref str 0))(hex2 (sref str 1))))))

(defun next-point (l)
  (caddr l))
(defun set-next (l x)
  (rplaca (cddr l) x))
(defun point-type (l)
  (caar l))
(defun point-x (l)
  (cadar l))
(defun point-y (l)
  (caddar l))
(defun set-x (l val)
  (rplaca (cdar l) val))
(defun set-y (l val)
  (rplaca (cddar l) val))
(defun previous-point (l)
  (cadr l))
(defun set-previous (l x)
  (rplaca (cdr l) x))

(defun insert-after (l ll)
  (let ((next (caddr l)))
    (rplaca (cddr l) ll)
    (rplaca (cdr next) ll)
    (rplaca (cdr ll) l)
    (rplaca (cddr ll) next)))
(defun unlink (point)
  (let ((next (next-point point))
	(previous (previous-point point)))
    (set-next previous next)
    (set-previous next previous)))
(defun delete (point)
  (print "Delete point")
  (cond 
   ((eq 'bezier (caar point))
    (cond 
     ((eq 'bezier (caar(next-point point)))
      (unlink (next-point point)))
     (t (unlink (previous-point point)))))
   ((and (eq 'bezier (caar (previous-point point)))
	 (eq 'bezier (caar (next-point point))))
    (unlink (previous-point point))
    (unlink (next-point  point))))
  (unlink point))
(defun insert-bezier (point)
  (cond ((and (not(eq 'bezier (point-type point)))
	      (not(eq 'bezier (point-type (next-point point)))))
	 (let ((x0 (point-x point))
	       (y0 (point-y point))
	       (x1 (point-x (next-point point)))
	       (y1 (point-y (next-point point))))
	   (insert-after point 
			 `((bezier ,(// (+ x1 x1 x0) 3) ,(// (+ y1 y1 y0) 3)) nil nil))
	   (insert-after point 
			 `((bezier ,(// (+ x1 x0 x0) 3) ,(// (+ y1 y0 y0) 3)) nil nil))))))
(defun smooth-point (point)
  (cond ((eq 'angle (caar point))
	 (rplaca (car point) 'smooth))))
(defun copy-point (point)
  (print "Copy point")
  (setq x (cadar point) y (caddar point))
  (cond 
   ((eq 'bezier (caar point)))
   (t 
;    (cond 
;     ((eq (next-point point) point)
;      (insert-after point
;		    `((bezier ,(+ x 5) ,(- y 5))nil nil))
;     (insert-after point
;		   `((bezier ,(+ x 10) ,(- y 5))nil nil))))
    (insert-after point
		  `((angle ,(+ x 15) ,y)nil nil))
;    (insert-after point
;		  `((bezier ,(+ x 10) ,y)nil nil))
;    (insert-after point
;		  `((bezier ,(+ x 5) ,y)nil nil))
)))

(defun out-to-ps (psfile (code))
  (cond ((null code))
	(t
	 (setq outfile (string-append "/home/misa/kanji/outline/" code ".out"))
	 (setq outline (loadoutline outfile))))
  (let ((standard-output (outopen (stream psfile)))
	(l (mapcar outline 'link-to-out)))
    (format "%!/n100 100 translate/n")
    (do ((ll l (cdr ll)))
	((atom ll))
	(do ((lll (car ll) (cdr lll)))
	    ((atom lll))
	    (match (car lll)
		   (('move x y)(format "/c /c moveto/n" x (- 400 y)))
		   (('line x y)(format "/c /c lineto/n" x (- 400 y)))
		   (('bezier x0 y0 x1 y1 x2 y2)
		    (format
		     "/c /c /c /c /c /c curveto/n"
		     x0 (- 400 y0) x1 (- 400 y1) x2 (- 400 y2))))))
    (format "closepath fill showpage/n")))
	
    
)
(defun hex2 (l)
  (string-append (string (sref "0123456789abcdef" (logand 15 (logshift l -4))))
		 (string (sref "0123456789abcdef" (logand 15 l)))))
(defun newedit (code (noload))
  (init_window 400 400)
  (cond ((= 2 (string-length code))
	 (setq code (string-append (hex2 (logand 127 (sref code 0)))
				   (hex2 (logand 127 (sref code 1)))))))
  (cond ((null noload)
	 (loadpbm (string-append "/home/misa/kanji/pbm/mincho/" code ".pbm")))
	(t
	 (loadpbm "/home/misa/kanji/pbm/nothing.pbm")))
  (setq outfile (string-append "/home/misa/kanji/outline/" code ".out"))
  (setq outline (loadoutline outfile))
  (disp outline nil)
  (do ((event (checkevent)(checkevent))
       (currentgroup nil)
       (x nil)
       (y nil)
       (currentpart nil))
      ()
;      (gc)(princ (heapfree))
;      (print event)
;      (print outline)
      (match event
	     (('KeyPress code)
	      (selectq code
		       (#g (print "Select group"))
		       (#c (print "Copy point"))
		       (#i (print "insert bezier point"))
		       (#d (print "Delete point"))
		       (#s (print "Smooth point"))
		       (#q 
			(close_window)(saveoutline outfile outline)(exit))
		       (#n (print "New point")))
	      (do ((event (checkevent)(checkevent)))
		  ((and (eq (car event) 'ButtonPress)
			(eq (cadr event) 'button1))
		   (setq x (caddr event))
		   (setq y (cadddr event))))
	      (selectq code
		       (#g 
			   (setq currentgroup (find-group outline x y)))
		       (#c (copy-point (find-point-in-group currentgroup x y)))
		       (#i (insert-bezier (find-point-in-group currentgroup x y)))
		       (#d (delete (find-point-in-group currentgroup x y)))
		       (#s 
			   (smooth-point (find-point-in-group currentgroup x y)))
		       (#n
			(setq currentgroup `((angle ,x ,y) nil nil))
			(rplaca (cdr currentgroup)currentgroup)
			(rplaca (cddr currentgroup)currentgroup)
			(push currentgroup outline))))
	     (('ButtonPress 'button2 x y)
	      (setq curpoint (cons x y)))
	     (('ButtonRelease 'button2 x y)
	      (movepoint currentgroup curpoint x y)))
      (disp outline currentgroup)))