1;; xmaxima.lisp: routines for Maxima's interface to xmaxima 2;; Copyright (C) 2007-2013 J. Villate 3;; 4;; This program is free software; you can redistribute it and/or 5;; modify it under the terms of the GNU General Public License 6;; as published by the Free Software Foundation; either version 2 7;; of the License, or (at your option) any later version. 8;; 9;; This program is distributed in the hope that it will be useful, 10;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12;; GNU General Public License for more details. 13;; 14;; You should have received a copy of the GNU General Public License 15;; along with this program; if not, write to the Free Software 16;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, 17;; MA 02110-1301, USA 18 19(in-package :maxima) 20 21;; Given a list of valid colors (see rgb-color function) and an object c 22;; that can be a real number or a string, produces an rgb color 23;; specification for c; when c is real, its nearest integer is assigned 24;; to one of the numbers in the list, using modulo length of the list. 25(defun xmaxima-color (colors c) 26 (unless (listp colors) (setq colors (list colors))) 27 (when (realp c) 28 (unless (integerp c) (setq c (round c))) 29 (setq c (nth (mod (1- c) (length colors)) colors))) 30 (rgb-color c)) 31 32;; style is a list starting with a symbol from the list: points, lines, 33;; linespoints or dots, 34;; The meaning of the numbers that follow the symbol are: 35;; 36;; lines, linewidth, color 37;; points, radius, color 38;; linespoints, linewidth, radius, color 39;; dots, color 40;; 41;; linewidth and radius are measured in the same units and can be 42;; floating-point numbers. 43;; 44;; type must be an integer 45;; color can be an integer, used as index to get one of the colors defined 46;; by the color option, or a 6-digit hexadecimal number #rrggbb 47 48(defun xmaxima-curve-style (style colors i) 49 (unless (listp style) (setq style (list style))) 50 (unless (listp colors) (setq colors (list colors))) 51 (with-output-to-string 52 (st) 53 (case (first style) 54 ($dots 55 (format st "\{ nolines 1 \} \{ plotpoints 1 \} \{ pointsize 0.7 \}") 56 (if (second style) 57 (format st " \{ color ~a \}" (xmaxima-color colors (second style))) 58 (format st " \{ color ~a \}" (xmaxima-color colors i)))) 59 ($lines 60 (format st "\{ nolines 0 \} \{ plotpoints 0 \}") 61 (if (realp (second style)) 62 (format st " \{ linewidth ~,2f \}" (second style))) 63 (if (third style) 64 (format st " \{ color ~a \}" (xmaxima-color colors (third style))) 65 (format st " \{ color ~a \}" (xmaxima-color colors i)))) 66 ($points 67 (format st "\{ nolines 1 \} \{ plotpoints 1 \}") 68 (if (realp (second style)) 69 (format st " \{ pointsize ~,2f \}" (second style)) 70 (format st " \{ pointsize 3 \}")) 71 (if (third style) 72 (format st " \{ color ~a \}" (xmaxima-color colors (third style))) 73 (format st " \{ color ~a \}" (xmaxima-color colors i)))) 74 ($linespoints 75 (format st "\{ nolines 0 \} \{ plotpoints 1 \}") 76 (if (realp (second style)) 77 (format st " \{ linewidth ~,2f \}" (second style))) 78 (if (realp (third style)) 79 (format st " \{ pointsize ~,2f \}" (third style)) 80 (format st " \{ pointsize 3 \}")) 81 (if (fourth style) 82 (format st " \{ color ~a \}" (xmaxima-color colors (fourth style))) 83 (format st " \{ color ~a \}" (xmaxima-color colors i)))) 84 (t 85 (format st "\{ nolines 0 \} \{ plotpoints 0 \} \{ color ~a \}" 86 (xmaxima-color colors i)))))) 87 88(defun xmaxima-palette (palette) 89;; palette should be a list starting with one of the symbols: hue, 90;; saturation, value, gray or gradient. 91;; 92;; If the symbol is gray, it should be followed by two floating point 93;; numbers that indicate the initial gray level and the interval of 94;; gray values. 95;; 96;; If the symbol is one of hue, saturation or value, it must be followed 97;; by three numbers that specify the hue, saturation and value for the 98;; initial color, and a fourth number that gives the range of values for 99;; the increment of hue, saturation or value. 100;; The values for the initial hue, saturation, value and grayness should 101;; be within 0 and 1, while the range can be higher or even negative. 102;; 103;; If the symbol is gradient, it must be followed by either a list of valid 104;; colors or by a list of lists with two elements, a number and a valid color. 105 106 (unless (listp palette) (setq palette (list palette))) 107 (let (hue sat val gray range fun) 108 (case (first palette) 109 ($gray 110 (case (length (rest palette)) 111 (2 (setq gray (second palette)) (setq range (third palette))) 112 (t (merror 113 (intl:gettext 114 "palette: gray must be followed by two numbers.")))) 115 (when (or (< gray 0) (> gray 1)) 116 (setq gray (- gray (floor gray)))) 117 (setq fun (format nil "{value ~,8f} {colorrange ~,8f}" gray range))) 118 (($hue $saturation $value) 119 (case (length (rest palette)) 120 (4 (setq hue (second palette)) 121 (setq sat (third palette)) 122 (setq val (fourth palette)) 123 (setq range (fifth palette))) 124 (t (merror 125 (intl:gettext 126 "palette: ~M must be followed by four numbers.") 127 (first palette)))) 128 (when (or (< hue 0) (> hue 1)) (setq hue (- hue (floor hue)))) 129 (when (or (< sat 0) (> sat 1)) (setq sat (- sat (floor sat)))) 130 (when (or (< val 0) (> val 1)) (setq val (- val (floor val)))) 131 (setq fun 132 (format nil " {hue ~,8f} {saturation ~,8f} {value ~,8f} {colorrange ~,8f}" 133 hue sat val range)))) 134 (with-output-to-string (st) 135 (case (first palette) 136 ($hue (format st "~&~a {colorscheme hue}" fun)) 137 ($saturation (format st "~&~a {colorscheme saturation}" fun)) 138 ($value (format st "~&~a {colorscheme value}" fun)) 139 ($gray (format st "~&~a {colorscheme gray}" fun)) 140 ($gradient 141 (let* ((colors (rest palette)) (n (length colors)) (map nil)) 142 ;; map is constructed as (n1 c1 n2 c2 ... nj cj) where ni is a 143 ;; decreasing sequence of numbers (n1=1, nj=0) and ci are colors 144 (cond 145 ;; Maxima list of numbers and colors (((mlist) ni ci) ...) 146 ((listp (first colors)) 147 (setq colors (sort colors #'< :key #'cadr)) 148 (dotimes (i n) 149 (setq map (cons (rgb-color (third (nth i colors))) ;; color 150 (cons 151 (/ (- (second (nth i colors)) ;; ni minus 152 (second (first colors))) ;; smallest ni 153 (- (second (nth (- n 1) colors));; biggest 154 (second (first colors)))) ;; - smallest 155 map))))) 156 ;; list of only colors 157 (t (dotimes (i n) 158 (setq map (cons (rgb-color (nth i colors)) ;; color i 159 (cons (/ i (1- n)) map)))))) ;; number i 160 161 ;; prints map with the format: nj, "cj", ...,n1, "c1" 162 (setq fun (format nil "~{{ ~,8f ~s}~^ ~}" (reverse map))) 163 (format st "~&{colorscheme gradient} ") 164 ;; writes: {gradlist {{nj "cj"} ...{n1 "c1"}}} 165 (format st "{gradlist {~a}}" fun))) 166 (t 167 (merror 168 (intl:gettext 169 "palette: wrong keyword ~M. Must be hue, saturation, value, gray or gradient.") 170 (first palette))))))) 171 172(defun xmaxima-palettes (palette n) 173 (unless (integerp n) (setq n (round n))) 174 (if (find 'mlist palette :key #'car) (setq palette (list palette))) 175 (xmaxima-palette (rest (nth (mod (- n 1) (length palette)) palette)))) 176 177(defun xmaxima-print-header (dest plot-options) 178 (cond ($show_openplot (format dest "~a -data {~%" (getf plot-options :type))) 179 (t (format dest "{~a " (getf plot-options :type)))) 180 (when (string= (getf plot-options :type) "plot3d") 181 (let ((palette (getf plot-options :palette)) 182 (meshcolor (if (member :mesh_lines_color plot-options) 183 (getf plot-options :mesh_lines_color) 184 '$black)) 185 (elev (getf plot-options :elevation)) 186 (azim (getf plot-options :azimuth))) 187 (if (find 'mlist palette :key #'car) (setq palette (list palette))) 188 (if palette 189 (progn 190 (if meshcolor 191 (format dest " {mesh_lines ~a}" (rgb-color meshcolor)) 192 (format dest " {mesh_lines 0}"))) 193 (format dest " {colorscheme 0}~%")) 194 (when elev (format dest " {el ~d}" elev)) 195 (when azim (format dest " {az ~d}" azim)) 196 (format dest "~%"))) 197 198 (when (getf plot-options :ps_file) 199 (format dest " {psfile ~s}" (getf plot-options :ps_file))) 200 (when (member :legend plot-options) 201 (unless (getf plot-options :legend) 202 (format dest " {nolegend 1}"))) 203 (when (member :box plot-options) 204 (unless (getf plot-options :box) 205 (format dest " {nobox 1}"))) 206 (if (getf plot-options :axes) 207 (case (getf plot-options :axes) 208 ($x (format dest " {axes {x} }")) 209 ($y (format dest " {axes {y} }")) 210 (t (format dest " {axes {xy} }"))) 211 (format dest " {axes 0}")) 212 (when (getf plot-options :x) 213 (format dest " {xrange ~{~g~^ ~}}" (getf plot-options :x))) 214 (when (getf plot-options :y) 215 (format dest " {yrange ~{~g~^ ~}}" (getf plot-options :y))) 216 (when (getf plot-options :xlabel) 217 (format dest " {xaxislabel ~s}" (getf plot-options :xlabel))) 218 (when (getf plot-options :ylabel) 219 (format dest " {yaxislabel ~s}" (getf plot-options :ylabel))) 220 (when (getf plot-options :z) 221 (format $pstream " {zcenter ~g }" 222 (/ (apply #'+ (getf plot-options :z)) 2)) 223 (format $pstream " {zradius ~g }~%" 224 (/ (apply #'- (getf plot-options :z)) -2))) 225 (format dest "~%")) 226 227