#!/usr/bin/env perl
# bespritetool - "beworld" prite-code generation tool
# License:  Creative Commons Attribution NonCommercial ShareAlike 3.0
# Revision: 110908

#---------------------------------------------------------------------
#                         license information
#---------------------------------------------------------------------

# This notice may not be  modified  except as  approved by  the author
# (and licensor), or to make non-content changes related to HTML tags,
# paragraph formatting, white space, etc.

# This software is distributed under the following license:
#
#     Creative Commons Attribution-NonCommercial-ShareAlike 2.5

# You may use, modify, and redistribute this software  without fees or
# royalties,  but only under the terms and conditions set forth by the
# license.  In particular, copies and derived works cannot be used for
# commercial purposes.  Additionally, the license propagates to copies
# and derived works. Furthermore, you must provide attribution "in the
# manner  specified  by the  author or licensor".  The latter point is
# discussed below.

# The author (and licensor) hereby specifies that  attribution must be
# handled in the following manner:  a. If the software is interactive,
# any About or Credits dialog boxes, windows, or text  provided by the
# original version must be preserved and operational. b. Additionally,
# whether or not clause (a) applies, the operating system and/or desk-
# top environment used must provide attribution that is readily acces-
# sible to the  end user at runtime. Note: "Readily accessible"  means
# that  attribution  should be  directly accessible  from  the desktop
# environment's highest-level Start menu or a similar location.

# The following techniques do *not* meet the attribution requirements:
# Attribution through  text files  whose contents aren't actually dis-
# played, attribution  through printed documentation,  verbal attribu-
# tion, or postings on external web sites (i.e., web sites that aren't
# an  intrinsic  local component of the  operating system  or  desktop
# environment used). These examples are provided for illustrative pur-
# poses only.

# It should be noted that trademarks are an additional issue.  If this
# software uses any trademarks, trademark-related restrictions may ap-
# ply.

# This  isn't a  complete explanation of the  terms and conditions in-
# volved.  For more information,  see the  applicable Creative Commons
# Attribution NonCommercial ShareAlike license[s].  If Internet access
# is enabled, the official copies of these license[s] should be avail-
# able at:
#
#     http://creativecommons.org/

#---------------------------------------------------------------------
#                           important note
#---------------------------------------------------------------------

# This software is provided on an  AS IS basis with ABSOLUTELY NO WAR-
# RANTY.  The  entire risk as to the  quality and  performance of  the
# software is with you.  Should the software prove defective,  you as-
# sume the cost of all necessary  servicing, repair or correction.  In
# no event will any of the developers,  or any other party, be  liable
# to anyone for damages arising out of use of the software, or inabil-
# ity to use the software.

#---------------------------------------------------------------------
#                            documentation
#---------------------------------------------------------------------

my $USAGE_TEXT = << 'END';
__PROGNAME__ rev. __REVISION__ - BEWorld sprite tool

Usage:    __PROGNAME__ OPTIONS IMAGEFILE

This code creates a text file based on  the specified  image file that
contains a sprite definition suitable for use with BEWorld. The output
file is stored in the  same directory as the input file;  its name  is
equal to the associated "class name" (see below) plus the filename ex-
tension ".bewsprite".

Options (none of these are required):

--name=CLASSNAME        Specifies the  class name  to  be  used.  This
                        should be a short string containing only  let-
                        ters,  digits, and/or underscores.  Default is
                        to create a class name based on the input-file
                        name.

--dim=WIDTHxHEIGHT      Specifies dimensions to use for the output im-
                        age.  Default  is to  use the  original dimen-
                        sions.  Note that the  output  dimensions must
                        fall  into the  range of  1x1  to 64x64 either
                        way.

--move                  Specify that sprite is mobile. This is the de-
                        fault.

--nomove                Specify that sprite is stationary.
END

#---------------------------------------------------------------------
#                        standard module setup
#---------------------------------------------------------------------

require 5.8.1;
use strict;
use Carp;
use warnings;
use Cwd;
use Getopt::Long;
                                # Trap warnings
$SIG {__WARN__} = sub { die @_; };

#---------------------------------------------------------------------
#                           basic constants
#---------------------------------------------------------------------

use constant ZERO  => 0;        # Zero
use constant ONE   => 1;        # One
use constant TWO   => 2;        # Two

use constant FALSE => 0;        # Boolean FALSE
use constant TRUE  => 1;        # Boolean TRUE

#---------------------------------------------------------------------
#                         program parameters
#---------------------------------------------------------------------

my $REVISION = '110830';        # Revision string

#---------------------------------------------------------------------

# If the "help" screen(s) used are more than about 23 lines long,  set
# $USE_LESS to TRUE. Otherwise, set this parameter to FALSE.

my $USE_LESS = TRUE;

#---------------------------------------------------------------------
#                          global variables
#---------------------------------------------------------------------

my $PROGNAME;                   # Single-word program name
   $PROGNAME =  $0;             # Obtain program name
   $PROGNAME =~ s@^.*/@@;       # Remove path component [if any]

#---------------------------------------------------------------------

my $TRANSPARRGB = 'FF00FF';     # Six upper-case hex digits that  spe-
                                # cify the RGB color used  to indicate
                                # transparency (must be  equal to  the
                                # corresponding parameter $TRANSPARRGB 
                                # used in "beworld")

my $NUMDIGITS   = 10;           # No. of decimal digits (10)
my $NUMLETTERS  = 26;           # No. of letters in alphabet, ignoring
                                # case (2)
my $NUMPUNCT    =  2;           # No. of  punctuation characters  sup-
                                # ported by the format used  (two, '.'
                                # and '*')

                                # Number of color characters supported
                                # by the format used: two for '.'  and
                                # '*', plus the number of decimal dig-
                                # its (10), plus the  number of lower-
                                # case letters (26),  plus the  number
                                # of upper-case letters (26)
my $MAXCOLORS  = $NUMPUNCT + $NUMDIGITS + ($NUMLETTERS * TWO);

my $IE = 'Internal error';      # Internal-error message prefix

#---------------------------------------------------------------------
#                         low-level routines
#---------------------------------------------------------------------

# Future change: Document this routine.

sub UsageError
{
    my $UsageText;              # Usage text
                                # Copy appropriate text block
    $UsageText =  $USAGE_TEXT;
                                # Adjust the usage text
    $UsageText =~ s@(__)(META_|)(REVISION__)\s+(-)@$1$2$3 $4@;
    $UsageText =~ s@__(META_|)PROG(NAME|RAM)__@$PROGNAME@g;
    $UsageText =~ s@__(META_|)REVISION__@$REVISION@g;
    $UsageText =~ s@^\s+@@s;
    $UsageText =~ s@\s*\z@\n@s;

    if ($USE_LESS && (-t STDOUT) && open (OFD, "|/usr/bin/less"))
    {                           # Display usage text using "less"
        $UsageText .= << 'END'; # 'END' should be single-quoted here

To exit this "help" text, press "q" or "Q".

END
        print OFD $UsageText;
        close OFD;
    }
    else
    {                           # Print usage text directly
        print "\n", $UsageText, "\n";
    }

    exit ONE;                   # Terminate the program
}

#---------------------------------------------------------------------

# Future change: Document this routine.

sub FixStr
{
    my ($str) = @_;
    $str =  "" unless defined $str;
    $str =~ s@^\s+@@s;
    $str =~ s@\s+\z@@s;
    $str;
}

#---------------------------------------------------------------------
#                            main routine
#---------------------------------------------------------------------

sub Main
{
    my $data;
    my $n;                      # Scratch (integer)
    my $str;                    # Scratch (string )
    my $xdata;
    my $HexPixel;
    my $classname = "";
    my $dim       = "";
    my $move      = TRUE;

    my %ColorHexToSum  = ();
    my %ColorCharToHex = ();
    my %ColorHexToChar = ();
    my %ColorCount     = ();

#---------------------------------------------------------------------
# Check for required external programs.

    for my $name (qw (convert hexdump imgdim))
    {
        my $path;
        $path = `which $name 2>&1`;
        $path = &FixStr ($path);
        next if (-f $path) && (-x $path);
        print << "END";
Error: This program needs the Linux utility "$name"
END
        print << "END" if $name eq 'imgdim';
Note: This is a distro-specific utility program
END
        exit 1;
    }

#---------------------------------------------------------------------
# Process the command line.

    &UsageError() unless scalar @ARGV;

    $n = GetOptions
    (
        "dim=s"  => \$dim       ,
        "name=s" => \$classname ,
        "move!"  => \$move
    );

    &UsageError() unless (scalar @ARGV) == 1;
    my $ifname = shift (@ARGV);

#---------------------------------------------------------------------
# Finalize class name.

    $str =  $classname;
    $str =  $ifname  unless length $str;
    $str =~ s@.*/@@;
    $str =~ s@\.\w+\z@@;
    $str =~ s@\W+@_@g;
    $str =~ y/_/_/s;
    $str =  'noname' unless length $str;
    $classname = $str;

#---------------------------------------------------------------------
# Adjust and check the "--dim" setting.

    $dim = "" if $dim eq 'x';

    if (length ($dim) && ($dim !~ m@^\d+x\d+\z@))
    {
        print << 'END';

Error: Invalid argument for --dim. Should be specified as follows:

--dim=WIDTHxHEIGHT

END
        exit ONE;
    }

#---------------------------------------------------------------------
# Check the input file.

    die "Error: File is invalid or inaccessible: $ifname\n"
        unless (-f $ifname) && (-r $ifname);

    $str = `imgdim $ifname 2>&1`;

    if ($str !~ m@ (\d+)[x ](\d+)\s*\z@)
    {
        print << 'END';
Error: Not a supported image-file type: $ifname
END
        exit ONE;
    }

    my ($width, $height) = ($1, $2);
    ($width  ) = $1 if $dim =~ m@^(\d+)x@;
    ($height ) = $1 if $dim =~ m@x(\d+)\z@;

    if (($width  < ONE) || ($width  > 64) ||
        ($height < ONE) || ($height > 64))
    {
        print << 'END';

Error: The input image must range from 1x1 to 64x64 in size or it must
be scaled (using the --dim switch) to fall somewhere in that range.

END
        exit ONE;
    }

#---------------------------------------------------------------------
# Convert the image file to RGB.

# This section of code  converts  arbitrary images to  scaled-down and
# dithered RGB  data files  while preserving occurences of "BEWorld's"
# "transparent" color ($TRANSPARRGB)  and  mapping existing occurences
# of transparency to the same color.

    my $TMPFILEGIF = "/var/tmp/image-$>-$$.gif";
    my $TMPFILERGB = "/var/tmp/image-$>-$$.rgb";

    unlink $TMPFILEGIF;
    unlink $TMPFILERGB;
                                # Safety measure
    my $NumColorsRequested = $MAXCOLORS - ONE;
       $NumColorsRequested = 32 if
       $NumColorsRequested > 32;

    my $resize = "-resize ${dim}\!";
       $resize = "" unless length $dim;

# This code converts the input file to GIF first, and then from GIF to
# RGB. Using GIF as an intermediate step is a  work-around for  an ap-
# parent ImageMagick bug related to indexed PNG files.

    system "convert $ifname $TMPFILEGIF";

    my $cmd = << "END";
convert
-transparent "#$TRANSPARRGB"
-quantize transparent
$TMPFILEGIF
$resize
+dither
-colors $NumColorsRequested
-depth 8
-fill "#${TRANSPARRGB}"
-opaque "#${TRANSPARRGB}00"
-alpha Off
rgb:$TMPFILERGB
END

    $cmd =~ s@\s*\n\s*@ @gs;
    $cmd =~ s@\s+\z@@s;
    print  $cmd . "\n";
    system $cmd;

#---------------------------------------------------------------------
# Get data as a hex dump.

    $data =  `hexdump -v -e '1/1 "%02x"' $TMPFILERGB`;
    $data =  "" unless defined $data;
    $data =~ s@\s+@@g;

    unlink $TMPFILEGIF;
    unlink $TMPFILERGB;

    if ((length ($data) % 6) != ZERO)
    {
        die "$IE 0001\n";
    }

#---------------------------------------------------------------------
# Color analysis part 1.

    $xdata = $data;

    while ($xdata =~ s@^([0-9a-f]{6})@@i)
    {
        $HexPixel = uc ($1);
        my (@rgb) = $HexPixel =~ m@^(..)(..)(..)\z@;

        $n = ZERO; map { $n += hex ($_); } @rgb;
        $ColorHexToSum {$HexPixel} = $n;

        $n = $ColorCount {$HexPixel};
        $n = ZERO unless defined $n;
        $n++;
        $ColorCount {$HexPixel} = $n;

        my $num_colors = scalar keys %ColorHexToSum;
        die "$IE #0002: $num_colors\n" if $num_colors > $MAXCOLORS;
    }

    my $NumColors = scalar keys %ColorHexToSum;
    print "NumColors = $NumColors\n";

#---------------------------------------------------------------------
# Color analysis part 2.

    my $DarkestHex;
    my $LightestHex;
    my $DarkestSum;
    my $LightestSum;
    my @HexPixel = sort keys %ColorHexToSum;

    for $HexPixel (@HexPixel)
    {
        $n = $ColorHexToSum {$HexPixel};

        if (!defined ($LightestSum) || ($n > $LightestSum) ||
            ($HexPixel eq $TRANSPARRGB))
        {
            $LightestHex = $HexPixel;
            $LightestSum = $n;
            last if $HexPixel eq $TRANSPARRGB;
        }
    }

    die "$IE #0003\n" unless defined $LightestHex;

#---------------------------------------------------------------------
# Color analysis part 3.

    my $CommonHex;
    my $CommonCount = -1;
    $n = ZERO;

    for my $key (keys %ColorCount)
    {
        next if $key eq $LightestHex;
        $n = $ColorCount {$key};

        if (!defined ($CommonHex) || ($n > $CommonCount))
        {
            $CommonHex   = $key;
            $CommonCount = $n;
        }
    }

    die "$IE #0004\n" unless defined $CommonHex;
    die "$IE #0005\n" if $LightestHex eq $CommonHex;

#---------------------------------------------------------------------
# Color analysis part 4.

    my $ColorNum = ZERO;
    my $limit2   = $NUMDIGITS + $NUMLETTERS;

    for my $HexPixel (keys %ColorHexToSum)
    {
        if    ($HexPixel eq $CommonHex   )
            { $ColorHexToChar {$HexPixel} = '*'; }
        elsif ($HexPixel eq $LightestHex )
            { $ColorHexToChar {$HexPixel} = '.'; }
        else
        {
            my $ColorChar = $ColorNum;

            if ($ColorNum >= $NUMDIGITS)
            {
                $ColorChar = chr (ord ('a') + $ColorNum - $NUMDIGITS);
            }

            if ($ColorNum >= $limit2)
            {
                $ColorChar = chr (ord ('A') + $ColorNum - $limit2);
            }

            $ColorHexToChar {$HexPixel}  = $ColorChar;
            $ColorCharToHex {$ColorChar} = $HexPixel;
            $ColorNum++;
        }
    }

#---------------------------------------------------------------------
# Color analysis part 5.

    my $COLORMAP;
    my $jjoff;

    if ($LightestHex eq $TRANSPARRGB)
    {
        $COLORMAP = "\$TRANSPARRGB \\\n        $CommonHex";
        $jjoff    = -1;
    }
    else
    {
        $COLORMAP = "$LightestHex  $CommonHex";
        $jjoff    = ZERO;
    }

    my $MAXCOLORIDX = $NumColors - ($NUMPUNCT + ONE);
    
    for my $ii (ZERO..$MAXCOLORIDX)
    {
        my $char = $ii;
           $char = chr (ord ('a') + $ii - $NUMDIGITS)
               if $ii >= $NUMDIGITS;
           $char = chr (ord ('A') + $ii - $limit2   )
               if $ii >= $limit2;

        $HexPixel = $ColorCharToHex {$char};
        die "$IE #0006: $char\n" unless defined $HexPixel;
        my $jj = $ii + $NUMPUNCT;
        $COLORMAP .= " \\\n      " if (($jj + $jjoff) % 6) == ZERO;
        $COLORMAP .= "  $HexPixel";
    }

#---------------------------------------------------------------------
# Build the output data.

    my $buffer = << 'END';
#---------------------------------------------------------------------

# Routine:    make_proto_OBJECT
# Purpose:    Creates a sprite prototype: OBJECT class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) OBJECT

dmproc 1 make_proto_OBJECT {} {
    global TRANSPARRGB
    make_proto_sprite __META_NAME__ \
        __META_WIDTH__ __META_HEIGHT__ 1 1 [list \
        __META_COLORMAP__] \
    __META_MOVE__ {
END
    $buffer =~ s@__META_COLORMAP__@$COLORMAP@;
    $buffer =~ s@__META_HEIGHT__@$height@;
    $buffer =~ s@__META_NAME__@$classname@;
    $buffer =~ s@__META_WIDTH__@$width@;
    $buffer =~ s@(\[list) \\\n\s*(\$TRANSPARRGB)\b@$1 $2@s;

    $str    =  $move ? "move" : "stationary";
    $buffer =~ s@__META_MOVE__@$str@;
    $xdata  =  $data;

    for my $row (ONE..$height)
    {
        for my $col (ONE..$width)
        {
            ($HexPixel, $xdata) = $xdata =~ m@^([0-9a-f]{6})(.*)\z@i;
            die "$IE #0007\n" unless defined $xdata;
            $HexPixel = uc ($HexPixel);
            my $ColorChar = $ColorHexToChar {$HexPixel};
            die "$IE #0008: $HexPixel\n" unless defined $ColorChar;
            $buffer .= $ColorChar;
        }

        $buffer .= "\n";
    }

    die "$IE #0009: $xdata\n" if length $xdata;
    $buffer .= "    }\n}\n";

    $buffer =  &FixStr ($buffer);
    $buffer =~ s@OBJECT@$classname@g;
    $buffer =~ s@\n{2,}@\n\n@gs;
    $buffer .= "\n";

#---------------------------------------------------------------------
# Create the output file.

    $str =  $ifname;
    $str =~ s@[^/]*\z@@;
    $str .= "$classname.bewsprite";
    my $ofname = $str;

    if (open (OFD, ">$ofname"))
    {
        print OFD $buffer;
        print "Created $ofname\n";
    }
    else
    {
        print "Error: Couldn't create output file: $!\n$ofname\n";
        exit ONE;
    }

    undef;
}

#---------------------------------------------------------------------
#                            main program
#---------------------------------------------------------------------

&Main();                        # Call the main routine
exit ZERO;                      # Normal exit