View of /lisp/disp.l

Parent Directory

Revision Log

*** empty log message ***

; X-Windowを扱うためのCの関数をロードする
;
;
;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so")
;
(declare (err:argument-type err:number-of-arguments err:unbound-variable 
			    err:zero-division err:undefined-function) special)

;
; PSファイルの出力
;

(comment
(defun out-to-ps-all (outlines tag psfile 
			       (nameflag)
			       (col 9)(line (fix (times 0.67 col)))
			       (printfile t))
  (let ((standard-output (outopen (stream psfile)))
	(scale (fix (times 160.0 (min (//$ 9.0 (float col))
				      (//$ 6.0 (float line))))))
	(ii nil)(jj nil)(page nil)(last nil)
	(next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
	(date (date-time)))
    (format "%!/n%%BoundingBox: 45 45 /c /c/n" 
	    (plus 55 (fix (times 0.001 scale (- (* line 500) 100))))
	    (plus 55 (fix (times 0.001 scale (- (* col 500) 100)))))
    (format "50 50 translate/n0.001 /c mul dup scale/n" scale)
    (format "//Helvetica findfont 70 scalefont setfont/n")
    (setq ii 0 jj 0 page 1)
    (and printfile
	 (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" 
		 (substring date 0 2)
		 (substring date 2 4)(substring date 4 6)
		 (substring date 6 8)(substring date 8 10)
		 psfile page))
    (do 
	((ol outlines (cdr ol))
	 (l nil))
      ((atom ol))
      (princ ";" terminal-output)
;     (princ (gccount) terminal-output)
      (print (car ol) terminal-output)
      (setq l
	    (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
		  (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
		  (err:unbound-variable #'(lambda (x (y))(throw 'err)))
		  (err:undefined-function #'(lambda (x (y))(throw 'err)))
		  (err:zero-division #'(lambda (x (y))(throw 'err))))
	      (catch 'err
		(skelton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag)))))
      (cond 
       ((atom l)
	(format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
	(format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
	(cond (nameflag
	       (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
		       (cond ((lessp (string-length (car ol)) 10) 100)
			     (t
			      (fix (quotient 800 (string-length (car ol)))))))
	       (format "0 410 moveto </c> show/n" (euc2jis(car ol)))))
	)
       (t
	(format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
	(format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
	(cond (nameflag
	       (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
		       (cond ((lessp (string-length (car ol)) 10) 100)
			     (t
			      (fix (quotient 800 (string-length (car ol)))))))
	       (format "0 410 moveto </c> show/n" (euc2jis (car ol)))))
	(do ((ll l (cdr ll)))
	  ((atom ll))
	  (setq last (caar ll))
	  (format "newpath /c /c moveto/n" (fix (cadr last))
		  (- 400 (fix (caddr last))))
	  (do ((lll (cdar ll) (cdr lll)))
	    ((atom lll))
	    (match 
		(car lll)
	      (('angle x y)
	       (format "/c /c lineto/n" (fix x) (- 400 (fix y))))
	      (('bezier x0 y0)
	       (setq next (cadr lll))
	       (setq nextnext 
		     (cond ((cddr lll)(setq lll (cddr lll))(car lll))
			   (t (setq lll (cdr lll))last)))
	       (setq x1 (cadr next) y1 (caddr next))
	       (setq x2 (cadr nextnext) y2 (caddr nextnext))
	       (format
		"/c /c /c /c /c /c curveto/n"
		(fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2))))))
	  (format "closepath fill/n"))))
      (setq ii (1+ ii))
      (cond ((eq ii col)
	     (format "500 /c translate/n" (* -500 (1- col)))
	     (setq ii 0)
	     (setq jj (1+ jj))
	     (cond ((and (eq jj line)(consp (cdr ol)))
		    (format "showpage/n")
		    (format "50 50 translate/n")
		    (format "0.001 /c mul dup scale/n" scale)
		    (format "//Helvetica findfont 70 scalefont setfont/n")
		    (setq page (1+ page))
		    (and printfile
			 (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" 
				 (substring date 0 2)
				 (substring date 2 4)(substring date 4 6)
				 (substring date 6 8)(substring date 8 10)
				 psfile page))
		    (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n")
		    (setq jj 0))))
	    (t (format "0 500 translate/n"))))
    (format "showpage/n")))
)
      
;
; アウトライン形式のデータを表示する
;
(defun showOutline (outline)
  (init_window 400 400)
  (mapcar outline '(lambda (x)(drawlines (setpart1 x))))
  (redraw)
  (checkevent)
  (close_window))
;
; スケルトンデータを renderingして表示する
;
(defun showSkeleton (skeleton tag)
  (showOutline (skelton2list skeleton tag)))
;
; スケルトンデータを折れ線に変換する．
;
(defun skeletonToLinesList (skeleton)
  (lets ((points (car skeleton))
	 (lineslist)
	 (elements (cadr skeleton))
	 (linkPoints))
	(mapc elements 
	      #'(lambda (element) 
		  (lets ((links (assq 'link (cddr element))))
			(and links
			     (mapc (cdr links)
				   #'(lambda (p) (or (memq p linkPoints)
						     (push p linkPoints))))))))
	(mapc elements 
	      #'(lambda (element)
		  (lets ((lines))
			(mapc (cadr element)
			      #'(lambda (p) 
				  (lets ((point (nth p points))
					 (x (fix (car point)))
					 (y (fix (cadr point))))
					(push `(,x .,y) lines))))
			(push lines lineslist))))
	(mapc linkPoints
	      #'(lambda (p) (push (makeSquareLines (nth p points)) lineslist)))
	lineslist))
;
; ある点を中心に四角を書く
; (100.0 100.0) -> 
; ((98 . 98)(98 . 102)(102 . 102)(102 . 98)(98 . 98)
(defun makeSquareLines (point (d 2))
  (lets ((x (fix (car point)))
	 (y (fix (cadr point))))
	`((,(- x d).,(- y d)) 
	  (,(- x d).,(+ y d)) 
	  (,(+ x d).,(+ y d)) 
	  (,(+ x d).,(- y d)) 
	  (,(- x d).,(- y d)))))

;
;
;
(defun showSkeletonByLines (skeleton)
  (init_window 400 400)
  (mapcar (skeletonToLinesList skeleton) #'drawlines)
  (redraw)
  (checkevent)
  (close_window))
  


;
; 
;
(defun showtest (l tag)
  (showSkeleton (applykanji l tag) tag))
;
(defun showtest1 (l tag)
  (lets ((outline nil))
    (init_window 400 400)
    (setq outline (makeoutline (skelton2list (applykanji l tag) tag)))
    (mapcar outline '(lambda (x)(drawlines (setpart1 x))))
    (redraw)
    (checkevent)
    (close_window)))
;
; 塗りつぶして表示する
;

(defun filltest (l tag)
  (init_window 400 400)
  (mapcar (skelton2list (rm-limit (applykanji l tag)) tag)
    (function (lambda (x)(fillpolygon (setpart1 x)))))
  (redraw)
  (checkevent)
  (close_window))

;
; pointを結ぶtension 1のスプラインを求める
;
(declare (alpha beta gamma sqrt2 d16 sqrt51 sqrt35)special)
(setq alpha 1.0 beta 1.0 gamma 0.0)
(defun reduce_points(points)
  (do ((l points (cdr l))
       (ret nil)
       (old '(10000.0 10000.0)))
    ((atom l)(nreverse ret))
    (cond ((>$ 1.0 (metric2 old (car l))))
	  (t (push (car l) ret)
	     (setq old (car l))))))
(defun spline (points)
  (let ((fais nil)
	(points (reduce_points points))
	(thetas nil)
	(lengthes nil)
	(npoints 2)
	(psis nil)
	(array nil)
	(x nil)
	(ret nil)
	(b nil))
    (do ((l points (cdr l))
	 (p0 nil)
	 (p1 nil)
	 (p2 nil)
	 (d0 nil)
	 (d1 nil)
	 (theta nil)
	 (costheta nil)
	 (sintheta nil))
      ((atom (cddr l))
       (push (metric2 (car l)(cadr l)) lengthes)
       (setq lengthes (nreverse lengthes))
       (push 0.0 psis)
       (setq psis (nreverse psis)))
      (setq p0 (car l) p1 (cadr l) p2 (caddr l))
      (setq d1 (diff2 p2 p1) d0 (diff2 p1 p0))
      (setq theta (theta d1 d0))
      (setq npoints (1+ npoints))
      (push (metric2 (car l)(cadr l)) lengthes)
;      (print (list costheta sintheta theta lengthes))
      (push theta psis))
    (setq array (vector (* npoints npoints) 0.0))
    (setq x (vector npoints 0.0) b (vector npoints 0.0))
    (vset array 0 (-$ (//$ (*$ alpha alpha) beta) 
		      (*$ 3.0 (*$ alpha alpha))
		      (//$ (*$ gamma beta beta) alpha)))
    (vset array 1 (-$ (//$ (*$ gamma beta beta) alpha)
		      (*$ 3.0 (*$ beta beta gamma))
		      (//$ (*$ alpha alpha) beta)))
    (vset b 0 (*$ (-$ (car psis))(vref array 1)))
    (do ((i 1 (1+ i))
	 (tmppsi psis (cdr tmppsi))
	 (lk nil)
	 (lk1 nil)
	 (psi nil)
	 (psi1 nil)
	 (tmplen lengthes (cdr tmplen))
	 (offset (+ npoints 1) (+ offset npoints 1)))
      ((>= i (1- npoints)))
      (setq lk (car tmplen) lk1 (cadr tmplen))
      (setq psi (car tmppsi) psi1 (cadr tmppsi))
      (vset array (1- offset) (//$ (*$ beta beta) lk alpha))
      (vset array offset (+$ (*$ beta beta (//$ 1.0 lk)
				 (-$ 3.0 (//$ 1.0 alpha)))
			     (*$ alpha alpha (//$ 1.0 lk1)
				 (-$ 3.0 (//$ 1.0 beta)))))
      (vset array (1+ offset) (//$ (*$ alpha alpha) lk1 beta))
      (vset b i (-$ (*$ psi beta beta (//$ 1.0 lk)
			(-$ (//$ 1.0 alpha) 3.0))
		    (//$ (*$ psi1 alpha alpha) lk1 beta))))
    (vset array (- (* npoints npoints) 2)
	  (-$ (//$ (*$ gamma alpha alpha) beta)
	      (*$ 3.0 gamma alpha alpha)
	      (//$ (*$ beta beta) alpha)))
    (vset array (- (* npoints npoints) 1)
	  (-$ (//$ (*$ beta beta) alpha)
	      (*$ gamma alpha alpha)
	      (*$ 3.0 beta beta)))
;    (print "psis")
;    (print psis)
;    (print "lengthes")
;    (print lengthes)
;    (print "array")
    (do ((i 0 (1+ i)))
      ((>= i npoints))
      (do ((j 0 (1+ j))
	   (ret nil))
	((>= j npoints)(nreverse ret))
	(push (vref array (+ (* npoints i) j)) ret)))
;    (print "b")
    (do ((i 0 (1+ i))
	 (ret nil))
      ((>= i npoints)(nreverse ret))
      (push (vref b i) ret))
;    (print "gs")
    (gs npoints array x b)
    (do ((i 0 (1+ i))
	 (ret nil))
      ((>= i npoints)(setq thetas (nreverse ret)))
      (push (vref x i) ret))
;    (print "thetas")(print thetas)
    (setq ret `((angle .,(car points))))
    (do ((l points (cdr l))
	 (tmptheta thetas (cdr tmptheta))
	 (tmppsi psis (cdr tmppsi))
	 (diff nil)(p0 nil)(p1 nil)(fai nil)(f nil)(r nil)
	 (rotdiff nil)(sintheta nil)(costheta nil)(sinfai nil)(cosfai nil))
      ((atom (cdr l))(nreverse ret))
      (setq p0 (car l) p1 (cadr l))
      (setq diff (diff2 p1 p0))
      (setq rotdiff (rot90 diff))
      (setq sintheta (sin (car tmptheta)) costheta (cos (car tmptheta)))
      (setq fai (-$ 0.0 (car tmppsi)(cadr tmptheta)))
;      (print (list (car tmppsi)(cadr tmptheta)fai))
      (setq sinfai (sin fai) cosfai (-$ (cos fai)))
      (setq f (_f (car tmptheta) fai))
      (setq r (//$ f alpha))
      (push `(bezier .,(plus2 p0 (times2 (*$ r costheta) diff)
			      (times2 (*$ r sintheta) rotdiff))) ret)
      (setq f (_f fai (car tmptheta)))
      (setq r (//$ f beta))
      (push `(bezier .,(plus2 p1 (times2 (*$ r cosfai) diff)
			      (times2 (*$ r sinfai) rotdiff))) ret)
      (push `(angle .,p1) ret))))
      
(setq sqrt2 (sqrt 2.0) sqrt5 (sqrt 5.0) d16 (//$ 1.0 16.0))
(setq sqrt51 (-$ sqrt5 1.0) sqrt35 (-$ 3.0 sqrt5))
(defun _f (theta fai)
  (let ((sinfai (sin fai))
	(cosfai (cos fai))
	(sintheta (sin theta))
	(costheta (cos theta)))
    (//$ (+$ 2.0 (*$ sqrt2 
		     (-$ sintheta (*$ d16 sinfai))
		     (-$ sinfai (*$ d16 sintheta))
		     (-$ costheta cosfai)))
	 (*$ 3.0 (+$ 1.0
		     (*$ 0.5 sqrt51 costheta)
		     (*$ 0.5 sqrt35 cosfai))))))
    
(defun gs (n array x b)
  (do ((i 0 (1+ i)))
    ((> i 10))
    (vset x 0 (//$ (-$ (vref b 0)
		       (*$ (vref array 1)(vref x 1))
		       (*$ (vref array (1- n))(vref x (1- n)))
		       )
		   (vref array 0)))
    (do ((j 1 (1+ j))
	 (offset (+ n 1) (+ offset n 1)))
      ((>= j (1- n)))
      (vset x j
	   (//$ (-$ (vref b j)
		    (+$ (*$ (vref array (1- offset))(vref x (1- j)))
			(*$ (vref array (1+ offset))(vref x (1+ j)))))
		     (vref array offset))))
    (vset x (1- n) (//$ (-$ (vref b (1- n))
			    (*$ (vref array (* (1- n) n))(vref x 0))
			    (*$ (vref array (- (* n n) 2))(vref x (- n 2))))
			    (vref array (1- (* n n)))))
    (do ((j 0 (1+ j))
	 (ret nil))
      ((>= j n)(nreverse ret))
      (push (vref x j)ret))))

(defun drawpoints (points)
  (init_window 400 400)
  (do ((l points (cdr l))
       (ret nil))
    ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
    (push (cons (fix (caar l))(fix (cadar l))) ret)))
(defun drawbezier (points bezier)
  (init_window 400 400)
  (drawlines (setpart1 bezier))
  (do ((l points (cdr l))
       (ret nil))
    ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
    (push (cons (fix (caar l))(fix (cadar l))) ret)))
(defun drawbezier1 (points bezier)
  (init_window 400 400)
  (do ((l bezier (cdr l))
       (ret nil))
    ((atom l)(drawlines ret))
    (push (cons (fix (cadr (car l)))(fix (caddr (car l)))) ret))
  (do ((l points (cdr l))
       (ret nil))
    ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
    (push (cons (fix (caar l))(fix (cadar l))) ret)))
;