share/dynamics/visualization.lisp

   1 ;; visualization.lisp
   2 ;;
   3 ;; Copyright (c) 2011-2014, Jaime E. Villate <villate@fe.up.pt>
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2 of the License, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
  18 ;; MA  02110-1301, USA.
  19 ;;
  20
  21 (in-package :maxima)
  22
  23 ;; translates Maxima scene object's option values into Xmaxima input syntax
  24 (defun tcl-vtk-option-value (name values)
  25   (when ($listp (car values)) (setq values (cdar values)))
  26   (with-output-to-string (st)
  27     (format st "{~a" name)
  28     (dolist (num values)
  29       (cond
  30         ((plotcolorp num)
  31          (format st "~{ ~d~}" (hexrgb-to-decimal (rgb-color num))))
  32         ((integerp num) (format st " ~d" num))
  33         ((floatp num) (format st " ~f" num))
  34         (($numberp num) (format st " ~f " (coerce-float num)))
  35         ((and ($constantp num) ($freeof '$%i num) (not (member num '(t nil)))
  36               (not ($listp num)))
  37          (format st " ~f " (coerce-float num)))
  38         (($listp num) (format st "~a" (tcl-output-number-list num)))
  39         (t
  40          (merror
  41           (intl:gettext "scene: Wrong value for option ~M~%Expecting a number; found: ~M")
  42           name num))))
  43     (format st "} ")))
  44
  45 ;; converts a Maxima list into a floating-point Tcl list string
  46 (defun tcl-output-number-list (maxlist)
  47   (with-output-to-string (st)
  48     (format st "{ ")
  49     (dolist (num (rest maxlist))
  50       (cond
  51         ((floatp num) (format st "~f " num))
  52         (($numberp num) (format st "~f " (coerce-float num)))
  53         ((and ($constantp num) ($freeof '$%i num) (not (member num '(t nil)))
  54               (not ($listp num)))
  55          (format st "~f " (coerce-float num)))
  56         (($listp num) (format st "~a" (tcl-output-number-list num)))
  57         (t
  58          (merror
  59           (intl:gettext "scene: Wrong value in animation list: ~M")
  60           num))))
  61     (format st "} ")))
  62
  63 ;; converts a hexadecimal rgb color string into list of numbers from 0 to 1
  64 (defun hexrgb-to-decimal (color)
  65   (list (/ (parse-integer (subseq color 1 3) :radix 16) 255.0)
  66         (/ (parse-integer (subseq color 3 5) :radix 16) 255.0)
  67         (/ (parse-integer (subseq color 5) :radix 16) 255.0)))
  68
  69 ;; parses a scene option into a command-line option passed to Xmaxima
  70 (defun scene-option-to-tcl (option)
  71   (let (v vv (name (car option)))
  72     (case name
  73       ($azimuth (if (cadr option)
  74                     (setf (cadr option) (parse-azimuth (cadr option))))
  75                 (setq v (check-option option #'realp "a real number" 1)))
  76       ($elevation (if (cadr option)
  77                       (setf (cadr option) (parse-elevation (cadr option))))
  78                   (setq v (check-option option #'realp "a real number" 1)))
  79       ($tstep
  80        (setq v (check-option option #'realp "a real number" 1))
  81        (setq option (list name v)))
  82       (($width $height)
  83        (setq v (check-option option #'naturalp "a natural number" 1))
  84        (setq option (list name v)))
  85       ($restart
  86        (setq v (check-option-boole option))
  87        (setq option (list name (if v 1 0))))
  88       ($background
  89        (setq v (check-option option #'plotcolorp "a color"))
  90        (setq option (cons name (hexrgb-to-decimal (rgb-color v)))))
  91       (($windowtitle $windowname)
  92        (setq v (check-option option #'string "a string" 1))
  93        (setq option (list name v)))
  94       (t (merror (intl:gettext "scene: Unknown option ~M") name)))
  95     (setq vv (mapcar #'(lambda (a) (if (symbolp a) (ensure-string a) a)) option))
  96     (with-output-to-string (st)
  97       (format st "-~(~a~) " (first vv))
  98       (format st "{~{~a~^ ~}}" (rest vv)))))
  99
 100 (defun $scene (&rest arguments)
 101   (let (objects options file (objs "") (opts " ") vtkname
 102                 (lf (format NIL "~%"))
 103         (classes '(($cube . "Cube") ($sphere . "Sphere")
 104                      ($cylinder . "Cylinder") ($cone . "Cone")))
 105         ;; VTK methods for the objects in classes
 106         (cmethods '(($center . "Center") ($radius . "Radius")
 107                     ($height . "Height") ($resolution . "Resolution")
 108                     ($latlongtessellation . "LatLongTessellation")
 109                     ($thetaresolution . "ThetaResolution")
 110                     ($phiresolution . "PhiResolution")
 111                     ($starttheta . "StartTheta") ($endtheta . "EndTheta")
 112                     ($startphi . "StartTheta") ($endphi . "EndTheta")
 113                     ($capping . "Capping") ($direction . "Direction")
 114                     ($xlength . "XLength") ($ylength . "YLength")
 115                     ($zlength . "ZLength") ($bounds . "Bounds")
 116                     ($angle . "Angle")))
 117         ;; VTK methods for properties
 118         (pmethods '(($color . "Color") ($opacity . "Opacity")
 119                     ($ambient . "Ambient") ($ambientcolor . "AmbientColor")
 120                     ($specular . "Specular") ($specularcolor . "SpecularColor")
 121                     ($diffuse . "Diffuse") ($diffusecolor . "DiffuseColor")
 122                     ($edgevisibility . "EdgeVisibility")
 123                     ($edgecolor . "EdgeColor") ($linewidth . "LineWidth")
 124                     ($pointsize . "PointSize") ($lightning . "Lightning")
 125                     ($shading . "Shading") ($texture . "Texture")
 126                     ($representation . "Representation")
 127                     ($points . "RepresentationToPoints")
 128                     ($wireframe . "RepresentationToWireframe")
 129                     ($surface . "RepresentationToSurface")
 130                     ($interpolation . "Interpolation")
 131                     ($flat . "InterpolationToFlat")
 132                     ($gourand . "InterpolationToGourand")
 133                     ($phong . "InterpolationToPhong")
 134                     ($stipplepattern . "LineStipplePattern")
 135                     ($stipplerepeat . "LineStippleRepeatFactor")
 136                     ($frontculling . "FrontFaceCulling")
 137                     ($backculling . "BackFaceCulling")))
 138         ;; VTK methods for actors
 139         (amethods '(($origin . "Origin") ($scale . "Scale")
 140                     ($position . "Position") ($orientation . "Orientation")
 141                     ($usertransform . "UserTransform"))))
 142     ;; separates arguments between objects and options
 143     (dolist (v arguments)
 144       (if (listp v) (setq v (cdr v)) (setq v (list v)))
 145       (if (assoc (car v) classes)
 146           (setq objects (append objects (list v)))
 147           (setq options (append options (list v)))))
 148     ;; sets up output file name to pass to Xmaxima
 149     (setq file (plot-temp-file (format nil "maxout~d.xmaxima" (getpid))))
 150
 151     ;; parses objects
 152     (dolist (v objects)
 153       (let ((copts "") (popts "") (aopts "") animate prop)
 154         (setq vtkname (cdr (assoc (car v) classes)))
 155         ;; parses object properties
 156         (dolist (w (cdr v))
 157           (unless ($listp w)
 158             (merror
 159              (intl:gettext "scene: Wrong option; expecting a list; found:  ~M")
 160              w))
 161           (cond
 162             ((setq prop (cdr (assoc (second w) cmethods)))
 163              (setq copts
 164                    (concatenate 'string copts
 165                                 (tcl-vtk-option-value prop (cddr w)))))
 166             ((setq prop (cdr (assoc (second w) pmethods)))
 167              (setq popts
 168                    (concatenate 'string popts
 169                    (tcl-vtk-option-value prop (cddr w)))))
 170             ((setq prop (cdr (assoc (second w) amethods)))
 171              (setq aopts
 172                    (concatenate 'string aopts
 173                                 (tcl-vtk-option-value prop (cddr w)))))
 174             ((eql (second w) '$animate)
 175              (unless (setq prop (cdr (assoc (third w) amethods)))
 176                (merror (intl:gettext "scene: ~M cannot be animated.")
 177                        (third w)))
 178              (setq animate
 179                    (concatenate 'string "{" prop " 0 "
 180                           (tcl-output-number-list (fourth w)) "}")))
 181             ((eql (second w) '$track)
 182              (setq animate
 183                    (concatenate 'string "{Position 1 "
 184                           (tcl-output-number-list (third w)) "}")))
 185             (t (mtell (intl:gettext "scene: Ignored option: ~M")
 186                       (second w)))))
 187         ;; save object name and properties in string objs
 188         (setq objs
 189               (concatenate 'string objs "{" vtkname lf "{" copts "}" lf
 190                            "{" popts "}" lf "{" aopts "}" lf animate "}" lf))))
 191
 192     ;; parse scene options and copy them to string opts
 193     (cond (options
 194            (dolist (v options)
 195              (setq opts (concatenate 'string opts " "
 196                                      (scene-option-to-tcl v))))))
 197     (show-open-plot
 198      (with-output-to-string (st)
 199                   (cond ($show_openplot
 200                          (format st "scene ~a -objects {~a}~%" opts objs))
 201                         (t (format st "{scene ~a -objects {~a}}" opts objs))))
 202      file)))
 203