png: enable to write transparent image with :background

irteus/euspng.c

@@ -140,16 +140,45 @@ pointer PNG_WRITE_IMAGE(register context *ctx, int n, register pointer *argv)
   char *file_name;
   png_bytep image_ptr;
   int width, height, channels;
-  ckarg(5);
+  pointer bg;
+  ckarg2(5,6);
   if (isstring(argv[0])) file_name = (char *)(argv[0]->c.str.chars);
   else error(E_NOSTRING);
   width  = ckintval(argv[1]);
   height = ckintval(argv[2]);
   channels  = ckintval(argv[3]);
-  image_ptr = (png_bytep)(argv[4]->c.str.chars);
+
+  if (n==6 && argv[5]!=NIL) {  /* set background color */
+    bg = argv[5];
+    if (!isfltvector(bg)) error(E_NOVECTOR);
+    if (3!=vecsize(bg)) error(E_VECSIZE);
+  }else{
+    bg=NIL;
+  }
+
+  if(bg==NIL) {
+    image_ptr = (png_bytep)(argv[4]->c.str.chars);
+  } else {
+    png_byte bg_r=bg->c.fvec.fv[0]*255, bg_g=bg->c.fvec.fv[1]*255, bg_b=bg->c.fvec.fv[2]*255;
+    image_ptr = malloc(width*height*4);
+    for(int y = 0; y < height; y++) {
+      for(int x = 0; x < width; x++) {
+        png_byte r, g, b;
+        r = (png_bytep)(argv[4]->c.str.chars)[(y*width+x)*3+0];
+        g = (png_bytep)(argv[4]->c.str.chars)[(y*width+x)*3+1];
+        b = (png_bytep)(argv[4]->c.str.chars)[(y*width+x)*3+2];
+        image_ptr[(y*width+x)*4+0] = r;
+        image_ptr[(y*width+x)*4+1] = g;
+        image_ptr[(y*width+x)*4+2] = b;
+        image_ptr[(y*width+x)*4+3] = ((r==bg_r)&&(g==bg_g)&&(b==bg_b))?0:255;
+      }
+    }
+  }
+
   FILE *fp = fopen(file_name, "wb");
   if (!fp) {
     error(E_OPENFILE);
+    if(bg!=NIL) {free(image_ptr);}
     return(NIL);
   }
 
@@ -161,12 +190,13 @@ pointer PNG_WRITE_IMAGE(register context *ctx, int n, register pointer *argv)
   if (setjmp(png_jmpbuf(png_ptr))) {
     png_destroy_write_struct(&png_ptr, &info_ptr);
     fclose(fp);
+    if(bg!=NIL) {free(image_ptr);}
     error(E_EOF);
     return(NIL);
   }
 
   png_init_io(png_ptr, fp);
-  png_set_IHDR(png_ptr, info_ptr, width, height, 8, PNG_COLOR_TYPE_RGB, //GRAY
+  png_set_IHDR(png_ptr, info_ptr, width, height, 8, (bg==NIL)?PNG_COLOR_TYPE_RGB:PNG_COLOR_TYPE_RGB_ALPHA, //GRAY
                PNG_INTERLACE_NONE, PNG_COMPRESSION_TYPE_BASE, PNG_FILTER_TYPE_BASE);
   png_bytep * row_pointers = (png_bytep*) malloc(sizeof(png_bytep) * height);
   int y, byte_per_scanline = png_get_rowbytes(png_ptr, info_ptr);
@@ -183,6 +213,7 @@ pointer PNG_WRITE_IMAGE(register context *ctx, int n, register pointer *argv)
 
   fclose(fp);
 
+  if(bg!=NIL) {free(image_ptr);}
   return (T);
 }
 

irteus/irtimage.l

@@ -61,14 +61,14 @@
    (t (warn ";; Could not find file ~A~%" fname)
       (return-from read-image-file nil))))
 
-(defun write-image-file (fname img)
+(defun write-image-file (fname img &optional background)
   "write img to given fname"
   (cond
    ((or (string= (pathname-type fname) "jpg")
         (string= (pathname-type fname) "jpeg"))
     (write-jpeg-file fname img))
    ((string= (pathname-type fname) "png")
-    (write-png-file fname img))
+    (write-png-file fname img background))
    (t
     (write-pnm-file fname img))))
 

irteus/irtviewer.l

@@ -534,12 +534,14 @@
                         (t "000000")))
      ))
   (:save-image
-   (filename)
-   "save curent view to image, supported formats are jpg/png/pnm"
+   (filename &key background)
+   "save curent view to image, supported formats are jpg/png/pnm,
+    png supports transparent image with background. To use this feature, set :change-background #f(0 1 0) and specify #f(0 1 0) as background"
    (user::write-image-file filename
                            (send viewer :viewsurface :getglimage
                                  :width (- (send viewer :viewsurface :width) 1)
-                                 :height (send viewer :viewsurface :height))))
+                                 :height (send viewer :viewsurface :height))
+                           background))
   )
 
 (defun draw-things (objs)

irteus/png.l

@@ -62,14 +62,15 @@
         img)
     nil))
 
-(defun write-png-file (fname img)
+(defun write-png-file (fname img &optional background)
   (let (byte-depth)
     (cond
      ((derivedp img grayscale-image) (setq byte-depth 1))
      ((derivedp img color-image24) (setq byte-depth (send img :byte-depth)))
      (t (error ";; write-png-file: unsupported image type ~A" img)))
   (png-write-image fname (send img :width) (send img :height) byte-depth
-                   (send img :entity))
+                   (send img :entity) background
+                   )
   ))
 
 (provide :png "@(#)$Id$")