# Copyright (c) 2025 Löwenfelsen UG (haftungsbeschränkt)
# Copyright (c) 2025 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: module for working with SIRTX font files

package SIRTX::Font;

use v5.20;
use strict;
use warnings;

use Carp;
#use parent 'Data::Identifier::Interface::Userdata';

use constant {
    MAGIC               => pack('CCCCCCCC', 0x00, 0x07, ord('S'), ord('F'), 0x0d, 0x0a, 0xc0, 0x0a),
    DATA_START_MARKER   => 0x0600,
};

our $VERSION = v0.01;



sub new {
    my ($pkg, @args) = @_;
    my $self = bless {
        width   => undef,
        height  => undef,
        bits    => undef,
        glyphs  => [],
        chars   => {},
    }, $pkg;

    croak 'Stray options passed' if scalar @args;

    return $self;
}


sub gc {
    my ($self) = @_;
    my $chars = $self->{chars};
    my $glyphs = $self->{glyphs};
    my $new = 0;
    my %updates;
    my %dedup;

    foreach my $glyph (values %{$chars}) {
        $updates{$glyph} //= $dedup{$glyphs->[$glyph]};
        $updates{$glyph} //= $new++;
        $dedup{$glyphs->[$glyph]} = $updates{$glyph};
    }

    {
        my @n;
        my $last = -1;

        foreach my $glyph (sort {$updates{$a} <=> $updates{$b}} keys %updates) {
            next if $last == $updates{$glyph};
            $last = $updates{$glyph};
            push(@n, $glyphs->[$glyph]);
        }

        $self->{glyphs} = \@n;
    }

    foreach my $char (keys %{$chars}) {
        $chars->{$char} = $updates{$chars->{$char}};
    }

    return $self;
}


sub width {
    my ($self, $n) = @_;

    if (defined $n) {
        $n = int $n;
        croak 'Invalid width: '.$n if $n < 1 || $n > 255;
        $self->{width} = $n;
    }

    return $self->{width} // croak 'No width set';
}


sub height {
    my ($self, $n) = @_;

    if (defined $n) {
        $n = int $n;
        croak 'Invalid height: '.$n if $n < 1 || $n > 255;
        $self->{height} = $n;
    }

    return $self->{height} // croak 'No height set';
}


sub bits {
    my ($self, $n) = @_;

    if (defined $n) {
        $n = int $n;
        croak 'Invalid width: '.$n if $n < 1 || $n > 255;
        $self->{bits} = $n;
    }

    return $self->{bits} // croak 'No bits set';
}


sub has_codepoint {
    my ($self, $codepoint) = @_;

    $codepoint = $self->_parse_codepoint($codepoint);

    return defined $self->{chars}{$codepoint};
}


sub remove_codepoint {
    my ($self, $codepoint) = @_;

    $codepoint = $self->_parse_codepoint($codepoint);

    delete $self->{chars}{$codepoint};

    return $self;
}


sub glyph_for {
    my ($self, $codepoint, $glyph) = @_;

    $codepoint = $self->_parse_codepoint($codepoint);

    if (defined $glyph) {
        $glyph = int $glyph;
        if ($glyph < 0 || $glyph >= scalar(@{$self->{glyphs}})) {
            croak 'Invalid glyph: '.$glyph;
        }
        $self->{chars}{$codepoint} = $glyph;
    }

    return $self->{chars}{$codepoint} // croak 'Codepoint unknown: '.$codepoint;
}

sub _parse_codepoint {
    my ($self, $codepoint) = @_;

    if ($codepoint =~ /^[Uu]\+([0-9a-fA-F]{4,6})$/) {
        $codepoint = hex($1);
    } else {
        $codepoint = int($codepoint);
    }

    croak 'Unicode character out of range: '.$codepoint if $codepoint < 0 || $codepoint > 0x10FFFF;

    return $codepoint;
}


sub default_glyph_for {
    my ($self, $codepoint, $glyph) = @_;

    $codepoint = $self->_parse_codepoint($codepoint);

    return $self->{chars}{$codepoint} if defined $self->{chars}{$codepoint};
    return $self->glyph_for($codepoint, $glyph);
}


sub alias_glyph {
    my ($self, $from, $to) = @_;
    $self->glyph_for($to, $self->glyph_for($from));
    return $self;
}


sub default_alias_glyph {
    my ($self, $from, $to) = @_;
    $self->default_glyph_for($to, $self->glyph_for($from));
    return $self;
}


sub read {
    my ($self, $in) = @_;
    my $chars = $self->{chars};
    my $glyphs = $self->{glyphs};
    my $offset = scalar @{$glyphs};
    my ($marker, $w, $h, $b, $count);
    my $entry_size;
    local $/ = \8;

    $in->binmode;

    croak 'Bad magic' unless scalar(<$in>) eq MAGIC;
    ($marker, $w, $h, $b, $count) = unpack('nCCCxn', scalar(<$in>));
    croak 'Bad marker' unless $marker == DATA_START_MARKER;
    croak 'Bits value is not 1' unless $b == 1;

    $self->width($w);
    $self->height($h);
    $self->bits($b);

    $entry_size = (int($w / 8) + ($w & 0x7 ? 1 : 0)) * $h;

    while (defined(my $data = <$in>)) {
        my ($char, $len, $glyph) = unpack('Nnn', $data);
        last if $char == 0xFFFFFFFF;

        for (my $i = 0; $i <= $len; $i++) {
            $chars->{$char+$i} = $glyph + $offset + $i;
        }
    }

    $/ = \$entry_size;

    while (defined(my $data = <$in>)) {
        croak 'Short read' unless length($data) == $entry_size;
        push(@{$glyphs}, $data);
    }

    return $self;
}


sub write {
    my ($self, $out) = @_;
    my $chars = $self->{chars};
    my $glyphs = $self->{glyphs};
    my %index;
    my @list = sort {$a <=> $b} keys %{$chars};
    my %index_update;
    my @runs;

    {
        my $next_index = 0;
        my $run;

        foreach my $idx (@list) {
            my $glyph = $index_update{$chars->{$idx}} //= $next_index++;

            if (defined $run) {
                my $next = $run->[1] + 1;
                if ($idx == ($run->[0] + $next) && $glyph == ($run->[2] + $next)) {
                    $run->[1]++;
                } else {
                    $run = undef;
                    redo;
                }
            } else {
                push(@runs, $run = [$idx, 0, $glyph]);
            }
        }

    }

    $out->binmode;

    print $out MAGIC;
    print $out pack('nCCCxn', DATA_START_MARKER, $self->width, $self->height, $self->bits, scalar(keys %index_update));
    print $out pack('Nnn', @{$_}) foreach @runs;
    print $out pack('Nnn', 0xFFFFFFFF, 0, 0);

    foreach my $glyph (sort {$index_update{$a} <=> $index_update{$b}} keys %index_update) {
        print $out $glyphs->[$glyph];
    }
}


sub import_glyph {
    my ($self, $in) = @_;

    if (!eval {$in->isa('Image::Magick')}) {
        require Image::Magick;
        my $p = Image::Magick->new;
        $p->Read($in);
        $in = $p;
    }

    return $self->_import_glyph_wbmp($in->ImageToBlob(magick => 'wbmp'));
}

sub _import_glyph_wbmp {
    my ($self, $data) = @_;
    my ($w, $h);

    croak 'Bad wbmp magic' unless substr($data, 0, 2) eq "\0\0";
    ($w, $h) = unpack('CC', substr($data, 2, 2));

    croak 'Bad geometry' if ($w & 0x80) || ($h & 0x80);

    $self->width($w);
    $self->height($h);
    $self->bits(1);

    push(@{$self->{glyphs}}, substr($data, 4));

    return scalar(@{$self->{glyphs}}) - 1;
}


sub export_glyph_as_image_magick {
    my ($self, $glyph) = @_;
    my $p;

    $glyph = int($glyph) if defined $glyph;
    croak 'No valid glyph given' unless defined($glyph) && $glyph >= 0;
    $glyph = $self->{glyphs}[$glyph];
    croak 'No valid glyph given' unless defined($glyph);

    if ($self->width >= 128 || $self->height >= 128 || $self->bits != 1) {
        croak 'Unsupported glyph size';
    }

    $p = Image::Magick->new(magick => 'wbmp');
    $p->BlobToImage(pack('CCCC', 0, 0, $self->width, $self->height).$glyph);

    return $p;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

SIRTX::Font - module for working with SIRTX font files

=head1 VERSION

version v0.01

=head1 SYNOPSIS

    use SIRTX::Font;

    my SIRTX::Font $font = SIRTX::Font->new;

    $font->read('cool-font.sf');
    $font->write('cool-font.sf');

    if ($font->has_codepoint(0x1234)) { ... }

    printf("%ux%u\@%u\n", $font->width, $font->height, $font->bits);

    $font->glyph_for(0x1234, $font->import_glyph('U+1234.png'));

This module implements an interface to SIRTX font files.

All methods in this module C<die> on error unless documented otherwise.

=head1 METHODS

=head2 new

    my SIRTX::Font $font = SIRTX::Font->new;

Creates a new font object. No parameters are supported.

=head2 gc

    $font->gc;

(experimental)

Takes the trash out. This will remove unused glyphs and deduplicate glyphs that are still in use.

B<Note:>
After a call to this all glyph numbers become invalid.

=head2 width

    $font->width($width);

    my $width = $font->width;

Sets or gets the width of character cells.

=head2 height

    $font->height($height);

    my $height = $font->height;

Sets or gets the height of character cells.

=head2 bits

    $font->bits($bits);

    my $bits = $font->bits;

Sets or gets the bits per pixel of character cells.

=head2 has_codepoint

    my $bool = $font->has_codepoint($codepoint);

Returns a true value if the code point is knowm, otherwise return a false value.

=head2 remove_codepoint

    $font->remove_codepoint(0x1234);

Removes a code point from the font.
This will not remove the glyph.

If the code point is not known this method will do nothing.

=head2 glyph_for

    my $glyph = $font->glyph_for($codepoint); # $codepoint is 0x1234 or 'U+1234'

    $font->glyph_for($codepoint => $glyph);

Sets or gets the glyph for a given code point.

=head2 default_glyph_for

    $glyph = $font->default_glyph_for($codepoint => $glyph);

Sets the glyph for the code point if it has no glyph set so far.
Returns the new glyph (if the code point was modified) or the old (if it was already set).

=head2 alias_glyph

    $font->alias_glyph($from, $to);

Aliases the glyph for code point C<$from> to the same as code point C<$to>.

See also L</glyph_for>.

=head2 default_alias_glyph

    $font->default_alias_glyph($from, $to);

Aliases the glyph for code point C<$from> to the same as code point C<$to> if C<$from> has no glyph set.

=head2 read

    $font->read($handle);

Reads a font file into memory.
If any data is already loaded the data is merged.

=head2 write

    $font->write($handle);

Writes the current font in the SIRTX format to the given handle.

=head2 import_glyph

    my $glyph = $font->import_glyph($filename);

Imports a glyph from a file.
The glyph index is returned.

The supported formats depend on the installed modules.
See also L<Image::Magick>.

=head2 export_glyph_as_image_magick

    my Image::Magick $image = $font->export_glyph_as_image_magick($glyph);

(experimental)

Exports a single glyph as a image object.

=head1 AUTHOR

Löwenfelsen UG (haftungsbeschränkt) <support@loewenfelsen.net>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2025 by Löwenfelsen UG (haftungsbeschränkt) <support@loewenfelsen.net>.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut
