1-- plimage demo 2 3-- Copyright (C) 2008 Jerry Bauck 4 5-- This file is part of PLplot. 6 7-- PLplot is free software; you can redistribute it and/or modify 8-- it under the terms of the GNU Library General Public License as published 9-- by the Free Software Foundation; either version 2 of the License, or 10-- (at your option) any later version. 11 12-- PLplot is distributed in the hope that it will be useful, 13-- but WITHOUT ANY WARRANTY; without even the implied warranty of 14-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15-- GNU Library General Public License for more details. 16 17-- You should have received a copy of the GNU Library General Public License 18-- along with PLplot; if not, write to the Free Software 19-- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 20 21with 22 Ada.Text_IO, 23 Interfaces.C, 24 System, 25 Ada.Sequential_IO, 26 Ada.Numerics, 27 Ada.Numerics.Long_Elementary_Functions, 28 PLplot_Auxiliary, 29 PLplot_Traditional; 30use 31 Ada.Text_IO, 32 Interfaces.C, 33 System, 34 Ada.Numerics, 35 Ada.Numerics.Long_Elementary_Functions, 36 PLplot_Auxiliary, 37 PLplot_Traditional; 38 39procedure xtraditional20a is 40 41 XDIM : constant Integer := 260; 42 YDIM : constant Integer := 220; 43 PLK_Return : constant unsigned := 16#0D#; 44 dbg : Integer := 0; 45 nosombrero : Integer := 0; 46 nointeractive : Integer := 0; 47 x : Real_Vector(0 .. XDIM - 1); 48 y : Real_Vector(0 .. YDIM - 1); 49 z, r : Real_Matrix(0 .. XDIM - 1, 0 .. YDIM - 1); 50 xi, yi, xe, ye : Long_Float; 51 width, height, num_col : Integer; 52 img_f : Real_Matrix(0 .. 310, 0 .. 239); -- Chloe is width 311, height 240. 53 img_min, img_max : Long_Float; 54 Get_Clip_Return : Integer; 55 type stretch_data is 56 record 57 xmin, xmax, ymin, ymax : Long_Float; 58 stretch : Long_Float; 59 end record; 60 stretch : stretch_data; 61 xx, yy : Long_Float; 62 f_name : String(1 .. 200); 63 f_name_length : Integer; 64 Save_Sombrero : Boolean := False; 65 66 -- Read image from file in binary ppm format. 67 procedure read_img 68 (fname : String; img_f : out Real_Matrix; 69 width, height, num_col : out Integer) 70 is 71 type Byte is mod 2 ** 8; 72 A_Byte : Byte; 73 package Chloe_IO is new Ada.Sequential_IO(Byte); 74 use Chloe_IO; 75 Input_File : Chloe_IO.File_Type; 76 begin 77 -- Naive grayscale binary ppm reading. If you know how to, improve it. 78 -- Mine is naiver than yours. 79 -- Chloe.pgm has 15 bytes of header followed by 311 * 240 bytes of 8-bit pixels. 80 Chloe_IO.Open(Input_File, In_File, fname); 81 82 for i in 1 .. 15 loop 83 Chloe_IO.Read(Input_File, A_Byte); 84 end loop; 85 86 width := 311; -- columns 87 height := 240; -- rows 88 num_col := 255; -- number of colors 89 90 for j in img_f'range(2) loop 91 for i in img_f'range(1) loop 92 Chloe_IO.Read(Input_File, A_Byte); 93 img_f(i, height - j - 1) := Long_Float(A_Byte); -- Flip image up-down. 94 end loop; 95 end loop; 96 end read_img; 97 98 99 -- Save plot. 100 procedure save_plot(fname : String) is 101 cur_strm, new_strm : Integer; 102 begin 103 plgstrm(cur_strm); -- Get current stream. 104 plmkstrm(new_strm); -- Create a new one. 105 plsdev("psc"); -- New device type. Use a known existing driver. 106 plsfnam(fname); -- Set the file name. 107 plcpstrm(cur_strm, False); -- Copy old stream parameters to new stream. 108 plreplot; -- Do the save. 109 plend1; -- Close new device... 110 plsstrm(cur_strm); -- ...and return to previous one. 111 end save_plot; 112 113 114 -- Get selection square interactively. 115 procedure get_clip(xi, xe, yi, ye : in out Long_Float; Return_This : out Integer) is 116 gin : Graphics_Input_Record_Type; 117 xxi : Long_Float := xi; 118 yyi : Long_Float := yi; 119 xxe : Long_Float := xe; 120 yye : Long_Float := ye; 121 t : Long_Float; 122 start : Integer := 0; 123 st : Boolean := False; 124 sx, sy : Real_Vector(0 .. 4); 125 begin 126 plxormod(True, st); -- Enter xor mode to draw a selection rectangle. 127 128 if st then -- Driver has xormod capability. Continue. 129 loop 130 plxormod(False, st); 131 plGetCursor(gin); 132 plxormod(True, st); 133 134 if gin.button = 1 then 135 xxi := gin.wX; 136 yyi := gin.wY; 137 if start /= 0 then 138 -- Suppress warning """sy"" may be referenced before it has a value". 139 pragma Warnings(Off); 140 plline(sx, sy); -- Clear previous rectangle. 141 pragma Warnings(On); 142 end if; 143 144 start := 0; 145 146 sx(0) := xxi; 147 sy(0) := yyi; 148 sx(4) := xxi; 149 sy(4) := yyi; 150 end if; 151 152 if (gin.state and Unsigned(16#100#)) /= 0 then 153 xxe := gin.wX; 154 yye := gin.wY; 155 156 if start /= 0 then 157 plline(sx, sy); -- Clear previous rectangle. 158 end if; 159 160 start := 1; 161 162 sx(2) := xxe; 163 sy(2) := yye; 164 sx(1) := xxe; 165 sy(1) := yyi; 166 sx(3) := xxi; 167 sy(3) := yye; 168 plline(sx, sy); -- Draw new rectangle. 169 end if; 170 171 if gin.button = 3 or gin.keysym = PLK_Return or 172 gin.keysym = unsigned(Character'pos('Q')) then 173 if start /= 0 then 174 plline(sx, sy); -- Clear previous rectangle. 175 end if; 176 exit; 177 end if; 178 end loop; 179 180 plxormod(False, st); -- Leave xor mod. 181 182 if xxe < xxi then 183 t := xxi; 184 xxi := xxe; 185 xxe := t; 186 end if; 187 188 if yyi < yye then 189 t :=yyi; 190 yyi := yye; 191 yye := t; 192 end if; 193 194 xe := xxe; 195 xi := xxi; 196 ye := yye; 197 yi := yyi; 198 199 if gin.keysym = unsigned(Character'pos('Q')) then 200 Return_This := 1; 201 else 202 Return_This := 0; 203 end if; 204 else -- Driver has no xormod capability; just do nothing. 205 Return_This := 0; 206 end if; 207 end get_clip; 208 209 210 -- Set gray colormap. 211 procedure gray_cmap(num_col : Integer) is 212 r, g, b, pos : Real_Vector(0 .. 1); 213 begin 214 r(0) := 0.0; 215 g(0) := 0.0; 216 b(0) := 0.0; 217 218 r(1) := 1.0; 219 g(1) := 1.0; 220 b(1) := 1.0; 221 222 pos(0) := 0.0; 223 pos(1) := 1.0; 224 225 plscmap1n(num_col); 226 plscmap1l(RGB, pos, r, g, b, Alt_Hue_Path_None); 227 end gray_cmap; 228 229 230 procedure mypltr 231 (x, y : Long_Float; 232 tx, ty : out Long_Float; 233 s : stretch_data) 234 is 235 x0, y0, dy : Long_Float; 236 begin 237 x0 := (s.xmin + s.xmax) * 0.5; 238 y0 := (s.ymin + s.ymax) * 0.5; 239 dy := (s.ymax - s.ymin) * 0.5; 240 tx := x0 + (x0 - x) * (1.0 - s.stretch * cos((y - y0) / dy * pi * 0.5)); 241 ty := y; 242 end mypltr; 243 244begin 245 246 -- Parse and process command line arguments 247 plparseopts(PL_PARSE_FULL); 248 249 -- Initialize plplot 250 plinit; 251 252 -- View image border pixels. 253 if dbg /= 0 then 254 plenv(1.0, Long_Float(XDIM), 1.0, Long_Float(YDIM), 1, 1); -- no plot box 255 256 -- Build a one pixel square border, for diagnostics. 257 for i in z'range(1) loop 258 z(i, YDIM - 1) := 1.0; -- right 259 end loop; 260 261 for i in z'range(1) loop 262 z(i, 0) := 1.0; -- left 263 end loop; 264 265 for i in z'range(2) loop 266 z(0, i) := 1.0; -- top 267 end loop; 268 269 for i in z'range(2) loop 270 z(XDIM - 1, i) := 1.0; -- botton 271 end loop; 272 273 pllab("...around a blue square."," ","A red border should appear..."); 274 275 plimage(z, 276 1.0, Long_Float(XDIM), 1.0, Long_Float(YDIM), 0.0, 0.0, 277 1.0, Long_Float(XDIM), 1.0, Long_Float(YDIM)); 278 end if; 279 280 -- sombrero-like demo 281 if nosombrero = 0 then 282 plcol0(2); -- Draw a yellow plot box, useful for diagnostics! :( 283 plenv(0.0, 2.0 * pi, 0.0, 3.0 * pi, 1, -1); 284 285 for i in x'range loop 286 x(i) := Long_Float(i) * 2.0 * pi / Long_Float(XDIM - 1); 287 end loop; 288 289 for i in y'range loop 290 y(i) := Long_Float(i) * 3.0 * pi / Long_Float(YDIM - 1); 291 end loop; 292 293 for i in z'range(1) loop 294 for j in z'range(2) loop 295 r(i, j) := sqrt(x(i) * x(i) + y(j) * y(j)) + 1.0e-3; 296 z(i, j) := sin(r(i, j)) / (r(i, j)); 297 end loop; 298 end loop; 299 300 pllab("No, an amplitude clipped ""sombrero""", "", "Saturn?"); 301 plptex(2.0, 2.0, 3.0, 4.0, 0.0, "Transparent image"); 302 plimage(z, 0.0, 2.0 * pi, 0.0, 3.0 * pi, 0.05, 1.0, 303 0.0, 2.0 * pi, 0.0, 3.0 * pi); 304 305 -- Save the plot. 306 if Save_Sombrero then 307 Put("Enter a path and name to save the Postscript file or RETURN to not save: "); 308 Get_Line(f_name, f_name_length); 309 if f_name'Length /= 0 then 310 save_plot(f_name(1 .. f_name_length)); 311 end if; 312 end if; 313 end if; 314 315 -- Read the Chloe image. 316 -- Note we try two different locations to cover the case where this 317 -- examples is being run from the test_c.sh script. 318 begin 319 read_img("./Chloe.pgm", img_f, width, height, num_col); 320 exception 321 when NAME_ERROR => 322 null; 323 begin 324 read_img("../Chloe.pgm", img_f, width, height, num_col); 325 exception 326 when NAME_ERROR => 327 Put_Line("Failed to open Chloe.pgm. Aborting."); 328 plend; 329 return; 330 end; -- second exception block 331 end; -- first exception block 332 333 -- Set gray colormap. 334 gray_cmap(num_col); 335 336 -- Display Chloe. 337 plenv(1.0, Long_Float(width), 1.0, Long_Float(height), 1, -1); 338 339 if nointeractive = 0 then 340 pllab("Set and drag Button 1 to (re)set selection, Button 2 to finish."," ","Chloe..."); 341 else 342 pllab(""," ","Chloe..."); 343 end if; 344 345 plimage(img_f, 1.0, Long_Float(width), 1.0, Long_Float(height), 0.0, 0.0, 1.0, 346 Long_Float(width), 1.0, Long_Float(height)); 347 348 -- Selection/expansion demo 349 if nointeractive = 0 then 350 xi := 25.0; 351 xe := 130.0; 352 yi := 235.0; 353 ye := 125.0; 354 355 get_clip(xi, xe, yi, ye, Get_Clip_Return); -- get selection rectangle 356 if Get_Clip_Return /= 0 then 357 plend; 358 end if; 359 360 -- I'm unable to continue, clearing the plot and advancing to the next 361 -- one, without hiting the enter key, or pressing the button... help! 362 363 -- Forcing the xwin driver to leave locate mode and destroying the 364 -- xhairs (in GetCursorCmd()) solves some problems, but I still have 365 -- to press the enter key or press Button-2 to go to next plot, even 366 -- if a pladv() is not present! Using plbop() solves the problem, but 367 -- it shouldn't be needed! 368 369 -- plbop(); 370 371 -- plspause(0), pladv(0), plspause(1), also works, 372 -- but the above question remains. 373 -- With this approach, the previous pause state is lost, 374 -- as there is no API call to get its current state. 375 376 plspause(False); 377 pladv(0); 378 379 -- Display selection only. 380 plimage(img_f, 1.0, Long_Float(width), 1.0, Long_Float(height), 0.0, 0.0, xi, xe, ye, yi); 381 382 plspause(True); 383 384 -- Zoom in selection. 385 plenv(xi, xe, ye, yi, 1, -1); 386 plimage(img_f, 1.0, Long_Float(width), 1.0, Long_Float(height), 0.0, 0.0, xi, xe, ye, yi); 387 end if; 388 389 -- Base the dynamic range on the image contents. 390 img_min := Matrix_Min(img_f); 391 img_max := Matrix_Max(img_f); 392 393 -- Draw a saturated version of the original image. Use only the middle 50% 394 -- of the image's full dynamic range. 395 plcol0(2); 396 plenv(0.0, Long_Float(width), 0.0, Long_Float(height), 1, -1); 397 pllab("", "", "Reduced dynamic range image example"); 398 plimagefr(img_f, 0.0, Long_Float(width), 0.0, Long_Float(height), 0.0, 0.0, 399 img_min + img_max * 0.25, img_max - img_max * 0.25, Null, System.Null_Address); 400 401 -- Draw a distorted version of the original image, showing its full dynamic range. 402 plenv(0.0, Long_Float(width), 0.0, Long_Float(height), 1, -1); 403 pllab("", "", "Distorted image example"); 404 405 stretch.xmin := 0.0; 406 stretch.xmax := Long_Float(width); 407 stretch.ymin := 0.0; 408 stretch.ymax := Long_Float(height); 409 stretch.stretch := 0.5; 410 411 -- In C / C++ the following would work, with plimagefr directly calling 412 -- mypltr. For compatibilty with other language bindings the same effect 413 -- can be achieved by generating the transformed grid first and then 414 -- using pltr2. 415 -- plimagefr(img_f, width, height, 0., width, 0., height, 0., 0., img_min, img_max, mypltr, &stretch); 416 417 declare -- Declare block is based on runtime-determined values of width, height. 418 cgrid2 : aliased Transformation_Data_Type_2 419 (x_Last => width, 420 y_Last => height); 421 begin 422 for i in 0 .. width loop 423 for j in 0 .. height loop 424 mypltr(Long_Float(i), Long_Float(j), xx, yy, stretch); 425 cgrid2.xg(i, j) := xx; 426 cgrid2.yg(i, j) := yy; 427 end loop; 428 end loop; 429 430 plimagefr(img_f, 0.0, Long_Float(width), 0.0, Long_Float(height), 0.0, 0.0, img_min, img_max, 431 pltr2'access, cgrid2'Address); 432 end; 433 plend; 434end xtraditional20a; 435