3 ;;; Copyright (C) 2012-2018 Mario Rodriguez Riotorto
5 ;;; This program is free software; you can redistribute
6 ;;; it and/or modify it under the terms of the
7 ;;; GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 2
9 ;;; of the License, or (at your option) any later version.
11 ;;; This program is distributed in the hope that it
12 ;;; will be useful, but WITHOUT ANY WARRANTY;
13 ;;; without even the implied warranty of MERCHANTABILITY
14 ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details at
16 ;;; http://www.gnu.org/copyleft/gpl.html
18 ;;; This is a maxima-vtk interface.
20 ;;; For examples, visit
21 ;;; http://tecnostats.net/Maxima/vtk
23 ;;; For questions, suggestions, bugs and the like, feel free
25 ;;; mario @@@ edu DOT xunta DOT es
28 ;;; AUXILIARY FUNCTIONS
31 (defvar *vtk-appenddata-counter
* 0)
32 (defvar *vtk-extract-counter
* 0)
33 (defvar *vtk-outline-counter
* 0)
34 (defvar *vtk-polydatamapper-counter
* 0)
35 (defvar *vtk-outlineactor-counter
* 0)
36 (defvar *vtk-textproperty-counter
* 0)
37 (defvar *vtk-cubeaxesactor2d-counter
* 0)
38 (defvar *vtk-camera-counter
* 0)
39 (defvar *vtk-renderer-counter
* 0)
40 (defvar *vtk-source-counter
* 0)
41 (defvar *vtk-mapper-counter
* 0)
42 (defvar *vtk-actor-counter
* 0)
43 (defvar *vtk-labelactor-counter
* 0)
44 (defvar *vtk-trans-counter
* 0)
45 (defvar *vtk-filter-counter
* 0)
46 (defvar *vtk-floatarray-counter
* 0)
47 (defvar *vtk-data-file-counter
* 0)
48 (defvar *vtk-points-counter
* 0)
49 (defvar *vtk-glyphpoints-counter
* 0)
50 (defvar *vtk-polydata-counter
* 0)
51 (defvar *vtk-cellarray-counter
* 0)
52 (defvar *vtk-solidsource-counter
* 0)
53 (defvar *vtk-triangle-counter
* 0)
54 (defvar *vtk-label-counter
* 0)
55 (defvar *vtk-chart-counter
* 0)
56 (defvar *vtk-table-counter
* 0)
57 (defvar *vtk-arrayX-counter
* 0)
58 (defvar *vtk-arrayY-counter
* 0)
59 (defvar *vtk-2dkey-counter
* 0)
60 (defvar *vtk-isolines-counter
* 0)
61 (defvar *lookup-tables
* nil
)
62 (defvar *unitscale-already-defined
* nil
)
63 (defparameter *enhanced3d-or-isolines-code
* (make-hash-table))
65 (defun get-appenddata-name ()
66 (format nil
"appenddata~a" (incf *vtk-appenddata-counter
*)))
68 (defun get-extract-name ()
69 (format nil
"extract~a" (incf *vtk-extract-counter
*)))
71 (defun get-outline-name ()
72 (format nil
"outline~a" (incf *vtk-outline-counter
*)))
74 (defun get-outlineactor-name ()
75 (format nil
"outlineactor~a" (incf *vtk-outlineactor-counter
*)))
77 (defun get-textproperty-name ()
78 (format nil
"textproperty~a" (incf *vtk-textproperty-counter
*)))
80 (defun get-cubeaxesactor2d-name ()
81 (format nil
"cubeaxesactor2d~a" (incf *vtk-cubeaxesactor2d-counter
*)))
83 (defun get-camera-name ()
84 (format nil
"camera~a" (incf *vtk-camera-counter
*)))
86 (defun get-renderer-name ()
87 (format nil
"renderer~a" (incf *vtk-renderer-counter
*)))
89 (defun get-source-name ()
90 (format nil
"source~a" (incf *vtk-source-counter
*)))
92 (defun get-mapper-name ()
93 (format nil
"mapper~a" (incf *vtk-mapper-counter
*)))
95 (defun get-actor-name ()
96 (format nil
"actor~a" (incf *vtk-actor-counter
*)))
98 (defun get-labelactor-name ()
99 (format nil
"labelactor~a" (incf *vtk-labelactor-counter
*)))
101 (defun get-trans-name ()
102 (format nil
"trans~a" (incf *vtk-trans-counter
*)))
104 (defun get-filter-name ()
105 (format nil
"filter~a" (incf *vtk-filter-counter
*)))
107 (defun get-floatarray-name ()
108 (format nil
"floatarray~a" (incf *vtk-floatarray-counter
*)))
110 (defun get-data-file-name ()
111 (format nil
"data~a.vtk" (incf *vtk-data-file-counter
*)))
113 (defun get-points-name ()
114 (format nil
"points~a" (incf *vtk-points-counter
*)))
116 (defun get-glyphpoints-name ()
117 (format nil
"glyphpoints~a" (incf *vtk-glyphpoints-counter
*)))
119 (defun get-polydata-name ()
120 (format nil
"polydata~a" (incf *vtk-polydata-counter
*)))
122 (defun get-cellarray-name ()
123 (format nil
"cellarray~a" (incf *vtk-cellarray-counter
*)))
125 (defun get-polydatamapper-name ()
126 (format nil
"polydatamapper~a" (incf *vtk-polydatamapper-counter
*)))
128 (defun get-solidsource-name ()
129 (format nil
"solidsource~a" (incf *vtk-solidsource-counter
*)))
131 (defun get-triangle-name ()
132 (format nil
"triangle~a" (incf *vtk-triangle-counter
*)))
134 (defun get-label-name ()
135 (format nil
"label~a" (incf *vtk-label-counter
*)))
137 (defun get-chart-name ()
138 (format nil
"chart~a" (incf *vtk-chart-counter
*)))
140 (defun get-table-name ()
141 (format nil
"table~a" (incf *vtk-table-counter
*)))
143 (defun get-arrayX-name ()
144 (format nil
"arrayX~a" (incf *vtk-arrayX-counter
*)))
146 (defun get-arrayY-name ()
147 (format nil
"arrayY~a" (incf *vtk-arrayY-counter
*)))
149 (defun get-isolines-name ()
150 (format nil
"isolines~a" (incf *vtk-isolines-counter
*)))
152 (defun scenebounds ()
153 (let ((xrange (get-option '$xrange
))
154 (yrange (get-option '$yrange
))
155 (zrange (get-option '$zrange
))
160 (format nil
"mib[0]=~a~%mxb[1]=~a~%" (car xrange
) (cadr xrange
))
163 (format nil
"mib[2]=~a~%mxb[3]=~a~%" (car yrange
) (cadr yrange
))
166 (format nil
"mib[4]=~a~%mxb[5]=~a~%" (car zrange
) (cadr zrange
))
168 (format nil
"~a~%~a~%~a~%~a~%~a~%~a~%~a~%~a~a~%~%"
169 "if sys.version_info[0] < 3:"
170 " trb = zip(*bounds)"
172 " trb = list(zip(*bounds))"
173 "mib = [min(i) for i in trb]"
174 "mxb = [max(i) for i in trb]"
175 "ranges = vtk.vtkBox()"
177 "ranges.SetBounds(mib[0],mxb[1],mib[2],mxb[3],mib[4],mxb[5])") ))
179 (defun vtkappendpolydata-code (an fe fl
)
180 (let ((str (make-array 0
181 :element-type
'character
184 (when (> (hash-table-count *enhanced3d-or-isolines-code
*) 0)
185 (format str
(format nil
"~V@{~a~:*~}~%" 18 "~a~%")
186 "def rescalearray( pts, arr ):"
189 " n = arr.GetNumberOfTuples()"
190 " for i in range(0, n):"
191 " v = pts.GetPoint(i)"
192 " f = arr.GetValue(i)"
193 " if (v[0] >= mib[0] and v[0] <= mxb[1] and"
194 " v[1] >= mib[2] and v[1] <= mxb[3] and"
195 " v[2] >= mib[4] and v[2] <= mxb[5]):"
201 " for i in range(0, n):"
202 " arr.SetValue(i, (arr.GetValue(i)-mini)/(maxi-mini))"
204 (format str
"~a=vtk.vtkAppendPolyData()~%" an
)
205 (loop for n from fe to
*vtk-extract-counter
* do
206 (format str
"~%extract~a.SetImplicitFunction(ranges)~%" n
)
207 (format str
"extract~a.SetInputConnection(filter~a.GetOutputPort())~%" n n
)
208 (format str
"mapper~a.SetInputConnection(extract~a.GetOutputPort())~%" n n
)
209 (when (gethash n
*enhanced3d-or-isolines-code
*)
210 (format str
"~a" (gethash n
*enhanced3d-or-isolines-code
*))
211 (remhash n
*enhanced3d-or-isolines-code
*))
212 (format str
"actor~a.SetMapper(mapper~a)~%" n n
)
213 (format str
"~a.AddInputConnection(extract~a.GetOutputPort())~%" an n
))
214 (loop for n from fl to
*vtk-label-counter
* do
215 (format str
"~a.AddInputConnection(label~a.GetOutputPort())~%" an n
))
216 (format str
"~%~a.Update()~%~%" an
)
219 (defun vtkoutlinefilter-code (on an
)
221 (format nil
"~a=vtk.vtkOutlineFilter()~%" on
)
222 (format nil
"~a.SetInputConnection(~a.GetOutputPort())~%" on an
)))
224 (defun vtkpolydatamapper-code (mn fn con
)
226 (format nil
"~a=vtk.vtkPolyDataMapper()~%" mn
)
228 (format nil
"~a.SetInputConnection(~a.GetOutputPort())~%" mn fn
)
232 (defun vtkpolydatamapper-isoline-code (mn sn fn
)
234 (format nil
"~a=vtk.vtkPolyDataMapper()~%" mn
)
235 (format nil
"~a.GetPointData().SetActiveScalars(\"name~a\")~%" sn fn
)
236 (format nil
"~a.ScalarVisibilityOn()~%" mn
) ))
238 (defun vtkextractpolydatageometry-code (en cell poin
)
240 (format nil
"~a=vtk.vtkExtractPolyDataGeometry()~%" en
)
242 (format nil
"~a.ExtractBoundaryCellsOn()~%" en
)
243 (format nil
"~a.ExtractBoundaryCellsOff()~%" en
))
245 (format nil
"~a.PassPointsOn()~%" en
)
246 (format nil
"~a.PassPointsOff()~%" en
)) ))
248 (defun vtktextproperty-code (tn)
250 (format nil
"~a=vtk.vtkTextProperty()~%" tn
)
251 (format nil
"~a.SetColor(0,0,0)~%" tn
)))
253 (defun vtkcubeaxesActor2d-code (can adn tn
)
255 (format nil
"~a=vtk.vtkCubeAxesActor2D()~%" can
)
256 (format nil
"~a.SetInputConnection(~a.GetOutputPort())~%" can adn
)
257 (format nil
"~a.SetLabelFormat(\"%6.4g\")~%" can
)
258 (format nil
"~a.SetFlyModeToOuterEdges()~%" can
)
259 (format nil
"~a.SetFontFactor(0.8)~%" can
)
260 (format nil
"~a.SetAxisTitleTextProperty(~a)~%" can tn
)
261 (format nil
"~a.SetAxisLabelTextProperty(~a)~%" can tn
)
262 (format nil
"~a.SetXLabel(\"~a\")~%" can
(get-option '$xlabel
))
263 (format nil
"~a.SetYLabel(\"~a\")~%" can
(get-option '$ylabel
))
264 (format nil
"~a.SetZLabel(\"~a\")~%~%" can
(get-option '$zlabel
)) ))
266 (defun vtkrenderer3d-code (rn an on bgcol cn rv rh fa fl
)
267 (let* ((k 0.0174532925199433) ; %pi/180
270 (x (* ($sin rvk
) ($sin rhk
)))
271 (y (- (* ($sin rvk
) ($cos rhk
))))
273 (colist (hex-to-numeric-list bgcol
))
275 :element-type
'character
278 (format str
"~a=vtk.vtkCamera()~%" cn
)
279 (format str
"~a.SetPosition(~a,~a,~a)~%" cn x y z
)
280 (format str
"~a=vtk.vtkRenderer()~%" rn
)
281 (format str
"~a.SetBackground(~a,~a,~a)~%" rn
(first colist
) (second colist
) (third colist
))
282 (loop for n from fa to
*vtk-actor-counter
* do
283 (format str
"~a.AddActor(actor~a)~%" rn n
))
284 (loop for n from fl to
*vtk-labelactor-counter
* do
285 (format str
"~a.AddActor(labelactor~a)~%" rn n
))
286 (format str
"~a.SetCamera(~a.GetActiveCamera())~%" an rn
)
287 (when (get-option '$axis_3d
)
288 (format str
"~a.AddActor(~a)~%" rn on
) ; add box
289 (format str
"~a.AddViewProp(~a)~%" rn an
)) ; add axes tics
290 (format str
"~a.SetActiveCamera(~a)~%" rn cn
)
291 (format str
"~a.ResetCamera()~%~%" rn
)
294 (defun vtkrenderer2d-code (cn rn
)
295 (let ((colist (hex-to-numeric-list (get-option '$background_color
)))
296 (xrange (get-option '$xrange
))
297 (yrange (get-option '$yrange
))
299 :element-type
'character
303 (format str
"~a.GetAxis(0).SetBehavior(1)~%" cn
)
304 (format str
"~a.GetAxis(0).SetRange(~a,~a)~%~%" cn
(first yrange
) (second yrange
)) )
306 (format str
"~a.GetAxis(1).SetBehavior(1)~%" cn
)
307 (format str
"~a.GetAxis(1).SetRange(~a,~a)~%~%" cn
(first xrange
) (second xrange
)) )
308 (format str
"scene~a=vtk.vtkContextScene()~%scene~a.AddItem(~a)~%" cn cn cn
)
309 (format str
"actor~a=vtk.vtkContextActor()~%actor~a.SetScene(scene~a)~%" cn cn cn
)
310 (format str
"~a.SetShowLegend(~a)~%"
312 (if (> *vtk-2dkey-counter
* 0) 1 0))
313 (format str
"~a.GetAxis(0).SetTitle(\"~a\")~%" cn
(get-option '$ylabel
))
314 (format str
"~a.GetAxis(1).SetTitle(\"~a\")~%" cn
(get-option '$xlabel
))
315 (when (get-option '$logx
)
316 (format str
"~a.GetAxis(1).SetLogScale(1)~%" cn
))
317 (when (get-option '$logy
)
318 (format str
"~a.GetAxis(0).SetLogScale(1)~%" cn
))
319 (let ((pos (get-option '$key_pos
))
322 (setf pos
(rest (mfunction-call $split pos
)))
325 (format str
"~a.GetLegend().SetVerticalAlignment(~a)~%"
328 ((string= vp
"top") 3)
329 ((string= vp
"center") 1)
330 ((string= vp
"bottom") 4)))
331 (format str
"~a.GetLegend().SetHorizontalAlignment(~a)~%"
334 ((string= hp
"left") 0)
335 ((string= hp
"center") 1)
336 ((string= hp
"right") 2))) ))
337 (format str
"~a=vtk.vtkRenderer()~%" rn
)
338 (format str
"~a.SetBackground(~a,~a,~a)~%" rn
(first colist
) (second colist
) (third colist
))
339 (format str
"~a.AddActor(actor~a)~%" rn cn
)
340 (format str
"scene~a.SetRenderer(~a)~%" cn rn
)
343 (defun vtkchartxy-code (cn)
344 (let ((str (make-array 0
345 :element-type
'character
348 (format str
"~a = vtk.vtkChartXY()~%" cn
)
349 (format str
"~a.GetAxis(0).SetGridVisible(~a)~%"
351 (case (first (get-option '$grid
))
354 (format str
"~a.GetAxis(1).SetGridVisible(~a)~%~%"
356 (case (second (get-option '$grid
))
361 (defun vtkcellarray-code (cn pn celldim ind
)
362 (let ((str (make-array 0
363 :element-type
'character
366 (format str
"~a=vtk.vtkCellArray()~%" cn
)
367 (loop for c in ind do
368 (format str
"~a.InsertNextCell(~a)~%" cn
(length c
))
370 (format str
"~a.InsertCellPoint(~a)~%" cn i
)) )
371 (format str
"~a.~a(~a)~%"
376 (otherwise "SetPolys"))
380 (defun vtkfloatarray-code (fan sn values
&optional
(addarr t
))
381 (let ((n (length values
))
383 :element-type
'character
386 (format str
"~a=vtk.vtkFloatArray()~%" fan
)
387 (loop for k from
0 below n do
388 (format str
"~a.InsertNextValue(~a)~%" fan
(aref values k
)))
389 (format str
"~a.SetName(\"name~a\")~%" fan fan
)
390 (format str
"~a.GetPointData().~a(~a)~%"
398 (defun vtkglyph3d-code (fn sn pdn
)
400 (format nil
"~a=vtk.vtkGlyph3D()~%" fn
)
401 (format nil
"~a.SetInputData(~a)~%" fn sn
)
402 (format nil
"~a.~a~%" fn pdn
)
403 (format nil
"~a.ScalingOff()~%" fn
)))
405 (defun vtkpoints-code (pn sn x y z
)
408 :element-type
'character
411 (format str
"~a=vtk.vtkPoints()~%" pn
)
412 (format str
"~a.SetNumberOfPoints(~a)~%" pn n
)
413 (loop for k from
0 below n do
414 (format str
"~a.InsertPoint(~a,~a,~a,~a)~%" pn k
(aref x k
) (aref y k
) (aref z k
)) )
415 (when (not (null sn
))
416 (format str
"~a.SetPoints(~a)~%" sn pn
))
419 (defun vtktransform-code (tn)
420 (format nil
"~a=vtk.vtkTransform()~%" tn
))
422 (defun vtktransformfilter-code (fn sn tn
)
424 (format nil
"~a=vtk.vtkTransformFilter()~%" fn
)
425 (format nil
"~a.SetInputConnection(~a.GetOutputPort())~%" fn sn
)
426 (format nil
"~a.SetTransform(~a)~%" fn tn
) ))
428 (defun vtktransformpolydatafilter-code (fn sn tn ds
)
430 (format nil
"~a=vtk.vtkTransformPolyDataFilter()~%" fn
)
432 (format nil
"~a.SetInputData(~a)~%" fn sn
)
433 (format nil
"~a.SetInputConnection(~a.GetOutputPort())~%" fn sn
))
434 (format nil
"~a.SetTransform(~a)~%" fn tn
) ))
436 (defun vtkactor-code (an mn col op lw ws
)
437 (let ((colist (hex-to-numeric-list col
)))
439 (format nil
"~a=vtk.vtkActor()~%" an
)
441 (format nil
"~a.SetMapper(~a)~%" an mn
)
443 (format nil
"~a.GetProperty().SetColor(~a,~a,~a)~%"
448 (format nil
"~a.GetProperty().SetOpacity(~a)~%" an op
)
449 (format nil
"~a.GetProperty().SetLineWidth(~a)~%" an lw
)
451 (format nil
"~a.GetProperty().EdgeVisibilityOn()~%~a.GetProperty().SetEdgeColor(0,0,0)~%" an an
)
452 (format nil
"~%")) )))
455 (defun vtkactor-isoline-code (an lw
)
457 (format nil
"~a=vtk.vtkActor()~%" an
)
458 (format nil
"# ~a.GetProperty().SetColor(1.0,0.0,0.0)~%" an
)
459 (format nil
"~a.GetProperty().SetLineWidth(~a)~%" an lw
) ))
462 (defun vtkactor-glyph-code (an col op
)
463 (let ((colist (hex-to-numeric-list col
)))
465 (format nil
"~a=vtk.vtkActor()~%" an
)
466 (format nil
"~a.GetProperty().SetColor(~a,~a,~a)~%"
471 (format nil
"~a.GetProperty().SetOpacity(~a)~%" an op
) )))
473 (defun vtktubefilter-code (tn fn lt
)
475 (format nil
"~a=vtk.vtkTubeFilter()~%" tn
)
476 (format nil
"~a.SetInputConnection(~a.GetOutputPort())~%" tn fn
)
477 (format nil
"~a.SetNumberOfSides(~a)~%" tn
(- lt
))
478 (format nil
"~a.SetRadius(~a)~%" tn
(get-option '$line_width
)) ))
481 (defun vtkContourFilter-code (in fn
)
482 (let ((str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
483 (contours (get-option '$isolines_levels
)))
484 (format str
"~a=vtk.vtkContourFilter()~%" in
)
485 (format str
"~a.SetInputConnection(~a.GetOutputPort())~%" in fn
)
487 ((numberp contours
) ; number of isolines
488 (format str
"~a.GenerateValues(~a,~a.GetOutput().GetScalarRange())~%" in contours fn
))
489 ((and (stringp contours
)
490 (search "incremental" contours
)); list with min, step, max
491 (format str
"u = [~a]~%" (subseq contours
12))
492 (format str
"~a.GenerateValues(int(round((u[2]-u[0]) / u[1])),u[0],u[2])~%" in
) )
493 (t ; set of user specified contour values
494 (format str
"u = [~a]~%" (subseq contours
9))
495 (format str
"for i in range(0, len(u)):~%")
496 (format str
" ~a.SetValue(i,u[i])~%" in
) ))
500 (defun vtkrendererwindow-code (ns)
501 (let* ((dim (get-option '$dimensions
))
502 (ncol (get-option '$columns
))
504 :element-type
'character
508 (alloc (reverse *allocations
*))
510 nrow dx dy thisalloc
)
511 (setf nrow
(ceiling (/ (count nil alloc
) ncol
)))
513 (setf dx
(/ 1.0 ncol
)
515 ; place scenes on the graphic window
516 (loop for counter from
1 to ns do
517 (setf thisalloc
(car alloc
))
518 (setf alloc
(cdr alloc
))
520 (thisalloc ; user defined scene allocation
521 (setf x1
(first thisalloc
)
522 y1
(second thisalloc
))
523 (setf x2
(+ x1
(third thisalloc
))
524 y2
(+ y1
(fourth thisalloc
))))
525 (t ; automatic scene allocation
527 (setf x1
(* (mod (- nilcounter
1) ncol
) dx
)
529 y1
(* (- nrow
(ceiling nilcounter ncol
)) dy
)
531 (format str
"renderer~a.SetViewport(~a,~a,~a,~a)~%" counter x1 y1 x2 y2
))
532 (format str
"renWin=vtk.vtkRenderWindow()~%renWin.SetMultiSamples(0)~%")
533 (format str
"renWin.SetSize(~a,~a)~%" (car dim
) (cadr dim
))
534 (loop for k from
1 to ns do
535 (format str
"renWin.AddRenderer(renderer~a)~%" k
))
539 ; code for file output
540 (defun vtk-terminal ()
541 (let ((terminal (get-option '$terminal
))
542 (filename (get-option '$file_name
))
543 (offscreenterms '($png $pngcairo $jpg $eps $eps_color $tiff $pnm
))
547 ((member terminal offscreenterms
)
550 (setf extension
"png"
551 classformat
"vtkPNGWriter"))
553 (setf extension
"jpg"
554 classformat
"vtkJPEGWriter"))
556 (setf extension
"tif"
557 classformat
"vtkTIFFWriter"))
559 (setf extension
"pnm"
560 classformat
"vtkPNMWriter"))
562 (setf extension
"eps"
563 classformat
"vtkPostScriptWriter")))
564 (format nil
"~a~%~a~%~a~%~a~%~a~a()~%~a~%~a(\"~a.~a\")~%~a~%~a~%"
565 "renWin.OffScreenRenderingOn()"
567 "w2if=vtk.vtkWindowToImageFilter()"
568 "w2if.SetInput(renWin)"
569 "writer=vtk." classformat
570 "writer.SetInputConnection(w2if.GetOutputPort())"
571 "writer.SetFileName" filename extension
574 ((eq terminal
'$vrml
)
575 (format nil
"~a~%~a~%~a(\"~a.~a\")~%~a~%~a~%~a~%"
576 "vrml=vtk.vtkVRMLExporter()"
577 "vrml.SetInput(renWin)"
578 "vrml.SetFileName" filename
"wrl"
583 (format nil
"~a~%~a~%~a(\"~a\")~%~a~%~a~%"
584 "obj=vtk.vtkOBJExporter()"
585 "obj.SetInput(renWin)"
586 "obj.SetFilePrefix" filename
589 ((eq terminal
'$screen
)
590 (format nil
"~a~%~a~%~a~%~a~%~a~%~a~%~a~%"
591 "iren=vtk.vtkRenderWindowInteractor()"
592 "iren.SetRenderWindow(renWin)"
594 "renderer1.ResetCamera()"
595 "renderer1.GetActiveCamera().Zoom(1.01)"
599 (format nil
"~a~%~a~%~a~%~a~%~a~a~a~%~a~%~a~%"
600 "triangulator=vtk.vtkTriangleFilter()"
601 "triangulator.SetInputConnection(appenddata1.GetOutputPort())"
602 "stl=vtk.vtkSTLWriter()"
603 "stl.SetInputConnection(triangulator.GetOutputPort())"
604 "stl.SetFileName(\"" filename
".stl\")"
608 (format nil
"~a~%~a~%~a~%~a~%~a~a~a~%~a~%~a~%"
609 "triangulator=vtk.vtkTriangleFilter()"
610 "triangulator.SetInputConnection(appenddata1.GetOutputPort())"
611 "stl=vtk.vtkPLYWriter()"
612 "stl.SetInputConnection(triangulator.GetOutputPort())"
613 "stl.SetFileName(\"" filename
"\")"
617 (merror "draw: unknown terminal for vtk")))))
620 ; Checks if lookup table is already created.
621 ; Returns its position number in *lookup-tables*
622 (defun lookup-table-exists (pal)
624 (setf pos
(position pal
*lookup-tables
* :test
#'equal
))
630 ; Writes tcl code for color transform functions
631 (defun color-transform-function (c n f
)
637 (0 (setf expr
"x = 0"))
638 (1 (setf expr
"x = 0.5"))
639 (2 (setf expr
"x = 1"))
640 (3 (setf expr
"x = x"))
641 (4 (setf expr
"x = x*x"))
642 (5 (setf expr
"x = x*x*x"))
643 (6 (setf expr
"x = x*x*x*x"))
644 (7 (setf expr
"x = math.sqrt(x)"))
645 (8 (setf expr
"x = math.sqrt(math.sqrt(x))"))
646 (9 (setf expr
"x = math.sin(1.570796326794897*x)")) ; %pi/2
647 (10 (setf expr
"x = math.cos(1.570796326794897*x)"))
648 (11 (setf expr
"x = math.fabs(x-0.5)"))
649 (12 (setf expr
"x = (2.0*x-1.0)*(2.0*x-1.0)"))
650 (13 (setf expr
"x = math.sin(3.141592653589793*x)")) ; %pi
651 (14 (setf expr
"x = math.fabs(math.cos(3.141592653589793*x))"))
652 (15 (setf expr
"x = math.sin(6.283185307179586*x)")) ; 2*%pi
653 (16 (setf expr
"x = math.cos(6.283185307179586*x)"))
654 (17 (setf expr
"x = math.fabs(math.sin(6.283185307179586*x))"))
655 (18 (setf expr
"x = math.fabs(math.cos(6.283185307179586*x))"))
656 (19 (setf expr
"x = math.fabs(math.sin(12.56637061435917*x))")) ; 4*%pi
657 (20 (setf expr
"x = math.fabs(math.cos(12.56637061435917*x))"))
658 (21 (setf expr
"x = 3.0*x"))
659 (22 (setf expr
"x = 3.0*x-1.0"))
660 (23 (setf expr
"x = 3.0*x-2.0"))
661 (24 (setf expr
"x = math.fabs(3.0*x-1.0)"))
662 (25 (setf expr
"x = math.fabs(3.0*x-2.0)"))
663 (26 (setf expr
"x = 1.5*x-0.5"))
664 (27 (setf expr
"x = 1.5*x-1.0"))
665 (28 (setf expr
"x = math.fabs(1.5*x-0.5)"))
666 (29 (setf expr
"x = math.fabs(1.5*x-1.0)"))
667 (30 (setf expr
"x = interval(x,0.25,0.57)/0.32-0.78125"))
668 (31 (setf expr
"x = 2*interval(x,0.42,0.92)-0.84"))
669 (32 (setf expr
(concatenate 'string
670 (format nil
"if x <= 0.42:~%")
671 (format nil
" x = 4.0*x~%")
672 (format nil
" elif x <= 0.92:~%")
673 (format nil
" x = -2.0*x+1.84~%")
674 (format nil
" else:~%")
675 (format nil
" x = x/0.08-11.5"))))
676 (33 (setf expr
"x = math.fabs(2.0*x-0.5)"))
677 (34 (setf expr
"x = 2*x"))
678 (35 (setf expr
"x = 2.0*x-0.5"))
679 (36 (setf expr
"x = 2.0*x-1.0")))
681 (format nil
"def f~a~a (k):~%" c n
)
682 (format nil
" x = unitscale(k)~%" )
683 (format nil
" ~a~%" expr
)
684 (format nil
" return interval(x,0,1)~%~%")) ))
687 ; Creates lookup table. See info for option 'palette'.
688 ; Returns list with lookup table name and the string.
689 (defun check-lookup-table ()
690 (let ((palette (get-option '$palette
))
693 (cond ((equal palette
'$gray
)
694 (setf palette
'(3 3 3)))
695 ((equal palette
'$color
)
696 (setf palette
'(7 5 15))) )
697 (setf lutn
(1+ (length *lookup-tables
*)))
698 (setf *lookup-tables
* (append *lookup-tables
* (list palette
)))
699 (setf palette-name
(format nil
"lut~a" lutn
))
700 (cond ((and (listp palette
) ; build lookup table with transform functionsunitscale
701 (= (length palette
) 3)
702 (every #'(lambda (x) (and (integerp x
) (<= (abs x
) 36))) palette
) )
703 ; if *unitscale-already-defined* is null, write
704 ; tcl functions 'unitscale' and 'unitinterval'
705 (when (null *unitscale-already-defined
*)
708 (format nil
"import math~%~%")
709 (format nil
"def unitscale (k):~%")
710 (format nil
" return k/255.0~%~%")
711 (format nil
"def interval (x,x0,x1):~%")
712 (format nil
" if x <= x0:~%")
713 (format nil
" return 0~%")
714 (format nil
" if x >= x1:~%")
715 (format nil
" return 1~%")
716 (format nil
" return x~%~%")))
717 (setf *unitscale-already-defined
* t
))
718 ; write tcl r-g-b transform functions
722 (color-transform-function "R" lutn
(car palette
))
723 (color-transform-function "G" lutn
(cadr palette
))
724 (color-transform-function "B" lutn
(caddr palette
))))
725 ; create lookup table
729 (format nil
"~a=vtk.vtkLookupTable()~%" palette-name
)
730 (format nil
"~a.SetNumberOfColors(256)~%" palette-name
)
731 (format nil
"~a.Build()~%" palette-name
)
732 (format nil
"for i in range (0,256):~%")
733 (format nil
" ~a.SetTableValue(i,fR~a(i),fG~a(i),fB~a(i),1)~%~%"
734 palette-name lutn lutn lutn
)))
735 (list palette-name lut
))
737 ((and (listp palette
) ; build user defined lookup table without transparency
738 (every #'(lambda (x) (and (listp x
) (= (length x
) 3))) palette
) )
742 (n (length palette
)))
743 (with-output-to-string (stream)
744 (format stream
"~a=vtk.vtkLookupTable()~%" palette-name
)
745 (format stream
"~a.SetNumberOfColors(~a)~%" palette-name n
)
747 (setf triplete
(nth k palette
))
748 (format stream
"~a.SetTableValue(~a,~a,~a,~a,1)~%"
749 palette-name k
(car triplete
) (cadr triplete
) (caddr triplete
)))))))
751 ((and (listp palette
) ; build user defined lookup table with transparency
752 (every #'(lambda (x) (and (listp x
) (= (length x
) 4))) palette
) )
756 (n (length palette
)))
757 (with-output-to-string (stream)
758 (format stream
"~a=vtk.vtkLookupTable()~%" palette-name
)
759 (format stream
"~a.SetNumberOfColors(~a)~%" palette-name n
)
761 (setf triplete
(nth k palette
))
762 (format stream
"~a.SetTableValue(~a,~a,~a,~a,~a)~%"
763 palette-name k
(car triplete
) (cadr triplete
) (caddr triplete
) (cadddr triplete
))))))))))
766 (defun build-surface-grid (nx ny
)
772 (setf poly
(cons (list (+ cont c
) (+ cont c
1) (+ cont nx c
1) (+ cont nx c
)) poly
))))
780 ;; 3d: cone(center, radius, height, direction)
781 ;; -------------------------------------------
782 (defun vtk3d-cone (cen rad hei dir
)
783 (let ((color (get-option '$color
))
784 (opacity (get-option '$opacity
))
785 (linewidth (get-option '$line_width
))
786 (wiredsurface (get-option '$wired_surface
))
787 (capping (rest (get-option '$capping
)))
788 (source-name (get-source-name))
789 (mapper-name (get-mapper-name))
790 (actor-name (get-actor-name))
791 (trans-name (get-trans-name))
792 (filter-name (get-filter-name))
798 (when (or (not ($listp fcen
))
799 (not (= ($length fcen
) 3))
800 (not (every #'floatp
(rest fcen
))) )
801 (merror "draw3d: cone center must be a list of three numbers"))
802 (when (or (not (floatp frad
))
804 (merror "draw3d: cone radius must be a number greater than zero"))
805 (when (or (not (floatp fhei
))
807 (merror "draw3d: cone height must be a number greater than zero"))
808 (when (or (not ($listp fdir
))
809 (not (= ($length fdir
) 3))
810 (not (every #'floatp
(rest fdir
))) )
811 (merror "draw3d: cone direction must be a list of three numbers"))
816 (format nil
"~a=vtk.vtkConeSource()~%" source-name
)
817 (format nil
"~a.SetHeight(~a)~%" source-name fhei
)
818 (format nil
"~a.SetRadius(~a)~%" source-name frad
)
819 (format nil
"~a.SetCenter(~a,~a,~a)~%"
824 (format nil
"~a.SetDirection(~a,~a,~a)~%"
829 (format nil
"~a.SetResolution(~a)~%" source-name
30)
830 (format nil
"~a.SetCapping(~a)~%" source-name capn
)
831 (vtktransform-code trans-name
)
832 (vtktransformpolydatafilter-code filter-name source-name trans-name nil
)
833 (vtkpolydatamapper-code mapper-name filter-name t
)
834 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
835 (vtkactor-code actor-name mapper-name color opacity linewidth wiredsurface
)
836 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
)) )))
840 ;; 3d: prism(center, n, edgepoint, height, direction)
841 ;; --------------------------------------------------
843 ; rotates point (x,y,z) rad radians around the line with unitary direction
844 ; vector (u,v,w) containing point (a,b,c)
845 (defun rotate (x y z a b c u v w rad
)
848 (* ($sin rad
) (+ (* -
1 c v
) (* b w
) (* -
1 w y
) (* v z
)))
849 (* (+ 1 (* -
1 ($cos rad
)))
850 (+ (* a
(+ (expt v
2) (expt w
2)))
851 (* -
1 u
(+ (* b v
) (* c w
) (* -
1 u x
) (* -
1 v y
) (* -
1 w z
))))))
853 (* ($sin rad
) (+ (* c u
) (* -
1 a w
) (* w x
) (* -
1 u z
)))
854 (* (+ 1 (* -
1 ($cos rad
)))
855 (+ (* b
(+ (expt u
2) (expt w
2)))
856 (* -
1 v
(+ (* a u
) (* c w
) (* -
1 u x
) (* -
1 v y
) (* -
1 w z
))))))
857 (+ (* ($sin rad
) (+ (* -
1 b u
) (* a v
) (* -
1 v x
) (* u y
)))
859 (* (+ 1 (* -
1 ($cos rad
)))
860 (+ (* c
(+ (expt u
2) (expt v
2)))
861 (* -
1 w
(+ (* a u
) (* b v
) (* -
1 u x
) (* -
1 v y
) (* -
1 w z
)))))) ))
863 (defun vtk3d-prism (cen n edgp hei dir
)
864 (let ((color (get-option '$color
))
865 (opacity (get-option '$opacity
))
866 (linewidth (get-option '$line_width
))
867 (wiredsurface (get-option '$wired_surface
))
868 (capping (rest (get-option '$capping
)))
869 (source-name (get-source-name))
870 (points-name (get-points-name))
871 (cellarray-name (get-cellarray-name))
872 (mapper-name (get-mapper-name))
873 (actor-name (get-actor-name))
874 (trans-name (get-trans-name))
875 (filter-name (get-filter-name))
876 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
878 (fedgp ($float edgp
))
881 (ang (/ 6.283185307179586 n
)) ; = 2*%pi/n
885 dirmod c1 c2 c3 d1 d2 d3 p1 p2 p3 du1 du2 du3 v v1 v2 v3 x y z
)
886 (when (or (not ($listp fcen
))
887 (not (= ($length fcen
) 3))
888 (not (every #'floatp
(rest fcen
))) )
889 (merror "draw3d: prism center must be a list of three numbers"))
890 (when (or (not ($listp fedgp
))
891 (not (= ($length fedgp
) 3))
892 (not (every #'floatp
(rest fedgp
))) )
893 (merror "draw3d: point on prism edge must be a list of three numbers"))
894 (when (or (not (floatp fhei
))
896 (merror "draw3d: prism height must be a number greater than zero"))
897 (when (or (not ($listp fdir
))
898 (not (= ($length fdir
) 3))
899 (not (every #'floatp
(rest fdir
))) )
900 (merror "draw3d: cylinder direction must be a list of three numbers"))
901 ; direction vector with module = height/2
902 (setf c1
(cadr fcen
) c2
(caddr fcen
) c3
(cadddr fcen
)
903 p1
(cadr fedgp
) p2
(caddr fedgp
) p3
(cadddr fedgp
)
904 d1
(cadr fdir
) d2
(caddr fdir
) d3
(cadddr fdir
))
905 (setf dirmod
(sqrt (+ (* d1 d1
) (* d2 d2
) (* d3 d3
))))
907 (setf d1
0 d2
0 d3
1 dirmod
1))
908 (setf du1
(/ (* d1 fhei
) (* 2 dirmod
))
909 du2
(/ (* d2 fhei
) (* 2 dirmod
))
910 du3
(/ (* d3 fhei
) (* 2 dirmod
)))
911 ; intersection between edge and perpendicular plane passing through center:
912 ; linsolve([d1*v1+d2*v2+d3*v3=d1*c1+d2*c2+d3*c3,
913 ; d2*v1-d1*v2 =d2*p1-d1*p2,
914 ; d3*v2-d2*v3=d3*p2-d2*p3], [v1,v2,v3]);
915 (let ((den (* dirmod dirmod
)))
916 (setf v1
(/ (+ (* c1 d1 d1
) (* c2 d1 d2
) (* c3 d1 d3
) (* d2 d2 p1
) (* d3 d3 p1
) (* -
1 d1 d2 p2
) (* -
1 d1 d3 p3
))
918 v2
(/ (+ (* c1 d1 d2
) (* c2 d2 d2
) (* c3 d2 d3
) (* -
1 d1 d2 p1
) (* d1 d1 p2
) (* d3 d3 p2
) (* -
1 d2 d3 p3
))
920 v3
(/ (+ (* c1 d1 d3
) (* c2 d2 d3
) (* c3 d3 d3
) (* -
1 d1 d3 p1
) (* -
1 d2 d3 p2
) (* d1 d1 p3
) (* d2 d2 p3
))
922 ; rotate n times 2 pi/n and save the vertices of the lateral rectangles
923 (setf x
(make-array (* (+ 2 (count t capping
)) (+ n
1) ) :element-type
'flonum
))
924 (setf y
(make-array (* (+ 2 (count t capping
)) (+ n
1) ) :element-type
'flonum
))
925 (setf z
(make-array (* (+ 2 (count t capping
)) (+ n
1) ) :element-type
'flonum
))
926 (loop for s from
0 to n do
928 (when (equal (second capping
) t
)
929 (setf (aref x
(incf xcount
)) (- c1 du1
))
930 (setf (aref y
(incf ycount
)) (- c2 du2
))
931 (setf (aref z
(incf zcount
)) (- c3 du3
)))
932 (setf v
(rotate v1 v2 v3 c1 c2 c3
(/ d1 dirmod
) (/ d2 dirmod
) (/ d3 dirmod
) (* s ang
)) )
933 (setf (aref x
(incf xcount
)) (- (first v
) du1
))
934 (setf (aref y
(incf ycount
)) (- (second v
) du2
))
935 (setf (aref z
(incf zcount
)) (- (third v
) du3
))
936 (setf (aref x
(incf xcount
)) (+ (first v
) du1
))
937 (setf (aref y
(incf ycount
)) (+ (second v
) du2
))
938 (setf (aref z
(incf zcount
)) (+ (third v
) du3
))
940 (when (equal (first capping
) t
)
941 (setf (aref x
(incf xcount
)) (+ c1 du1
))
942 (setf (aref y
(incf ycount
)) (+ c2 du2
))
943 (setf (aref z
(incf zcount
)) (+ c3 du3
))) ) ; end loop
946 (format str
"~a=vtk.vtkPolyData()~%" source-name
)
947 (format str
"~a~%" (vtkpoints-code points-name source-name x y z
))
948 (format str
"~a~%" (vtkcellarray-code cellarray-name source-name
2
949 (build-surface-grid (+ 2 (count t capping
)) (+ n
1))))
950 (format str
"~a~%" (vtktransform-code trans-name
))
951 (format str
"~a~%" (vtktransformpolydatafilter-code filter-name source-name trans-name t
))
952 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name t
))
953 (format str
"bounds.append(~a.GetBounds())~%" mapper-name
)
954 (format str
"~a~%" (vtkactor-code actor-name mapper-name color opacity linewidth wiredsurface
))
955 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
960 ;; 3d: cylinder(center, radius, height, direction)
961 ;; -----------------------------------------------
962 (defun vtk3d-cylinder (cen rad hei dir
)
963 (let ((color (get-option '$color
))
964 (opacity (get-option '$opacity
))
965 (linewidth (get-option '$line_width
))
966 (wiredsurface (get-option '$wired_surface
))
967 (capping (rest (get-option '$capping
)))
968 (source-name (get-source-name))
969 (mapper-name (get-mapper-name))
970 (actor-name (get-actor-name))
971 (trans-name (get-trans-name))
972 (filter-name (get-filter-name))
977 capn dirmod xrot yrot zrot
)
978 (when (or (not ($listp fcen
))
979 (not (= ($length fcen
) 3))
980 (not (every #'floatp
(rest fcen
))) )
981 (merror "draw3d: cylinder center must be a list of three numbers"))
982 (when (or (not (floatp fhei
))
984 (merror "draw3d: cylinder height must be a number greater than zero"))
985 (when (or (not (floatp frad
))
987 (merror "draw3d: cylinder radius must be a number greater than zero"))
988 (when (or (not ($listp fdir
))
989 (not (= ($length fdir
) 3))
990 (not (every #'floatp
(rest fdir
))) )
991 (merror "draw3d: cylinder direction must be a list of three numbers"))
995 (setf dirmod
(sqrt (+ (* (cadr fdir
) (cadr fdir
))
996 (* (caddr fdir
) (caddr fdir
))
997 (* (cadddr fdir
) (cadddr fdir
)))))
1000 ; we use the same default direction used by cones,
1001 ; which is the positive X-direction
1005 ((= (caddr fdir
) 0.0)
1007 yrot
(* 57.29577951308232
1008 ($acos
(/ (cadddr fdir
)
1009 (sqrt (+ (* (cadr fdir
) (cadr fdir
))
1010 (* (cadddr fdir
) (cadddr fdir
)) )))))
1012 ((< (caddr fdir
) 0.0)
1013 (setf xrot
(* 57.29577951308232 ($asin
(/ (cadddr fdir
) dirmod
)))
1015 zrot
(* 57.29577951308232 (+ -
3.141592653589793 (- ($atan
(/ (cadr fdir
) (caddr fdir
))))))))
1017 (setf xrot
(* 57.29577951308232 ($asin
(/ (cadddr fdir
) dirmod
)))
1019 zrot
(* 57.29577951308232 (- ($atan
(/ (cadr fdir
) (caddr fdir
))))))) )
1021 (concatenate 'string
1022 (format nil
"~a=vtk.vtkCylinderSource()~%" source-name
)
1023 (format nil
"~a.SetHeight(~a)~%" source-name fhei
)
1024 (format nil
"~a.SetRadius(~a)~%" source-name frad
)
1025 (format nil
"~a.SetResolution(~a)~%" source-name
30)
1026 (format nil
"~a.SetCapping(~a)~%" source-name capn
)
1027 (vtktransform-code trans-name
)
1028 (format nil
"~a.Translate(~a,~a,~a)~%"
1033 ; rotations are made in reverse order as indicated here
1034 (format nil
"~a.RotateZ(~a)~%" trans-name zrot
) ; azimuth
1035 (format nil
"~a.RotateY(~a)~%" trans-name yrot
)
1036 (format nil
"~a.RotateX(~a)~%" trans-name xrot
) ; elevation
1037 (vtktransformpolydatafilter-code filter-name source-name trans-name nil
)
1038 (vtkpolydatamapper-code mapper-name filter-name t
)
1039 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
1040 (vtkactor-code actor-name mapper-name color opacity linewidth wiredsurface
)
1041 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
)) )))
1045 ;; 3d: cube(xlength, ylength, zlength, center)
1046 ;; -------------------------------------------
1047 (defun vtk3d-cube (xlen ylen zlen cen
)
1048 (let ((color (get-option '$color
))
1049 (opacity (get-option '$opacity
))
1050 (linewidth (get-option '$line_width
))
1051 (wiredsurface (get-option '$wired_surface
))
1052 (source-name (get-source-name))
1053 (mapper-name (get-mapper-name))
1054 (actor-name (get-actor-name))
1055 (trans-name (get-trans-name))
1056 (filter-name (get-filter-name))
1057 (fxlen ($float xlen
))
1058 (fylen ($float ylen
))
1059 (fzlen ($float zlen
))
1060 (fcen ($float cen
)) )
1061 (when (or (not (floatp fxlen
))
1063 (merror "draw3d: cube x-length must be a number greater than zero"))
1064 (when (or (not (floatp fylen
))
1066 (merror "draw3d: cube y-length must be a number greater than zero"))
1067 (when (or (not (floatp fzlen
))
1069 (merror "draw3d: cube z-length must be a number greater than zero"))
1070 (when (or (not ($listp fcen
))
1071 (not (= ($length fcen
) 3))
1072 (not (every #'floatp
(rest fcen
))) )
1073 (merror "draw3d: cube center must be a list of three floats"))
1075 (concatenate 'string
1076 (format nil
"~a=vtk.vtkCubeSource()~%" source-name
)
1077 (format nil
"~a.SetXLength(~a)~%" source-name fxlen
)
1078 (format nil
"~a.SetYLength(~a)~%" source-name fylen
)
1079 (format nil
"~a.SetZLength(~a)~%" source-name fzlen
)
1080 (format nil
"~a.SetCenter(~a,~a,~a)~%"
1085 (vtktransform-code trans-name
)
1086 (vtktransformpolydatafilter-code filter-name source-name trans-name nil
)
1087 (vtkpolydatamapper-code mapper-name filter-name t
)
1088 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
1089 (vtkactor-code actor-name mapper-name color opacity linewidth wiredsurface
)
1090 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
)) )))
1094 ;; 3d: sphere(center, radius)
1095 ;; --------------------------
1096 (defun vtk3d-sphere (cen rad
)
1097 (let ((color (get-option '$color
))
1098 (opacity (get-option '$opacity
))
1099 (linewidth (get-option '$line_width
))
1100 (wiredsurface (get-option '$wired_surface
))
1101 (source-name (get-source-name))
1102 (mapper-name (get-mapper-name))
1103 (actor-name (get-actor-name))
1104 (trans-name (get-trans-name))
1105 (filter-name (get-filter-name))
1107 (fcen ($float cen
)) )
1108 (when (or (not ($listp fcen
))
1109 (not (= ($length fcen
) 3))
1110 (not (every #'floatp
(rest fcen
))) )
1111 (merror "draw3d: sphere center must be a list of three numbers"))
1112 (when (or (not (floatp frad
))
1114 (merror "draw3d: sphere radius must be a number greater than zero"))
1117 (concatenate 'string
1118 (format nil
"~a=vtk.vtkSphereSource()~%" source-name
)
1119 (format nil
"~a.SetRadius(~a)~%" source-name frad
)
1120 (format nil
"~a.SetCenter(~a,~a,~a)~%"
1125 (format nil
"~a.SetThetaResolution(~a)~%" source-name
30)
1126 (format nil
"~a.SetPhiResolution(~a)~%" source-name
30)
1127 (vtktransform-code trans-name
)
1128 (vtktransformpolydatafilter-code filter-name source-name trans-name nil
)
1129 (vtkpolydatamapper-code mapper-name filter-name t
)
1130 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
1131 (vtkactor-code actor-name mapper-name color opacity linewidth wiredsurface
)
1132 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
)) )))
1136 ;; 3d: parallelogram(origin, point1, point2)
1137 ;; -----------------------------------------
1138 ;; The parallelogram is defined by one vertex and the two other adjacent vertices
1139 (defun vtk3d-parallelogram (ori p1 p2
)
1140 (let ((color (get-option '$color
))
1141 (opacity (get-option '$opacity
))
1142 (linewidth (get-option '$line_width
))
1143 (wiredsurface (get-option '$wired_surface
))
1144 (source-name (get-source-name))
1145 (trans-name (get-trans-name))
1146 (filter-name (get-filter-name))
1147 (mapper-name (get-mapper-name))
1148 (actor-name (get-actor-name))
1149 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
1150 (fori (map 'list
#'$float
(rest ori
)))
1151 (fp1 (map 'list
#'$float
(rest p1
)))
1152 (fp2 (map 'list
#'$float
(rest p2
)))
1153 xx yy zz a1 b1 c1 a2 b2 c2
)
1154 (when (notevery #'(lambda (z) (floatp z
))
1155 (append fori fp1 fp2
))
1156 (merror "vtk3d: arguments to parallelogram must be lists of floats"))
1159 (format str
"~a=vtk.vtkPlaneSource()~%" source-name
)
1167 (format str
"~a.SetOrigin(~a,~a,~a)~%" source-name xx yy zz
)
1172 (if (and (= a1 xx
) (= b1 yy
) (= c1 zz
))
1173 (merror "vtk3d (parallelogram): three distinct vertices are needed.")
1177 (format str
"~a.SetPoint1(~a,~a,~a)~%" source-name xx yy zz
)
1182 (when (or (and (= a1 xx
) (= b1 yy
) (= c1 zz
))
1183 (and (= a2 xx
) (= b2 yy
) (= c2 zz
)) )
1184 (merror "vtk3d: we need three distinct vertices to draw a parallelogram.") )
1185 (format str
"~a.SetPoint2(~a,~a,~a)~%" source-name xx yy zz
)
1186 (format nil
"~a.SetXResolution(~a)~%" source-name
10)
1187 (format str
"~a.SetYResolution(~a)~%" source-name
10)
1188 (format str
"~a" (vtktransform-code trans-name
))
1189 (format str
"~a" (vtktransformpolydatafilter-code filter-name source-name trans-name nil
))
1190 (format str
"~a" (vtkpolydatamapper-code mapper-name filter-name t
))
1191 (format str
"bounds.append(~a.GetBounds())~%" mapper-name
)
1192 (format str
"~a" (vtkactor-code actor-name mapper-name color opacity linewidth wiredsurface
))
1193 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
1198 ;; 3d: triangle(vertex1, vertex2, vertex3)
1199 ;; ---------------------------------------
1200 ;; The triangle is defined by three vertices
1201 (defun vtk3d-triangle (v1 v2 v3
)
1202 (let ((color (get-option '$color
))
1203 (opacity (get-option '$opacity
))
1204 (linewidth (get-option '$line_width
))
1205 (wiredsurface (get-option '$wired_surface
))
1206 (points-name (get-points-name))
1207 (triangle-name (get-triangle-name))
1208 (polydata-name (get-polydata-name))
1209 (trans-name (get-trans-name))
1210 (filter-name (get-filter-name))
1211 (mapper-name (get-mapper-name))
1212 (actor-name (get-actor-name))
1213 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
1214 (fv1 (map 'list
#'$float
(rest v1
)))
1215 (fv2 (map 'list
#'$float
(rest v2
)))
1216 (fv3 (map 'list
#'$float
(rest v3
)))
1218 (when (notevery #'(lambda (z) (floatp z
))
1219 (append fv1 fv2 fv3
))
1220 (merror "vtk3d (triangle): arguments must be lists of three numbers"))
1222 (format str
"~a=vtk.vtkPoints()~%" points-name
)
1223 (format str
"~a.SetNumberOfPoints(3)~%" points-name
)
1228 (format str
"~a.InsertPoint(0,~a,~a,~a)~%" points-name xx yy zz
)
1233 (format str
"~a.InsertPoint(1,~a,~a,~a)~%" points-name xx yy zz
)
1238 (format str
"~a.InsertPoint(2,~a,~a,~a)~%" points-name xx yy zz
)
1239 (format str
"~a=vtk.vtkTriangle()~%" triangle-name
)
1240 (format str
"~a.GetPointIds().SetId(0,0)~%" triangle-name
)
1241 (format str
"~a.GetPointIds().SetId(1,1)~%" triangle-name
)
1242 (format str
"~a.GetPointIds().SetId(2,2)~%" triangle-name
)
1243 (format str
"~a=vtk.vtkPolyData()~%" polydata-name
)
1244 (format str
"~a.Allocate(1,1)~%" polydata-name
)
1245 (format str
"~a.InsertNextCell(~a.GetCellType(),~a.GetPointIds())~%"
1249 (format str
"~a.SetPoints(~a)~%" polydata-name points-name
)
1250 (format str
"~a" (vtktransform-code trans-name
))
1251 (format str
"~a" (vtktransformpolydatafilter-code filter-name polydata-name trans-name t
))
1252 (format str
"~a=vtk.vtkPolyDataMapper()~%" mapper-name
)
1253 (format str
"~a.SetInputData(~a)~%" mapper-name polydata-name
)
1254 (format str
"bounds.append(~a.GetBounds())~%" mapper-name
)
1255 (format str
"~a" (vtkactor-code actor-name mapper-name color opacity linewidth wiredsurface
))
1256 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
1261 ;; 3d: vector([x,y,z], [dx,dy,dz])
1262 ;; ---------------------------
1263 (defun vtk3d-vector (arg1 arg2
)
1264 (when (or (not ($listp arg1
))
1265 (not (= ($length arg1
) 3))
1267 (not (= ($length arg2
) 3)))
1268 (merror "vtk3d (vector): coordinates are not correct"))
1269 (let ((color (get-option '$color
))
1270 (head-length (get-option '$head_length
))
1271 (head-angle (get-option '$head_angle
))
1272 (line-width (get-option '$line_width
))
1273 (unit-vectors (get-option '$unit_vectors
))
1274 (opacity (get-option '$opacity
))
1275 (wiredsurface (get-option '$wired_surface
))
1276 (source-name (get-source-name))
1277 (trans-name (get-trans-name))
1278 (filter-name (get-filter-name))
1279 (mapper-name (get-mapper-name))
1280 (actor-name (get-actor-name))
1281 (x ($float
(cadr arg1
)))
1282 (y ($float
(caddr arg1
)))
1283 (z ($float
(cadddr arg1
)))
1284 (dx ($float
(cadr arg2
)))
1285 (dy ($float
(caddr arg2
)))
1286 (dz ($float
(cadddr arg2
)))
1287 ndx ndy ndz radians tiplength module radius rotangle
)
1289 (setf module
(sqrt (+ (* dx dx
) (* dy dy
) (* dz dz
))))
1290 (setf ndx
(/ dx module
)
1293 ; transform into unitary vector when unit_vectors=true
1297 (setf radians
(* head-angle
0.0174532925199433)) ; 0.017..=%pi/180
1298 (setf tiplength
(* head-length
($float
($cos radians
))))
1299 (setf radius
(* head-length
($float
($sin radians
))))
1302 (* 57.29577951308232 ; 57.29..=180/%pi
1303 ($float
($asin
(sqrt (+ (* ndz ndz
) (* ndy ndy
)))))))
1304 ; check if rotation angle is obtuse
1306 (setf rotangle
(- 180.0 rotangle
)))
1307 (when (and (= ndz
0.0) (= ndy
0.0))
1312 (concatenate 'string
1313 (format nil
"~a=vtk.vtkArrowSource()~%" source-name
)
1314 (format nil
"~a.SetTipResolution(~a)~%" source-name
20)
1315 (format nil
"~a.SetTipRadius(~a)~%" source-name
(/ radius module
))
1316 (format nil
"~a.SetTipLength(~a)~%" source-name
(/ tiplength module
))
1317 (format nil
"~a.SetShaftResolution(~a)~%" source-name
10)
1318 (format nil
"~a.SetShaftRadius(~a)~%" source-name
(/ line-width module
))
1319 (vtktransform-code trans-name
)
1320 (format nil
"~a.Translate(~a,~a,~a)~%" trans-name x y z
)
1321 (format nil
"~a.RotateWXYZ(~a,~a,~a,~a)~%" trans-name rotangle
0 (- ndz
) ndy
)
1322 (format nil
"~a.Scale(~a,~a,~a)~%" trans-name module module module
)
1323 (vtktransformfilter-code filter-name source-name trans-name
)
1324 (vtkpolydatamapper-code mapper-name filter-name t
)
1325 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
1326 (vtkactor-code actor-name mapper-name color opacity line-width wiredsurface
)
1327 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
)) )))
1331 ;; 3D: points([[x1,y1,z1], [x2,y2,z2], [x3,y3,z3],...])
1332 ;; ----------------------------------------------------
1333 (defun vtk3d-points (arg)
1334 (let ((points-joined (get-option '$points_joined
))
1335 (point-type (get-option '$point_type
))
1336 (point-size ($float
(get-option '$point_size
)))
1337 (line-type (get-option '$line_type
))
1338 (color (get-option '$color
))
1339 (opacity (get-option '$opacity
))
1340 (linewidth (get-option '$line_width
))
1341 (wiredsurface (get-option '$wired_surface
))
1342 (source-name (get-source-name))
1343 (points-name (get-points-name))
1344 (floatarray-name (get-floatarray-name))
1345 (tmp (mapcar #'rest
(rest arg
)))
1347 (minscalar most-positive-double-float
)
1348 (maxscalar most-negative-double-float
)
1349 source-name2 points-name2 filter-name trans-name mapper-name actor-name polydata-name
1350 cellarray-name cellarray-name2 solidsource-name lookup-table-name glyphpoints-name
1351 newscalar slope scalars x y z ax ay az n
)
1353 (setf n
($length arg
))
1354 ; create array of points
1355 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
1356 y
(map 'list
#'$float
(map 'list
#'second tmp
))
1357 z
(map 'list
#'$float
(map 'list
#'third tmp
)) )
1359 (setf ax
(make-array n
:element-type
'flonum
:initial-contents x
)
1360 ay
(make-array n
:element-type
'flonum
:initial-contents y
)
1361 az
(make-array n
:element-type
'flonum
:initial-contents z
))
1363 ; check enhanced3d model
1364 (check-enhanced3d-model "points" '(0 1 3))
1365 (when (> *draw-enhanced3d-type
* 0)
1366 (setf scalars
(make-array n
:element-type
'flonum
))
1368 ((= *draw-enhanced3d-type
* 1)
1370 (setf newscalar
(funcall *draw-enhanced3d-fun
* k
))
1371 (when (< newscalar minscalar
) (setf minscalar newscalar
))
1372 (when (> newscalar maxscalar
) (setf maxscalar newscalar
))
1373 (setf (aref scalars k
) newscalar
)) )
1374 ((= *draw-enhanced3d-type
* 3)
1376 (setf newscalar
(funcall *draw-enhanced3d-fun
* (aref ax k
) (aref ay k
) (aref az k
)))
1377 (when (< newscalar minscalar
) (setf minscalar newscalar
))
1378 (when (> newscalar maxscalar
) (setf maxscalar newscalar
))
1379 (setf (aref scalars k
) newscalar
))))
1380 (if (< minscalar maxscalar
)
1381 (setf slope
(/ 1.0 (- maxscalar minscalar
)))
1383 ; rescale array of scalars to interval [0,1]
1384 (loop for s from
0 below
(length scalars
) do
1385 (setf (aref scalars s
) (* slope
(- (aref scalars s
) minscalar
))))
1386 (let ((lut (check-lookup-table)))
1387 (setf lookup-table-name
(car lut
))
1388 (setf output-string
(cadr lut
))) )
1392 (concatenate 'string
1394 (format nil
"~a=vtk.vtkPolyData()~%" source-name
)
1395 (vtkpoints-code points-name source-name ax ay az
)
1396 (when (> *draw-enhanced3d-type
* 0)
1397 (vtkfloatarray-code floatarray-name source-name scalars nil
) )))
1398 (when points-joined
; true or impulses
1399 (setf trans-name
(get-trans-name)
1400 filter-name
(get-filter-name)
1401 mapper-name
(get-mapper-name)
1402 polydata-name
(get-polydata-name)
1403 cellarray-name
(get-cellarray-name)
1404 actor-name
(get-actor-name))
1406 (concatenate 'string
1409 ((eql points-joined
'$impulses
)
1410 (setf source-name2
(get-source-name)
1411 points-name2
(get-points-name)
1412 cellarray-name2
(get-cellarray-name))
1413 (concatenate 'string
1414 (format nil
"~a=vtk.vtkPolyData()~%" source-name2
)
1415 (let ((xx (make-array (* 2 n
) :element-type
'flonum
))
1416 (yy (make-array (* 2 n
) :element-type
'flonum
))
1417 (zz (make-array (* 2 n
) :element-type
'flonum
))
1419 (loop for k from
0 below n do
1420 (setf (aref xx ind
) (aref ax k
)
1421 (aref yy ind
) (aref ay k
)
1424 (setf (aref xx ind
) (aref ax k
)
1425 (aref yy ind
) (aref ay k
)
1426 (aref zz ind
) (aref az k
))
1427 (setf ind
(1+ ind
)) )
1428 (vtkpoints-code points-name2 source-name2 xx yy zz
))
1429 (vtkcellarray-code cellarray-name2 source-name2
1
1430 (loop for k from
0 below n collect
(list (* 2 k
) (+ (* 2 k
) 1))))
1431 (vtktransform-code trans-name
)
1434 ((< line-type
0) ; line type is a tube
1435 (concatenate 'string
1436 (vtktransformpolydatafilter-code "auxfiltertube" source-name2 trans-name t
)
1437 (vtktubefilter-code filter-name
"auxfiltertube" line-type
)
1438 (vtkpolydatamapper-code mapper-name filter-name t
)))
1440 (concatenate 'string
1441 (vtktransformpolydatafilter-code filter-name source-name2 trans-name t
)
1442 (vtkpolydatamapper-code mapper-name filter-name t
))))))
1444 (concatenate 'string
1445 (vtkcellarray-code cellarray-name source-name
1 (list (loop for k from
0 below n collect k
)))
1446 (vtktransform-code trans-name
)
1448 ((< line-type
0) ; line type is a tube
1449 (concatenate 'string
1450 (vtktransformpolydatafilter-code "auxfiltertube" source-name trans-name t
)
1451 (vtktubefilter-code filter-name
"auxfiltertube" line-type
)
1452 (vtkpolydatamapper-code mapper-name filter-name t
)))
1454 (concatenate 'string
1455 (vtktransformpolydatafilter-code filter-name source-name trans-name t
)
1456 (vtkpolydatamapper-code mapper-name filter-name t
))) ) ) ))
1458 (if (> *draw-enhanced3d-type
* 0)
1459 (format nil
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
1462 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
1463 (format nil
"~a~%" (vtkactor-code actor-name nil color opacity linewidth wiredsurface
))
1464 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
1466 (if (>= line-type
0) ; when line type is not a tube, set line pattern
1467 (format nil
"~a.GetProperty().SetLineStipplePattern(~a)~%~%"
1476 ; draw glyphs according to point-type
1478 ((and (>= point-type
0)
1480 (setf glyphpoints-name
(get-glyphpoints-name)
1481 polydata-name
(get-polydata-name)
1482 cellarray-name
(get-cellarray-name)
1483 filter-name
(get-filter-name)
1484 mapper-name
(get-mapper-name)
1485 actor-name
(get-actor-name)
1486 color
(get-option '$color
)
1487 opacity
(get-option '$opacity
)
1488 linewidth
(get-option '$line_width
) )
1491 (concatenate 'string
1494 (0 (vtkpoints-code glyphpoints-name nil
1495 (make-array 1 :element-type
'flonum
:initial-element
0.0)
1496 (make-array 1 :element-type
'flonum
:initial-element
0.0)
1497 (make-array 1 :element-type
'flonum
:initial-element
0.0)))
1498 (1 (vtkpoints-code glyphpoints-name nil
1499 (make-array 4 :element-type
'flonum
1500 :initial-contents
(list (- point-size
) point-size
0.0 0.0))
1501 (make-array 4 :element-type
'flonum
1502 :initial-contents
(list 0.0 0.0 0.0 0.0))
1503 (make-array 4 :element-type
'flonum
1504 :initial-contents
(list 0.0 0.0 (- point-size
) point-size
))))
1505 (2 (vtkpoints-code glyphpoints-name nil
1506 (make-array 4 :element-type
'flonum
1507 :initial-contents
(list point-size
(- point-size
) (- point-size
) point-size
))
1508 (make-array 4 :element-type
'flonum
1509 :initial-contents
(list 0.0 0.0 0.0 0.0))
1510 (make-array 4 :element-type
'flonum
1511 :initial-contents
(list point-size
(- point-size
) point-size
(- point-size
)))))
1512 (3 (vtkpoints-code glyphpoints-name nil
1513 (make-array 8 :element-type
'flonum
1514 :initial-contents
(list point-size
(- point-size
) (- point-size
) point-size
1515 (- point-size
) point-size
0.0 0.0))
1516 (make-array 8 :element-type
'flonum
1517 :initial-contents
(list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
1518 (make-array 8 :element-type
'flonum
1519 :initial-contents
(list point-size
(- point-size
) point-size
(- point-size
)
1520 0.0 0.0 (- point-size
) point-size
))))
1521 (4 (vtkpoints-code glyphpoints-name nil
1522 (make-array 4 :element-type
'flonum
1523 :initial-contents
(list point-size
(- point-size
) (- point-size
) point-size
))
1524 (make-array 4 :element-type
'flonum
1525 :initial-contents
(list 0.0 0.0 0.0 0.0))
1526 (make-array 4 :element-type
'flonum
1527 :initial-contents
(list point-size point-size
(- point-size
) (- point-size
)))))
1528 (5 (vtkpoints-code glyphpoints-name nil
1529 (make-array 4 :element-type
'flonum
1530 :initial-contents
(list (- point-size
) point-size point-size
(- point-size
)))
1531 (make-array 4 :element-type
'flonum
1532 :initial-contents
(list 0.0 0.0 0.0 0.0))
1533 (make-array 4 :element-type
'flonum
1534 :initial-contents
(list point-size point-size
(- point-size
) (- point-size
))))))
1535 (format nil
"~a=vtk.vtkPolyData()~%" polydata-name
)
1536 (format nil
"~a.SetPoints(~a)~%" polydata-name glyphpoints-name
)
1538 (0 (vtkcellarray-code cellarray-name polydata-name
0 '((0))))
1539 ((1 2) (vtkcellarray-code cellarray-name polydata-name
1 '((0 1) (2 3))))
1540 (3 (vtkcellarray-code cellarray-name polydata-name
1 '((0 1) (2 3) (4 5) (6 7))))
1541 (4 (vtkcellarray-code cellarray-name polydata-name
1 '((0 1) (1 2) (2 3) (3 0))))
1542 (5 (vtkcellarray-code cellarray-name polydata-name
2 '((0 1 2 3))))
1544 (vtkglyph3d-code filter-name source-name
(format nil
"SetSourceData(~a)" polydata-name
))
1545 (format nil
"~a~%" (vtkpolydatamapper-code mapper-name filter-name t
))
1546 (if (> *draw-enhanced3d-type
* 0)
1547 (format nil
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
1549 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
1550 (format nil
"~a~%" (vtkactor-code actor-name nil color opacity linewidth nil
))
1551 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) t t
)) )))
1553 ((and (>= point-type
14)
1555 (setf solidsource-name
(get-solidsource-name)
1556 filter-name
(get-filter-name)
1557 mapper-name
(get-mapper-name)
1558 actor-name
(get-actor-name)
1559 color
(get-option '$color
)
1560 opacity
(get-option '$opacity
) )
1562 (concatenate 'string
1566 (format nil
"~a=vtk.vtkSphereSource()~%~a.SetRadius(~a)~%"
1569 (/ point-size
2.0)))
1571 (format nil
"~a=vtk.vtkCubeSource()~%~a.SetXLength(~a)~%~a.SetYLength(~a)~%~a.SetZLength(~a)~%"
1579 (16 ; cylinder glyph
1580 (format nil
"~a=vtk.vtkCylinderSource()~%~a.SetRadius(~a)~%~a.SetHeight(~a)~%"
1587 (format nil
"~a=vtk.vtkConeSource()~%~a.SetRadius(~a)~%~a.SetHeight(~a)~%"
1593 (vtkglyph3d-code filter-name
1595 (format nil
"SetSourceConnection(~a.GetOutputPort())" solidsource-name
))
1596 (format nil
"~a~%" (vtkpolydatamapper-code mapper-name filter-name t
))
1597 (if (> *draw-enhanced3d-type
* 0)
1598 (format nil
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
1600 (format nil
"bounds.append(~a.GetBounds())~%" mapper-name
)
1601 (format nil
"~a~%" (vtkactor-glyph-code actor-name color opacity
))
1602 (format nil
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) t t
)) )))
1604 (merror "vtk3d: not recognized point_type")))))
1608 ;; 2D: points([[x1,y1], [x2,y2], [x3,y3],...])
1609 ;; -------------------------------------------
1619 (defun vtk2d-points (arg1 &optional
(arg2 nil
))
1620 (let ((pointsjoined (get-option '$points_joined
))
1621 (pointtype (get-option '$point_type
))
1622 (pointsize ($float
(get-option '$point_size
)))
1623 (linetype (get-option '$line_type
))
1624 (color (hex-to-numeric-list (get-option '$color
)))
1625 (linewidth (get-option '$line_width
))
1626 (key (get-option '$key
))
1627 (arrayX-name (get-arrayX-name))
1628 (arrayY-name (get-arrayY-name))
1629 (table-name (get-table-name))
1630 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
1633 (when (not (string= (string-trim " " key
) ""))
1634 (incf *vtk-2dkey-counter
*) )
1635 ; check type of input
1639 (every #'$listp
(rest arg1
))) ; xy format
1640 (setf tmp
(mapcar #'rest
(rest arg1
)))
1641 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
1642 y
(map 'list
#'$float
(map 'list
#'second tmp
))) )
1643 ((and ($matrixp arg1
)
1644 (= (length (cadr arg1
)) 3)
1645 (null arg2
)) ; two-column matrix
1646 (setf tmp
(mapcar #'rest
(rest arg1
)))
1647 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
1648 y
(map 'list
#'$float
(map 'list
#'second tmp
))) )
1651 (notany #'$listp
(rest arg1
))) ; y format
1652 (setf x
(loop for xx from
1 to
(length (rest arg1
)) collect
($float xx
))
1653 y
(map 'list
#'$float
(rest arg1
))))
1654 ((and ($matrixp arg1
)
1655 (= (length (cadr arg1
)) 2)
1656 (null arg2
)) ; one-column matrix
1657 (setf x
(loop for xx from
1 to
(length (rest arg1
)) collect
($float xx
))
1658 y
(map 'list
#'$float
(map 'list
#'second
(rest arg1
)))))
1659 ((and ($matrixp arg1
)
1660 (= ($length arg1
) 1)
1661 (null arg2
)) ; one-row matrix
1662 (setf x
(loop for xx from
1 to
(length (cdadr arg1
)) collect
($float xx
))
1663 y
(map 'list
#'$float
(cdadr arg1
))))
1666 (= (length arg1
) (length arg2
))) ; xx yy format
1667 (setf x
(map 'list
#'$float
(rest arg1
))
1668 y
(map 'list
#'$float
(rest arg2
))))
1669 ((and ($matrixp arg1
)
1670 (= ($length arg1
) 2)
1671 (null arg2
)) ; two-row matrix
1672 (setf x
(map 'list
#'$float
(cdadr arg1
))
1673 y
(map 'list
#'$float
(cdaddr arg1
))))
1674 (t (merror "draw (points2d): incorrect input format")))
1677 (setf ax
(make-array n
:element-type
'flonum
:initial-contents x
)
1678 ay
(make-array n
:element-type
'flonum
:initial-contents y
))
1681 (format str
"~a=vtk.vtkFloatArray()~%" arrayX-name
)
1682 (format str
"~a.SetName(\"~a\")~%" arrayX-name arrayX-name
)
1683 (format str
"~a=vtk.vtkFloatArray()~%" arrayY-name
)
1684 (format str
"~a.SetName(\"~a\")~%" arrayY-name key
)
1685 (loop for i from
0 below n do
1686 (format str
"~a.InsertNextValue(~a)~%" arrayX-name
(aref ax i
))
1687 (format str
"~a.InsertNextValue(~a)~%" arrayY-name
(aref ay i
)) )
1688 (format str
"~a=vtk.vtkTable()~%" table-name
)
1689 (format str
"~a.AddColumn(~a)~%" table-name arrayX-name
)
1690 (format str
"~a.AddColumn(~a)~%~%" table-name arrayY-name
)
1692 ((equal pointsjoined t
)
1693 (format str
"line = chart~a.AddPlot(~a)~%" *vtk-chart-counter
* 0)
1694 (format str
"line.SetInputData(~a,0,1)~%" table-name
)
1695 (format str
"line.SetColor(~a,~a,~a,255)~%"
1696 (round (* 255 (first color
)))
1697 (round (* 255 (second color
)))
1698 (round (* 255 (third color
))) )
1699 (format str
"line.SetWidth(~a)~%" linewidth
)
1700 (format str
"#line.SetLegendVisibility(0)~%")
1701 (format str
"line.SetMarkerStyle(0)~%")
1702 (format str
"line.GetPen().SetLineType(~a)~%"
1703 (case linetype
; translate some gnuplot codes into vtk codes
1706 (otherwise linetype
) ) ))
1707 ((equal pointsjoined
'$impulses
)
1708 (let (tbl impx impy
)
1709 (loop for i from
0 below n do
1710 (setf tbl
(get-table-name)
1711 impx
(get-arrayX-name)
1712 impy
(get-arrayY-name))
1713 (format str
"~a=vtk.vtkTable()~%" tbl
)
1714 (format str
"~a=vtk.vtkFloatArray()~%" impx
)
1715 (format str
"~a.SetNumberOfTuples(2)~%" impx
)
1716 (format str
"~a.SetName(\"~a\")~%" impx impx
)
1717 (format str
"~a=vtk.vtkFloatArray()~%" impy
)
1718 (format str
"~a.SetNumberOfTuples(2)~%" impy
)
1719 (format str
"~a.SetName(\"~a\")~%" impy impy
)
1720 (format str
"~a.InsertValue(0,~a.GetColumn(0).GetValue(~a))~%" impx table-name i
)
1721 (format str
"~a.InsertValue(1,~a.GetColumn(0).GetValue(~a))~%" impx table-name i
)
1722 (format str
"~a.InsertValue(0,~a.GetColumn(1).GetValue(~a))~%" impy table-name i
)
1723 (format str
"~a.InsertValue(1,0.0)~%" impy
)
1724 (format str
"~a.AddColumn(~a)~%" tbl impx
)
1725 (format str
"~a.AddColumn(~a)~%" tbl impy
)
1726 (format str
"line = chart~a.AddPlot(0)~%" *vtk-chart-counter
*)
1727 (format str
"line.SetInputData(~a,0,1)~%" tbl
)
1728 (format str
"line.SetColor(~a,~a,~a,255)~%"
1729 (round (* 255 (first color
)))
1730 (round (* 255 (second color
)))
1731 (round (* 255 (third color
))) )
1732 (format str
"line.SetWidth(~a)~%" linewidth
)
1733 (format str
"#line.SetLegendVisibility(0)~%~%") )) ) )
1734 (format str
"line = chart~a.AddPlot(~a)~%" *vtk-chart-counter
* 1)
1735 (format str
"line.SetInputData(~a,0,1)~%" table-name
)
1736 (format str
"line.SetColor(~a,~a,~a,255)~%"
1737 (round (* 255 (first color
)))
1738 (round (* 255 (second color
)))
1739 (round (* 255 (third color
))) )
1740 (format str
"line.SetWidth(~a)~%" pointsize
)
1741 (format str
"#line.SetLegendVisibility(~a)~%"
1742 (if (string= (string-trim " " key
) "")
1745 (format str
"line.SetMarkerStyle(~a)~%~%"
1758 ;; 3D: parametric(xfun,yfun,zfun,par1,parmin,parmax)
1759 ;; -------------------------------------------------
1760 (defun vtk3d-parametric (xfun yfun zfun par1 parmin parmax
)
1761 (let* ((nticks (get-option '$nticks
))
1762 (color (get-option '$color
))
1763 (line-type (get-option '$line_type
))
1764 (opacity (get-option '$opacity
))
1765 (linewidth (get-option '$line_width
))
1766 (wiredsurface (get-option '$wired_surface
))
1767 (source-name (get-source-name))
1768 (points-name (get-points-name))
1769 (cellarray-name (get-cellarray-name))
1770 (floatarray-name (get-floatarray-name))
1771 (trans-name (get-trans-name))
1772 (filter-name (get-filter-name))
1773 (mapper-name (get-mapper-name))
1774 (actor-name (get-actor-name))
1776 (tmin ($float parmin
))
1777 (tmax ($float parmax
))
1779 (eps (/ (- tmax tmin
) (- nticks
1)))
1780 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
1782 lookup-table-name scalars f1 f2 f3 x y z xx yy zz
)
1783 (check-enhanced3d-model "parametric" '(0 1 3 99))
1784 (when (= *draw-enhanced3d-type
* 99)
1785 (update-enhanced3d-expression (list '(mlist) par1
)))
1787 (merror "vtk3d (parametric): illegal range"))
1788 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
)))
1789 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
)))
1790 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
)))
1791 (setf x
(make-array nticks
:element-type
'flonum
)
1792 y
(make-array nticks
:element-type
'flonum
)
1793 z
(make-array nticks
:element-type
'flonum
))
1794 (when (> *draw-enhanced3d-type
* 0)
1795 (setf scalars
(make-array nticks
:element-type
'flonum
)))
1797 (setf xx
(funcall f1 tt
))
1798 (setf yy
(funcall f2 tt
))
1799 (setf zz
(funcall f3 tt
))
1800 (case *draw-enhanced3d-type
*
1801 ((1 99) (setf (aref scalars k
) (funcall *draw-enhanced3d-fun
* tt
)))
1802 (3 (setf (aref scalars k
) (funcall *draw-enhanced3d-fun
* xx yy zz
))))
1804 (setf (aref x
(incf count
)) xx
)
1805 (setf (aref y count
) yy
)
1806 (setf (aref z count
) zz
)
1807 (setf tt
(+ tt eps
)) )
1808 (when (> *draw-enhanced3d-type
* 0)
1809 (let ((lut (check-lookup-table)))
1810 (setf lookup-table-name
(car lut
))
1811 (format str
"~a~%" (cadr lut
))))
1814 (format str
"~a=vtk.vtkPolyData()~%" source-name
)
1815 (format str
"~a~%" (vtkpoints-code points-name source-name x y z
))
1816 (format str
"~a~%" (vtkcellarray-code cellarray-name source-name
1
1817 (list (loop for k from
0 below nticks collect k
))))
1818 (format str
"~a~%" (vtktransform-code trans-name
))
1819 (if (< line-type
0) ; line type is a tube
1820 (format str
"~a~%" (vtktransformpolydatafilter-code "auxfiltertube" source-name trans-name t
))
1821 (format str
"~a~%" (vtktransformpolydatafilter-code filter-name source-name trans-name t
) ) )
1823 ((< line-type
0) ; line type is a tube
1824 (format str
"~a~%" (vtktubefilter-code filter-name
"auxfiltertube" line-type
))
1825 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name t
)))
1827 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name t
))))
1828 (format str
"bounds.append(~a.GetBounds())~%" mapper-name
)
1829 (format str
"~a~%" (vtkactor-code actor-name nil color opacity linewidth wiredsurface
))
1830 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
1831 (when (> *draw-enhanced3d-type
* 0)
1832 (format str
"~a~%" (vtkfloatarray-code floatarray-name source-name scalars nil
))
1833 (format str
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
1834 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
1835 (format nil
"rescalearray(~a,~a)~%" points-name floatarray-name
)) )
1836 (when (>= line-type
0) ; when line type is not a tube, set line pattern
1837 (format str
"~a.GetProperty().SetLineStipplePattern(~a)~%~%"
1849 ;; 2D: parametric(xfun,yfun,par,parmin,parmax)
1850 ;; -----------------------------------
1857 (defun vtk2d-parametric (xfun yfun par parmin parmax
)
1858 (let* ((nticks (get-option '$nticks
))
1859 (linewidth (get-option '$line_width
))
1860 (linetype (get-option '$line_type
))
1861 (color (hex-to-numeric-list (get-option '$color
)))
1862 (key (get-option '$key
))
1863 (arrayX-name (get-arrayX-name))
1864 (arrayY-name (get-arrayY-name))
1865 (table-name (get-table-name))
1866 (tmin ($float parmin
))
1867 (tmax ($float parmax
))
1868 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
1870 (eps (/ (- tmax tmin
) (- ($float nticks
) 1)))
1871 (tt ($float parmin
))
1872 (*plot-realpart
* *plot-realpart
*)
1873 result f1 f2 xx yy result-array
)
1876 (merror "draw2d (parametric): illegal range"))
1877 (when (not (string= (string-trim " " key
) ""))
1878 (incf *vtk-2dkey-counter
*) )
1879 (when (not (subsetp (append (rest ($listofvars xfun
)) (rest ($listofvars yfun
))) (list par
) :test
#'like
))
1880 (merror "draw2d (parametric): non defined variable"))
1881 (setq *plot-realpart
* (get-option '$draw_realpart
))
1882 (setq f1
(coerce-float-fun xfun
`((mlist) ,par
)))
1883 (setq f2
(coerce-float-fun yfun
`((mlist) ,par
)))
1886 do
(setf xx
($float
(funcall f1 tt
)))
1887 (setf yy
($float
(funcall f2 tt
)))
1891 when
(>= tt tmax
) do
(loop-finish)
1892 do
(setq tt
(+ tt eps
))
1893 (if (>= tt tmax
) (setq tt tmax
)) ))
1894 (setf result-array
(make-array (length result
) :initial-contents result
))
1897 (format str
"~a=vtk.vtkFloatArray()~%" arrayX-name
)
1898 (format str
"~a.SetName(\"~a\")~%" arrayX-name arrayX-name
)
1899 (format str
"~a=vtk.vtkFloatArray()~%" arrayY-name
)
1900 (format str
"~a.SetName(\"~a\")~%" arrayY-name key
)
1901 (loop for i from
0 below
(length result
) by
2 do
1902 (format str
"~a.InsertNextValue(~a)~%" arrayX-name
(aref result-array i
))
1903 (format str
"~a.InsertNextValue(~a)~%" arrayY-name
(aref result-array
(+ i
1))) )
1904 (format str
"~a=vtk.vtkTable()~%" table-name
)
1905 (format str
"~a.AddColumn(~a)~%" table-name arrayX-name
)
1906 (format str
"~a.AddColumn(~a)~%" table-name arrayY-name
)
1907 (format str
"line=chart~a.AddPlot(0)~%" *vtk-chart-counter
*)
1908 (format str
"line.SetInputData(~a,0,1)~%" table-name
)
1909 (format str
"line.SetColor(~a,~a,~a,255)~%"
1910 (round (* 255 (first color
)))
1911 (round (* 255 (second color
)))
1912 (round (* 255 (third color
))) )
1913 (format str
"line.SetWidth(~a)~%" linewidth
)
1914 (format str
"#line.SetLegendVisibility(~a)~%"
1915 (if (string= (string-trim " " key
) "")
1918 (format str
"line.GetPen().SetLineType(~a)~%~%"
1919 (case linetype
; translate some gnuplot codes into vtk codes
1922 (otherwise linetype
) ) )
1927 ;; 2D: polar(radius,ang,minang,maxang)
1928 ;; -----------------------------------
1935 (defun vtk2d-polar (radius ang minang maxang
)
1936 (vtk2d-parametric `((mtimes simp
) ,radius
((%cos simp
) ,ang
))
1937 `((mtimes simp
) ,radius
((%sin simp
) ,ang
))
1938 ang minang maxang
) )
1942 ;; 3D: parametric_surface(xfun,yfun,zfun,par1,par1min,par1max,par2,par2min,par2max)
1943 ;; --------------------------------------------------------------------------------
1944 (defun vtk3d-parametric_surface (xfun yfun zfun par1 par1min par1max par2 par2min par2max
)
1945 (let* ((xu_grid (get-option '$xu_grid
))
1946 (yv_grid (get-option '$yv_grid
))
1947 (color (get-option '$color
))
1948 (opacity (get-option '$opacity
))
1949 (linewidth (get-option '$line_width
))
1950 (wiredsurface (get-option '$wired_surface
))
1951 (umin ($float par1min
))
1952 (umax ($float par1max
))
1953 (vmin ($float par2min
))
1954 (vmax ($float par2max
))
1955 (epsu (/ (- umax umin
) xu_grid
))
1956 (epsv (/ (- vmax vmin
) yv_grid
))
1957 (source-name (get-source-name))
1958 (points-name (get-points-name))
1959 (cellarray-name (get-cellarray-name))
1960 (mapper-name (get-mapper-name))
1961 (actor-name (get-actor-name))
1962 (trans-name (get-trans-name))
1963 (filter-name (get-filter-name))
1964 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
1971 (scalars nil
) ; used for coloring
1972 (scalars2 nil
) ; used for isolines
1976 floatarray-name mapper2-name filter2-name floatarray2-name lookup-table-name
1978 (check-enhanced3d-model "parametric_surface" '(0 2 3 99))
1979 (check-isolines-model "parametric_surface" '(0 2 3 99))
1980 (when (= *draw-enhanced3d-type
* 99)
1981 (update-enhanced3d-expression (list '(mlist) par1 par2
)))
1982 (when (= *draw-isolines-type
* 99)
1983 (update-isolines-expression (list '(mlist) par1 par2
)))
1984 (when (or (< umax umin
)
1986 (merror "vtk3d (parametric_surface): illegal range"))
1987 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
,par2
)))
1988 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
,par2
)))
1989 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
,par2
)))
1990 (setf x
(make-array (* nx ny
) :element-type
'flonum
)
1991 y
(make-array (* nx ny
) :element-type
'flonum
)
1992 z
(make-array (* nx ny
) :element-type
'flonum
))
1993 (when (> *draw-enhanced3d-type
* 0)
1994 (setf scalars
(make-array (* nx ny
) :element-type
'flonum
)))
1995 (when (> *draw-isolines-type
* 0)
1996 (setf scalars2
(make-array (* nx ny
) :element-type
'flonum
)))
1997 (loop for j below ny
1998 initially
(setf vv vmin
)
2000 (loop for i below nx
2002 (setf xx
(funcall f1 uu vv
))
2003 (setf yy
(funcall f2 uu vv
))
2004 (setf zz
(funcall f3 uu vv
))
2005 ; geometric transformation
2007 (setf (aref x
(incf count
)) xx
)
2008 (setf (aref y count
) yy
)
2009 (setf (aref z count
) zz
)
2010 ; check texture model
2011 (case *draw-enhanced3d-type
*
2012 ((2 99) (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* uu vv
)))
2013 (3 (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
2014 ; check isolines model
2015 (case *draw-isolines-type
*
2016 ((2 99) (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* uu vv
)))
2017 (3 (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* xx yy zz
))) )
2018 (setq uu
(+ uu epsu
)))
2019 (setq vv
(+ vv epsv
)))
2020 (when (> *draw-enhanced3d-type
* 0)
2021 (let ((lut (check-lookup-table)))
2022 (setf lookup-table-name
(car lut
))
2023 (format str
"~a~%" (cadr lut
))))
2026 (format str
"~a=vtk.vtkPolyData()~%" source-name
)
2027 (format str
"~a~%" (vtkpoints-code points-name source-name x y z
))
2028 (format str
"~a~%" (vtkcellarray-code cellarray-name source-name
2 (build-surface-grid nx ny
)))
2029 (format str
"~a~%" (vtktransform-code trans-name
))
2030 (format str
"~a~%" (vtktransformpolydatafilter-code filter-name source-name trans-name t
))
2031 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name nil
))
2033 (format str
"bounds.append(~a.GetBounds())~%" points-name
)
2034 (format str
"~a~%" (vtkactor-code actor-name nil color opacity linewidth wiredsurface
))
2035 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil t
))
2037 (when (> *draw-enhanced3d-type
* 0)
2038 (format str
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
2039 (format str
"~a.SetScalarModeToUsePointFieldData()~%" mapper-name
)
2040 (format str
"~a.ScalarVisibilityOn()~%~%" mapper-name
)
2041 (setf floatarray-name
(get-floatarray-name))
2042 (format str
"~a~%" (vtkfloatarray-code floatarray-name source-name scalars
))
2043 ; remove next string if we want isolines and solid color when enhanced3d is not active
2044 (format str
"~a.SelectColorArray(\"name~a\")~%" mapper-name floatarray-name
)
2045 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2046 (format nil
"rescalearray(~a,~a)~%" points-name floatarray-name
)) )
2048 (when (> *draw-isolines-type
* 0)
2049 (setf floatarray2-name
(get-floatarray-name))
2050 (format str
"~a~%" (vtkfloatarray-code floatarray2-name source-name scalars2
))
2051 (setf filter2-name
(get-filter-name))
2052 (format str
"~a~%" (vtkContourFilter-code filter2-name filter-name
))
2053 (setf mapper2-name
(get-mapper-name))
2054 (format str
"~a" (vtkpolydatamapper-isoline-code mapper2-name source-name floatarray2-name
))
2055 (format str
"~a~%" (vtkactor-isoline-code (get-actor-name) linewidth
))
2056 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
2057 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2058 (format nil
"rescalearray(~a,~a)~%" points-name floatarray2-name
)) )
2064 ;; spherical(radius,az,minazi,maxazi,zen,minzen,maxzen)
2065 ;; ----------------------------------------------------
2066 (defun vtk3d-spherical (radius azi minazi maxazi zen minzen maxzen
)
2067 (vtk3d-parametric_surface
2068 `((mtimes simp
) ,radius
((%sin simp
) ,zen
) ((%cos simp
) ,azi
))
2069 `((mtimes simp
) ,radius
((%sin simp
) ,zen
) ((%sin simp
) ,azi
))
2070 `((mtimes simp
) ,radius
((%cos simp
) ,zen
))
2076 ;; cylindrical(r,z,minz,maxz,azi,minazi,maxazi)
2077 ;; --------------------------------------------
2078 (defun vtk3d-cylindrical (r z minz maxz azi minazi maxazi
)
2079 (vtk3d-parametric_surface
2080 `((mtimes simp
) ,r
((%cos simp
) ,azi
))
2081 `((mtimes simp
) ,r
((%sin simp
) ,azi
))
2088 ;; 3D: explicit(fcn,par1,minval1,maxval1,par2,minval2,maxval2)
2089 ;; -----------------------------------------------------------
2090 (defun vtk3d-explicit (fcn par1 minval1 maxval1 par2 minval2 maxval2
)
2091 (let* ((xu_grid (get-option '$xu_grid
))
2092 (yv_grid (get-option '$yv_grid
))
2093 (color (get-option '$color
))
2094 (opacity (get-option '$opacity
))
2095 (linewidth (get-option '$line_width
))
2096 (wiredsurface (get-option '$wired_surface
))
2097 (fminval1 ($float minval1
))
2098 (fminval2 ($float minval2
))
2099 (fmaxval1 ($float maxval1
))
2100 (fmaxval2 ($float maxval2
))
2101 (epsx (/ (- fmaxval1 fminval1
) xu_grid
))
2102 (epsy (/ (- fmaxval2 fminval2
) yv_grid
))
2103 (source-name (get-source-name))
2104 (points-name (get-points-name))
2105 (cellarray-name (get-cellarray-name))
2106 (mapper-name (get-mapper-name))
2107 (actor-name (get-actor-name))
2108 (trans-name (get-trans-name))
2109 (filter-name (get-filter-name))
2110 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
2113 (scalars nil
) ; used for coloring
2114 (scalars2 nil
) ; used for isolines
2122 floatarray-name floatarray2-name mapper2-name filter2-name lookup-table-name
2124 (check-enhanced3d-model "explicit" '(0 2 3 99))
2125 (check-isolines-model "explicit" '(0 2 3 99))
2126 (when (= *draw-enhanced3d-type
* 99)
2127 (update-enhanced3d-expression (list '(mlist) par1 par2
)))
2128 (when (= *draw-isolines-type
* 99)
2129 (update-isolines-expression (list '(mlist) par1 par2
)))
2130 (setq fcn
(coerce-float-fun fcn
`((mlist) ,par1
,par2
)))
2131 (setf x
(make-array (* nx ny
) :element-type
'flonum
)
2132 y
(make-array (* nx ny
) :element-type
'flonum
)
2133 z
(make-array (* nx ny
) :element-type
'flonum
))
2134 (when (> *draw-enhanced3d-type
* 0)
2135 (setf scalars
(make-array (* nx ny
) :element-type
'flonum
)))
2136 (when (> *draw-isolines-type
* 0)
2137 (setf scalars2
(make-array (* nx ny
) :element-type
'flonum
)))
2138 (loop for j below ny
2139 initially
(setf vv fminval2
)
2140 do
(setf uu fminval1
)
2141 (loop for i below nx
2145 (setf zz
(funcall fcn xx yy
))
2146 ; geometric transformation
2148 (setf (aref x
(incf count
)) xx
)
2149 (setf (aref y count
) yy
)
2150 (setf (aref z count
) zz
)
2151 ; check texture model
2152 (case *draw-enhanced3d-type
*
2153 ((2 99) (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* xx yy
)))
2154 (3 (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
2155 ; check isolines model
2156 (case *draw-isolines-type
*
2157 ((2 99) (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* xx yy
)))
2158 (3 (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* xx yy zz
))) )
2159 (setq uu
(+ uu epsx
)))
2160 (setq vv
(+ vv epsy
)))
2161 (when (> *draw-enhanced3d-type
* 0)
2162 (let ((lut (check-lookup-table)))
2163 (setf lookup-table-name
(car lut
))
2164 (format str
"~a~%" (cadr lut
))))
2167 (format str
"~a=vtk.vtkPolyData()~%" source-name
)
2168 (format str
"~a~%" (vtkpoints-code points-name source-name x y z
))
2169 (format str
"~a~%" (vtkcellarray-code cellarray-name source-name
2 (build-surface-grid nx ny
)))
2170 (format str
"~a~%" (vtktransform-code trans-name
))
2171 (format str
"~a~%" (vtktransformpolydatafilter-code filter-name source-name trans-name t
))
2172 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name nil
))
2174 (format str
"bounds.append(~a.GetBounds())~%" points-name
)
2175 (format str
"~a~%" (vtkactor-code actor-name nil color opacity linewidth wiredsurface
))
2176 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil t
))
2178 (when (> *draw-enhanced3d-type
* 0)
2179 (format str
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
2180 (format str
"~a.SetScalarModeToUsePointFieldData()~%" mapper-name
)
2181 (format str
"~a.ScalarVisibilityOn()~%~%" mapper-name
)
2182 (setf floatarray-name
(get-floatarray-name))
2183 (format str
"~a~%" (vtkfloatarray-code floatarray-name source-name scalars
))
2184 ; remove next string if we want isolines and solid color when enhanced3d is not active
2185 (format str
"~a.SelectColorArray(\"name~a\")~%" mapper-name floatarray-name
)
2186 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2187 (format nil
"rescalearray(~a,~a)~%" points-name floatarray-name
)) )
2189 (when (> *draw-isolines-type
* 0)
2190 (setf floatarray2-name
(get-floatarray-name))
2191 (format str
"~a~%" (vtkfloatarray-code floatarray2-name source-name scalars2
))
2192 (setf filter2-name
(get-filter-name))
2193 (format str
"~a~%" (vtkContourFilter-code filter2-name filter-name
))
2194 (setf mapper2-name
(get-mapper-name))
2195 (format str
"~a" (vtkpolydatamapper-isoline-code mapper2-name source-name floatarray2-name
))
2196 (format str
"~a~%" (vtkactor-isoline-code (get-actor-name) linewidth
))
2197 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
2198 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2199 (format nil
"rescalearray(~a,~a)~%" points-name floatarray2-name
)) )
2205 ;; 2D: explicit(fcn,var,minval,maxval)
2206 ;; -----------------------------------
2214 (defun vtk2d-explicit (fcn var minval maxval
)
2215 (let* ((nticks (get-option '$nticks
))
2216 (adaptdepth (get-option '$adapt_depth
))
2217 (linewidth (get-option '$line_width
))
2218 (linetype (get-option '$line_type
))
2219 (color (hex-to-numeric-list (get-option '$color
)))
2220 (fillcolor (hex-to-numeric-list (get-option '$fill_color
)))
2221 (key (get-option '$key
))
2222 (xmin ($float minval
))
2223 (xmax ($float maxval
))
2224 (x-step (/ (- xmax xmin
) ($float nticks
) 2))
2225 (arrayX-name (get-arrayX-name))
2226 (arrayY-name (get-arrayY-name))
2227 (table-name (get-table-name))
2228 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
2229 (*plot-realpart
* *plot-realpart
*)
2231 x-samples y-samples result result-array
)
2233 (merror "draw2d (explicit): illegal range"))
2234 (when (not (string= (string-trim " " key
) ""))
2235 (incf *vtk-2dkey-counter
*) )
2236 (when (get-option '$logx
)
2237 (setf xmin
(log xmin
))
2238 (setf xmax
(log xmax
))
2239 (setf x-step
(/ (- xmax xmin
) ($float nticks
) 2)))
2240 (setq *plot-realpart
* (get-option '$draw_realpart
))
2241 (setq fcn
(coerce-float-fun fcn
`((mlist) ,var
)))
2243 (let ((y (if (get-option '$logx
)
2244 (funcall fcn
(exp x
))
2246 (if (and (get-option '$logy
)
2250 (merror "draw2d (explicit): logarithm of negative number"))
2252 (dotimes (k (1+ (* 2 nticks
)))
2253 (let ((x (+ xmin
(* k x-step
))))
2255 (push (fun x
) y-samples
)))
2256 (setf x-samples
(nreverse x-samples
))
2257 (setf y-samples
(nreverse y-samples
))
2258 ;; For each region, adaptively plot it.
2259 (do ((x-start x-samples
(cddr x-start
))
2260 (x-mid (cdr x-samples
) (cddr x-mid
))
2261 (x-end (cddr x-samples
) (cddr x-end
))
2262 (y-start y-samples
(cddr y-start
))
2263 (y-mid (cdr y-samples
) (cddr y-mid
))
2264 (y-end (cddr y-samples
) (cddr y-end
)))
2266 ;; The region is x-start to x-end, with mid-point x-mid.
2267 (let ((sublst (adaptive-plot #'fun
(car x-start
) (car x-mid
) (car x-end
)
2268 (car y-start
) (car y-mid
) (car y-end
)
2270 (when (notevery #'(lambda (x) (or (numberp x
) (eq x t
) )) sublst
)
2271 (let ((items sublst
) (item 'nil
))
2272 ;; Search for the item in sublist that is the undefined variable
2274 (when (not (or (numberp (car items
)) (eq (car items
) t
) ))
2275 (setq item
(car items
)) )
2276 (setq items
(cdr items
)) )
2277 (merror "draw2d (explicit): non defined variable in term ~M" item
) ) )
2278 (when (not (null result
))
2279 (setf sublst
(cddr sublst
)))
2280 (do ((lst sublst
(cddr lst
)))
2282 (setf result
(append result
2284 (if (and (get-option '$logx
)
2285 (numberp (first lst
)))
2288 (if (and (get-option '$logy
)
2289 (numberp (second lst
)))
2291 (second lst
)))))))))
2293 ((> *draw-transform-dimensions
* 0)
2294 ; With geometric transformation.
2295 ; When option filled_func in not nil,
2296 ; geometric transformation is ignored
2297 (setf result-array
(make-array (length result
)))
2298 (setf xmin most-positive-double-float
2299 xmax most-negative-double-float
)
2300 (let (xold yold x y
(count -
1))
2301 (do ((lis result
(cddr lis
)))
2303 (setf xold
(first lis
)
2305 (setf x
(funcall *draw-transform-f1
* xold yold
)
2306 y
(funcall *draw-transform-f2
* xold yold
))
2307 (setf (aref result-array
(incf count
)) x
)
2308 (setf (aref result-array
(incf count
)) y
) ) ) )
2310 ; No geometric transformation invoked.
2311 (setf result-array
(make-array (length result
)
2312 :initial-contents result
))))
2314 (format str
"~a=vtk.vtkFloatArray()~%" arrayX-name
)
2315 (format str
"~a.SetName(\"~a\")~%" arrayX-name arrayX-name
)
2316 (format str
"~a=vtk.vtkFloatArray()~%" arrayY-name
)
2317 (format str
"~a.SetName(\"~a\")~%" arrayY-name key
)
2318 (loop for i from
0 below
(length result
) by
2 do
2319 (when (not (equal (aref result-array
(+ i
1)) t
))
2320 ; in case of division by zero, do not insert next value.
2321 ; A vertical line will be plotted, which should be fixed.
2322 (format str
"~a.InsertNextValue(~a)~%" arrayX-name
(aref result-array i
))
2323 (format str
"~a.InsertNextValue(~a)~%" arrayY-name
(aref result-array
(+ i
1))) ) )
2324 (format str
"~a=vtk.vtkTable()~%" table-name
)
2325 (format str
"~a.AddColumn(~a)~%" table-name arrayX-name
)
2326 (format str
"~a.AddColumn(~a)~%" table-name arrayY-name
)
2327 (format str
"line=chart~a.AddPlot(~a)~%"
2329 (if (get-option '$filled_func
) 3 0))
2330 (format str
"line.SetInputData(~a,0,1)~%" table-name
)
2332 (if (get-option '$filled_func
)
2333 (setf col fillcolor
)
2335 (format str
"line.SetColor(~a,~a,~a,255)~%"
2336 (round (* 255 (first col
)))
2337 (round (* 255 (second col
)))
2338 (round (* 255 (third col
))) ))
2339 (format str
"line.SetWidth(~a)~%" linewidth
)
2340 ; not present in 6.2
2341 ; (format str "line.SetLegendVisibility(~a)~%"
2342 ; (if (string= (string-trim " " key) "")
2345 (format str
"line.GetPen().SetLineType(~a)~%~%"
2346 (case linetype
; translate some gnuplot codes into vtk codes
2349 (otherwise linetype
) ) )
2354 ;; 3d: elevation_grid(mat x0 y0 width height)
2355 ;; ------------------------------------------
2356 (defun vtk3d-elevation_grid (mat x0 y0 width height
)
2357 (let* ((fx0 ($float x0
))
2359 (fwidth ($float width
))
2360 (fheight ($float height
))
2361 (color (get-option '$color
))
2362 (opacity (get-option '$opacity
))
2363 (linewidth (get-option '$line_width
))
2364 (wiredsurface (get-option '$wired_surface
))
2365 (source-name (get-source-name))
2366 (points-name (get-points-name))
2367 (cellarray-name (get-cellarray-name))
2368 (mapper-name (get-mapper-name))
2369 (actor-name (get-actor-name))
2370 (trans-name (get-trans-name))
2371 (filter-name (get-filter-name))
2372 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
2374 (yi (+ fy0 fheight
))
2379 (scalars nil
) ; used for coloring
2380 (scalars2 nil
) ; used for isolines
2383 floatarray-name floatarray2-name mapper2-name filter2-name lookup-table-name
2385 (check-enhanced3d-model "elevation_grid" '(0 2 3))
2386 (check-isolines-model "elevation_grid" '(0 2 3))
2387 (when (null ($matrixp mat
))
2388 (merror "draw3d (elevation_grid): Argument not recognized"))
2389 (setf nx
(length (cdadr mat
))
2390 ny
(length (cdr mat
)))
2391 (setf dx
(/ fwidth
(1- nx
))
2392 dy
(/ fheight
(1- ny
)))
2393 (setf x
(make-array (* nx ny
) :element-type
'flonum
)
2394 y
(make-array (* nx ny
) :element-type
'flonum
)
2395 z
(make-array (* nx ny
) :element-type
'flonum
))
2396 (when (> *draw-enhanced3d-type
* 0)
2397 (setf scalars
(make-array (* nx ny
) :element-type
'flonum
)))
2398 (when (> *draw-isolines-type
* 0)
2399 (setf scalars2
(make-array (* nx ny
) :element-type
'flonum
)))
2400 (loop for row on
(cdr mat
) by
#'cdr do
2402 (loop for col on
(cdar row
) by
#'cdr do
2405 (setf zz
($float
(car col
)))
2406 ; geometric transformation
2408 (setf (aref x
(incf count
)) xx
)
2409 (setf (aref y count
) yy
)
2410 (setf (aref z count
) zz
)
2411 ; check texture model
2412 (case *draw-enhanced3d-type
*
2413 (2 (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* xx yy
)))
2414 (3 (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))))
2415 ; check isolines model
2416 (case *draw-isolines-type
*
2417 (2 (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* xx yy
)))
2418 (3 (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* xx yy zz
))) )
2419 (setf xi
(+ xi dx
)))
2420 (setf yi
(- yi dy
)))
2421 (when (> *draw-enhanced3d-type
* 0)
2422 (let ((lut (check-lookup-table)))
2423 (setf lookup-table-name
(car lut
))
2424 (format str
"~a~%" (cadr lut
))))
2427 (format str
"~a=vtk.vtkPolyData()~%" source-name
)
2428 (format str
"~a~%" (vtkpoints-code points-name source-name x y z
))
2429 (format str
"~a~%" (vtkcellarray-code cellarray-name source-name
2 (build-surface-grid nx ny
)))
2430 (format str
"~a~%" (vtktransform-code trans-name
))
2431 (format str
"~a~%" (vtktransformpolydatafilter-code filter-name source-name trans-name t
))
2432 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name nil
))
2434 (format str
"bounds.append(~a.GetBounds())~%" points-name
)
2435 (format str
"~a~%" (vtkactor-code actor-name nil color opacity linewidth wiredsurface
))
2436 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil t
))
2438 (when (> *draw-enhanced3d-type
* 0)
2439 (format str
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
2440 (format str
"~a.SetScalarModeToUsePointFieldData()~%" mapper-name
)
2441 (format str
"~a.ScalarVisibilityOn()~%~%" mapper-name
)
2442 (setf floatarray-name
(get-floatarray-name))
2443 (format str
"~a~%" (vtkfloatarray-code floatarray-name source-name scalars
))
2444 ; remove next string if we want isolines and solid color when enhanced3d is not active
2445 (format str
"~a.SelectColorArray(\"name~a\")~%" mapper-name floatarray-name
)
2446 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2447 (format nil
"rescalearray(~a,~a)~%" points-name floatarray-name
)) )
2449 (when (> *draw-isolines-type
* 0)
2450 (setf floatarray2-name
(get-floatarray-name))
2451 (format str
"~a~%" (vtkfloatarray-code floatarray2-name source-name scalars2
))
2452 (setf filter2-name
(get-filter-name))
2453 (format str
"~a~%" (vtkContourFilter-code filter2-name filter-name
))
2454 (setf mapper2-name
(get-mapper-name))
2455 (format str
"~a" (vtkpolydatamapper-isoline-code mapper2-name source-name floatarray2-name
))
2456 (format str
"~a~%" (vtkactor-isoline-code (get-actor-name) linewidth
))
2457 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
2458 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2459 (format nil
"rescalearray(~a,~a)~%" points-name floatarray2-name
)) )
2465 ;; 3d: implicit(expr,x,xmin,xmax,y,ymin,ymax,z,zmin,zmax)
2466 ;; ------------------------------------------------------
2467 (defun build-surface-triangular-grid (ntri)
2472 (setf poly
(cons (list (incf cont
) (incf cont
) (incf cont
)) poly
)))
2475 (defun vtk3d-implicit (expr par1 xmin xmax par2 ymin ymax par3 zmin zmax
)
2476 (let ((fxmin ($float xmin
))
2477 (fxmax ($float xmax
))
2478 (fymin ($float ymin
))
2479 (fymax ($float ymax
))
2480 (fzmin ($float zmin
))
2481 (fzmax ($float zmax
))
2482 (color (get-option '$color
))
2483 (opacity (get-option '$opacity
))
2484 (linewidth (get-option '$line_width
))
2485 (wiredsurface (get-option '$wired_surface
))
2486 (transform (get-option '$transform
))
2487 (source-name (get-source-name))
2488 (points-name (get-points-name))
2489 (cellarray-name (get-cellarray-name))
2490 (mapper-name (get-mapper-name))
2491 (actor-name (get-actor-name))
2492 (trans-name (get-trans-name))
2493 (filter-name (get-filter-name))
2494 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
2495 (scalars nil
) ; used for coloring
2496 (scalars2 nil
) ; used for isolines
2497 floatarray-name floatarray2-name mapper2-name filter2-name lookup-table-name
2498 vertices numvert xx yy zz x y z
)
2499 (check-enhanced3d-model "implicit" '(0 3 99))
2500 (check-isolines-model "implicit" '(0 3 99))
2501 (when (= *draw-enhanced3d-type
* 99)
2502 (update-enhanced3d-expression (list '(mlist) par1 par2 par3
)))
2503 (when (= *draw-isolines-type
* 99)
2504 (update-isolines-expression (list '(mlist) par1 par2 par3
)))
2505 (setf vertices
(find-triangles expr par1 fxmin fxmax par2 fymin fymax par3 fzmin fzmax
))
2506 (when (null vertices
)
2507 (merror "draw3d (implicit): no surface within these ranges"))
2508 (setf numvert
(length vertices
))
2509 (setf x
(make-array numvert
:element-type
'flonum
:initial-contents
(map 'list
#'first vertices
))
2510 y
(make-array numvert
:element-type
'flonum
:initial-contents
(map 'list
#'second vertices
))
2511 z
(make-array numvert
:element-type
'flonum
:initial-contents
(map 'list
#'third vertices
)))
2512 (when (> *draw-enhanced3d-type
* 0)
2513 (setf scalars
(make-array numvert
:element-type
'flonum
)))
2514 (when (> *draw-isolines-type
* 0)
2515 (setf scalars2
(make-array numvert
:element-type
'flonum
)))
2516 (do ((nf 0 (1+ nf
)))
2517 ((= nf numvert
) 'done
)
2518 (setf xx
(aref x nf
)
2521 ; geometric transformation
2522 (when (not (eq transform
'$none
))
2524 (setf (aref x nf
) xx
)
2525 (setf (aref y nf
) yy
)
2526 (setf (aref z nf
) zz
))
2527 ; check texture model
2528 (when (> *draw-enhanced3d-type
* 0)
2529 (setf (aref scalars nf
) (funcall *draw-enhanced3d-fun
* xx yy zz
)))
2530 ; check isolines model
2531 (when (> *draw-isolines-type
* 0)
2532 (setf (aref scalars2 nf
) (funcall *draw-isolines-fun
* xx yy zz
))) )
2533 (let ((lut (check-lookup-table)))
2534 (setf lookup-table-name
(car lut
))
2535 (format str
"~a~%" (cadr lut
)))
2538 (format str
"~a=vtk.vtkPolyData()~%" source-name
)
2539 (format str
"~a~%" (vtkpoints-code points-name source-name x y z
))
2540 (format str
"~a~%" (vtkcellarray-code cellarray-name source-name
2 (build-surface-triangular-grid numvert
)))
2541 (format str
"~a~%" (vtktransform-code trans-name
))
2542 (format str
"~a~%" (vtktransformpolydatafilter-code filter-name source-name trans-name t
))
2543 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name nil
))
2545 (format str
"bounds.append(~a.GetBounds())~%" points-name
)
2546 (format str
"~a~%" (vtkactor-code actor-name nil color opacity linewidth wiredsurface
))
2547 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil t
))
2549 (when (> *draw-enhanced3d-type
* 0)
2550 (format str
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
2551 (format str
"~a.SetScalarModeToUsePointFieldData()~%" mapper-name
)
2552 (format str
"~a.ScalarVisibilityOn()~%~%" mapper-name
)
2553 (setf floatarray-name
(get-floatarray-name))
2554 (format str
"~a~%" (vtkfloatarray-code floatarray-name source-name scalars
))
2555 ; remove next string if we want isolines and solid color when enhanced3d is not active
2556 (format str
"~a.SelectColorArray(\"name~a\")~%" mapper-name floatarray-name
)
2557 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2558 (format nil
"rescalearray(~a,~a)~%" points-name floatarray-name
)) )
2560 (when (> *draw-isolines-type
* 0)
2561 (setf floatarray2-name
(get-floatarray-name))
2562 (format str
"~a~%" (vtkfloatarray-code floatarray2-name source-name scalars2
))
2563 (setf filter2-name
(get-filter-name))
2564 (format str
"~a~%" (vtkContourFilter-code filter2-name filter-name
))
2565 (setf mapper2-name
(get-mapper-name))
2566 (format str
"~a" (vtkpolydatamapper-isoline-code mapper2-name source-name floatarray2-name
))
2567 (format str
"~a~%" (vtkactor-isoline-code (get-actor-name) linewidth
))
2568 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
2569 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2570 (format nil
"rescalearray(~a,~a)~%" points-name floatarray2-name
)) )
2576 ;; 3d: label([string1,x1,y1,z1],[string2,x2,y2,z2],...)
2577 ;; ----------------------------------------------------
2578 (defun vtk3d-label (&rest lab
)
2579 (let ((font-size (get-option '$font_size
))
2580 (colist (hex-to-numeric-list (get-option '$color
)))
2587 (merror "vtk (label): no arguments in object labels"))
2588 ((or (notevery #'$listp lab
)
2589 (notevery #'(lambda (z) (= 4 ($length z
))) lab
))
2590 (merror "vtk3d (label): arguments must be lists of length 4"))
2593 (setf text
(format nil
"\"~a\"" ($first k
))
2594 fx
($float
($second k
))
2595 fy
($float
($third k
))
2596 fz
($float
($fourth k
)))
2597 (when (or (not (floatp fx
))
2600 (merror "vtk3d (label): non real 3d coordinates"))
2601 (setf labelactor-name
(get-labelactor-name)
2602 label-name
(get-label-name)
2603 polydatamapper-name
(get-polydatamapper-name))
2605 (concatenate 'string
2607 (format nil
"~a=vtk.vtkVectorText()~%" label-name
)
2608 (format nil
"~a.SetText(~a)~%" label-name text
)
2609 (format nil
"~a=vtk.vtkPolyDataMapper()~%" polydatamapper-name
)
2610 (format nil
"~a.SetInputConnection(~a.GetOutputPort())~%"
2613 (format nil
"~a.ScalarVisibilityOff()~%" polydatamapper-name
)
2614 (format nil
"~a=vtk.vtkFollower()~%" labelactor-name
)
2615 (format nil
"~a.SetMapper(~a)~%" labelactor-name polydatamapper-name
)
2616 (format nil
"~a.SetScale(~a,~a,~a)~%" labelactor-name font-size font-size font-size
)
2617 (format nil
"~a.AddPosition(~a,~a,~a)~%" labelactor-name fx fy fz
)
2618 (format nil
"~a.GetProperty().SetColor(~a,~a,~a)~%~%"
2627 ;; 3d: tube(xfun,yfun,zfun,rad,par,parmin,parmax)
2628 ;; ----------------------------------------------
2629 (defmacro vtk-check-tube-extreme
(ex cx cy cz
)
2630 `(when (equal (nth ,ex
(get-option '$capping
)) t
)
2634 (when (> *draw-transform-dimensions
* 0)
2635 (setf cxx
(funcall *draw-transform-f1
* ,cx
,cy
,cz
)
2636 cyy
(funcall *draw-transform-f2
* ,cx
,cy
,cz
)
2637 czz
(funcall *draw-transform-f3
* ,cx
,cy
,cz
)))
2639 ; check texture model
2640 (when (> *draw-enhanced3d-type
* 0)
2641 (case *draw-enhanced3d-type
*
2642 ((1 99) (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* tt
)))
2643 (3 (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* cxx cyy czz
)))) )
2645 (setf (aref x
(incf count
)) cxx
)
2646 (setf (aref y count
) cyy
)
2647 (setf (aref z count
) czz
) ))))
2649 (defun vtk3d-tube (xfun yfun zfun rad par parmin parmax
)
2650 (let* ((ugrid (get-option '$xu_grid
))
2651 (vgrid (get-option '$yv_grid
))
2652 (color (get-option '$color
))
2653 (opacity (get-option '$opacity
))
2654 (linewidth (get-option '$line_width
))
2655 (wiredsurface (get-option '$wired_surface
))
2656 (capping (rest (get-option '$capping
)))
2657 (tmin ($float parmin
))
2658 (tmax ($float parmax
))
2659 (vmax 6.283185307179586) ; = float(2*%pi)
2660 (teps (/ (- tmax tmin
) (- ugrid
1)))
2661 (veps (/ vmax
(- vgrid
1)))
2662 (nu (+ ugrid
(count t capping
)))
2664 (source-name (get-source-name))
2665 (points-name (get-points-name))
2666 (cellarray-name (get-cellarray-name))
2667 (trans-name (get-trans-name))
2668 (filter-name (get-filter-name))
2669 (mapper-name (get-mapper-name))
2670 (actor-name (get-actor-name))
2671 (str (make-array 0 :element-type
'character
:adjustable t
:fill-pointer
0))
2673 (scalars nil
) ; used for coloring
2674 (scalars2 nil
) ; used for isolines
2680 xx yy zz module r vv rcos rsin
2682 uxold uyold uzold ttnext
2683 floatarray-name floatarray2-name mapper2-name filter2-name lookup-table-name
2686 (merror "draw3d (tube): illegal parametric range"))
2687 (when (not (subsetp (rest ($append
($listofvars xfun
) ($listofvars yfun
)
2688 ($listofvars zfun
) ($listofvars rad
)))
2689 (list par
) :test
#'like
))
2690 (merror "draw3d (tube): non defined variable"))
2691 (check-enhanced3d-model "tube" '(0 1 3 99))
2692 (check-isolines-model "tube" '(0 1 3 99))
2693 (when (= *draw-enhanced3d-type
* 99)
2694 (update-enhanced3d-expression (list '(mlist) par
)))
2695 (when (= *draw-isolines-type
* 99)
2696 (update-isolines-expression (list '(mlist) par
)))
2697 (setq f1
(coerce-float-fun xfun
`((mlist) ,par
)))
2698 (setq f2
(coerce-float-fun yfun
`((mlist) ,par
)))
2699 (setq f3
(coerce-float-fun zfun
`((mlist) ,par
)))
2700 (setf radius
(coerce-float-fun rad
`((mlist) ,par
)))
2701 (setf x
(make-array (* nu nv
) :element-type
'flonum
)
2702 y
(make-array (* nu nv
) :element-type
'flonum
)
2703 z
(make-array (* nu nv
) :element-type
'flonum
))
2704 (when (> *draw-enhanced3d-type
* 0)
2705 (setf scalars
(make-array (* nu nv
) :element-type
'flonum
)))
2706 (when (> *draw-isolines-type
* 0)
2707 (setf scalars2
(make-array (* nu nv
) :element-type
'flonum
)))
2708 (loop for j from
0 below ugrid do
2709 (setf tt
(+ tmin
(* j teps
)))
2710 ; calculate center and radius of circle
2712 ((= j
0) ; 1st circle
2713 (setf cx
(funcall f1 tt
)
2717 (vtk-check-tube-extreme 1 cx cy cz
)
2718 (setf nx
(- (funcall f1 ttnext
) cx
)
2719 ny
(- (funcall f2 ttnext
) cy
)
2720 nz
(- (funcall f3 ttnext
) cz
)))
2721 (t ; all next circles
2725 (setf cx
(funcall f1 tt
)
2728 (setf nx
(- cx cxold
)
2731 (setf r
(funcall radius tt
))
2732 ; calculate the unitary normal vector
2733 (setf module
(sqrt (+ (* nx nx
) (* ny ny
) (* nz nz
))))
2734 (setf nx
(/ nx module
)
2737 ; calculate unitary vector perpendicular to n=(nx,ny,nz)
2738 ; ux.nx+uy.ny+uz.nz=0 => ux=-t(ny+nz)/nx, uy=uz=t
2742 (setf ux
1.0 uy
0.0 uz
0.0))
2744 (setf ux
0.0 uy
1.0 uz
0.0))
2746 (setf ux
0.0 uy
0.0 uz
1.0))
2747 (t ; all other cases
2748 (setf ux
(- (/ (+ ny nz
) nx
))
2751 (setf module
(sqrt (+ (* ux ux
) (* uy uy
) (* uz uz
))))
2752 (setf ux
(/ ux module
)
2755 (when (and (> tt tmin
)
2756 (< (+ (* uxold ux
) (* uyold uy
) (* uzold uz
)) 0))
2763 ; vector v = n times u
2764 (setf vx
(- (* ny uz
) (* nz uy
))
2765 vy
(- (* nz ux
) (* nx uz
))
2766 vz
(- (* nx uy
) (* ny ux
)))
2767 ; parametric equation of the circumference of radius
2768 ; r and centered at c=(cx,cy,cz):
2769 ; x(t) = c + r(cos(t)u + sin(t)v),
2770 ; for t in (0, 2*%pi)
2772 ; calculate points of one circumference
2773 (loop for i below vgrid do
2774 (setf rcos
(* r
(cos vv
))
2775 rsin
(* r
(sin vv
)))
2776 (setf xx
(+ cx
(* rcos ux
) (* rsin vx
))
2777 yy
(+ cy
(* rcos uy
) (* rsin vy
))
2778 zz
(+ cz
(* rcos uz
) (* rsin vz
)))
2779 ; geometric translation
2781 (setf (aref x
(incf count
)) xx
)
2782 (setf (aref y count
) yy
)
2783 (setf (aref z count
) zz
)
2784 ; check texture model
2785 (when (> *draw-enhanced3d-type
* 0)
2786 (case *draw-enhanced3d-type
*
2787 ((1 99) (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* tt
)))
2788 (3 (setf (aref scalars
(incf scalars-count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
)))) )
2789 ; check isolines model
2790 (when (> *draw-isolines-type
* 0)
2791 (case *draw-isolines-type
*
2792 ((1 99) (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* tt
)) )
2793 (3 (setf (aref scalars2
(incf scalars2-count
)) (funcall *draw-isolines-fun
* xx yy zz
))) ))
2794 (setf vv
(+ vv veps
))
2795 (when (> vv vmax
) (setf vv vmax
)) ) ) ; end both loops
2796 (vtk-check-tube-extreme 2 cx cy cz
)
2797 (let ((lut (check-lookup-table)))
2798 (setf lookup-table-name
(car lut
))
2799 (format str
"~a~%" (cadr lut
)))
2802 (format str
"~a=vtk.vtkPolyData()~%" source-name
)
2803 (format str
"~a~%" (vtkpoints-code points-name source-name x y z
))
2804 (format str
"~a~%" (vtkcellarray-code cellarray-name source-name
2 (build-surface-grid nv nu
)))
2805 (format str
"~a~%" (vtktransform-code trans-name
))
2806 (format str
"~a~%" (vtktransformpolydatafilter-code filter-name source-name trans-name t
))
2807 (format str
"~a~%" (vtkpolydatamapper-code mapper-name filter-name nil
))
2809 (format str
"bounds.append(~a.GetBounds())~%" points-name
)
2810 (format str
"~a~%" (vtkactor-code actor-name nil color opacity linewidth wiredsurface
))
2811 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil t
))
2813 (when (> *draw-enhanced3d-type
* 0)
2814 (format str
"~a.SetLookupTable(~a)~%" mapper-name lookup-table-name
)
2815 (format str
"~a.SetScalarModeToUsePointFieldData()~%" mapper-name
)
2816 (format str
"~a.ScalarVisibilityOn()~%~%" mapper-name
)
2817 (setf floatarray-name
(get-floatarray-name))
2818 (format str
"~a~%" (vtkfloatarray-code floatarray-name source-name scalars
))
2819 ; remove next string if we want isolines and solid color when enhanced3d is not active
2820 (format str
"~a.SelectColorArray(\"name~a\")~%" mapper-name floatarray-name
)
2821 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2822 (format nil
"rescalearray(~a,~a)~%" points-name floatarray-name
)) )
2824 (when (> *draw-isolines-type
* 0)
2825 (setf floatarray2-name
(get-floatarray-name))
2826 (format str
"~a~%" (vtkfloatarray-code floatarray2-name source-name scalars2
))
2827 (setf filter2-name
(get-filter-name))
2828 (format str
"~a~%" (vtkContourFilter-code filter2-name filter-name
))
2829 (setf mapper2-name
(get-mapper-name))
2830 (format str
"~a" (vtkpolydatamapper-isoline-code mapper2-name source-name floatarray2-name
))
2831 (format str
"~a~%" (vtkactor-isoline-code (get-actor-name) linewidth
))
2832 (format str
"~a~%" (vtkextractpolydatageometry-code (get-extract-name) nil nil
))
2833 (setf (gethash *vtk-extract-counter
* *enhanced3d-or-isolines-code
*)
2834 (format nil
"rescalearray(~a,~a)~%" points-name floatarray2-name
)) )
2844 (defvar *vtk2d-graphic-objects
* (make-hash-table))
2846 ; table of 2d graphic objects
2847 (setf (gethash '$explicit
*vtk2d-graphic-objects
*) 'vtk2d-explicit
2848 (gethash '$parametric
*vtk2d-graphic-objects
*) 'vtk2d-parametric
2849 (gethash '$points
*vtk2d-graphic-objects
*) 'vtk2d-points
2850 (gethash '$polar
*vtk2d-graphic-objects
*) 'vtk2d-polar
)
2852 (defun make-vtk-scene-2d (args)
2854 (chart-name (get-chart-name))
2855 (renderer-name (get-renderer-name))
2858 (ini-local-option-variables)
2860 (setf largs
(listify-arguments args
))
2862 (cond ((equal ($op x
) "=")
2864 ($allocation
(update-allocation ($rhs x
)))
2865 ($color
(update-color '$color
($rhs x
)))
2866 ($fill_color
(update-color '$fill_color
($rhs x
)))
2867 ($file_name
(update-string '$file_name
($rhs x
)))
2868 ($font_size
(update-positive-float '$font_size
($rhs x
)))
2869 ($head_angle
(update-positive-float '$head_angle
($rhs x
)))
2870 ($head_length
(update-positive-float '$head_length
($rhs x
)))
2871 ($background_color
(update-color '$background_color
($rhs x
)))
2872 ($dimensions
(update-dimensions ($rhs x
)))
2873 ($nticks
(update-positive-integer '$nticks
($rhs x
)))
2874 ($line_width
(update-positive-float '$line_width
($rhs x
)))
2875 ($line_type
(update-linestyle '$line_type
($rhs x
)))
2876 ($key
(update-string '$key
($rhs x
)))
2877 ($key_pos
(update-key_pos ($rhs x
)))
2878 ($logx
(update-boolean-option '$logx
($rhs x
)))
2879 ($logy
(update-boolean-option '$logy
($rhs x
)))
2880 ($filled_func
(update-gr-option '$filled_func
($rhs x
)))
2881 ($grid
(update-gr-option '$grid
($rhs x
)))
2882 ($transform
(update-transform ($rhs x
)))
2883 ($points_joined
(update-pointsjoined ($rhs x
)))
2884 ($point_type
(update-pointtype ($rhs x
)))
2885 ($point_size
(update-nonnegative-float '$point_size
($rhs x
)))
2886 ($terminal
(update-terminal ($rhs x
)))
2887 ($unit_vectors
(update-boolean-option '$unit_vectors
($rhs x
)))
2888 ($xlabel
(update-string '$xlabel
($rhs x
)))
2889 ($ylabel
(update-string '$ylabel
($rhs x
)))
2891 ; options not yet implemented for 2D-vtk
2892 ; they are included here to avoid error messages
2893 ($xrange
(update-gr-option '$xrange
($rhs x
)))
2894 ($yrange
(update-gr-option '$yrange
($rhs x
)))
2896 (otherwise (merror "vtk2d: unknown option ~M " ($lhs x
)))))
2898 ((setf obj
(gethash (caar x
) *vtk2d-graphic-objects
*))
2900 (concatenate 'string
2902 (apply obj
(rest x
)))))
2905 (merror "vtk2d: item ~M is not recognized" x
))))
2907 (setf *allocations
* (cons (get-option '$allocation
) *allocations
*))
2908 (concatenate 'string
2909 (vtkchartxy-code chart-name
)
2919 (defvar *vtk3d-graphic-objects
* (make-hash-table))
2921 ; table of 3d graphic objects
2922 (setf (gethash '$cone
*vtk3d-graphic-objects
*) 'vtk3d-cone
2923 (gethash '$cylinder
*vtk3d-graphic-objects
*) 'vtk3d-cylinder
2924 (gethash '$cube
*vtk3d-graphic-objects
*) 'vtk3d-cube
2925 (gethash '$prism
*vtk3d-graphic-objects
*) 'vtk3d-prism
2926 (gethash '$elevation_grid
*vtk3d-graphic-objects
*) 'vtk3d-elevation_grid
2927 (gethash '$implicit
*vtk3d-graphic-objects
*) 'vtk3d-implicit
2928 (gethash '$sphere
*vtk3d-graphic-objects
*) 'vtk3d-sphere
2929 (gethash '$parallelogram
*vtk3d-graphic-objects
*) 'vtk3d-parallelogram
2930 (gethash '$triangle
*vtk3d-graphic-objects
*) 'vtk3d-triangle
2931 (gethash '$vector
*vtk3d-graphic-objects
*) 'vtk3d-vector
2932 (gethash '$points
*vtk3d-graphic-objects
*) 'vtk3d-points
2933 (gethash '$parametric
*vtk3d-graphic-objects
*) 'vtk3d-parametric
2934 (gethash '$parametric_surface
*vtk3d-graphic-objects
*) 'vtk3d-parametric_surface
2935 (gethash '$spherical
*vtk3d-graphic-objects
*) 'vtk3d-spherical
2936 (gethash '$cylindrical
*vtk3d-graphic-objects
*) 'vtk3d-cylindrical
2937 (gethash '$explicit
*vtk3d-graphic-objects
*) 'vtk3d-explicit
2938 (gethash '$label
*vtk3d-graphic-objects
*) 'vtk3d-label
2939 (gethash '$tube
*vtk3d-graphic-objects
*) 'vtk3d-tube
)
2941 (defun make-vtk-scene-3d (args)
2943 (appenddata-name (get-appenddata-name))
2944 (outline-name (get-outline-name))
2945 (polydatamapper-name (get-polydatamapper-name))
2946 (outlineactor-name (get-outlineactor-name))
2947 (textproperty-name (get-textproperty-name))
2948 (cubeaxesactor2d-name (get-cubeaxesactor2d-name))
2949 (renderer-name (get-renderer-name))
2950 (camera-name (get-camera-name))
2951 (first-actor (+ *vtk-actor-counter
* 1))
2952 (first-labelactor (+ *vtk-labelactor-counter
* 1))
2953 (first-extract (+ *vtk-extract-counter
* 1))
2954 (first-label (+ *vtk-label-counter
* 1))
2957 (ini-local-option-variables)
2959 (setf largs
(listify-arguments args
))
2961 (cond ((equal ($op x
) "=")
2963 ($allocation
(update-allocation ($rhs x
)))
2964 ($axis_3d
(update-boolean-option '$axis_3d
($rhs x
)))
2965 ($background_color
(update-color '$background_color
($rhs x
)))
2966 ($capping
(update-capping ($rhs x
)))
2967 ($color
(update-color '$color
($rhs x
)))
2968 ($isolines_color
(update-color '$isolines_color
($rhs x
)))
2969 ($isolines_levels
(update-contour-isolines '$isolines_levels
($rhs x
)))
2970 ($dimensions
(update-dimensions ($rhs x
)))
2971 ($enhanced3d
(update-enhanced3d ($rhs x
)))
2972 ($file_name
(update-string '$file_name
($rhs x
)))
2973 ($font_size
(update-positive-float '$font_size
($rhs x
)))
2974 ($head_angle
(update-positive-float '$head_angle
($rhs x
)))
2975 ($head_length
(update-positive-float '$head_length
($rhs x
)))
2976 ($isolines
(update-isolines ($rhs x
)))
2977 ($line_type
(update-linestyle '$line_type
($rhs x
)))
2978 ($line_width
(update-positive-float '$line_width
($rhs x
)))
2979 ($nticks
(update-positive-integer '$nticks
($rhs x
)))
2980 ($opacity
(update-opacity ($rhs x
)))
2981 ($palette
(update-palette ($rhs x
)))
2982 ($points_joined
(update-pointsjoined ($rhs x
)))
2983 ($point_size
(update-nonnegative-float '$point_size
($rhs x
)))
2984 ($point_type
(update-pointtype ($rhs x
)))
2985 ($terminal
(update-terminal ($rhs x
)))
2986 ($transform
(update-transform ($rhs x
)))
2987 ($unit_vectors
(update-boolean-option '$unit_vectors
($rhs x
)))
2988 ($view
(update-view ($rhs x
)))
2989 ($wired_surface
(update-boolean-option '$wired_surface
($rhs x
)))
2990 ($xu_grid
(update-positive-integer '$xu_grid
($rhs x
)))
2991 ($yv_grid
(update-positive-integer '$yv_grid
($rhs x
)))
2992 ($x_voxel
(update-positive-integer '$x_voxel
($rhs x
)))
2993 ($y_voxel
(update-positive-integer '$y_voxel
($rhs x
)))
2994 ($z_voxel
(update-positive-integer '$z_voxel
($rhs x
)))
2995 ($xlabel
(update-string '$xlabel
($rhs x
)))
2996 ($ylabel
(update-string '$ylabel
($rhs x
)))
2997 ($zlabel
(update-string '$zlabel
($rhs x
)))
2999 ; must be changed to script_file_name
3000 ($gnuplot_file_name
(update-string '$gnuplot_file_name
($rhs x
)))
3002 ; options not yet implemented for 3D-vtk
3003 ; they are included here to avoid error messages
3004 ($surface_hide
(update-boolean-option '$surface_hide
($rhs x
)))
3005 ($label_alignment
(update-string '$label_alignment
($rhs x
)))
3006 ($label_orientation
(update-string '$label_orientation
($rhs x
)))
3007 ($xrange
(update-gr-option '$xrange
($rhs x
)))
3008 ($yrange
(update-gr-option '$yrange
($rhs x
)))
3009 ($zrange
(update-gr-option '$zrange
($rhs x
)))
3011 (otherwise (merror "vtk3d: unknown option ~M " ($lhs x
)))))
3013 ((setf obj
(gethash (caar x
) *vtk3d-graphic-objects
*))
3015 (concatenate 'string
3017 (apply obj
(rest x
)))))
3020 (merror "vtk3d: item ~M is not recognized" x
))))
3022 (setf *allocations
* (cons (get-option '$allocation
) *allocations
*))
3023 (concatenate 'string
3025 (if (> *vtk-extract-counter
* 0)
3028 (vtkappendpolydata-code appenddata-name first-extract first-label
)
3029 (vtkoutlinefilter-code outline-name appenddata-name
)
3030 (vtkpolydatamapper-code polydatamapper-name outline-name t
)
3031 (vtkactor-code outlineactor-name polydatamapper-name
"#ff0000" 1 1 nil
)
3032 (vtktextproperty-code textproperty-name
)
3033 (vtkcubeaxesactor2d-code cubeaxesactor2d-name appenddata-name textproperty-name
)
3036 cubeaxesactor2d-name
3038 (get-option '$background_color
)
3040 (car (get-option '$view
))
3041 (cadr (get-option '$view
))
3043 first-labelactor
) )))
3047 (defun draw_vtk (&rest args
)
3052 (ini-global-options)
3053 (ini-local-option-variables)
3055 (setf *allocations
* nil
)
3056 (setf *vtk-appenddata-counter
* 0
3057 *vtk-extract-counter
* 0
3058 *vtk-outline-counter
* 0
3059 *vtk-polydatamapper-counter
* 0
3060 *vtk-outlineactor-counter
* 0
3061 *vtk-textproperty-counter
* 0
3062 *vtk-cubeaxesactor2d-counter
* 0
3063 *vtk-camera-counter
* 0
3064 *vtk-renderer-counter
* 0
3065 *vtk-source-counter
* 0
3066 *vtk-mapper-counter
* 0
3067 *vtk-actor-counter
* 0
3068 *vtk-labelactor-counter
* 0
3069 *vtk-trans-counter
* 0
3070 *vtk-filter-counter
* 0
3071 *vtk-data-file-counter
* 0
3072 *vtk-floatarray-counter
* 0
3073 *vtk-points-counter
* 0
3074 *vtk-glyphpoints-counter
* 0
3075 *vtk-polydata-counter
* 0
3076 *vtk-cellarray-counter
* 0
3077 *vtk-polydatamapper-counter
* 0
3078 *vtk-solidsource-counter
* 0
3079 *vtk-triangle-counter
* 0
3080 *vtk-label-counter
* 0
3081 *vtk-chart-counter
* 0
3082 *vtk-table-counter
* 0
3083 *vtk-arrayX-counter
* 0
3084 *vtk-arrayY-counter
* 0
3085 *vtk-2dkey-counter
* 0
3086 *vtk-isolines-counter
* 0
3088 *unitscale-already-defined
* nil
)
3089 (setf largs
(listify-arguments args
))
3091 (cond ((equal ($op x
) "=")
3093 ($terminal
(update-terminal ($rhs x
)))
3094 ($columns
(update-positive-integer '$columns
($rhs x
)))
3095 ($dimensions
(update-dimensions ($rhs x
)))
3096 ($file_name
(update-string '$file_name
($rhs x
)))
3097 ($background_color
(update-color '$background_color
($rhs x
)))
3098 (otherwise (merror "draw: unknown global option ~M " ($lhs x
)))))
3099 ((equal (caar x
) '$gr3d
)
3100 (setf scenes
(append scenes
(list (funcall #'make-vtk-scene-3d
(rest x
))))))
3101 ((equal (caar x
) '$gr2d
)
3102 (setf scenes
(append scenes
(list (funcall #'make-vtk-scene-2d
(rest x
))))))
3104 (merror "draw: item ~M is not recognized" x
))) )
3106 ;; prepare script file
3107 (setf gfn
(plot-temp-file (format nil
"maxout~d.py" (getpid))))
3110 :direction
:output
:if-exists
:supersede
))
3111 (when (eql cmdstorage nil
)
3112 (merror "draw: Cannot create file '~a'. Probably maxima_tempdir doesn't point to a writable directory." gfn
))
3114 ;; pull in required packages
3115 (format cmdstorage
"~a~%~a~%~%~a~%~a~%~%~a~%~%"
3116 "#!/usr/bin/env python"
3117 "# -*- coding: UTF-8 -*-"
3123 (dolist (scn scenes
)
3124 (format cmdstorage
"~a" scn
) )
3126 ;; the renderer window
3127 (format cmdstorage
"~a" (vtkrendererwindow-code (length scenes
)))
3128 (format cmdstorage
"~a" (vtk-terminal))
3130 ;; close script file
3133 #+(or windows win32 win64
)
3134 ($system
"vtkpython " gfn
)
3135 #-
(or windows win32 win64
)
3136 (if (member $draw_renderer
'($vtk $vtk6
))
3137 ($system
(format nil
"(python \"~a\")&" gfn
))
3138 ($system
(format nil
"(python3 \"~a\")&" gfn
)))
