From 2056821ff0b1f5738852c24632eb878808c0415a Mon Sep 17 00:00:00 2001 From: Kei Okada Date: Wed, 29 Mar 2023 12:08:43 +0900 Subject: [PATCH 1/4] add irtdraw, eps creater imported from rbrain/jsk/kdraw.l --- irteus/Makefile | 3 +- irteus/compile_irtg.l | 1 + irteus/irtdraw.l | 1113 +++++++++++++++++++++++++++++++++++++++++ irteus/irtext.l | 2 +- 4 files changed, 1117 insertions(+), 2 deletions(-) create mode 100644 irteus/irtdraw.l diff --git a/irteus/Makefile b/irteus/Makefile index 51fed4ae7..6e4921b47 100644 --- a/irteus/Makefile +++ b/irteus/Makefile @@ -94,7 +94,7 @@ MODULES.L=irt_modules.l EUSLIB_MODULES.L=$(addprefix $(EUSDIR)/lib/,$(MODULES.L)) IRTEUS=irtmath irtutil irtgraph gnuplotlib pgsql time -IRTEUSG=irtgeo pqp bullet irtcollision irtscene irtmodel irtsensor irtdyna irtrobot irtbvh irtcollada irtpointcloud irtstl irtwrl +IRTEUSG=irtgeo pqp bullet irtcollision irtscene irtmodel irtsensor irtdyna irtrobot irtbvh irtcollada irtpointcloud irtstl irtwrl irtdraw IRTEUSX=irtx IRTEUSIMG=irtimage eusjpeg png IRTEUSGL=irtgl irtglrgb irtviewer @@ -253,6 +253,7 @@ $(INSTALLOBJDIR)/irtdyna.$(OSFX): irtdyna.l $(INSTALLOBJDIR)/irtcollada.$(OSFX): irtcollada.l $(INSTALLOBJDIR)/irtstl.$(OSFX): irtstl.l $(INSTALLOBJDIR)/irtwrl.$(OSFX): irtwrl.l +$(INSTALLOBJDIR)/irtdraw.$(OSFX): irtdraw.l $(INSTALLOBJDIR)/irtsensor.$(OSFX): irtsensor.l $(INSTALLOBJDIR)/irtpointcloud.$(OSFX): irtpointcloud.l $(INSTALLOBJDIR)/irtrobot.$(OSFX): irtrobot.l diff --git a/irteus/compile_irtg.l b/irteus/compile_irtg.l index eab860ccc..fc1801c52 100644 --- a/irteus/compile_irtg.l +++ b/irteus/compile_irtg.l @@ -61,6 +61,7 @@ (comp:compile-file-if-src-newer "irtcollada.l" user::*objdir*) (comp:compile-file-if-src-newer "irtstl.l" user::*objdir*) (comp:compile-file-if-src-newer "irtwrl.l" user::*objdir*) +(comp:compile-file-if-src-newer "irtdraw.l" user::*objdir*) (comp:compile-file-if-src-newer "irtpointcloud.l" user::*objdir*) (exit 0) diff --git a/irteus/irtdraw.l b/irteus/irtdraw.l new file mode 100644 index 000000000..296fd92a3 --- /dev/null +++ b/irteus/irtdraw.l @@ -0,0 +1,1113 @@ +;;; +;;; Kdraw primitives by M.Inaba 1991.9.3 +;;; (Add line type, arrow, MLine by N.Sawasaki 5 Sep. 1991) +;;; (Add Poly, Elli, BSpl, CBSpl, Rect, pattern +;;; by N.Sawasaki 6 Sep. 1991) +;;; (Add Coordinate Transfomation by N.Sawasaki 7 Sep. 1991) +;;; +;;; $Log$ +;;; Revision 1.3 2007-01-29 14:16:11 kojima +;;; add draw-arc and use colors in draw-lines,draw-arc +;;; +;;; Revision 1.2 2005/05/04 23:00:54 inaba +;;; extend bounding box +;;; +;;; Revision 1.1.1.1 2000/03/13 10:37:01 kanehiro +;;; EusLisp library +;;; +;;; Revision 1.6 1999/11/29 14:58:01 kanehiro +;;; fixed line width and bounding box +;;; +;;; Revision 1.5 1998/07/31 04:56:43 kanehiro +;;; added :drawtext-primitive and kdraw-text-primitive +;;; +;;; Revision 1.4 1997/04/03 12:48:41 kanehiro +;;; merged change in branch jsk3_0 +;;; +;;; Revision 1.3.2.2 1997/03/28 04:27:02 kanehiro +;;; cahnged :drawin-line-list -> :drawn-image +;;; +;;; Revision 1.3.2.1 1997/02/25 06:07:32 kanehiro +;;; moved color difinition -> jskgl.l and changed color name string -> symbol +;;; +;;; Revision 1.3 1996/10/16 12:02:20 eus +;;; start logging +;;; +;;; + +(provide :kdraw "$Id$") +(in-package "GEOMETRY") + +(proclaim '(special *kdraw* *kdraw-coord*)) +(defclass kdraw-viewsurface + :super viewsurface + :slots (color strm fname) ) + +(defmethod kdraw-viewsurface + (:init (&rest args + &key ((:color c) 0) + ((:fname f) "kdrawout.eps") + (open t) + &allow-other-keys) + (setq fname f) + (setq color c) + (if open (send self :open fname)) + self) + (:open (&optional (f fname)) + (setq strm (open-kdraw-file (setq fname f)))) + (:close nil (close-kdraw-file strm)) + (:set-erase-mode ()) + (:set-show-mode ()) + (:clear () + (send self :close) + (send self :open fname)) + (:flush () t) + (:line-width (width) nil) + (:line-style (dash) nil) + (:drawline-primitive + (x0 y0 x1 y1 width &optional color) + (kdraw-line-primitive x0 y0 x1 y1 width strm color)) ;bug fixed by Y.K. 4/16/92 + (:drawtext-primitive + (x0 y0 textstring &optional color) + (kdraw-text-primitive x0 y0 textstring strm)) + (:draw-arc + (x0 y0 w h ang1 ang2 width &optional color) + (let* ((sc 100) (1persc (/ 1.0 sc))) + (kdraw-arc (float-vector (* sc x0) (* sc y0)) + (* sc w) (* sc h) ang1 ang2 + :xscale 1persc :yscale 1persc + :offset #f(2 -312) + :type (list 'norm (1+ width)) + :color color) + )) + (:begin-pict nil (kdraw-begin-pict strm)) + (:end-pict nil (kdraw-end-pict strm)) + ) +;;; +(defun kdraw-viewsurface-copy (vs fname) + (let ((kvs (instance kdraw-viewsurface :init :fname fname)) + (height (send vs :height))) + (send kvs :begin-pict) + (dolist (l (send vs :drawn-image)) + (case (length l) + (6 + (send kvs :drawline-primitive + (nth 0 l) (- height (nth 1 l)) + (nth 2 l) (- height (nth 3 l)) (nth 4 l) (nth 5 l))) + (4 + (send kvs :drawtext-primitive + (nth 0 l) (- (+ 10 height) (nth 1 l)) (nth 2 l))) + (8 + (send kvs :draw-arc + (+ (nth 0 l) (* 0.5 (nth 2 l))) + (- height (nth 1 l) (* 0.5 (nth 3 l))) + (* 0.5 (nth 2 l)) (* 0.5 (nth 3 l)) + (nth 4 l) (nth 5 l) (nth 6 l) (nth 7 l))) + ) + ) + (send kvs :end-pict) + (send kvs :close)) + ) +;;; +(defun kdraw-object (data &key (block t) (frame t) (hid t) + (fname "demo.eps") + ((:viewer ver)) + (close t)) + (cond + (ver + (kdraw-viewer fname :viewer ver)) + (t (kdraw-viewer fname))) + (if block (send (ver . surface) :begin-pict)) + (cond + (hid + (let ((*viewer* *kdraw-viewer*)) (hid data))) + (t (send ver :draw data))) + (if block (send (ver . surface) :end-pict)) + (if block (send (ver . surface) :begin-pict)) + (if frame (send ver :pane)) + (if block (send (ver . surface) :end-pict)) + (if close (send (ver . surface) :close))) +;;; +(defun kdraw-viewer (&optional (fname "demo.eps") + &key ((:viewer vw))) + (let ((k (instance kdraw-viewsurface :init :fname fname))) + (cond + (vw (setq (vw . surface) k) + (if (derivedp (send vw :viewport) canvas-viewsurface) + (send vw :viewport :height + (- (send vw :viewport :height)))) + (setq *kdraw-viewer* vw)) + (t + (setq *kdraw-viewer* + (instance viewer + :init + :viewing + (instance perspective-viewing :init + :screen-x 5 + :screen-y 5 + :viewdistance 40.0 + :hither 10000.0 + :yon 40.0 + :pos #f(1500 1000 500) + :target #f(0 0 0) + ) + :viewport + (instance viewport + :init :width 256 :height 256 + :xcenter 256 :ycenter 256) + :viewsurface k)))) + )) +;; +(defun kdraw-begin-pict (&optional (strm *kdraw*)) + (format strm "~%Begin %I Pict~%") + (format strm "%I b u~%") + (format strm "%I cfg u~%") + (format strm "%I cbg u~%") + (format strm "%I f u~%") + (format strm "%I k u~%") + (format strm "%I p u~%") + (format strm "%I t u~%") + ) +;; +(defun kdraw-end-pict (&optional (strm *kdraw*)) + (format strm "End %I eop~%")) +;; +(defun kdraw-line-primitive (x0 y0 x1 y1 width &optional (strm *kdraw*) + (color (list 0 #xffffff))) + (format strm "Begin %I Line~%") + (format strm "%I b 65535~%") + (format strm "~A 0 0 [] 0 SetB~%" (1+ width)) + (format strm "%I cfg~%") + (format strm "~A ~A ~A SetCFg~%" + (/ (ash (logand (car color) #xff0000) -16) 255.0) + (/ (ash (logand (car color) #x00ff00) -8) 255.0) + (/ (ash (logand (car color) #x0000ff) 0) 255.0)) + (format strm "%I cbg~%") + (format strm "~A ~A ~A SetCBg~%" + (/ (ash (logand (cadr color) #xff0000) -16) 255.0) + (/ (ash (logand (cadr color) #x00ff00) -8) 255.0) + (/ (ash (logand (cadr color) #x0000ff) 0) 255.0)) + (format strm "%I p~%") + (format strm "0 SetP~%") + (format strm "%I t~%") + (format strm "[ 0.01 0 0 0.01 102 188 ] concat~%") + (format strm "%I~%") + (format strm "~a ~a ~a ~a Line~%" + (round (* 100 x0)) (round (* 100 y0)) + (round (* 100 x1)) (round (* 100 y1))) + (format strm "End~%") + ) + +(defun kdraw-text-primitive (x0 y0 textstring &optional (strm *kdraw*)) + (format strm "Begin %I Text~%") + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I f *-helvetica-medium-r-*-120-*~%") + (format strm "/Helvetica 12 SetF~%") + (format strm "%I t~%") + (format strm "[ 1 0 0 1 ~a ~a ] concat~%" (+ 102 x0 ) (+ 188 y0)) + (format strm "%I~%") + (format strm "[~%") + (format strm "(~a)~%" textstring) + (format strm "] WhiteBg Text~%") + (format strm "End~%") + ) + +;; +;; +(defun kdraw-check-linetype (type) + (cond + ((consp type) + (cond + ((eq (first type) 'norm) + (cond + ((eq (second type) 'bold1) '(65535 2 "[]" 0)) + ((eq (second type) 'bold2) (list 65535 5 "[]" 0)) + ((numberp (second type)) (list 65535 (second type) "[]" 0)))) + ((eq (first type) 'dotted) + (cond + ((eq (second type) 'bold1) '(13107 2 "[2 2 2 2 2 2 2 2]" 15)) + ((eq (second type) 'bold1aux) '(13107 2 "[2 2 2 2 2 2 2 2]" 15)) + ((eq (second type) 'bold2) (list 13107 5 "[8 8]" 17)))))) + ((eq type 'dotted) '(13107 1 "[2 2 2 2 2 2 2 2]" 15)) + (t '(65535 1 "[]" 0))) + ) +;; +(defun kdraw-check-arrow (arrow) + (cond + ((eq arrow 'start) '(1 0)) + ((eq arrow 'end) '(0 1)) + ((eq arrow 'both) '(1 1)) + (t '(0 0))) + ) +;; +(defun kdraw-set-pattern (pattern strm &optional arrow) + (cond + ((or (null arrow) (eq arrow 'none)) + (cond + ((and (>= pattern 0) (<= pattern 1)) + (format strm "%I p~%") + (format strm "~a SetP~%" pattern)) + (t (format strm "none SetP %I p n~%")))) + (t (format strm "%I p~%") + (format strm "0 SetP~%"))) + ) +;; +(defun kdraw-make-coord (&key (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil)) + (let* ((smat (make-matrix 2 2)) + (rmat (make-matrix 2 2)) + (theta (deg2rad rot)) + (sin (sin theta)) + (cos (cos theta))) + (setf (aref smat 0 0) xscale) + (setf (aref smat 1 1) yscale) + (setf (aref rmat 0 0) cos) + (setf (aref rmat 0 1) sin) + (setf (aref rmat 1 0) (- sin)) + (setf (aref rmat 1 1) cos) + (cond + (inv (list (m* rmat smat) offset)) + (t (list (m* smat rmat) offset)))) + ) +;; +(defun kdraw-make-trans-string (tcoord) + (cond + ((null tcoord) *kdraw-coord-string*) + (t (make-coord-string (m* (first *kdraw-coord*) (first tcoord)) + (v+ (second *kdraw-coord*) (second tcoord))))) + ) +;; +(defun kdraw-line (p0 p1 &key (type 'norm) + (arrow 'none) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*)) + (let ((adata (kdraw-check-arrow arrow)) + (tdata (kdraw-check-linetype type))) + (format strm "Begin %I Line~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a ~a ~a ~a ~a SetB~%" + (second tdata) (first adata) (second adata) (third tdata) (fourth tdata)) + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I cbg White~%") + (format strm "1 1 1 SetCBg~%") + (format strm "%I p~%") + (format strm "0 SetP~%") + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I~%") + (format strm "~a ~a ~a ~a Line~%" + (round (aref p0 0)) (round (aref p0 1)) + (round (aref p1 0)) (round (aref p1 1))) + (format strm "End~%")) + strm) +;; +(defun kdraw-arc (p0 w h ang1 ang2 &key (type 'norm) + (arrow 'none) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*) + (color (list 0 #xffffff))) + (let ((adata (kdraw-check-arrow arrow)) + (tdata (kdraw-check-linetype type))) + (format strm "Begin %I Arc~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a ~a ~a ~a ~a SetB~%" + (second tdata) (first adata) (second adata) (third tdata) (fourth tdata)) + (format strm "%I cfg~%") + (format strm "~A ~A ~A SetCFg~%" + (/ (ash (logand (car color) #xff0000) -16) 255.0) + (/ (ash (logand (car color) #x00ff00) -8) 255.0) + (/ (ash (logand (car color) #x0000ff) 0) 255.0)) + (format strm "%I cbg~%") + (format strm "~A ~A ~A SetCBg~%" + (/ (ash (logand (cadr color) #xff0000) -16) 255.0) + (/ (ash (logand (cadr color) #x00ff00) -8) 255.0) + (/ (ash (logand (cadr color) #x0000ff) 0) 255.0)) + (format strm "%I p~%") + (format strm "0 SetP~%") + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I~%") + (format strm "~a ~a ~a ~a ~a ~a Arc~%" + (round (elt p0 0)) (round (elt p0 1)) + (round w) (round h) + (round (rad2deg ang1)) (round (rad2deg ang2))) + (format strm "End~%")) + strm) +;; +(defun kdraw-polyline (plist &key (type 'norm) + (arrow 'none) + (pattern -1) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*)) + (let ((len (length plist)) + (adata (kdraw-check-arrow arrow)) + (tdata (kdraw-check-linetype type))) + (format strm "Begin %I MLine~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a ~a ~a ~a ~a SetB~%" + (second tdata) (first adata) (second adata) (third tdata) (fourth tdata)) + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I cbg White~%") + (format strm "1 1 1 SetCBg~%") + (kdraw-set-pattern pattern strm arrow) + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I ~a~%" len) + (dolist (pv plist) + (format strm "~a ~a ~%" (round (aref pv 0)) (round (aref pv 1)))) + (format strm "~a MLine~%" len) + (format strm "End~%")) + strm) +;; +(defun kdraw-polygon (plist &key (type 'norm) + (pattern -1) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*)) + (let ((len (length plist)) + (tdata (kdraw-check-linetype type))) + (format strm "Begin %I Poly~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a 0 0 ~a ~a SetB~%" + (second tdata) (third tdata) (fourth tdata)) + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I cbg White~%") + (format strm "1 1 1 SetCBg~%") + (kdraw-set-pattern pattern strm) + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I ~a~%" len) + (dolist (pv plist) + (format strm "~a ~a ~%" (round (aref pv 0)) (round (aref pv 1)))) + (format strm "~a Poly~%" len) + (format strm "End~%")) + strm) +;; +(defun kdraw-elli (cv rx ry &key (type 'norm) + (pattern -1) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*)) + (let ((tdata (kdraw-check-linetype type))) + (format strm "Begin %I Elli~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a 0 0 ~a ~a SetB~%" + (second tdata) (third tdata) (fourth tdata)) + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I cbg White~%") + (format strm "1 1 1 SetCBg~%") + (kdraw-set-pattern pattern strm) + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I~%") + (format strm "~a ~a ~a ~a Elli~%" + (round (aref cv 0)) (round (aref cv 1)) (round rx) (round ry)) + (format strm "End~%")) + strm) +;; +(defun kdraw-bspl (plist &key (type 'norm) + (arrow 'none) + (pattern -1) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*)) + (let ((len (length plist)) + (adata (kdraw-check-arrow arrow)) + (tdata (kdraw-check-linetype type))) + (format strm "Begin %I BSpl~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a ~a ~a ~a ~a SetB~%" + (second tdata) (first adata) (second adata) (third tdata) (fourth tdata)) + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I cbg White~%") + (format strm "1 1 1 SetCBg~%") + (kdraw-set-pattern pattern strm arrow) + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I ~a~%" len) + (dolist (pv plist) + (format strm "~a ~a ~%" (round (aref pv 0)) (round (aref pv 1)))) + (format strm "~a BSpl~%" len) + (format strm "End~%")) + strm) +;; +(defun kdraw-cbspl (plist &key (type 'norm) + (pattern -1) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*)) + (let ((len (length plist)) + (tdata (kdraw-check-linetype type))) + (format strm "Begin %I CBSpl~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a 0 0 ~a ~a SetB~%" + (second tdata) (third tdata) (fourth tdata)) + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I cbg White~%") + (format strm "1 1 1 SetCBg~%") + (kdraw-set-pattern pattern strm) + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I ~a~%" len) + (dolist (pv plist) + (format strm "~a ~a ~%" (round (aref pv 0)) (round (aref pv 1)))) + (format strm "~a CBSpl~%" len) + (format strm "End~%")) + strm) +;; +(defun kdraw-rect (sv ev &key (type 'norm) + (pattern -1) + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + ((:stream strm) *kdraw*)) + (let ((tdata (kdraw-check-linetype type))) + (format strm "Begin %I Rect~%") + (format strm "%I b ~a~%" (first tdata)) + (format strm "~a 0 0 ~a ~a SetB~%" + (second tdata) (third tdata) (fourth tdata)) + (format strm "%I cfg Black~%") + (format strm "0 0 0 SetCFg~%") + (format strm "%I cbg White~%") + (format strm "1 1 1 SetCBg~%") + (kdraw-set-pattern pattern strm) + (format strm "%I t~%") + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (format strm "~a concat~%" (kdraw-make-trans-string trans-coord)) + (format strm "%I~%") + (format strm "~a ~a ~a ~a Rect~%" + (round (aref sv 0)) (round (aref sv 1)) + (round (aref ev 0)) (round (aref ev 1))) + (format strm "End~%")) + strm) +;; +(defmacro format-to-string (x &rest args) + `(let ((strm (make-string-output-stream))) + (format strm ,x ,@args) + (subseq (strm . buffer) 0 (strm . count))) + ) +;; +(defun make-coord-string (tmat offset) + (format-to-string "[~a ~a ~a ~a ~a ~a ]" + (aref tmat 0 0) (aref tmat 0 1) + (aref tmat 1 0) (aref tmat 1 1) + (aref offset 0) (aref offset 1)) + ) +;; +(defun kdraw-get-page-info () *kdraw-coord*) +;; +(defun kdraw-page-setup (&key + (xscale 1) + (yscale 1) + (rot 0.0) + (offset (float-vector 0 0)) + (inv nil) + (trans-coord nil) + (default nil)) + (cond + (default + (setq *kdraw-coord* *kdraw-default-coord* + *kdraw-coord-string* *kdraw-default-coord-string*)) + (t + (if (null trans-coord) + (setq trans-coord (kdraw-make-coord :xscale xscale + :yscale yscale + :rot rot + :offset offset + :inv inv))) + (setq *kdraw-coord* trans-coord + *kdraw-coord-string* (make-coord-string (first trans-coord) + (second trans-coord))))) + *kdraw-coord*) +;; +(defun close-kdraw-file (&optional (strm *kdraw*)) + (format strm "~%End %I eop~%") + (format strm "showpage~%") + (format strm "%%Trailer~%") + (format strm "end~%~%") + (close strm) + ) +#| +(defun open-kdraw-file (fname) + (let ((dat nil)) + (setq *kdraw* (open fname :direction :output)) + (with-open-file + (f "kdrawhead.eps" :direction :input) + (while (setq dat (read-line f nil nil)) + (format *kdraw* "~a~%" dat)) + ))) +|# +(defun open-kdraw-file (fname) + (let ((strm nil)) + (setq strm (open fname :direction :output)) + (setq *kdraw* strm) + (setq *kdraw-coord* (list (unit-matrix 2) (float-vector 100 500)) + *kdraw-coord-string* "[1 0 0 1 100 500 ]" + *kdraw-default-coord* *kdraw-coord* + *kdraw-default-coord-string* *kdraw-coord*) ;; added by N.S + (format strm "%!PS-Adobe-2.0 EPSF-1.2~%") + (format strm "%%DocumentFonts:~%") + (format strm "%%Pages: 1~%") + (format strm "%%BoundingBox: 70 145 500 500~%") + (format strm "%%EndComments~%") + (format strm "~%") + (format strm "50 dict begin~%") + (format strm "~%") + (format strm "/arrowHeight 8 def~%") + (format strm "/arrowWidth 4 def~%") + (format strm "/none null def~%") + (format strm "/numGraphicParameters 17 def~%") + (format strm "/stringLimit 65535 def~%") + (format strm "~%") + (format strm "/Begin {~%") + (format strm "save~%") + (format strm "numGraphicParameters dict begin~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/End {~%") + (format strm "end~%") + (format strm "restore~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/SetB {~%") + (format strm "dup type /nulltype eq {~%") + (format strm "pop~%") + (format strm "false /brushRightArrow idef~%") + (format strm "false /brushLeftArrow idef~%") + (format strm "true /brushNone idef~%") + (format strm "} {~%") + (format strm "/brushDashOffset idef~%") + (format strm "/brushDashArray idef~%") + (format strm "0 ne /brushRightArrow idef~%") + (format strm "0 ne /brushLeftArrow idef~%") + (format strm "/brushWidth idef~%") + (format strm "false /brushNone idef~%") + (format strm "} ifelse~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/SetCFg {~%") + (format strm "/fgblue idef~%") + (format strm "/fggreen idef~%") + (format strm "/fgred idef~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/SetCBg {~%") + (format strm "/bgblue idef~%") + (format strm "/bggreen idef~%") + (format strm "/bgred idef~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/SetF {~%") + (format strm "/printSize idef~%") + (format strm "/printFont idef~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/SetP {~%") + (format strm "dup type /nulltype eq {~%") + (format strm "pop true /patternNone idef~%") + (format strm "} {~%") + (format strm "/patternGrayLevel idef~%") + (format strm "patternGrayLevel -1 eq {~%") + (format strm "/patternString idef~%") + (format strm "} if~%") + (format strm "false /patternNone idef~%") + (format strm "} ifelse~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/BSpl {~%") + (format strm "0 begin~%") + (format strm "storexyn~%") + (format strm "newpath~%") + (format strm "n 1 gt {~%") + (format strm "0 0 0 0 0 0 1 1 true subspline~%") + (format strm "n 2 gt {~%") + (format strm "0 0 0 0 1 1 2 2 false subspline~%") + (format strm "1 1 n 3 sub {~%") + (format strm "/i exch def~%") + (format strm "i 1 sub dup i dup i 1 add dup i 2 add dup false subspline~%") + (format strm "} for~%") + (format strm "n 3 sub dup n 2 sub dup n 1 sub dup 2 copy false subspline~%") + (format strm "} if~%") + (format strm "n 2 sub dup n 1 sub dup 2 copy 2 copy false subspline~%") + (format strm "patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "0 0 1 1 leftarrow~%") + (format strm "n 2 sub dup n 1 sub dup rightarrow~%") + (format strm "} if~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "/Circ {~%") + (format strm "newpath~%") + (format strm "0 360 arc~%") + (format strm "patternNone not { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/CBSpl {~%") + (format strm "0 begin~%") + (format strm "dup 2 gt {~%") + (format strm "storexyn~%") + (format strm "newpath~%") + (format strm "n 1 sub dup 0 0 1 1 2 2 true subspline~%") + (format strm "1 1 n 3 sub {~%") + (format strm "/i exch def~%") + (format strm "i 1 sub dup i dup i 1 add dup i 2 add dup false subspline~%") + (format strm "} for~%") + (format strm "n 3 sub dup n 2 sub dup n 1 sub dup 0 0 false subspline~%") + (format strm "n 2 sub dup n 1 sub dup 0 0 1 1 false subspline~%") + (format strm "patternNone not { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "} {~%") + (format strm "Poly~%") + (format strm "} ifelse~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "~%") + (format strm "/RRect { CBSpl } def~%") + (format strm "~%") + (format strm "/Elli {~%") + (format strm "0 begin~%") + (format strm "newpath~%") + (format strm "4 2 roll~%") + (format strm "translate~%") + (format strm "scale~%") + (format strm "0 0 1 0 360 arc~%") + (format strm "patternNone not { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "end~%") + (format strm "} dup 0 1 dict put def~%") + (format strm "~%") + (format strm "/Arc {~%") + (format strm "0 begin~%") + (format strm "newpath~%") + (format strm "6 2 roll~%") + (format strm "4 2 roll~%") + (format strm "translate~%") + (format strm "scale~%") + (format strm "0 0 1~%") + (format strm "5 3 roll~%") + (format strm "arc~%") +;; (format strm "patternNone not { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "end~%") + (format strm "} dup 0 1 dict put def~%") + (format strm "~%") + (format strm "/Line {~%") + (format strm "0 begin~%") + (format strm "2 storexyn~%") + (format strm "newpath~%") + (format strm "x 0 get y 0 get moveto~%") + (format strm "x 1 get y 1 get lineto~%") + (format strm "brushNone not { istroke } if~%") + (format strm "0 0 1 1 leftarrow~%") + (format strm "0 0 1 1 rightarrow~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "/MLine {~%") + (format strm "0 begin~%") + (format strm "storexyn~%") + (format strm "newpath~%") + (format strm "n 1 gt {~%") + (format strm "x 0 get y 0 get moveto~%") + (format strm "1 1 n 1 sub {~%") + (format strm "/i exch def~%") + (format strm "x i get y i get lineto~%") + (format strm "} for~%") + (format strm "patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "0 0 1 1 leftarrow~%") + (format strm "n 2 sub dup n 1 sub dup rightarrow~%") + (format strm "} if~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "/Poly {~%") + (format strm "3 1 roll~%") + (format strm "newpath~%") + (format strm "moveto~%") + (format strm "-1 add~%") + (format strm "{ lineto } repeat~%") + (format strm "closepath~%") + (format strm "patternNone not { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/Rect {~%") + (format strm "0 begin~%") + (format strm "/t exch def~%") + (format strm "/r exch def~%") + (format strm "/b exch def~%") + (format strm "/l exch def~%") + (format strm "newpath~%") + (format strm "l b moveto~%") + (format strm "l t lineto~%") + (format strm "r t lineto~%") + (format strm "r b lineto~%") + (format strm "closepath~%") + (format strm "patternNone not { ifill } if~%") + (format strm "brushNone not { istroke } if~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "/WhiteBg 1 def~%") + (format strm "/HollowBg 0 def~%") + (format strm "/Text { ishow } def~%") + (format strm "~%") + (format strm "/idef {~%") + (format strm "dup where { pop pop pop } { exch def } ifelse~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/ifill {~%") + (format strm "0 begin~%") + (format strm "gsave~%") + (format strm "patternGrayLevel -1 ne {~%") + (format strm "fgred bgred fgred sub patternGrayLevel mul add~%") + (format strm "fggreen bggreen fggreen sub patternGrayLevel mul add~%") + (format strm "fgblue bgblue fgblue sub patternGrayLevel mul add setrgbcolor~%") + (format strm "eofill~%") + (format strm "} {~%") + (format strm "eoclip~%") + (format strm "originalCTM setmatrix~%") + (format strm "pathbbox /t exch def /r exch def /b exch def /l exch def~%") + (format strm "/w r l sub ceiling cvi def~%") + (format strm "/h t b sub ceiling cvi def~%") + (format strm "/imageByteWidth w 8 div ceiling cvi def~%") + (format strm "/imageHeight h def~%") + (format strm "bgred bggreen bgblue setrgbcolor~%") + (format strm "eofill~%") + (format strm "fgred fggreen fgblue setrgbcolor~%") + (format strm "w 0 gt h 0 gt and {~%") + (format strm "l b translate w h scale~%") + (format strm "w h true [w 0 0 h neg 0 h] { patternproc } imagemask~%") + (format strm "} if~%") + (format strm "} ifelse~%") + (format strm "grestore~%") + (format strm "end~%") + (format strm "} dup 0 8 dict put def~%") + (format strm "~%") + (format strm "/istroke {~%") + (format strm "gsave~%") + (format strm "brushDashOffset -1 eq {~%") +(format strm "[] 0 setdash~%") +(format strm "1 setgray~%") +(format strm "} {~%") +(format strm "brushDashArray brushDashOffset setdash~%") +(format strm "fgred fggreen fgblue setrgbcolor~%") +(format strm "} ifelse~%") +(format strm "brushWidth setlinewidth~%") +(format strm "originalCTM setmatrix~%") +(format strm "stroke~%") +(format strm "grestore~%") +(format strm "} def~%") +(format strm "~%") +(format strm "/xdescender {~%") +(format strm "begin 0~%") +(format strm "FontType 0 eq~%") +(format strm "{ FDepVector dup length 1 sub get xdescender }~%") +(format strm "{ [FontBBox] 1 get } ifelse~%") +(format strm "FontMatrix transform exch pop end~%") +(format strm "} def~%") +(format strm "/ishow {~%") +(format strm "0 begin~%") +(format strm "gsave~%") +(format strm "fgred fggreen fgblue setrgbcolor~%") +(format strm "WhiteBg eq /drawBg exch def~%") +(format strm "/fontDict printFont findfont printSize scalefont dup setfont def~%") +(format strm "/descender fontDict xdescender def~%") +(format strm "/vertoffset 0 descender sub printSize sub printFont /Courier ne~%") +(format strm "printFont /Courier-Bold ne and { 1 add } if def {~%") +(format strm "drawBg {~%") +(format strm "newpath 0 vertoffset descender add moveto~%") +(format strm "dup stringwidth pop dup 0 rlineto~%") +(format strm "0 printSize rlineto 0 exch sub 0 rlineto~%") +(format strm "closepath currentgray 1 setgray fill setgray } if~%") +(format strm "0 vertoffset moveto show~%") +(format strm "/vertoffset vertoffset printSize sub def~%") +(format strm "} forall~%") +(format strm "grestore~%") +(format strm "end~%") +(format strm "} dup 0 4 dict put def~%") +(format strm "~%") +(format strm "/patternproc {~%") +(format strm "0 begin~%") +(format strm "/patternByteLength patternString length def~%") +(format strm "/patternHeight patternByteLength 8 mul sqrt cvi def~%") +(format strm "/patternWidth patternHeight def~%") +(format strm "/patternByteWidth patternWidth 8 idiv def~%") +(format strm "/imageByteMaxLength imageByteWidth imageHeight mul~%") +(format strm "stringLimit patternByteWidth sub min def~%") +(format strm "/imageMaxHeight imageByteMaxLength imageByteWidth idiv patternHeight idiv~%") +(format strm "patternHeight mul patternHeight max def~%") +(format strm "/imageHeight imageHeight imageMaxHeight sub store~%") +(format strm "/imageString imageByteWidth imageMaxHeight mul patternByteWidth add string def~%") +(format strm "0 1 imageMaxHeight 1 sub {~%") +(format strm "/y exch def~%") +(format strm "/patternRow y patternByteWidth mul patternByteLength mod def~%") +(format strm "/patternRowString patternString patternRow patternByteWidth getinterval def~%") +(format strm "/imageRow y imageByteWidth mul def~%") +(format strm "0 patternByteWidth imageByteWidth 1 sub {~%") +(format strm "/x exch def~%") +(format strm "imageString imageRow x add patternRowString putinterval~%") +(format strm "} for~%") +(format strm "} for~%") +(format strm "imageString~%") +(format strm "end~%") +(format strm "} dup 0 12 dict put def~%") +(format strm "~%") +(format strm "/min {~%") +(format strm "dup 3 2 roll dup 4 3 roll lt { exch } if pop~%") +(format strm "} def~%") +(format strm "~%") +(format strm "/max {~%") +(format strm "dup 3 2 roll dup 4 3 roll gt { exch } if pop~%") +(format strm "} def~%") +(format strm "~%") +(format strm "/arrowhead {~%") +(format strm "0 begin~%") +(format strm "transform originalCTM itransform~%") +(format strm "/taily exch def~%") +(format strm "/tailx exch def~%") +(format strm "transform originalCTM itransform~%") +(format strm "/tipy exch def~%") +(format strm "/tipx exch def~%") +(format strm "/dy tipy taily sub def~%") +(format strm "/dx tipx tailx sub def~%") +(format strm "/angle dx 0 ne dy 0 ne or { dy dx atan } { 90 } ifelse def~%") +(format strm "gsave~%") +(format strm "originalCTM setmatrix~%") +(format strm "tipx tipy translate~%") +(format strm "angle rotate~%") +(format strm "newpath~%") +(format strm "0 0 moveto~%") +(format strm "arrowHeight neg arrowWidth 2 div lineto~%") +(format strm "arrowHeight neg arrowWidth 2 div neg lineto~%") +(format strm "closepath~%") +(format strm "patternNone not {~%") +(format strm "originalCTM setmatrix~%") +(format strm "/padtip arrowHeight 2 exp 0.25 arrowWidth 2 exp mul add sqrt brushWidth mul~%") +(format strm "arrowWidth div def~%") +(format strm "/padtail brushWidth 2 div def~%") +(format strm "tipx tipy translate~%") +(format strm "angle rotate~%") +(format strm "padtip 0 translate~%") +(format strm "arrowHeight padtip add padtail add arrowHeight div dup scale~%") +(format strm "arrowheadpath~%") +(format strm "ifill~%") +(format strm "} if~%") +(format strm "brushNone not {~%") +(format strm "originalCTM setmatrix~%") +(format strm "tipx tipy translate~%") +(format strm "angle rotate~%") +(format strm "arrowheadpath~%") +(format strm "istroke~%") +(format strm "} if~%") +(format strm "grestore~%") +(format strm "end~%") +(format strm "} dup 0 9 dict put def~%") +(format strm "~%") +(format strm "/arrowheadpath {~%") +(format strm "newpath~%") +(format strm "0 0 moveto~%") +(format strm "arrowHeight neg arrowWidth 2 div lineto~%") +(format strm "arrowHeight neg arrowWidth 2 div neg lineto~%") +(format strm "closepath~%") +(format strm "} def~%") +(format strm "~%") +(format strm "/leftarrow {~%") +(format strm "0 begin~%") +(format strm "y exch get /taily exch def~%") +(format strm "x exch get /tailx exch def~%") +(format strm "y exch get /tipy exch def~%") +(format strm "x exch get /tipx exch def~%") +(format strm "brushLeftArrow { tipx tipy tailx taily arrowhead } if~%") +(format strm "end~%") +(format strm "} dup 0 4 dict put def~%") +(format strm "~%") +(format strm "/rightarrow {~%") +(format strm "0 begin~%") +(format strm "y exch get /tipy exch def~%") +(format strm "x exch get /tipx exch def~%") +(format strm "y exch get /taily exch def~%") +(format strm "x exch get /tailx exch def~%") +(format strm "brushRightArrow { tipx tipy tailx taily arrowhead } if~%") +(format strm "end~%") +(format strm "} dup 0 4 dict put def~%") +(format strm "~%") +(format strm "/midpoint {~%") +(format strm "0 begin~%") +(format strm "/y1 exch def~%") +(format strm "/x1 exch def~%") +(format strm "/y0 exch def~%") +(format strm "/x0 exch def~%") +(format strm "x0 x1 add 2 div~%") +(format strm "y0 y1 add 2 div~%") +(format strm "end~%") +(format strm "} dup 0 4 dict put def~%") +(format strm "~%") +(format strm "/thirdpoint {~%") +(format strm "0 begin~%") +(format strm "/y1 exch def~%") +(format strm "/x1 exch def~%") +(format strm "/y0 exch def~%") +(format strm "/x0 exch def~%") +(format strm "x0 2 mul x1 add 3 div~%") +(format strm "y0 2 mul y1 add 3 div~%") +(format strm "end~%") +(format strm "} dup 0 4 dict put def~%") +(format strm "~%") +(format strm "/subspline {~%") +(format strm "0 begin~%") +(format strm "/movetoNeeded exch def~%") +(format strm "y exch get /y3 exch def~%") +(format strm "x exch get /x3 exch def~%") +(format strm "y exch get /y2 exch def~%") +(format strm "x exch get /x2 exch def~%") +(format strm "y exch get /y1 exch def~%") +(format strm "x exch get /x1 exch def~%") +(format strm "y exch get /y0 exch def~%") +(format strm "x exch get /x0 exch def~%") +(format strm "x1 y1 x2 y2 thirdpoint~%") +(format strm "/p1y exch def~%") +(format strm "/p1x exch def~%") +(format strm "x2 y2 x1 y1 thirdpoint~%") +(format strm "/p2y exch def~%") +(format strm "/p2x exch def~%") +(format strm "x1 y1 x0 y0 thirdpoint~%") +(format strm "p1x p1y midpoint~%") +(format strm "/p0y exch def~%") +(format strm "/p0x exch def~%") +(format strm "x2 y2 x3 y3 thirdpoint~%") +(format strm "p2x p2y midpoint~%") +(format strm "/p3y exch def~%") +(format strm "/p3x exch def~%") +(format strm "movetoNeeded { p0x p0y moveto } if~%") +(format strm "p1x p1y p2x p2y p3x p3y curveto~%") +(format strm "end~%") +(format strm "} dup 0 17 dict put def~%") +(format strm "~%") +(format strm "/storexyn {~%") +(format strm "/n exch def~%") +(format strm "/y n array def~%") +(format strm "/x n array def~%") +(format strm "n 1 sub -1 0 {~%") +(format strm "/i exch def~%") +(format strm "y i 3 2 roll put~%") +(format strm "x i 3 2 roll put~%") +(format strm "} for~%") +(format strm "} def~%") +(format strm "~%") +(format strm "%%EndProlog~%") +(format strm "~%") +(format strm "%I Idraw 9 Grid 8 ~%") +(format strm "~%") +(format strm "%%Page: 1 1~%") +(format strm "~%") +(format strm "Begin~%") +(format strm "%I b u~%") +(format strm "%I cfg u~%") +(format strm "%I cbg u~%") +(format strm "%I f u~%") +(format strm "%I k u~%") +(format strm "%I p u~%") +(format strm "%I t~%") +(format strm "[ .8 0 0 .8 0 0 ] concat~%") +(format strm "/originalCTM matrix currentmatrix def~%") +(format strm "~%") +strm)) + +;;;(eval-when (eval) (format t ";; loaded kdraw.l~%")) +;;;(eval-when (load) (format t ";; loaded kdraw.o~%")) diff --git a/irteus/irtext.l b/irteus/irtext.l index b21416881..260e4357d 100644 --- a/irteus/irtext.l +++ b/irteus/irtext.l @@ -53,7 +53,7 @@ (load-library (format nil "~A~A/lib/libirteusg" *eusdir* (unix:getenv "ARCHDIR")) - '("irtgeo" "euspqp" "pqp" "irtscene" "irtmodel" "irtdyna" "irtrobot" "irtsensor" "irtbvh" "irtcollada" "irtstl" "irtwrl" "irtpointcloud" "eusbullet" "bullet" "irtcollision")) + '("irtgeo" "euspqp" "pqp" "irtscene" "irtmodel" "irtdyna" "irtrobot" "irtsensor" "irtbvh" "irtcollada" "irtstl" "irtwrl" "irtdraw" "irtpointcloud" "eusbullet" "bullet" "irtcollision")) (in-package "USER") (import '(collada::convert-irtmodel-to-collada collada::eus2collada))) (defun load-irteusx () From 84091dc4cb72ad46c15c0f5edb4c2bad652734e0 Mon Sep 17 00:00:00 2001 From: Kei Okada Date: Wed, 29 Mar 2023 12:11:48 +0900 Subject: [PATCH 2/4] 2023.3.28 created for idraw imported from rbrain/jsk/kdraw.l, M.Inaba --- irteus/irtdraw.l | 572 +++++++++++++++++++++++++---------------------- 1 file changed, 305 insertions(+), 267 deletions(-) diff --git a/irteus/irtdraw.l b/irteus/irtdraw.l index 296fd92a3..b3fc733d5 100644 --- a/irteus/irtdraw.l +++ b/irteus/irtdraw.l @@ -1,9 +1,12 @@ ;;; ;;; Kdraw primitives by M.Inaba 1991.9.3 -;;; (Add line type, arrow, MLine by N.Sawasaki 5 Sep. 1991) -;;; (Add Poly, Elli, BSpl, CBSpl, Rect, pattern -;;; by N.Sawasaki 6 Sep. 1991) -;;; (Add Coordinate Transfomation by N.Sawasaki 7 Sep. 1991) +;;; 2023.3.28 created for idraw imported from rbrain/jsk/kdraw.l +;;; to install idraw : sudo apt install ivtools-dev ivtools-bin +;;; +;;; (Add line type, arrow, MLine by N.Sawasaki 5 Sep. 1991) +;;; (Add Poly, Elli, BSpl, CBSpl, Rect, pattern +;;; by N.Sawasaki 6 Sep. 1991) +;;; (Add Coordinate Transfomation by N.Sawasaki 7 Sep. 1991) ;;; ;;; $Log$ ;;; Revision 1.3 2007-01-29 14:16:11 kojima @@ -33,9 +36,7 @@ ;;; Revision 1.3 1996/10/16 12:02:20 eus ;;; start logging ;;; -;;; - -(provide :kdraw "$Id$") +(provide :irtdraw "$Id$") (in-package "GEOMETRY") (proclaim '(special *kdraw* *kdraw-coord*)) @@ -133,9 +134,6 @@ (let ((k (instance kdraw-viewsurface :init :fname fname))) (cond (vw (setq (vw . surface) k) - (if (derivedp (send vw :viewport) canvas-viewsurface) - (send vw :viewport :height - (- (send vw :viewport :height)))) (setq *kdraw-viewer* vw)) (t (setq *kdraw-viewer* @@ -176,7 +174,8 @@ (color (list 0 #xffffff))) (format strm "Begin %I Line~%") (format strm "%I b 65535~%") - (format strm "~A 0 0 [] 0 SetB~%" (1+ width)) +;; (format strm "~A 0 0 [] 0 SetB~%" (1+ width)) 2023.3.28 + (format strm "~A 0 0 [] 0 SetB~%" 2) ;; (1+ width)) (format strm "%I cfg~%") (format strm "~A ~A ~A SetCFg~%" (/ (ash (logand (car color) #xff0000) -16) 255.0) @@ -300,8 +299,7 @@ (format strm "0 0 0 SetCFg~%") (format strm "%I cbg White~%") (format strm "1 1 1 SetCBg~%") - (format strm "%I p~%") - (format strm "0 SetP~%") + (format strm "none SetP %I p n~%") (format strm "%I t~%") (if (null trans-coord) (setq trans-coord (kdraw-make-coord :xscale xscale @@ -314,6 +312,7 @@ (format strm "~a ~a ~a ~a Line~%" (round (aref p0 0)) (round (aref p0 1)) (round (aref p1 0)) (round (aref p1 1))) + (format strm "%I 1~%") (format strm "End~%")) strm) ;; @@ -636,16 +635,92 @@ *kdraw-coord-string* "[1 0 0 1 100 500 ]" *kdraw-default-coord* *kdraw-coord* *kdraw-default-coord-string* *kdraw-coord*) ;; added by N.S + (format strm "%!PS-Adobe-2.0 EPSF-1.2~%") + (format strm "%%Creator: idraw~%") (format strm "%%DocumentFonts:~%") (format strm "%%Pages: 1~%") - (format strm "%%BoundingBox: 70 145 500 500~%") + (format strm "%%BoundingBox: 0 -600 500 600~%") (format strm "%%EndComments~%") (format strm "~%") - (format strm "50 dict begin~%") + (format strm "%%BeginIdrawPrologue~%") + (format strm "/arrowhead {~%") + (format strm "0 begin~%") + (format strm "transform originalCTM itransform~%") + (format strm "/taily exch def~%") + (format strm "/tailx exch def~%") + (format strm "transform originalCTM itransform~%") + (format strm "/tipy exch def~%") + (format strm "/tipx exch def~%") + (format strm "/dy tipy taily sub def~%") + (format strm "/dx tipx tailx sub def~%") + (format strm "/angle dx 0 ne dy 0 ne or { dy dx atan } { 90 } ifelse def~%") + (format strm "gsave~%") + (format strm "originalCTM setmatrix~%") + (format strm "tipx tipy translate~%") + (format strm "angle rotate~%") + (format strm "newpath~%") + (format strm "arrowHeight neg arrowWidth 2 div moveto~%") + (format strm "0 0 lineto~%") + (format strm "arrowHeight neg arrowWidth 2 div neg lineto~%") + (format strm "patternNone not {~%") + (format strm "originalCTM setmatrix~%") + (format strm "/padtip arrowHeight 2 exp 0.25 arrowWidth 2 exp mul add sqrt brushWidth mul~%") + (format strm "arrowWidth div def~%") + (format strm "/padtail brushWidth 2 div def~%") + (format strm "tipx tipy translate~%") + (format strm "angle rotate~%") + (format strm "padtip 0 translate~%") + (format strm "arrowHeight padtip add padtail add arrowHeight div dup scale~%") + (format strm "arrowheadpath~%") + (format strm "ifill~%") + (format strm "} if~%") + (format strm "brushNone not {~%") + (format strm "originalCTM setmatrix~%") + (format strm "tipx tipy translate~%") + (format strm "angle rotate~%") + (format strm "arrowheadpath~%") + (format strm "istroke~%") + (format strm "} if~%") + (format strm "grestore~%") + (format strm "end~%") + (format strm "} dup 0 9 dict put def~%") + (format strm "~%") + (format strm "/arrowheadpath {~%") + (format strm "newpath~%") + (format strm "arrowHeight neg arrowWidth 2 div moveto~%") + (format strm "0 0 lineto~%") + (format strm "arrowHeight neg arrowWidth 2 div neg lineto~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/leftarrow {~%") + (format strm "0 begin~%") + (format strm "y exch get /taily exch def~%") + (format strm "x exch get /tailx exch def~%") + (format strm "y exch get /tipy exch def~%") + (format strm "x exch get /tipx exch def~%") + (format strm "brushLeftArrow { tipx tipy tailx taily arrowhead } if~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "/rightarrow {~%") + (format strm "0 begin~%") + (format strm "y exch get /tipy exch def~%") + (format strm "x exch get /tipx exch def~%") + (format strm "y exch get /taily exch def~%") + (format strm "x exch get /tailx exch def~%") + (format strm "brushRightArrow { tipx tipy tailx taily arrowhead } if~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "%%EndIdrawPrologue~%") + (format strm "~%") + (format strm "/arrowHeight 11 def~%") + (format strm "/arrowWidth 5 def~%") + (format strm "~%") + (format strm "/IdrawDict 50 dict def~%") + (format strm "IdrawDict begin~%") (format strm "~%") - (format strm "/arrowHeight 8 def~%") - (format strm "/arrowWidth 4 def~%") (format strm "/none null def~%") (format strm "/numGraphicParameters 17 def~%") (format strm "/stringLimit 65535 def~%") @@ -697,10 +772,12 @@ (format strm "dup type /nulltype eq {~%") (format strm "pop true /patternNone idef~%") (format strm "} {~%") + (format strm "dup -1 eq {~%") (format strm "/patternGrayLevel idef~%") - (format strm "patternGrayLevel -1 eq {~%") (format strm "/patternString idef~%") - (format strm "} if~%") + (format strm "} {~%") + (format strm "/patternGrayLevel idef~%") + (format strm "} ifelse~%") (format strm "false /patternNone idef~%") (format strm "} ifelse~%") (format strm "} def~%") @@ -731,6 +808,7 @@ (format strm "/Circ {~%") (format strm "newpath~%") (format strm "0 360 arc~%") + (format strm "closepath~%") (format strm "patternNone not { ifill } if~%") (format strm "brushNone not { istroke } if~%") (format strm "} def~%") @@ -755,9 +833,6 @@ (format strm "end~%") (format strm "} dup 0 4 dict put def~%") (format strm "~%") - (format strm "~%") - (format strm "/RRect { CBSpl } def~%") - (format strm "~%") (format strm "/Elli {~%") (format strm "0 begin~%") (format strm "newpath~%") @@ -765,22 +840,8 @@ (format strm "translate~%") (format strm "scale~%") (format strm "0 0 1 0 360 arc~%") + (format strm "closepath~%") (format strm "patternNone not { ifill } if~%") - (format strm "brushNone not { istroke } if~%") - (format strm "end~%") - (format strm "} dup 0 1 dict put def~%") - (format strm "~%") - (format strm "/Arc {~%") - (format strm "0 begin~%") - (format strm "newpath~%") - (format strm "6 2 roll~%") - (format strm "4 2 roll~%") - (format strm "translate~%") - (format strm "scale~%") - (format strm "0 0 1~%") - (format strm "5 3 roll~%") - (format strm "arc~%") -;; (format strm "patternNone not { ifill } if~%") (format strm "brushNone not { istroke } if~%") (format strm "end~%") (format strm "} dup 0 1 dict put def~%") @@ -843,9 +904,9 @@ (format strm "end~%") (format strm "} dup 0 4 dict put def~%") (format strm "~%") - (format strm "/WhiteBg 1 def~%") - (format strm "/HollowBg 0 def~%") - (format strm "/Text { ishow } def~%") + (format strm "/Text {~%") + (format strm "ishow~%") + (format strm "} def~%") (format strm "~%") (format strm "/idef {~%") (format strm "dup where { pop pop pop } { exch def } ifelse~%") @@ -871,7 +932,7 @@ (format strm "eofill~%") (format strm "fgred fggreen fgblue setrgbcolor~%") (format strm "w 0 gt h 0 gt and {~%") - (format strm "l b translate w h scale~%") + (format strm "l w add b translate w neg h scale~%") (format strm "w h true [w 0 0 h neg 0 h] { patternproc } imagemask~%") (format strm "} if~%") (format strm "} ifelse~%") @@ -882,232 +943,209 @@ (format strm "/istroke {~%") (format strm "gsave~%") (format strm "brushDashOffset -1 eq {~%") -(format strm "[] 0 setdash~%") -(format strm "1 setgray~%") -(format strm "} {~%") -(format strm "brushDashArray brushDashOffset setdash~%") -(format strm "fgred fggreen fgblue setrgbcolor~%") -(format strm "} ifelse~%") -(format strm "brushWidth setlinewidth~%") -(format strm "originalCTM setmatrix~%") -(format strm "stroke~%") -(format strm "grestore~%") -(format strm "} def~%") -(format strm "~%") -(format strm "/xdescender {~%") -(format strm "begin 0~%") -(format strm "FontType 0 eq~%") -(format strm "{ FDepVector dup length 1 sub get xdescender }~%") -(format strm "{ [FontBBox] 1 get } ifelse~%") -(format strm "FontMatrix transform exch pop end~%") -(format strm "} def~%") -(format strm "/ishow {~%") -(format strm "0 begin~%") -(format strm "gsave~%") -(format strm "fgred fggreen fgblue setrgbcolor~%") -(format strm "WhiteBg eq /drawBg exch def~%") -(format strm "/fontDict printFont findfont printSize scalefont dup setfont def~%") -(format strm "/descender fontDict xdescender def~%") -(format strm "/vertoffset 0 descender sub printSize sub printFont /Courier ne~%") -(format strm "printFont /Courier-Bold ne and { 1 add } if def {~%") -(format strm "drawBg {~%") -(format strm "newpath 0 vertoffset descender add moveto~%") -(format strm "dup stringwidth pop dup 0 rlineto~%") -(format strm "0 printSize rlineto 0 exch sub 0 rlineto~%") -(format strm "closepath currentgray 1 setgray fill setgray } if~%") -(format strm "0 vertoffset moveto show~%") -(format strm "/vertoffset vertoffset printSize sub def~%") -(format strm "} forall~%") -(format strm "grestore~%") -(format strm "end~%") -(format strm "} dup 0 4 dict put def~%") -(format strm "~%") -(format strm "/patternproc {~%") -(format strm "0 begin~%") -(format strm "/patternByteLength patternString length def~%") -(format strm "/patternHeight patternByteLength 8 mul sqrt cvi def~%") -(format strm "/patternWidth patternHeight def~%") -(format strm "/patternByteWidth patternWidth 8 idiv def~%") -(format strm "/imageByteMaxLength imageByteWidth imageHeight mul~%") -(format strm "stringLimit patternByteWidth sub min def~%") -(format strm "/imageMaxHeight imageByteMaxLength imageByteWidth idiv patternHeight idiv~%") -(format strm "patternHeight mul patternHeight max def~%") -(format strm "/imageHeight imageHeight imageMaxHeight sub store~%") -(format strm "/imageString imageByteWidth imageMaxHeight mul patternByteWidth add string def~%") -(format strm "0 1 imageMaxHeight 1 sub {~%") -(format strm "/y exch def~%") -(format strm "/patternRow y patternByteWidth mul patternByteLength mod def~%") -(format strm "/patternRowString patternString patternRow patternByteWidth getinterval def~%") -(format strm "/imageRow y imageByteWidth mul def~%") -(format strm "0 patternByteWidth imageByteWidth 1 sub {~%") -(format strm "/x exch def~%") -(format strm "imageString imageRow x add patternRowString putinterval~%") -(format strm "} for~%") -(format strm "} for~%") -(format strm "imageString~%") -(format strm "end~%") -(format strm "} dup 0 12 dict put def~%") -(format strm "~%") -(format strm "/min {~%") -(format strm "dup 3 2 roll dup 4 3 roll lt { exch } if pop~%") -(format strm "} def~%") -(format strm "~%") -(format strm "/max {~%") -(format strm "dup 3 2 roll dup 4 3 roll gt { exch } if pop~%") -(format strm "} def~%") -(format strm "~%") -(format strm "/arrowhead {~%") -(format strm "0 begin~%") -(format strm "transform originalCTM itransform~%") -(format strm "/taily exch def~%") -(format strm "/tailx exch def~%") -(format strm "transform originalCTM itransform~%") -(format strm "/tipy exch def~%") -(format strm "/tipx exch def~%") -(format strm "/dy tipy taily sub def~%") -(format strm "/dx tipx tailx sub def~%") -(format strm "/angle dx 0 ne dy 0 ne or { dy dx atan } { 90 } ifelse def~%") -(format strm "gsave~%") -(format strm "originalCTM setmatrix~%") -(format strm "tipx tipy translate~%") -(format strm "angle rotate~%") -(format strm "newpath~%") -(format strm "0 0 moveto~%") -(format strm "arrowHeight neg arrowWidth 2 div lineto~%") -(format strm "arrowHeight neg arrowWidth 2 div neg lineto~%") -(format strm "closepath~%") -(format strm "patternNone not {~%") -(format strm "originalCTM setmatrix~%") -(format strm "/padtip arrowHeight 2 exp 0.25 arrowWidth 2 exp mul add sqrt brushWidth mul~%") -(format strm "arrowWidth div def~%") -(format strm "/padtail brushWidth 2 div def~%") -(format strm "tipx tipy translate~%") -(format strm "angle rotate~%") -(format strm "padtip 0 translate~%") -(format strm "arrowHeight padtip add padtail add arrowHeight div dup scale~%") -(format strm "arrowheadpath~%") -(format strm "ifill~%") -(format strm "} if~%") -(format strm "brushNone not {~%") -(format strm "originalCTM setmatrix~%") -(format strm "tipx tipy translate~%") -(format strm "angle rotate~%") -(format strm "arrowheadpath~%") -(format strm "istroke~%") -(format strm "} if~%") -(format strm "grestore~%") -(format strm "end~%") -(format strm "} dup 0 9 dict put def~%") -(format strm "~%") -(format strm "/arrowheadpath {~%") -(format strm "newpath~%") -(format strm "0 0 moveto~%") -(format strm "arrowHeight neg arrowWidth 2 div lineto~%") -(format strm "arrowHeight neg arrowWidth 2 div neg lineto~%") -(format strm "closepath~%") -(format strm "} def~%") -(format strm "~%") -(format strm "/leftarrow {~%") -(format strm "0 begin~%") -(format strm "y exch get /taily exch def~%") -(format strm "x exch get /tailx exch def~%") -(format strm "y exch get /tipy exch def~%") -(format strm "x exch get /tipx exch def~%") -(format strm "brushLeftArrow { tipx tipy tailx taily arrowhead } if~%") -(format strm "end~%") -(format strm "} dup 0 4 dict put def~%") -(format strm "~%") -(format strm "/rightarrow {~%") -(format strm "0 begin~%") -(format strm "y exch get /tipy exch def~%") -(format strm "x exch get /tipx exch def~%") -(format strm "y exch get /taily exch def~%") -(format strm "x exch get /tailx exch def~%") -(format strm "brushRightArrow { tipx tipy tailx taily arrowhead } if~%") -(format strm "end~%") -(format strm "} dup 0 4 dict put def~%") -(format strm "~%") -(format strm "/midpoint {~%") -(format strm "0 begin~%") -(format strm "/y1 exch def~%") -(format strm "/x1 exch def~%") -(format strm "/y0 exch def~%") -(format strm "/x0 exch def~%") -(format strm "x0 x1 add 2 div~%") -(format strm "y0 y1 add 2 div~%") -(format strm "end~%") -(format strm "} dup 0 4 dict put def~%") -(format strm "~%") -(format strm "/thirdpoint {~%") -(format strm "0 begin~%") -(format strm "/y1 exch def~%") -(format strm "/x1 exch def~%") -(format strm "/y0 exch def~%") -(format strm "/x0 exch def~%") -(format strm "x0 2 mul x1 add 3 div~%") -(format strm "y0 2 mul y1 add 3 div~%") -(format strm "end~%") -(format strm "} dup 0 4 dict put def~%") -(format strm "~%") -(format strm "/subspline {~%") -(format strm "0 begin~%") -(format strm "/movetoNeeded exch def~%") -(format strm "y exch get /y3 exch def~%") -(format strm "x exch get /x3 exch def~%") -(format strm "y exch get /y2 exch def~%") -(format strm "x exch get /x2 exch def~%") -(format strm "y exch get /y1 exch def~%") -(format strm "x exch get /x1 exch def~%") -(format strm "y exch get /y0 exch def~%") -(format strm "x exch get /x0 exch def~%") -(format strm "x1 y1 x2 y2 thirdpoint~%") -(format strm "/p1y exch def~%") -(format strm "/p1x exch def~%") -(format strm "x2 y2 x1 y1 thirdpoint~%") -(format strm "/p2y exch def~%") -(format strm "/p2x exch def~%") -(format strm "x1 y1 x0 y0 thirdpoint~%") -(format strm "p1x p1y midpoint~%") -(format strm "/p0y exch def~%") -(format strm "/p0x exch def~%") -(format strm "x2 y2 x3 y3 thirdpoint~%") -(format strm "p2x p2y midpoint~%") -(format strm "/p3y exch def~%") -(format strm "/p3x exch def~%") -(format strm "movetoNeeded { p0x p0y moveto } if~%") -(format strm "p1x p1y p2x p2y p3x p3y curveto~%") -(format strm "end~%") -(format strm "} dup 0 17 dict put def~%") -(format strm "~%") -(format strm "/storexyn {~%") -(format strm "/n exch def~%") -(format strm "/y n array def~%") -(format strm "/x n array def~%") -(format strm "n 1 sub -1 0 {~%") -(format strm "/i exch def~%") -(format strm "y i 3 2 roll put~%") -(format strm "x i 3 2 roll put~%") -(format strm "} for~%") -(format strm "} def~%") -(format strm "~%") -(format strm "%%EndProlog~%") -(format strm "~%") -(format strm "%I Idraw 9 Grid 8 ~%") -(format strm "~%") -(format strm "%%Page: 1 1~%") -(format strm "~%") -(format strm "Begin~%") -(format strm "%I b u~%") -(format strm "%I cfg u~%") -(format strm "%I cbg u~%") -(format strm "%I f u~%") -(format strm "%I k u~%") -(format strm "%I p u~%") -(format strm "%I t~%") -(format strm "[ .8 0 0 .8 0 0 ] concat~%") -(format strm "/originalCTM matrix currentmatrix def~%") -(format strm "~%") -strm)) + (format strm "[] 0 setdash~%") + (format strm "1 setgray~%") + (format strm "} {~%") + (format strm "brushDashArray brushDashOffset setdash~%") + (format strm "fgred fggreen fgblue setrgbcolor~%") + (format strm "} ifelse~%") + (format strm "brushWidth setlinewidth~%") + (format strm "originalCTM setmatrix~%") + (format strm "stroke~%") + (format strm "grestore~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/ishow {~%") + (format strm "0 begin~%") + (format strm "gsave~%") + (format strm "fgred fggreen fgblue setrgbcolor~%") + (format strm "/fontDict printFont printSize scalefont dup setfont def~%") + (format strm "/descender fontDict begin 0 /FontBBox load 1 get FontMatrix end~%") + (format strm "transform exch pop def~%") + (format strm "/vertoffset 1 printSize sub descender sub def {~%") + (format strm "0 vertoffset moveto show~%") + (format strm "/vertoffset vertoffset printSize sub def~%") + (format strm "} forall~%") + (format strm "grestore~%") + (format strm "end~%") + (format strm "} dup 0 3 dict put def~%") + (format strm "/patternproc {~%") + (format strm "0 begin~%") + (format strm "/patternByteLength patternString length def~%") + (format strm "/patternHeight patternByteLength 8 mul sqrt cvi def~%") + (format strm "/patternWidth patternHeight def~%") + (format strm "/patternByteWidth patternWidth 8 idiv def~%") + (format strm "/imageByteMaxLength imageByteWidth imageHeight mul~%") + (format strm "stringLimit patternByteWidth sub min def~%") + (format strm "/imageMaxHeight imageByteMaxLength imageByteWidth idiv patternHeight idiv~%") + (format strm "patternHeight mul patternHeight max def~%") + (format strm "/imageHeight imageHeight imageMaxHeight sub store~%") + (format strm "/imageString imageByteWidth imageMaxHeight mul patternByteWidth add string def~%") + (format strm "0 1 imageMaxHeight 1 sub {~%") + (format strm "/y exch def~%") + (format strm "/patternRow y patternByteWidth mul patternByteLength mod def~%") + (format strm "/patternRowString patternString patternRow patternByteWidth getinterval def~%") + (format strm "/imageRow y imageByteWidth mul def~%") + (format strm "0 patternByteWidth imageByteWidth 1 sub {~%") + (format strm "/x exch def~%") + (format strm "imageString imageRow x add patternRowString putinterval~%") + (format strm "} for~%") + (format strm "} for~%") + (format strm "imageString~%") + (format strm "end~%") + (format strm "} dup 0 12 dict put def~%") + (format strm "~%") + (format strm "/min {~%") + (format strm "dup 3 2 roll dup 4 3 roll lt { exch } if pop~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/max {~%") + (format strm "dup 3 2 roll dup 4 3 roll gt { exch } if pop~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/midpoint {~%") + (format strm "0 begin~%") + (format strm "/y1 exch def~%") + (format strm "/x1 exch def~%") + (format strm "/y0 exch def~%") + (format strm "/x0 exch def~%") + (format strm "x0 x1 add 2 div~%") + (format strm "y0 y1 add 2 div~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "/thirdpoint {~%") + (format strm "0 begin~%") + (format strm "/y1 exch def~%") + (format strm "/x1 exch def~%") + (format strm "/y0 exch def~%") + (format strm "/x0 exch def~%") + (format strm "x0 2 mul x1 add 3 div~%") + (format strm "y0 2 mul y1 add 3 div~%") + (format strm "end~%") + (format strm "} dup 0 4 dict put def~%") + (format strm "~%") + (format strm "/subspline {~%") + (format strm "0 begin~%") + (format strm "/movetoNeeded exch def~%") + (format strm "y exch get /y3 exch def~%") + (format strm "x exch get /x3 exch def~%") + (format strm "y exch get /y2 exch def~%") + (format strm "x exch get /x2 exch def~%") + (format strm "y exch get /y1 exch def~%") + (format strm "x exch get /x1 exch def~%") + (format strm "y exch get /y0 exch def~%") + (format strm "x exch get /x0 exch def~%") + (format strm "x1 y1 x2 y2 thirdpoint~%") + (format strm "/p1y exch def~%") + (format strm "/p1x exch def~%") + (format strm "x2 y2 x1 y1 thirdpoint~%") + (format strm "/p2y exch def~%") + (format strm "/p2x exch def~%") + (format strm "x1 y1 x0 y0 thirdpoint~%") + (format strm "p1x p1y midpoint~%") + (format strm "/p0y exch def~%") + (format strm "/p0x exch def~%") + (format strm "x2 y2 x3 y3 thirdpoint~%") + (format strm "p2x p2y midpoint~%") + (format strm "/p3y exch def~%") + (format strm "/p3x exch def~%") + (format strm "movetoNeeded { p0x p0y moveto } if~%") + (format strm "p1x p1y p2x p2y p3x p3y curveto~%") + (format strm "end~%") + (format strm "} dup 0 17 dict put def~%") + (format strm "~%") + (format strm "/storexyn {~%") + (format strm "/n exch def~%") + (format strm "/y n array def~%") + (format strm "/x n array def~%") + (format strm "n 1 sub -1 0 {~%") + (format strm "/i exch def~%") + (format strm "y i 3 2 roll put~%") + (format strm "x i 3 2 roll put~%") + (format strm "} for~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/SSten {~%") + (format strm "fgred fggreen fgblue setrgbcolor~%") + (format strm "dup true exch 1 0 0 -1 0 6 -1 roll matrix astore~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/FSten {~%") + (format strm "dup 3 -1 roll dup 4 1 roll exch~%") + (format strm "newpath~%") + (format strm "0 0 moveto~%") + (format strm "dup 0 exch lineto~%") + (format strm "exch dup 3 1 roll exch lineto~%") + (format strm "0 lineto~%") + (format strm "closepath~%") + (format strm "bgred bggreen bgblue setrgbcolor~%") + (format strm "eofill~%") + (format strm "SSten~%") + (format strm "} def~%") + (format strm "~%") + (format strm "/Rast {~%") + (format strm "exch dup 3 1 roll 1 0 0 -1 0 6 -1 roll matrix astore~%") + (format strm "} def~%") + (format strm "~%") + (format strm "%%EndProlog~%") + (format strm "~%") + (format strm "%I Idraw 13 Grid 8 8 ~%") + (format strm "~%") + (format strm "%%Page: 1 1~%") + (format strm "~%") + (format strm "Begin~%") + (format strm "%I b u~%") + (format strm "%I cfg u~%") + (format strm "%I cbg u~%") + (format strm "%I f u~%") + (format strm "%I p u~%") + (format strm "%I t~%") + (format strm "[ 0.747198 0 0 0.747198 0 0 ] concat~%") + (format strm "/originalCTM matrix currentmatrix def~%") + (format strm "~%") + strm)) ;;;(eval-when (eval) (format t ";; loaded kdraw.l~%")) ;;;(eval-when (load) (format t ";; loaded kdraw.o~%")) +(in-package "USER") +(defun irtdraw-save (&key (fname (format nil "~A.eps" (send *robot* :name))) + (y 300) (bodies (send *robot* :bodies))) + (hid2 bodies (send *irtviewer* :viewer)) + (geo::open-kdraw-file fname) + ;;(dolist (ei *hid*) + ;;(send *viewer* :draw-edge-image ei t)) + ;;(send *viewer* :draw *hid*) + (dolist (ei *hid*) + (dolist (v (send ei :visible-segments)) + ;;(send *viewer* :draw-line-ndc (car v) (cadr v) nil (send ei :color)) + (setq p1 (send (*viewer* . geo::port) :ndc-line-to-screen (car v) (cadr v) t)) + ;;(if p1 (send (*viewer* . geo::surface) :draw-line (car p1) (cadr p1))) + ;;(if p1 (format t ";; ~A ~A ~%" (car p1) (cadr p1))) + (geo::kdraw-line (float-vector (elt (car p1) 0) (- y (elt (car p1) 1))) + (float-vector (elt (cadr p1) 0) (- y (elt (cadr p1) 1)))) + )) + #| + (geo::kdraw-line + (scale scale (v+ #f(1 0 0) (ei . geo::pvert2))) + (scale scale (v+ #f(1 0 0) (ei . geo::nvert2)))) + |# + (geo::close-kdraw-file) + ) +;; + +#| +(defun irtdraw-demo-hand nil + (load "irteus/demo/demo.l") + (hand-grasp) + (irtdraw-save :fname "hand-grasp.eps" + :bodies (cons (cadr (objects)) + (send (car (objects)) :bodies))) + ) +(defun irtdraw-dual-arm nil + (load "irteus/demo/demo.l") + (dual-arm-ik) + (irtdraw-save :fname "dual-arm.eps" + :bodies (flatten (send-all (objects) :bodies))) + ) +|# From 0c5bedf720ed2a6f72d7b1b6293bfedfc2b76542 Mon Sep 17 00:00:00 2001 From: Kei Okada Date: Wed, 29 Mar 2023 12:38:26 +0900 Subject: [PATCH 3/4] irtdraw.l: fix minor changes, remove global variables, enable to call irtdraw-save --- irteus/irtdraw.l | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/irteus/irtdraw.l b/irteus/irtdraw.l index b3fc733d5..466142ec9 100644 --- a/irteus/irtdraw.l +++ b/irteus/irtdraw.l @@ -1108,10 +1108,14 @@ ;;;(eval-when (eval) (format t ";; loaded kdraw.l~%")) ;;;(eval-when (load) (format t ";; loaded kdraw.o~%")) -(in-package "USER") -(defun irtdraw-save (&key (fname (format nil "~A.eps" (send *robot* :name))) - (y 300) (bodies (send *robot* :bodies))) - (hid2 bodies (send *irtviewer* :viewer)) +;;; (in-package "USER") + +(export '(irtdraw-save)) + +(defun irtdraw-save (&key (fname (format nil "~A.eps" (send user::*robot* :name))) + (y 300) (bodies (send user::*robot* :bodies))) + (let (p1) + (hid2 bodies (send user::*irtviewer* :viewer)) (geo::open-kdraw-file fname) ;;(dolist (ei *hid*) ;;(send *viewer* :draw-edge-image ei t)) @@ -1119,8 +1123,8 @@ (dolist (ei *hid*) (dolist (v (send ei :visible-segments)) ;;(send *viewer* :draw-line-ndc (car v) (cadr v) nil (send ei :color)) - (setq p1 (send (*viewer* . geo::port) :ndc-line-to-screen (car v) (cadr v) t)) - ;;(if p1 (send (*viewer* . geo::surface) :draw-line (car p1) (cadr p1))) + (setq p1 (send (user::*viewer* . geo::port) :ndc-line-to-screen (car v) (cadr v) t)) + ;;(if p1 (send (user::*viewer* . geo::surface) :draw-line (car p1) (cadr p1))) ;;(if p1 (format t ";; ~A ~A ~%" (car p1) (cadr p1))) (geo::kdraw-line (float-vector (elt (car p1) 0) (- y (elt (car p1) 1))) (float-vector (elt (cadr p1) 0) (- y (elt (cadr p1) 1)))) @@ -1131,7 +1135,7 @@ (scale scale (v+ #f(1 0 0) (ei . geo::nvert2)))) |# (geo::close-kdraw-file) - ) + )) ;; #| From d2f1630558039f9e1e7b85e37c8a11baad615b75 Mon Sep 17 00:00:00 2001 From: Kei Okada Date: Wed, 29 Mar 2023 12:38:45 +0900 Subject: [PATCH 4/4] add doc on irtdraw-save, with-save-animgif --- doc/irtviewer.tex | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/doc/irtviewer.tex b/doc/irtviewer.tex index 49a23ff55..efd787a30 100644 --- a/doc/irtviewer.tex +++ b/doc/irtviewer.tex @@ -44,3 +44,42 @@ \section{ロボットビューワ} \input{irtviewer-func} + + +\subsection{Animation GIF} + +\verb+with-save-animgif+ マクロを用いることでAnimation Gifファイルを生成することが出来る． + + +{\baselineskip=10pt +\begin{verbatim} +(with-save-animgif "file" + (dotimes (a 45) + (send *robot* :larm-shoulder-r :joint-angle (* a 4)) + (send *irtviewer*:draw-objects))) +\end{verbatim} +} + +\verb+with-save-mpeg+を用いることで\verb+mpeg+ファイルの生成も可能である． + +\subsection{Eps} + +\verb+irtdraw-save+ を用いることでEpsファイルを生成することが出来る． + +{\baselineskip=10pt +\begin{verbatim} +(defun irtdraw-demo-hand nil + (load "irteus/demo/demo.l") + (hand-grasp) + (irtdraw-save :fname "hand-grasp.eps" + :bodies (cons (cadr (objects)) + (send (car (objects)) :bodies))) + ) +(defun irtdraw-dual-arm nil + (load "irteus/demo/demo.l") + (dual-arm-ik) + (irtdraw-save :fname "dual-arm.eps" + :bodies (flatten (send-all (objects) :bodies))) + ) +\end{verbatim} +}