/* Interpretation of generic GDL images for Xconq.
   Copyright (C) 1994-1998 Stanley T. Shebs.

Xconq is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.  See the file COPYING.  */

/* Note!  This file does not use the standard "conq.h" header, so can't assume
   all the usual definitions. */
 
#include "config.h"
#include "misc.h"
#include "lisp.h"
#include "imf.h"
extern Image *largest_image PARAMS ((ImageFamily *imf));

extern void syntax_error PARAMS ((Obj *x, char *msg));

/* RGB above this value should be considered white. */

#define WHITE_THRESHOLD (65535 - 256)

/* RGB below this value should be considered black. */

#define BLACK_THRESHOLD (    0 + 255)

/* (should remove these fixed limits someday) */

#define MAXIMAGEFAMILIES 1000

#define MAXIMAGEPALETTES 100

enum {
    K_MONO_,
    K_MASK_,
    K_COLR_,
    K_OTHER_
};

static ImageFamily *new_imf PARAMS ((char *name));
static Image *add_shrunken_image PARAMS ((ImageFamily *imf));
static Image *add_magnified_image PARAMS ((ImageFamily *imf));
static int bitmaps_match PARAMS ((int w, int h, Obj *lispdata, char *rawdata));
static int color_matches_mono PARAMS ((Image *img));
static void write_pixmap PARAMS ((FILE *fp, int w, int h, int aw, int ah,
				 int pixelsize,
				 Obj *palette, int *rawpalette, int numcolors,
				 Obj *lispdata, char *rawdata));
static void write_bitmap PARAMS ((FILE *fp, char *subtyp, int w, int h,
				 Obj *data, char *rawdata));
static void write_palette_contents PARAMS ((FILE *fp, Obj *palette,
					    int *rawpalette, int numcolors));
static void write_color PARAMS ((FILE *fp, int n, int r, int g, int b));

/* This is the array and count of known image families. */

ImageFamily **images;

int numimages = 0;

/* This is the array and count of named palettes. */

ImagePalette **palettes;

int numpalettes = 0;

/* Head of the linked list of image files. */

ImageFile *image_files;

ImageFamily *(*imf_load_hook) PARAMS ((ImageFamily *imf));

ImageFamily *(*imf_interp_hook) PARAMS ((ImageFamily *imf, Image *img, int force));

short write_synthetic_also;

/* Create and return an image family. */

static ImageFamily *
new_imf(name)
char *name;
{
    ImageFamily *imf;

    imf = (ImageFamily *) xmalloc(sizeof(ImageFamily));
    imf->name = name;
    imf->notes = lispnil;
    return imf;
}

ImageFamily *
clone_imf(imf)
ImageFamily *imf;
{
    Image *img, *img2, *truenext;
    ImageFamily *imf2;

    imf2 = new_imf(imf->name);
    memcpy(imf2, imf, sizeof(ImageFamily));
    /* Clear the hook, we expect that the caller of this routine will
       supply any new hook that might be necessary. */
    imf2->hook = NULL;
    imf2->images = NULL;
    /* Clone the images. */
    for_all_images(imf, img) {
	img2 = get_img(imf2, img->w, img->h);
	truenext = img2->next;
	memcpy(img2, img, sizeof(Image));
	/* Clear the hook, we expect that the caller of this routine
	   will supply any new hook that might be necessary. */
	img2->hook = NULL;
	/* Restore the link. */
	img2->next = truenext;
	/* Note that pointers to raw image data and suchlike can be
	   left as-is, since they should be shared by image clones. */
	/* (should copy anyway, for safety?) */
    }
    return imf2;
}

/* Test that the given name is a valid image family name (all alphanumeric,
   hyphens anywhere but as first char). */

int
valid_imf_name(name)
char *name;
{
    char *tmp;

    for (tmp = name; *tmp; ++tmp) {
	if (!(isalnum(*tmp)
	      || (tmp != name && *tmp == '-')))
	  return FALSE;
    }
    return TRUE;
}

/* Bash invalid chars in a prospective imf name. */

void
validify_imf_name(buf)
char *buf;
{
    char *tmp;

    for (tmp = buf; *tmp; ++tmp) {
	if (tmp == buf && *tmp == '-')
	  *tmp = 'Z';
	if (!isalnum(*tmp) && *tmp != '-')
	  *tmp = '-';
    }
}

/* Given a name, find or create an image family with that name. */

ImageFamily *
get_imf(name)
char *name;
{
    ImageFamily *imf = NULL;
    
    if (name == NULL) {
	init_warning("can't get an unnamed image family");
	return NULL;
    }
    if (!valid_imf_name(name)) {
	init_warning("\"%s\" is not a valid image family name", name);
	return NULL;
    }
    if (images == NULL) {
	images =
	  (ImageFamily **) xmalloc(MAXIMAGEFAMILIES * sizeof(ImageFamily *));
    }
    imf = find_imf(name);
    if (imf == NULL) {
	if (numimages >= MAXIMAGEFAMILIES) {
	    return NULL;
	}
	imf = new_imf(copy_string(name));
	if (imf != NULL) {
	    images[numimages++] = imf;
	}
    }
    return imf;
}

ImageFile *
get_image_file(name)
char *name;
{
    ImageFile *imfile;
    
    if (name == NULL)
      run_error("can't get an unnamed image file");
    for (imfile = image_files; imfile != NULL; imfile = imfile->next) {
	if (strcmp(name, imfile->name) == 0)
	  return imfile;
    }
    imfile = (ImageFile *) xmalloc(sizeof(ImageFile));
    imfile->name = copy_string(name);
    imfile->next = image_files;
    image_files = imfile;
    return imfile;
}

void
load_image_families(fp, loadnow, callback)
FILE *fp;
int loadnow;
void (*callback) PARAMS ((ImageFamily *imf, int loadnow));
{
    int done = FALSE, rslt, first = TRUE;
    char buf[BUFSIZE], *buf1, *buf2, *tmp;
    ImageFamily *imf = NULL;
    ImageFile *imfile;
    
    while (!done) {
	/* Get a line from the file and parse it. */
	if (fgets(buf, BUFSIZE-1, fp)) {
	  buf1 = buf;
	  buf2 = strchr(buf, ' ');
	  if (buf2 == NULL)
	    break;
	  *buf2 = '\0';
	  ++buf2;
	  tmp = strchr(buf2, '\n');
	  if (tmp)
	    *tmp = '\0';
	} else
	  break;
	if (strcmp(buf1, ".") == 0
	    && strcmp(buf2, ".") == 0)
	  done = TRUE;
	else if (first) {
	    if (strcmp(buf1, "ImageFamilyName") == 0
		&& strcmp(buf2, "FileName") == 0)
	      first = FALSE;
	    else {
		init_warning("File not a valid imf dir, will close and ignore");
		/* We've already given a warning message, so pretend we're done
		   so the format error message doesn't get displayed below. */
		done = TRUE;
		break;
	    }
	} else {
	    imf = get_imf(buf1);
	    if (imf != NULL) {
		imfile = get_image_file(buf2);
		imf->location = imfile;
		if (loadnow && !imfile->loaded) {
		    load_imf_file(imfile->name, callback);
		    imfile->loaded = TRUE;
		} else {
		    if (callback != NULL)
		      (*callback)(imf, loadnow);
		}
	    }
	}
    }
    if (!done) {
	init_warning("Format error in imf dir near %s, will only use part",
		     (imf ? imf->name : "???"));
    }
}

/* Given a filename, open it and read/interpret all the image-related
   forms therein. */

int
load_imf_file(filename, callback)
char *filename;
void (*callback) PARAMS ((ImageFamily *imf, int loadnow));
{
    int startlineno = 1, endlineno = 1;
    Obj *form;
    FILE *fp;

    fp = fopen(filename, "r");
    if (fp != NULL) {
	/* Read everything in the file. */
	while ((form = read_form(fp, &startlineno, &endlineno)) != lispeof) {
	    interp_imf_form(form, callback);
	}
	fclose(fp);
	return TRUE;
    }
    return FALSE;
}

/* Interpret a form, looking specifically for image-related forms. */

void
interp_imf_form(form, imf_callback)
Obj *form;
void (*imf_callback) PARAMS ((ImageFamily *imf, int loadnow));
{
    Obj *head;
    ImageFamily *imf;

    /* Ignore any non-lists, we might be reading from a normal game design. */
    if (!consp(form))
      return;
    head = car(form);
    if (match_keyword(head, K_IMF)) {
	imf = interp_imf(form);
	if (imf_callback != NULL && imf != NULL)
	  (*imf_callback)(imf, TRUE);
    } else if (match_keyword(head, K_PALETTE)) {
	interp_palette(form);
    } else {
	/* Ignore any non-image forms, we might be reading from a 
	   normal game design. */
    }
}

/* Find the image family of the given name, if it exists. */

ImageFamily *
find_imf(name)
char *name;
{
    int i;

    for (i = 0; i < numimages; ++i) {
	if (strcmp(name, images[i]->name) == 0)
	  return images[i];
    }
    return NULL;
}

/* Get an image of the given size from the family, creating a new one
   if necessary. */

Image *
get_img(imf, w, h)
ImageFamily *imf;
int w, h;
{
    Image *img, *nimg, *previmg;

    for_all_images(imf, img) {
	if (w == img->w && h == img->h)
	  return img;
    }
    /* Not found; create a new image and add it to the family. */
    nimg = (Image *) xmalloc(sizeof(Image));
    nimg->w = w;  nimg->h = h;
    nimg->embedx = nimg->embedy = -1;
    nimg->embedw = nimg->embedh = -1;
    nimg->monodata = nimg->colrdata = nimg->maskdata = lispnil;
    nimg->palette = lispnil;
    nimg->actualw = w;  nimg->actualh = h;
    nimg->notes = lispnil;
    nimg->bboxw = w;  nimg->bboxh = h;
    /* Rely on zeroing of xmalloc blocks to avoid clearing other fields. */
    /* Link in order by size, smallest first. */
    previmg = NULL;
    for_all_images(imf, img) {
	if ((nimg->w < img->w) || (nimg->w == img->w && nimg->h < img->h))
	  break;
	previmg = img;
    }
    if (previmg != NULL) {
	nimg->next = previmg->next;
	previmg->next = nimg;
    } else {
	nimg->next = imf->images;
	imf->images = nimg;
    }
    ++(imf->numsizes);
    return nimg;
}

Image *
find_img(imf, w, h)
ImageFamily *imf;
int w, h;
{
    Image *img;
	
    for_all_images(imf, img) {
	if (w == img->w && h == img->h)
	  return img;
    }
    return NULL;
}

ImageFamily *
interp_imf(form)
Obj *form;
{
    ImageFamily *imf;

    if (stringp(cadr(form))) {
	imf = get_imf(c_string(cadr(form)));
	if (imf != NULL) {
	    interp_imf_contents(imf, cddr(form));
	}
	return imf;
    } else {
	run_warning("image family name must be a string");
    }
    return NULL;
}

void
interp_imf_contents(imf, clauses)
ImageFamily *imf;
Obj *clauses;
{
    Obj *rest, *clause;

    for_all_list(clauses, rest) {
	clause = car(rest);
	if (consp(clause)) {
	    if (symbolp(car(clause))) {
		if (match_keyword(car(clause), K_NOTES)) {
		    imf->notes = cadr(clause);
		    syntax_error(clause, "extra junk after property value");
		} else {
		    syntax_error(clause, "unknown image family property");
		}
	    } else if (consp(car(clause))) {
		interp_image(imf, car(clause), cdr(clause));
	    } else {
		syntax_error(clause, "not image or image family property");
	    }
	} else {
	    syntax_error(clause, "bogus clause");
	}
    }
    compute_image_bboxes(imf);
}

void
interp_image(imf, size, parts)
ImageFamily *imf;
Obj *size, *parts;
{
    int w, h, imtype, emx, emy, emw, emh;
    char *name;
    Image *img;
    Obj *head, *rest, *typ, *prop, *proptype, *datalist;
    
    w = c_number(car(size));  h = c_number(cadr(size));
    img = get_img(imf, w, h);
    if (img == NULL)
      run_error("no image?");
    if (img->w == 1 && img->h == 1) {
	/* A color is more like a tile than an icon. */
	img->istile = TRUE;
	img->palette = cons(cons(new_number(0), parts), lispnil);
	return;
    }
    if (match_keyword(car(cddr(size)), K_TILE))
      img->istile = TRUE;
    for_all_list(parts, rest) {
	head = car(rest);
	typ = car(head);
	imtype = K_OTHER_;
	if (match_keyword(typ, K_MONO)) {
	    imtype = K_MONO_;
	} else if (match_keyword(typ, K_MASK)) {
	    imtype = K_MASK_;
	} else if (match_keyword(typ, K_COLOR)) {
	    imtype = K_COLR_;
	} else if (match_keyword(typ, K_EMBED)) {
	    name = c_string(cadr(head));
	    if (img->embedname != NULL
		&& strcmp(img->embedname, name) != 0)
	      run_warning("Changing embed name from \"%s\" to \"%s\" in %dx%d image of \"%s\"",
			  img->embedname, name, w, h, imf->name);
	    img->embedname = name;
	} else if (match_keyword(typ, K_EMBED_AT)) {
	    emx = c_number(cadr(head));  emy = c_number(caddr(head));
	    if ((img->embedx >= 0 && emx != img->embedx)
		|| (img->embedy >= 0 && emy != img->embedy))
	      run_warning("Changing embed x,y from %d,%d to %d,%d in %dx%d image of \"%s\"",
			  img->embedx, img->embedy, emx, emy, w, h, imf->name);
	    img->embedx = emx;  img->embedy = emy;
	} else if (match_keyword(typ, K_EMBED_SIZE)) {
	    emw = c_number(cadr(head));  emh = c_number(caddr(head));
	    if ((img->embedw >= 0 && emw != img->embedw)
		|| (img->embedh >= 0 && emh != img->embedh))
	      run_warning("Changing embed w,h from %d,%d to %d,%d in %dx%d image of \"%s\"",
			  img->embedw, img->embedh, emw, emh, w, h, imf->name);
	    img->embedw = emw;  img->embedh = emh;
	} else if (match_keyword(typ, K_NOTES)) {
	    img->notes = cadr(head);
	    syntax_error(head, "extra junk after image notes property");
	} else {
	    run_warning("unknown image property in \"%s\"", imf->name);
	}
	if (imtype == K_OTHER_)
	  continue;
	datalist = cdr(head);
	/* Interpret random image subproperties. */
	while (consp(car(datalist))) {
	    prop = car(datalist);
	    proptype = car(prop);
	    if (match_keyword(proptype, K_ACTUAL)) {
		img->actualw = c_number(cadr(prop));
		img->actualh = c_number(caddr(prop));
	    } else if (match_keyword(proptype, K_PIXEL_SIZE)) {
		img->pixelsize = c_number(cadr(prop));
	    } else if (match_keyword(proptype, K_PALETTE)) {
		if (img->palette != lispnil && !equal(cdr(prop), img->palette))
		  run_warning("Changing palette in %dx%d image of \"%s\"",
			      w, h, imf->name);
		img->palette = cdr(prop);
	    } else {
		run_warning("unknown image subproperty in \"%s\"", imf->name);
	    }
	    datalist = cdr(datalist);
	}
	switch (imtype) {
	  case K_MONO_:
	    if (img->monodata != lispnil && !equal(datalist, img->monodata))
	      run_warning("Changing mono data in %dx%d image of \"%s\"",
			  w, h, imf->name);
	    img->monodata = datalist;
	    break;
	  case K_COLR_:
	    if (img->colrdata != lispnil && !equal(datalist, img->colrdata))
	      run_warning("Changing color data in %dx%d image of \"%s\"",
			  w, h, imf->name);
	    img->colrdata = datalist;
	    break;
	  case K_MASK_:
	    if (img->maskdata != lispnil && !equal(datalist, img->maskdata))
	      run_warning("Changing mask data in %dx%d image of \"%s\"",
			  w, h, imf->name);
	    img->maskdata = datalist;
	    break;
	  default:
	    break;
	}
    }
}

void
compute_image_bboxes(imf)
ImageFamily *imf;
{
    Image *img;

    if (imf == NULL)
      return;
    for_all_images(imf, img) {
	compute_image_bbox(img);
    }
}

void
compute_image_bbox(img)
Image *img;
{
    int numbytes, i, j = 0, byte, x, y, x1, x2, k;
    int xmin, ymin, xmax, ymax;
    char *data = NULL;
    Obj *datalist, *next;

    datalist = img->maskdata;
    numbytes = img->h * computed_rowbytes(img->w, 1);
    x = y = 0;
    xmin = img->w;  ymin = img->h;
    xmax = 0;  ymax = 0;
    for (i = 0; i < numbytes; ++i) {
	if (img->maskdata != lispnil) {
	    if (data == NULL || data[j] == '\0') {
		next = car(datalist);
		if (!stringp(next)) {
		    syntax_error(datalist, "garbage in image data list");
		    return;
		}
		data = c_string(next);
		j = 0;
		datalist = cdr(datalist);
	    }
	    /* Just skip over slashes, which are for readability only. */
	    if (data[j] == '/')
	      ++j;
	    byte = hextoi(data[j]) * 16 + hextoi(data[j+1]);
	    j += 2;
	} else if (img->rawmaskdata != NULL) {
	    byte = img->rawmaskdata[i] & 0xff;
	} else {
	    byte = 0xff;
	}
	if (byte != 0) {
	    /* Find the most-significant and least-significant bits in
	       the mask byte. */
	    x1 = x2 = -1;
	    k = 0;
	    while (byte != 0) {
		if ((byte & 0x1) != 0 && x2 < 0)
		  x2 = x + 7 - k;
		byte >>= 1;
		if (byte == 0 && x1 < 0)
		  x1 = x + 7 - k;
		++k;
	    }
	    xmin = min(x1, xmin);  ymin = min(y, ymin);
	    xmax = max(x2, xmax);  ymax = max(y, ymax);
	}
	x += 8;
	if (x >= img->w) {
	    x = 0;
	    ++y;
	}
    }
    /* Compute position and size of bounding box. */
    if (xmin <= xmax && ymin <= ymax) {
	img->bboxx = xmin;  img->bboxy = ymin;
	img->bboxw = xmax - xmin;  img->bboxh = ymax - ymin;
    }
}

extern int image_pixel_at PARAMS ((Image *img, int imtype, int x, int y));

extern void set_image_pixel_at PARAMS ((Image *img, int imtype, int x, int y, int val));

int
image_pixel_at(img, imtype, x, y)
Image *img;
int imtype, x, y;
{
    int rowbytes, psize, i, byte, rslt;
    char *rawdata = NULL;

    if (imtype == K_MONO_) {
	rawdata = img->rawmonodata;
	psize = 1;
    } else if (imtype == K_MASK_) {
	rawdata = img->rawmaskdata;
	psize = 1;
    } else {
	rawdata = img->rawcolrdata;
	psize = img->pixelsize;
    }
    if (rawdata != NULL) {
	rowbytes = computed_rowbytes(img->w, psize);
	i = y * rowbytes + ((x * psize) >> 3);
	byte = rawdata[i];
	rslt = (byte >> ((8 - psize) - ((x * psize) & 0x7))) & ((1 << psize) - 1);
	return rslt;
    }
}

void
set_image_pixel_at(img, imtype, x, y, val)
Image *img;
int imtype, x, y, val;
{
    int rowbytes, psize, i, byte;
    char *rawdata = NULL;

    if (imtype == K_MONO_) {
	rawdata = img->rawmonodata;
	psize = 1;
    } else if (imtype == K_MASK_) {
	rawdata = img->rawmaskdata;
	psize = 1;
    } else {
	rawdata = img->rawcolrdata;
	psize = img->pixelsize;
    }
    if (rawdata != NULL) {
	rowbytes = computed_rowbytes(img->w, psize);
	i = y * rowbytes + ((x * psize) >> 3);
	byte = rawdata[i];
	byte |= val << ((8 - psize) - ((x * psize) & 0x7));
	rawdata[i] = byte;
    }
}

/* If an image family includes no small images (16x16 or less), then
   add an image that is half the size of the smallest image in the
   family. */

static Image *
add_shrunken_image(imf)
ImageFamily *imf;
{
    int numbytes, numbytes2, x, y, sum;
    Image *img, *img2;

    if (imf == NULL)
      return NULL;
    img = smallest_image(imf);
    /* Don't try to shrink tiles or already-shrunken images or very
       small images. */
    if (img->istile || img->synthetic || img->w <= 8 || img->h <= 8)
      return NULL;
    img2 = get_img(imf, img->w / 2, img->h / 2);
    /* Chances are that any embedded subimage will become unrecognizable,
       so leave embedname empty. */
    if (img2->embedx > 0)
      img2->embedx = img->embedx / 2;
    if (img2->embedy > 0)
      img2->embedy = img->embedy / 2;
    if (img2->embedw > 0)
      img2->embedw = img->embedw / 2;
    if (img2->embedh > 0)
      img2->embedh = img->embedh / 2;
    img2->pixelsize = img->pixelsize;
    img2->palette = img->palette;
    img2->rawpalette = img->rawpalette;
    img2->numcolors = img->numcolors;
    img2->synthetic = TRUE;
    if (img->rawcolrdata == NULL && img->colrdata != lispnil) {
	numbytes = img->h * computed_rowbytes(img->w, img->pixelsize);
	img->rawcolrdata = xmalloc(numbytes);
	interp_bytes(img->colrdata, numbytes, img->rawcolrdata, 0);
    }
    if (img->rawcolrdata != NULL) {
	numbytes2 = img2->h * computed_rowbytes(img2->w, img2->pixelsize);
	img2->rawcolrdata = xmalloc(numbytes2);
    }
    numbytes = img->h * computed_rowbytes(img->w, 1);
    numbytes2 = img2->h * computed_rowbytes(img2->w, 1);
    /* Ensure that binary version of mono image exists. */
    /* (should make into sep. routine) */
    if (img->rawmonodata == NULL && img->monodata != lispnil) {
	img->rawmonodata = xmalloc(numbytes);
	interp_bytes(img->monodata, numbytes, img->rawmonodata, 0);
    }
    if (img->rawmonodata != NULL)
      img2->rawmonodata = xmalloc(numbytes2);
    /* Ensure that binary version of mask exists. */
    if (img->rawmaskdata == NULL && img->maskdata != lispnil) {
	img->rawmaskdata = xmalloc(numbytes);
	interp_bytes(img->maskdata, numbytes, img->rawmaskdata, 0);
    }
    if (img->rawmaskdata != NULL)
      img2->rawmaskdata = xmalloc(numbytes2);
    /* Scan through the new image, computing each pixel separately. */
    for (x = 0; x < img2->w; ++x) {
	for (y = 0; y < img2->h; ++y) {
	    if (img2->rawcolrdata != NULL) {
		/* (should choose most common or else average colors) */
		int vals[4];
		vals[0] = image_pixel_at(img, K_COLR_, 2 * x,     2 * y);
		vals[1] = image_pixel_at(img, K_COLR_, 2 * x + 1, 2 * y);
		vals[2] = image_pixel_at(img, K_COLR_, 2 * x,     2 * y + 1);
		vals[3] = image_pixel_at(img, K_COLR_, 2 * x + 1, 2 * y + 1);
		sum = vals[0];
		if (vals[1] == vals[2] || vals[1] == vals[3])
		  sum = vals[1];
		else if (vals[2] == vals[3])
		  sum = vals[2];
		set_image_pixel_at(img2, K_COLR_, x, y, sum);
	    }
	    /* Add to the mono image if 2 or more of the 4 original
	       bits are on. */
	    if (img2->rawmonodata != NULL) {
		sum = 0;
		sum += image_pixel_at(img, K_MONO_, 2 * x,     2 * y);
		sum += image_pixel_at(img, K_MONO_, 2 * x + 1, 2 * y);
		sum += image_pixel_at(img, K_MONO_, 2 * x,     2 * y + 1);
		sum += image_pixel_at(img, K_MONO_, 2 * x + 1, 2 * y + 1);
		sum = (sum >= 2 ? 1 : 0);
		set_image_pixel_at(img2, K_MONO_, x, y, sum);
	    }
	    /* Add to the mask if any of the 4 original mask bits are on. */
	    if (img2->rawmaskdata != NULL) {
		if (   image_pixel_at(img, K_MASK_, 2 * x,     2 * y)
		    || image_pixel_at(img, K_MASK_, 2 * x + 1, 2 * y)
		    || image_pixel_at(img, K_MASK_, 2 * x,     2 * y + 1)
		    || image_pixel_at(img, K_MASK_, 2 * x + 1, 2 * y + 1))
		  set_image_pixel_at(img2, K_MASK_, x, y, 1);
	    }
	}
    }
    compute_image_bbox(img2);
    if (imf_interp_hook)
      (*imf_interp_hook)(imf, img2, FALSE);
    return img2;
}

/* Add an image twice the size of the largest image in the family, if
   the family does not already include a large image. */

static Image *
add_magnified_image(imf)
ImageFamily *imf;
{
    int numbytes, numbytes2, x, y, x2, y2;
    Image *img, *img2;

    if (imf == NULL)
      return NULL;
    img = largest_image(imf);
    if (img->istile || img->synthetic || img->w >= 64 || img->h >= 64)
      return NULL;
    img2 = get_img(imf, img->w * 2, img->h * 2);
    img2->embedname = img->embedname;
    if (img2->embedx > 0)
      img2->embedx = img->embedx * 2;
    if (img2->embedy > 0)
      img2->embedy = img->embedy * 2;
    if (img2->embedw > 0)
      img2->embedw = img->embedw * 2;
    if (img2->embedh > 0)
      img2->embedh = img->embedh * 2;
    img2->pixelsize = img->pixelsize;
    img2->palette = img->palette;
    img2->rawpalette = img->rawpalette;
    img2->numcolors = img->numcolors;
    img2->synthetic = TRUE;
    if (img->rawcolrdata == NULL && img->colrdata != lispnil) {
	numbytes = img->h * computed_rowbytes(img->w, img->pixelsize);
	img->rawcolrdata = xmalloc(numbytes);
	interp_bytes(img->colrdata, numbytes, img->rawcolrdata, 0);
    }
    if (img->rawcolrdata != NULL) {
	numbytes2 = img2->h * computed_rowbytes(img2->w, img2->pixelsize);
	img2->rawcolrdata = xmalloc(numbytes2);
    }
    numbytes = img->h * computed_rowbytes(img->w, 1);
    numbytes2 = img2->h * computed_rowbytes(img2->w, 1);
    if (img->rawmonodata == NULL && img->monodata != lispnil) {
	img->rawmonodata = xmalloc(numbytes);
	interp_bytes(img->monodata, numbytes, img->rawmonodata, 0);
    }
    if (img->rawmonodata != NULL)
      img2->rawmonodata = xmalloc(numbytes2);
    if (img->rawmaskdata == NULL && img->maskdata != lispnil ) {
	img->rawmaskdata = xmalloc(numbytes);
	interp_bytes(img->maskdata, numbytes, img->rawmaskdata, 0);
    }
    if (img->rawmaskdata != NULL)
      img2->rawmaskdata = xmalloc(numbytes2);
    for (x = 0; x < img2->w; ++x) {
	for (y = 0; y < img2->h; ++y) {
	    x2 = x >> 1;  y2 = y >> 1;
	    if (img->rawcolrdata != NULL) {
		set_image_pixel_at(img2, K_COLR_, x, y,
				   image_pixel_at(img, K_COLR_, x2, y2));
	    }
	    if (img->rawmonodata != NULL) {
		set_image_pixel_at(img2, K_MONO_, x, y,
				   image_pixel_at(img, K_MONO_, x2, y2));
	    }
	    if (img->rawmaskdata != NULL) {
		set_image_pixel_at(img2, K_MASK_, x, y,
				   image_pixel_at(img, K_MASK_, x2, y2));
	    }
	}
    }
    compute_image_bbox(img2);
    if (imf_interp_hook)
      (*imf_interp_hook)(imf, img2, FALSE);
    return img2;
}

/* Given a list of strings, interpret the hex digits and put the
   results at the given address. */

void
interp_bytes(datalist, numbytes, destaddr, jump)
Obj *datalist;
int numbytes, jump;
char *destaddr;
{
    int i, j = 0;
    char *data = NULL;

    for (i = 0; i < numbytes; ++i) {
	if (data == NULL || data[j] == '\0') {
	    if (datalist == lispnil) {
		return;
	    } else if (stringp(car(datalist))) {
		data = c_string(car(datalist));
		j = 0;
	    } else {
		syntax_error(datalist, "Non-string in image data list");
		/* Have to give up now. */
		return;
	    }
	    datalist = cdr(datalist);
	}
	/* Just skip over slashes, which are for readability only. */
	if (data[j] == '/')
	  ++j;
	destaddr[i] = hextoi(data[j]) * 16 + hextoi(data[j+1]);
	if (jump == 1 || (jump > 0 && i % jump == 0)) {
	    i += jump;
	    /* Be neat, put a zero in the location we're jumping over. */
	    /* (doesn't work for jump > 1, but that never happens anymore?) */
	    destaddr[i] = 0;
	}
	j += 2;
    }
}

ImagePalette *
interp_palette(form)
Obj *form;
{
    Obj *elts;
    ImagePalette *imp;

    if (stringp(cadr(form))) {
	imp = get_imp(c_string(cadr(form)));
	elts = cddr(form);
	if (consp(car(elts))
	    && symbolp(car(car(elts)))) {
	    if (match_keyword(car(car(elts)), K_NOTES)) {
		imp->notes = cadr(car(elts));
	    } else {
	    }
	    elts = cdr(elts);
	}
	return imp;
    }
    return NULL;
}

ImagePalette *
new_image_palette(name)
char *name;
{
    ImagePalette *imp;

    imp = (ImagePalette *) xmalloc(sizeof(ImagePalette));
    imp->name = name;
    imp->notes = lispnil;
    imp->palette = lispnil;
    return imp;
}

char *
canonical_palette_name(str)
char *str;
{
    return str;
}

/* Given a name, find or create an image palette with that name. */

ImagePalette *
get_imp(name)
char *name;
{
    ImagePalette *imp = NULL;

    if (name == NULL)
      return NULL;
    if (palettes == NULL)
      palettes =
	(ImagePalette **) xmalloc(MAXIMAGEPALETTES * sizeof(ImagePalette *));
    if ((imp = find_imp(name)) == NULL) {
	if (numpalettes >= MAXIMAGEPALETTES)
	  return NULL;
	imp = new_image_palette(canonical_palette_name(name));
	if (imp != NULL) {
	    palettes[numpalettes++] = imp;
	}
    }
    return imp;
}

/* Find the image palette of the given name, if it exists. */

ImagePalette *
find_imp(name)
char *name;
{
    int i;

    for (i = 0; i < numpalettes; ++i) {
	if (strcmp(name, palettes[i]->name) == 0)
	  return palettes[i];
    }
    return NULL;
}


/* Try to find the best of multiple images for the given bounding box.
   Don't return anything that won't fit in min space. */

Image *
best_image(imf, w, h)
ImageFamily *imf;
int w, h;
{
    Image *img, *best = NULL, *fallback;

    if (imf == NULL || imf->images == NULL)
      return NULL;
    if (imf->images->istile) {
	/* For tiles, always use the largest available. */
	/* (should test depth also...) */
	for_all_images(imf, img) {
	    if (best == NULL || (img->w > best->w && img->h > best->h))
	      best = img;
	}
    } else {
	for_all_images(imf, img) {
	    /* Exact matches need no further searching. */
	    if (w == img->w && h == img->h)
	      return img;
	    if (best == NULL
		|| (img->w < w && img->h < h
		    && img->w > best->w && img->h > best->h))
	      best = img;
	}
	if (best->w > w && best->h > h) {
	    best = add_shrunken_image(imf);
	} else if (best->w <= (w >> 1) && best->h <= (h >> 1)) {
	    fallback = add_magnified_image(imf);
	    if (fallback != NULL)
	      best = fallback;
	}
    }
    return best;
}

Image *
smallest_image(imf)
ImageFamily *imf;
{
    Image *img, *smallest = NULL;

    if (imf == NULL)
      return NULL;
    for_all_images(imf, img) {
	if (smallest == NULL || (img->w < smallest->w && img->h < smallest->h))
	  smallest = img;
    }
    return smallest;
}

Image *
largest_image(imf)
ImageFamily *imf;
{
    Image *img, *largest = NULL;

    if (imf == NULL)
      return NULL;
    for_all_images(imf, img) {
	if (largest == NULL || (img->w > largest->w && img->h > largest->h))
	  largest = img;
    }
    return largest;
}

/* Compute the right location for the given emblem and unit images. */

static int tmpbw;  /* work around Think C bug */

int
emblem_position(uimg, ename, eimg, sw, sh, exxp, eyyp, ewp, ehp)
Image *uimg, *eimg;
char *ename;
int sw, sh, *exxp, *eyyp, *ewp, *ehp;
{
    int ex, ey, ew, eh, bx, by, bw, bh, overlap;

    if (uimg
	&& uimg->embedname
	&& ename != NULL
	&& strcmp(uimg->embedname, ename) == 0) {
	/* Correct emblem is part of the unit's image, don't need to draw. */
	return FALSE;
    }
    /* (should use emblem bbox to help calc) */
    /* Get the size of the emblem, either from the image or by computing
       a reasonable default. */
    if (uimg && uimg->embedw > 0 && uimg->embedh > 0) {
	ew = uimg->embedw;  eh = uimg->embedh;
    } else {
	ew = min(sw, max(8, sw / 4));  eh = min(sh, max(8, sh / 4));
    }
    /* Position the emblem, either explicitly, or default to UR corner
	   (note that we need the emblem's width to do this) */
    if (uimg && uimg->embedx >= 0 && uimg->embedy >= 0) {
	ex = uimg->embedx;  ey = uimg->embedy;
    } else if (uimg && (uimg->bboxw != uimg->w || uimg->bboxh != uimg->h)) {
	overlap = FALSE;
	/* Scale bounding box by space given to image. */
	bx = (uimg->bboxx * sw) / uimg->w;  by = (uimg->bboxy * sh) / uimg->h;
	tmpbw = (uimg->bboxw * sw) / uimg->w;
	bh = (uimg->bboxh * sh) / uimg->h;
	bw = tmpbw;
	/* Position the emblem outside the image's bbox if possible,
	   moving in if necessary to stay inside the image's allowed
	   area (sw x sh). */
	ex = bx + bw;
	if (ex + ew > sw) {
	    /* Emblem too wide to fit between unit bbox and edge of
	       area; butt it against edge of area, note the
	       overlap. */
	    ex = sw - ew;
	    overlap = TRUE;
	}
	if (ex < 0)
	  ex = 0;
	ey = by;
	if (overlap)
	  ey -= eh;
	if (ey + eh > sh)
	  ey = sh - eh;
	if (ey < 0)
	  ey = 0;
    } else {
	ex = sw - ew;  ey = 0;
    }
    /* Return the results. */
    *exxp = ex;  *eyyp = ey;
    *ewp = ew;  *ehp = eh;
    return TRUE;
}

/* The comparison function for the image list just does "strcmp" order
   and *requires* that all image families be named and named uniquely. */

static int
image_name_compare(imf1, imf2)
#ifdef THINK_C
const
#endif
void *imf1, *imf2;
{
    return strcmp((*((ImageFamily **) imf1))->name,
		  (*((ImageFamily **) imf2))->name);
}

void
sort_all_images()
{
    qsort(&(images[0]), numimages, sizeof(ImageFamily *), image_name_compare);
}

/* The comparison function for the palette list just does "strcmp" order
   and *requires* that all image palettes be named and named uniquely. */

static int
palette_name_compare(imp1, imp2)
#ifdef THINK_C
const
#endif
void *imp1, *imp2;
{
    return strcmp((*((ImagePalette **) imp1))->name,
		  (*((ImagePalette **) imp2))->name);
}

void
sort_all_palettes()
{
    qsort(&(palettes[0]), numpalettes, sizeof(ImagePalette *), palette_name_compare);
}

/* Check Lisp-format and binary-format data for consistency. */

void
check_imf(imf)
ImageFamily *imf;
{
    Image *img;
    
    if (imf == NULL)
      return;
    if (imf->name == NULL) {
	return;
    }
    for_all_images(imf, img) {
	/* Check consistency of Lisp and binary data. */
	if (img->colrdata != lispnil && img->rawcolrdata) {
	    /* (should add color image comparison) */
	}
	if (img->monodata != lispnil && img->rawmonodata) {
	    if (!bitmaps_match(img->w, img->h, img->monodata, img->rawmonodata))
	      run_warning("mono bitmap data not consistent in  %dx%d image of \"%s\"",
			  img->w, img->h, imf->name);
	}
	if (img->maskdata != lispnil && img->rawmaskdata) {
	    if (!bitmaps_match(img->w, img->h, img->maskdata, img->rawmaskdata))
	      run_warning("mask bitmap data not consistent in  %dx%d image of \"%s\"",
			  img->w, img->h, imf->name);
	}
    }
}

static int
bitmaps_match(w, h, lispdata, rawdata)
int w, h;
Obj *lispdata;
char *rawdata;
{
    int i, j = 0, rowbytes, numbytes, byte, jump = 0;
    char *datastr = NULL;

    rowbytes = computed_rowbytes(w, 1);
    numbytes =  h * rowbytes;
    for (i = 0; i < numbytes; ++i) {
	if (datastr == NULL || datastr[j] == '\0') {
		if (!stringp(car(lispdata)))
		  break;
		datastr = c_string(car(lispdata));
		j = 0;
		lispdata = cdr(lispdata);
	}
	if (datastr[j] == '/')
	  ++j;
	byte = hextoi(datastr[j]) * 16 + hextoi(datastr[j+1]);
	j += 2;
	if (byte != rawdata[i])
	  return FALSE;
    }
    return TRUE;
}

/* Write the imf directory for the given set of images. */

void
write_imf_dir(filename, images, num)
char *filename;
ImageFamily **images;
int num;
{
    int i;
    char *loc;
    ImageFamily *imf;
    FILE *fp;

    fp = fopen(filename, "w");
    if (fp != NULL) {
	fprintf(fp, "ImageFamilyName FileName\n");
	for (i = 0; i < num; ++i) {
	    imf = images[i];
	    loc = "???";
	    if (imf->location && !empty_string(imf->location->name))
	      loc = imf->location->name;
	    fprintf(fp, "%s %s\n", imf->name, loc);
	    /* (to write imf files, should scan through images once for
	       each file, writing all images found that are in that file) */
	}
	fprintf(fp, ". .\n");
	fclose(fp);
    } else {
	run_warning("could not open file \"%s\" for writing", filename);
    }
}

/* Write out the entire image family. */

void
write_imf(fp, imf)
FILE *fp;
ImageFamily *imf;
{
    Obj *palent;
    Image *img;
    
    if (fp == NULL || imf == NULL)
      return;
    if (imf->name == NULL) {
	fprintf(fp, "; garbage image family?\n");
	return;
    }
    if (imf->notes != lispnil) {
	fprintf(fp, "(%s \"%s\"", keyword_name(K_IMF), imf->name);
	fprintf(fp, "\n  (%s ", keyword_name(K_NOTES));
	fprintlisp(fp, imf->notes);
	fprintf(fp, "))\n");
    }
    for_all_images(imf, img) {
	if (img->monodata != lispnil
	    || img->maskdata != lispnil
	    || img->colrdata != lispnil
	    || img->rawmonodata != NULL
	    || img->rawmaskdata != NULL
	    || img->rawcolrdata != NULL
	    || (img->w == 1 && img->h == 1)) {
	    /* Skip over synthesized images. */
	    if (img->synthetic && !write_synthetic_also)
	      continue;
	    fprintf(fp, "(%s \"%s\"", keyword_name(K_IMF), imf->name);
	    fprintf(fp, " (");
	    fprintf(fp, "(%d %d", img->w, img->h);
	    if (img->istile && !(img->w == 1 && img->h == 1))
	      fprintf(fp, " %s", keyword_name(K_TILE));
	    fprintf(fp, ")");
	    if (img->embedname) {
		fprintf(fp, " (%s \"%s\")",
			keyword_name(K_EMBED), img->embedname);
	    }
	    if (img->embedx >= 0 && img->embedy >= 0) {
		fprintf(fp, " (%s %d %d)",
			keyword_name(K_EMBED_AT), img->embedx, img->embedy);
	    }
	    if (img->embedw >= 0 && img->embedh >= 0) {
		fprintf(fp, " (%s %d %d)",
			keyword_name(K_EMBED_SIZE), img->embedw, img->embedh);
	    }
	    if (img->notes != lispnil) {
		fprintf(fp, "\n  (%s ", keyword_name(K_NOTES));
		fprintlisp(fp, img->notes);
		fprintf(fp, ")\n ");
	    }
	    /* Write a single color if that's what this image is. */
	    if (img->w == 1 && img->h == 1) {
		if (img->rawpalette != NULL) {
		    write_color(fp, -1,
				img->rawpalette[1], img->rawpalette[2], img->rawpalette[3]);
		} else if (img->palette != lispnil) {
		    palent = cdr(car(img->palette));
		    if (stringp(car(palent)) || symbolp(car(palent))) {
			fprintf(fp, " %s", c_string(car(palent)));
		    } else {
			write_color(fp, -1,
				    c_number(car(palent)),
				    c_number(cadr(palent)),
				    c_number(caddr(palent)));
		    }
		}
	    } else if ((img->colrdata != lispnil || img->rawcolrdata)
			&& !color_matches_mono(img)) {
		fprintf(fp, "\n  ");
		write_pixmap(fp, img->w, img->h, img->actualw, img->actualh,
			     img->pixelsize,
			     img->palette, img->rawpalette, img->numcolors,
			     img->colrdata, img->rawcolrdata);
	    }
	    if (img->monodata != lispnil || img->rawmonodata) {
		fprintf(fp, "\n  ");
		write_bitmap(fp, keyword_name(K_MONO), img->w, img->h,
			     img->monodata, img->rawmonodata);
	    }
	    if (img->maskdata != lispnil || img->rawmaskdata) {
		fprintf(fp, "\n  ");
		write_bitmap(fp, keyword_name(K_MASK), img->w, img->h,
			     img->maskdata, img->rawmaskdata);
	    }
	    fprintf(fp, "))\n");
	}
    }
}

/* Study an ostensibly color image to see if its color table includes
   black and white only (white first, then black), and if its data is
   the same as the mono version of the image. */

static int
color_matches_mono(img)
Image *img;
{
    int i, cj, mj, rowbytes, numbytes, cbyte, mbyte, jump = 0;
    int col[2], red[2], grn[2], blu[2];
    char *cdatastr = NULL, *mdatastr = NULL;
    Obj *clispdata = img->colrdata, *mlispdata = img->monodata, *palette;

    if (img->pixelsize != 1)
      return FALSE;

    /* No match possible if not a black-white-only palette. */
    if (img->numcolors > 2)
      return FALSE;

    if (img->rawpalette != NULL) {
	for (i = 0; i < 2; i++) {
	    col[i] = img->rawpalette[4*i+0];
	    red[i] = img->rawpalette[4*i+1];
	    grn[i] = img->rawpalette[4*i+2];
	    blu[i] = img->rawpalette[4*i+3];
	}
    } else if (img->palette != lispnil) {
	palette = img->palette;
	parse_lisp_palette_entry(car(palette), &col[0],
				 &red[0], &grn[0], &blu[0]);
	if (cdr(palette) == lispnil) {
	    /* If only one color in the palette, say the other one is
	       black. */
	    col[1] = 1;
	    red[1] = grn[1] = blu[1] = 0;
	    /* If the one color is black, say it's white. */
	    if (col[0] == 0
		&& red[0] < BLACK_THRESHOLD
		&& grn[0] < BLACK_THRESHOLD
		&& blu[0] < BLACK_THRESHOLD) {
		col[0] = 0;
		red[0] = grn[0] = blu[0] = 65535;
	    }
	} else {
	    /* Parse the second entry in the palette. */
	    parse_lisp_palette_entry(cadr(palette), &col[1],
				     &red[1], &grn[1], &blu[1]);
	}
    } else {
	return FALSE;
    }

    if (!(col[0] == 0
	  && red[0] > WHITE_THRESHOLD
	  && grn[0] > WHITE_THRESHOLD
	  && blu[0] > WHITE_THRESHOLD
	  && col[1] == 1
	  && red[1] < BLACK_THRESHOLD
	  && grn[1] < BLACK_THRESHOLD
	  && blu[1] < BLACK_THRESHOLD))
	return FALSE;

    /* Now compare the contents. */
    rowbytes = computed_rowbytes(img->w, 1);
    numbytes =  img->h * rowbytes;
    cj = mj = 0;
    for (i = 0; i < numbytes; ++i) {
	/* Extract one byte of the color image. */
	if (clispdata != lispnil) {
	    if (cdatastr == NULL || cdatastr[cj] == '\0') {
		if (!stringp(car(clispdata)))
		  break;
		cdatastr = c_string(car(clispdata));
		cj = 0;
		clispdata = cdr(clispdata);
	    }
	    if (cdatastr[cj] == '/')
	      ++cj;
	    cbyte = hextoi(cdatastr[cj]) * 16 + hextoi(cdatastr[cj+1]);
	    cj += 2;
	} else if (img->rawcolrdata != NULL) {
	    cbyte = (img->rawcolrdata)[i];
	} else {
	    return FALSE;
	}
	/* Extract one byte of the mono image. */
	if (mlispdata != lispnil) {
	    if (mdatastr == NULL || mdatastr[mj] == '\0') {
		if (!stringp(car(mlispdata)))
		  break;
		mdatastr = c_string(car(mlispdata));
		mj = 0;
		mlispdata = cdr(mlispdata);
	    }
	    if (mdatastr[mj] == '/')
	      ++mj;
	    mbyte = hextoi(mdatastr[mj]) * 16 + hextoi(mdatastr[mj+1]);
	    mj += 2;
	} else if (img->rawmonodata != NULL) {
	    mbyte = (img->rawmonodata)[i];
	} else {
	    return FALSE;
	}
	/* Compare the bytes. */
	if (cbyte != mbyte)
	  return FALSE;
    }
    return TRUE;
}

static void
write_pixmap(fp, w, h, actualw, actualh, pixelsize,
	     palette, rawpalette, numcolors, lispdata, rawdata)
FILE *fp;
int w, h, actualw, actualh, pixelsize, *rawpalette, numcolors;
Obj *palette, *lispdata;
char *rawdata;
{
    int dolisp, i, j = 0, rowbytes, numbytes, byte;
    char *datastr = NULL;

    actualw = (actualw != 0 ? actualw : w);
    actualh = (actualh != 0 ? actualh : h);
    dolisp = (lispdata != lispnil);
    rowbytes = computed_rowbytes(actualw, pixelsize);
    numbytes = actualh * rowbytes;
    fprintf(fp, "(%s", keyword_name(K_COLOR));
    if (actualw != w || actualh != h)
      fprintf(fp, " (%s %d %d)", keyword_name(K_ACTUAL), actualw, actualh);
    fprintf(fp, " (%s %d)", keyword_name(K_PIXEL_SIZE), pixelsize);
    if (palette != lispnil || (rawpalette && numcolors))
      write_palette_contents(fp, palette, rawpalette, numcolors);
    fprintf(fp, "\n   \"");
    for (i = 0; i < numbytes; ++i) {
	if (i > 0 && i % 32 == 0)
	  fprintf(fp, "\"\n   \"");
	if (i > 0 && i % 32 != 0 && i % rowbytes == 0)
	  fprintf(fp, "/");
	if (dolisp) {
	    if (datastr == NULL || datastr[j] == '\0') {
		if (!stringp(car(lispdata)))
		  break;
		datastr = c_string(car(lispdata));
		j = 0;
		lispdata = cdr(lispdata);
	    }
	    if (datastr[j] == '/')
	      ++j;
	    byte = hextoi(datastr[j]) * 16 + hextoi(datastr[j+1]);
	    j += 2;
	} else {
	    byte = rawdata[i];
	}
	fprintf(fp, "%02x", (unsigned char) byte);
    }
    fprintf(fp, "\")");
}

static void
write_bitmap(fp, subtyp, w, h, lispdata, rawdata)
FILE *fp;
char *subtyp;
int w, h;
Obj *lispdata;
char *rawdata;
{
    int dolisp, i, j = 0, rowbytes, numbytes, byte;
    char *datastr = NULL;

    /* Lisp data overrides raw byte data. */	
    dolisp = (lispdata != lispnil);	
    rowbytes = computed_rowbytes(w, 1);
    numbytes =  h * rowbytes;
    fprintf(fp, "(%s", subtyp);
    if (w > 16 || h > 16)
      fprintf(fp, "\n  ");
    fprintf(fp, " \"");
    for (i = 0; i < numbytes; ++i) {
	if (i > 0 && i % 32 == 0)
	  fprintf(fp, "\"\n   \"");
	if (i > 0 && i % 32 != 0 && i % rowbytes == 0)
	  fprintf(fp, "/");
	if (dolisp) {
	    if (datastr == NULL || datastr[j] == '\0') {
		if (!stringp(car(lispdata)))
		  break;
		datastr = c_string(car(lispdata));
		j = 0;
		lispdata = cdr(lispdata);
	    }
	    /* Ignore any slashes, they're for human readability. */
	    if (datastr[j] == '/')
	      ++j;
	    byte = hextoi(datastr[j]) * 16 + hextoi(datastr[j+1]);
	    j += 2;
	} else {
	    byte = rawdata[i];
	}
	fprintf(fp, "%02x", (unsigned char) byte);
    }
    fprintf(fp, "\")");
}

static void
write_palette_contents(fp, palette, rawpalette, numcolors)
FILE *fp;
Obj *palette;
int *rawpalette, numcolors;
{
    int len, i, col, red, grn, blu;
    Obj *restpal;

    len = (palette != lispnil ? length(palette) : numcolors);
    if (len > 2)
      fprintf(fp, "\n  ");
    fprintf(fp, " (%s", keyword_name(K_PALETTE));
    if (symbolp(palette)) {
	fprintf(fp, " %s", c_string(palette));
    } else if (palette != lispnil) {
	for_all_list(palette, restpal) {
	    parse_lisp_palette_entry(car(restpal), &col, &red, &grn, &blu);
	    if (len > 2)
	      fprintf(fp, "\n   ");
 	    write_color(fp, col, red, grn, blu);
	}
    } else if (rawpalette != NULL) {
	for (i = 0; i < numcolors; i++) {
	    if (len > 2)
	      fprintf(fp, "\n   ");
	    write_color(fp, rawpalette[4*i],
			rawpalette[4*i+1], rawpalette[4*i+2], rawpalette[4*i+3]);
	}
    } else {
	fprintf(fp, " #| no palette? |# ");
    }
    fprintf(fp, ")");
}

static void
write_color(fp, n, r, g, b)
FILE *fp;
int n, r, g, b;
{
    char *colorname;

    if (n >= 0)
      fprintf(fp, " (%d", n);
    colorname = find_color_name(r, g, b);
    if (!empty_string(colorname)) {
	/* Write color name.  Note that we write as a symbol, so that
	   each instance of "white" doesn't become a separate string. */
	fprintf(fp, " %s", colorname);
    } else {
	/* Write individual color components. */
	fprintf(fp, " %d %d %d", r, g, b);
    }
    if (n >= 0)
      fprintf(fp, ")");
}

void
write_imp(fp, imp)
FILE *fp;
ImagePalette *imp;
{
    if (imp == NULL)
      return;
    if (imp->name == NULL) {
	fprintf(fp, "; garbage palette?\n");
	return;
    }
    fprintf(fp, "(%s \"%s\"",
	    keyword_name(K_PALETTE), imp->name);
    if (imp->notes != lispnil) {
	fprintf(fp, "\n  (%s ", keyword_name(K_NOTES));
	fprintlisp(fp, imp->notes);
	fprintf(fp, ")\n ");
    }
    write_palette_contents(fp, imp->palette, NULL, 0);
    fprintf(fp, ")\n");
}

/* Given rgb components, return names of standard colors if the match is close. */

char *
find_color_name(r, g, b)
int r, g, b;
{
    if (r > WHITE_THRESHOLD
	&& g > WHITE_THRESHOLD
	&& b > WHITE_THRESHOLD)
      return "white";
    else if (r < BLACK_THRESHOLD
	&& g < BLACK_THRESHOLD
	&& b < BLACK_THRESHOLD)
      return "black";
    else if (r > WHITE_THRESHOLD
	&& g < BLACK_THRESHOLD
	&& b < BLACK_THRESHOLD)
      return "red";
    else if (r < BLACK_THRESHOLD
	&& g > WHITE_THRESHOLD
	&& b < BLACK_THRESHOLD)
      return "green";
    else if (r < BLACK_THRESHOLD
	&& g < BLACK_THRESHOLD
	&& b > WHITE_THRESHOLD)
      return "blue";
    else
      return NULL;
}

void
parse_lisp_palette_entry(palentry, col, red, grn, blu)
Obj *palentry;
int *col, *red, *grn, *blu;
{
    Obj *colorcomp;
    char *colorname;

    *col = c_number(car(palentry));
    colorcomp = cdr(palentry);
    if (symbolp(car(colorcomp)) || stringp(car(colorcomp))) {
	colorname = c_string(car(colorcomp));
	*red = *grn = *blu = 0;
	if (strcmp(colorname, "white") == 0) {
	    *red = *grn = *blu = 65535;
	} else if (strcmp(colorname, "black") == 0) {
	    /* done */
	} else if (strcmp(colorname, "red") == 0) {
	    *red = 65535;
	} else if (strcmp(colorname, "green") == 0) {
	    *grn = 65535;
	} else if (strcmp(colorname, "blue") == 0) {
	    *blu = 65535;
	} else {
	    init_warning("No color named \"%s\" found, substituting gray",
			 colorname);
	    *red = *grn = *blu = 128 * 256;
	}
    } else if (numberp(car(colorcomp))) {
	*red = c_number(car(colorcomp));
	*grn = c_number(cadr(colorcomp));
	*blu = c_number(caddr(colorcomp));
    } else {
	init_warning("palette color info is not a name or set of numbers, ignoring");
    }
}