View of /lisp/test/lowdev.l

Parent Directory

Revision Log

*** empty log message ***

(declare (meshsize) special)
(defun filltest1 (l tag size (meshsize size))
  (setq m (1+ (fix size)))
  (init_window 400 400)
  (setq outline (skeleton2list (normkanji (applykanji l tag)) tag))
  (mapcar outline
    (function (lambda (x)(fillpolygon (setpart1 x)))))
  (getimage)
  (do ((i 0 (plus i size)))
    ((greaterp (plus i size) 400))
    (do ((j 0 (plus j size)))
      ((greaterp (plus j size)400))
      (setq ii (fix (times 0.5 (plus 1.0 i i size))))
      (setq jj (fix (times 0.5 (plus 1.0 j j size))))
      (setq p (getpixel ii jj))
      (fillrectangle (fix (plus i 0.5)) (fix (plus j 0.5))  m m 0)
      (cond ((0< p)
	     (fillrectangle (fix (plus i 0.5)) (fix (plus j 0.5)) m m 1)
	    )
	    (t
;	     (fillrectangle (fix i) (fix j) 
;			    (- (fix (plus i size))(fix i))
;			    (- (fix (plus j size))(fix j))  0)
	     (fillrectangle ii jj 1 1 2)
	     ))))
  (freeimage)
  (mapcar outline
    (function (lambda (x)(drawlines (setpart1 x)))))
  (redraw)
  (checkevent)
  (close_window))

(defun out-to-ps-all-1 (outlines tag psfile 
			       (nameflag)
			       (col 9)(line (fix (times 0.67 col)))(meshsize 1.0))
  (let ((standard-output (outopen (stream psfile)))
	(scale (fix (times 160.0 (max (//$ 9.0 (float col))
				      (//$ 6.0 (float line))))))
	(i nil)(j nil)(page nil)(last nil)
	(next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
	(date (date-time)))
    (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
    (princ "/rec{/h exch def /w exch def /y exch def /x exch def")
    (terpri)
    (format "newpath x 400 y sub moveto w 0 rlineto 0 h neg rlineto/n")
    (format "w neg 0 rlineto closepath fill}def/n")
    (format "//Helvetica findfont 70 scalefont setfont/n")
    (setq i 0 j 0 page 1)
    (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)
    (init_window 400 400 t)
    (setq m (1+ (fix meshsize)))
    (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
	       (skeleton2list (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)))))
       (fillrectangle 0 0 400 400 0)
       (mapcar l
	 (function (lambda (x)(fillpolygon (setpart1 x)))))
       (getimage)
       (do ((i 0 (plus i meshsize)))
	 ((greaterp i 400))
	 (do ((j 0 (plus j meshsize)))
	   ((greaterp j 400))
	   (setq ii (fix (plus i (times 0.5 meshsize))))
	   (setq jj (fix (plus j (times 0.5 meshsize))))
	   (setq p (getpixel ii jj))
	   (cond ((0< p)
		  (format "/c /c /c /c rec/n" (fix i) (fix j) 
			  (- (fix (plus i meshsize))(fix i))
			  (- (fix (plus j meshsize))(fix j)))))))
       (freeimage)
       )
      )
     (setq i (1+ i))
     (cond ((eq i col)
	    (format "500 /c translate/n" (* -500 (1- col)))
	    (setq i 0)
	    (setq j (1+ j))
	    (cond ((eq j line)
		   (format "showpage/n50 50 translate/n")
		   (format "0.001 /c mul dup scale/n" scale)
		   (format "//Helvetica findfont 70 scalefont setfont/n")
		   (setq page (1+ page))
		   (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 j 0))))
	   (t (format "0 500 translate/n"))))
    (close_window)
    (format "showpage/n")))