View of /lisp/test/maketestdata.lView of /lisp/test/maketestdata.l
Parent Directory
| 
Revision Log
*** empty log message ***
(defun show-skeleton (outline)
; (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)
; (princ "/dot { /y exch def /x exch def")(terpri)
; (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)
(do ((points (car outline))
(l (cadr outline)(cdr l)))
((atom l))
(do ((ll (cadar l)(cdr ll)))
((atom (cdr ll))
(setq p (nth (car ll) points))
(format "/c /c dot 0 setlinewidth/n" (fix (car p))(fix (cadr p))))
(setq p (nth (car ll) points))
(setq p1 (nth (cadr ll) points))
(format "/c /c dot/n" (fix (car p))(fix (cadr p)))
(format "10 setlinewidth newpath /c /c moveto/n" (fix (car p))(- 400 (fix (cadr p))))
(format "/c /c lineto closepath stroke/n"
(fix (car p1))(- 400 (fix (cadr p1)))))))
(defun cross-skeleton (outline tag)
(format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)
(princ "/dot { /y exch def /x exch def")(terpri)
(princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)
(setq crosses (skeleton2cross outline tag))
(do ((l crosses (cdr l)))
((atom l))
(format "/c /c dot/n" (fix(caar l))(fix(cadar l)))))
(defun out-to-ps-test (outlines tag psfile (numberflag)
(col 1)(line 5))
(let ((standard-output (outopen (stream psfile)))
(scale 160)
(i nil)(j nil)(page nil)(last nil)
(next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
(date (date-time)))
(format "%!/n%%BoundingBox: 50 50 /c /c/n"
(plus 50 (fix (times 0.001 scale (- (times 500 line) 100))))
(plus 50 (fix (times 0.001 scale (- (times 500 col) 100)))))
(format "50 50 translate/n0.001 /c mul dup scale/n" scale)
(format "//Helvetica findfont 70 scalefont setfont/n")
(princ "/dot { /y exch def /x exch def")(terpri)
(princ "newpath x 400 y sub 15 0 360 arc closepath fill } def")(terpri)
(setq i 0 j 0 page 1)
(do
((ol outlines (cdr ol))
(l nil))
((atom ol))
(princ ";" terminal-output)
(print (car ol) terminal-output)
(setq l (skeleton2list (applykanji (car ol) tag) tag))
(and numberflag
(format "0 0 moveto (/c) show/n" (plus 1 i (times j col))))
(format "0 setlinewidth/n")
; (format "newpath 0 0 moveto 400 0 lineto/n")
; (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
(show-skeleton (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 stroke/n"))
(setq i (1+ i))
(cond ((<= col i)
(setq i 0 j (1+ j))
(format "500 /c translate/n" (* -500 (1- col))))
(t (format "0 500 translate/n"))))))
(defun skeleton2list1 (l tag)
(let ((linkpoints nil)
(linelist nil)
(outline nil)
(points (floatlist(car l)))
(part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil)
(tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil)
(tmpline nil)(type3 nil)
(type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil)
(lines (cadr l)))
(do ((ll points (cdr ll))
(linkcount 0 (1+ linkcount)))
((atom ll))
(push (list linkcount (ncons 'link)) linkpoints))
(do ((ll lines (cdr ll)))
((atom ll))
(setq part (car ll))
(setq type (car part))
; (setq npoint (get type 'npoint))
(setq cpoint (cadr part))
(setq lpoint (assq 'link (cddr part)))
(setq lpoint (cond (lpoint (cdr lpoint))))
(setq partpoint nil)
(do ((lll cpoint (cdr lll)))
((atom lll))
; (push (point-n (car lll) points) partpoint)
(push (nth (car lll) points) partpoint))
;; tag に対するプロパティが未定義のときのため(石井)
;; if を使わないように直す(田中)
(setq tmpline
(lets ((funcname (getdef type tag))
(result (cond (funcname
(funcall funcname
(nreverse partpoint)(cddr part)))
(t
(print (list 'undefined tag))
(funcall (get type 'mincho)
(nreverse partpoint)(cddr part))))))
`(lines ,result)))
(push tmpline linelist)
(do ((lll cpoint (cdr lll))
(i 0 (1+ i)))
((atom lll))
(cond ((zerop i)
(setq flag 0))
((atom (cdr lll));(eq i (1- npoint))
(setq flag 1))
(t (setq flag 2)))
(setq link (assq 'link (cdr (assq (car lll) linkpoints))))
(rplacd link (cons (list type flag tmpline) (cdr link))))
(do ((lll lpoint (cdr lll)))
((atom lll))
(setq link (assq 'link (cdr (assq (car lll) linkpoints))))
(rplacd link (cons (list type 2 tmpline) (cdr link)))))
(do ((ll linelist (cdr ll))
(part0 nil)
(part1 nil))
((atom ll))
(setq part0 (car (cadar ll)))
(setq part1 (cadr (cadar ll)))
(push part0 outline)
(push part1 outline))
outline))
(defun skeleton2cross (l tag)
(let ((linkpoints nil)
(linelist nil)
(retcross nil)
(outline nil)
(points (floatlist(car l)))
(part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil)
(tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil)
(tmpline nil)(type3 nil)
(type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil)
(lines (cadr l)))
(do ((ll points (cdr ll))
(linkcount 0 (1+ linkcount)))
((atom ll))
(push (list linkcount (ncons 'link)) linkpoints))
(do ((ll lines (cdr ll)))
((atom ll))
(setq part (car ll))
(setq type (car part))
; (setq npoint (get type 'npoint))
(setq cpoint (cadr part))
(setq lpoint (assq 'link (cddr part)))
(setq lpoint (cond (lpoint (cdr lpoint))))
(setq partpoint nil)
(do ((lll cpoint (cdr lll)))
((atom lll))
; (push (point-n (car lll) points) partpoint)
(push (nth (car lll) points) partpoint))
;; tag に対するプロパティが未定義のときのため(石井)
;; if を使わないように直す(田中)
(setq tmpline
(lets ((funcname (getdef type tag))
(result (cond (funcname
(funcall funcname
(nreverse partpoint)(cddr part)))
(t
(print (list 'undefined tag))
(funcall (get type 'mincho)
(nreverse partpoint)(cddr part))))))
`(lines ,result)))
(push tmpline linelist)
(do ((lll cpoint (cdr lll))
(i 0 (1+ i)))
((atom lll))
(cond ((zerop i)
(setq flag 0))
((atom (cdr lll));(eq i (1- npoint))
(setq flag 1))
(t (setq flag 2)))
(setq link (assq 'link (cdr (assq (car lll) linkpoints))))
(rplacd link (cons (list type flag tmpline) (cdr link))))
(do ((lll lpoint (cdr lll)))
((atom lll))
(setq link (assq 'link (cdr (assq (car lll) linkpoints))))
(rplacd link (cons (list type 2 tmpline) (cdr link)))))
(do ((ll linkpoints (cdr ll)))
((atom ll))
(setq link (assq 'link (cdar ll)))
(cond ((eq 4 (length link))
(setq part1 (cadr link) part2 (caddr link) part3 (cadddr link))
(setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3))
)
((eq 3 (length link))
(setq part1 (cadr link) part2 (caddr link))
(setq type1 (cadr part1) type2 (cadr part2))
(setq cross (crosspoint part1 part2))
(do ((i 0 (1+ i)))
((> i 3))
(push (vref cross i) retcross))
(setq kazari
(selectq type1
(1
(selectq type2
(1
(appendrev
(findkazari part1 part2 0 1 cross tag)
(findkazari part1 part2 1 0 cross tag)))
(0
(appendrev
(findkazari part1 part2 0 0 cross tag)
(findkazari part1 part2 1 1 cross tag)))
(2
(find-last part1 part2))))
(0
(selectq type2
(1
(appendrev
(findkazari part1 part2 0 0 cross tag)
(findkazari part1 part2 1 1 cross tag)))
(0
(appendrev
(findkazari part1 part2 0 1 cross tag)
(findkazari part1 part2 1 0 cross tag)))
(2
(find-first part1 part2))))
(2 (selectq type2
(0 (find-first part2 part1))
(1 (find-last part2 part1))))))
(cond ((> (length kazari) 2) (push kazari outline)))
)
((and (eq 2 (length link))(<= 0 (cadadr link) 1))
(setq part1 (cadr link))
(setq type1 (cadr part1))
; (setq cross (cross2point part1 (point-n (caar ll) points)))
(setq cross (cross2point part1 (nth (caar ll) points)))
(setq kazari
(findkazari part1 part1 0 1 cross tag))
(nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari))))))
(do ((ll linelist (cdr ll))
(part0 nil)
(part1 nil))
((atom ll))
(setq part0 (car (cadar ll)))
(setq part1 (cadr (cadar ll)))
(setq part2 nil part3 nil)
(do ((lll (cddar ll) (cdr lll)))
((atom lll))
(selectq (caar lll)
(-2 (setq part3 (cond ((cdar lll)(cddar lll)))))
(-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll))))))
(0 (setq part0 (change-head part0 (cdar lll))))
(1 (setq part1 (change-head part1 (cdar lll))))
(2 (setq part0 (change-tail part0 (cdar lll))))
(3 (setq part1 (change-tail part1 (cdar lll))))))
(push (append part0 part3 (reverse part1) part2) outline))
; (break)
retcross))
(defun out-to-ps-all1 (outlines tag psfile
(nameflag)
(col 1)(line 10))
(let ((standard-output (outopen (stream psfile)))
(scale 160)
(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)
(format "//Helvetica findfont 70 scalefont setfont/n")
(setq i 0 j 0 page 1)
(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)))))
(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 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"))))
(format "showpage/n")))
;
(setq tendata
'((80 171 136 255)
((angle 80 171)(bezier 119 214)(bezier 104 256)(angle 136 255))
((angle 80 171)(bezier 155 204)(bezier 173 251)(angle 136 255))))
(setq recratio 0.3)
(defun smoveto (p)
(format "/c /c moveto/n" (fix (times 100.0 (car p)))(- 40000 (fix (times 100.0 (cadr p))))))
(defun slineto (p)
(format "/c /c lineto/n" (fix (times 100.0 (car p)))(- 40000 (fix (times 100.0 (cadr p))))))
(defun scurveto (p0 p1 p2)
(format "/c /c /c /c /c /c curveto/n"
(fix (times 100.0 (car p0)))(- 40000 (fix (times 100.0 (cadr p0))))
(fix (times 100.0 (car p1)))(- 40000 (fix (times 100.0 (cadr p1))))
(fix (times 100.0 (car p2)))(- 40000 (fix (times 100.0 (cadr p2))))))
(setq testten '(((100 100)(300 300))((200 100)(200 300))((300 100)(200 200))))
(defun tens (tenlist)
(lets ((points (car tendata))
(p0 (list (first points)(second points)))
(p1 (cddr points))
(outline (append (cadr tendata)(reverse (caddr tendata)))))
(format "%!/n50 50 translate/n0.0016 0.0016 scale/n")
(format "0 setlinewidth/n")
(do ((l tenlist (cdr l))(pp0)(pp1))
((atom l))
(setq pp0 (car (car l)) pp1 (cadr (car l)))
(setq trans (type1-trans (car points)(cadr points)(caddr points)(cadddr points)(car pp0)(cadr pp0)(car pp1)(cadr pp1) 1.0))
; (setq len (metric2 pp0 pp1))
(setq len 100.0)
(setq d0 (diff2 pp1 pp0))
(setq pp2 (inter2 pp0 pp1 0.5))
(setq l0 (normlen2 (times recratio len) (rot270 d0)))
(setq r0 (plus2 pp0 l0) r1 (plus2 pp1 l0)
r2 (diff2 pp1 l0) r3 (diff2 pp0 l0)
r4 (plus2 pp2 l0) r5 (diff2 pp2 l0))
(format "newpath/n")
(smoveto r0)(slineto r1)(slineto r2)(slineto r3)(slineto r0)
(format "stroke/n")
(format "newpath/n")
(smoveto pp0)(slineto pp1)
(format "stroke/n")
(format "newpath/n")
(smoveto r4)(slineto r5)
(format "stroke/n")
(format "newpath/n")
(do ((ll outline))
((atom ll))
(match ll
((('angle . ppp0)('angle . ppp1). rest)
(smoveto (affine ppp0 trans))
(slineto (affine ppp1 trans))
(setq ll (cdr ll)))
((('angle . ppp0)('bezier . ppp1)('bezier . ppp2)('angle . ppp3) . rest)
(smoveto (affine ppp0 trans))
(scurveto (affine ppp1 trans)(affine ppp2 trans)(affine ppp3 trans))
(setq ll (cdddr ll)))
(dummy (setq ll (cdr ll)))))
(format "stroke/n")
(format "50000 0 translate/n")
)))
(setq element-data
'(
(((110 110)(290 290))((ten (0 1))))
(((200 50)(200 350))((tate (0 1))))
(((50 200)(350 200))((yoko (0 1))))
(((50 220)(200 200)(350 170))((migiue (0 1 2))))
(((300 50)(250 250)(100 350))((hidari (0 1 2))))
(((200 50)(200 100)(200 300)(100 350))((tatehidari (0 1 2 3))))
(((100 50)(150 250)(350 300))((migi (0 1 2))))
(((200 50)(250 200)(200 350)(150 350))((kozato (0 1 2 3))))
(((200 50)(200 350)(150 350))((tatehane (0 1 2))))
(((250 50)(250 200)(200 350)(150 350))((tsukurihane (0 1 2 3))))
(((200 350)(250 50))((sanzui (0 1))))
(((100 100)(100 350)(350 350)(350 250))((kokoro (0 1 2 3))))
(((200 50)(200 200)(300 350)(300 250))((tasuki (0 1 2 3))))
(((220 50)(200 200)(150 350))((magaritate (0 1 2))))
(((100 100)(100 350)(350 350))((kagi (0 1 2))))
(((50 200)(100 300)(350 300))((shin-nyuu (0 1 2))))))
;
;(out-to-ps-test element-data 'micnho t 4 4)
; -> mincho-element.ps
;(out-to-ps-test element-data 'gothic t 4 4)
; -> gothic-element.ps
; 折れ線近似からの変換
(setq oresendata '((50 100)(150 120)(170 300)(350 300)(350 100)))
;
(defun oresenkinji (points (scale 160))
(lets ((maxx)(minx)(maxy)(miny))
(do ((l points (cdr l)))
((atom l))
(and (or (null maxx)(lessp maxx (caar l)))(setq maxx (caar l)))
(and (or (null minx)(greaterp minx (caar l)))(setq minx (caar l)))
(and (or (null maxy)(lessp maxy (cadar l)))(setq maxy (cadar l)))
(and (or (null miny)(greaterp miny (cadar l)))(setq miny (cadar l))))
(format "%!/n%%BoundingBox: /c /c /c /c/n"
(plus 50 (fix (times 0.001 scale minx)))
(plus 50 (fix (times 0.001 scale (difference 400 maxy))))
(plus 50 (fix (times 0.001 scale maxx)))
(plus 50 (fix (times 0.001 scale (difference 400 miny)))))
(format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
(princ "/dot { /y exch def /x exch def")(terpri)
(princ "newpath x 400 y sub 15 0 360 arc closepath fill } def")(terpri)
(do ((l points (cdr l)))
((atom l))
(format "/c /c dot/n" (caar l) (cadar l)))
(format "newpath /c /c moveto 0 setlinewidth/n"
(caar points)(difference 400 (cadar points)))
(do ((l (cdr points) (cdr l)))
((atom l))
(format "/c /c lineto/n" (caar l) (fix (difference 400 (cadar l)))))
(format "stroke/n10 setlinewidth /c /c moveto/n"
(caar points)(difference 400 (cadar points)))
(do ((l (cdr points)(cdr l)))
((atom (cdr l))(format "stroke/n"))
(format "/c /c /c /c "
(caar l)(difference 400 (cadar l))
(caar l)(difference 400 (cadar l)))
(cond ((atom (cddr l))
(format "/c /c curveto/n"
(caadr l)(difference 400 (cadadr l))))
(t
(setq soko (inter2 (car l)(cadr l) 0.5))
(format "/c /c curveto/n"
(fix (car soko))(fix (difference 400 (cadr soko)))))))))
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |