#! /bin/sh
#!perl -w # --*- Perl -*--
eval 'exec perl -x $0 ${1+"$@"}'
    if 0;
#------------------------------------------------------------------------------
#$Author: antanas $
#$Date: 2021-04-28 19:35:53 +0300 (Wed, 28 Apr 2021) $
#$Revision: 8738 $
#$URL: svn+ssh://www.crystallography.net/home/coder/svn-repositories/cod-tools/tags/v3.3.0/scripts/cif_reduce_Niggli $
#------------------------------------------------------------------------------
#*
#* Perform Niggli cell reduction of CIF files.
#*
#* USAGE:
#*    $0 --options input1.cif input*.cif
#**

use strict;
use warnings;
use COD::CIF::Parser qw( parse_cif );
use COD::Algebra::Vector qw( matrix_vector_mul
                             vector_modulo_1 );
use COD::CIF::Data qw( get_cell );
use COD::CIF::Tags::CanonicalNames qw( canonicalize_all_names );
use COD::CIF::Tags::Print qw( print_cif );
use COD::Cell::Niggli::KG76 qw( reduce );
use COD::Fractional qw( symop_fract_from_ortho
                        symop_ortho_from_fract );
use COD::Spacegroups::Symop::Algebra qw( symop_det
                                         symop_mul
                                         symop_transpose );
use COD::Spacegroups::Symop::Parse qw( string_from_symop
                                       symop_from_string );
use COD::Spacegroups::Lookup qw( make_symop_hash
                                 make_symop_key );
use COD::Spacegroups::Lookup::COD qw( @table @extra_settings );
use COD::SOptions qw( getOptions );
use COD::SUsage qw( usage options );
use COD::CIF::Tags::Manage qw( exclude_tag set_tag );
use COD::ErrorHandler qw( process_warnings
                          process_errors
                          process_parser_messages );
use COD::ToolsVersion qw( get_version_string );

my $die_on_error_level = {
    ERROR   => 1,
    WARNING => 0,
    NOTE    => 0
};

my $use_parser = 'c';
$COD::Cell::Niggli::KG76::debug = 0;
my $compute_symops = 0;

# Format for floating point numbers:
my $fformat = "%.12g";

my $Pi = 4 * atan2(1,1);

my %symop_lookup_table = make_symop_hash( [ \@table, \@extra_settings ] );

#* OPTIONS:
#*   --use-perl-parser
#*                     Use Perl parser for CIF parsing.
#*   --use-c-parser
#*                     Use Perl & C parser for CIF parsing.
#*
#*   --compute-symops
#*                     Apply basis change to symmetry operators. Not all
#*                     lattices are processed correctly, thus this option
#*                     is experimental only and is turned off by default.
#*
#*   --debug, --no-debug
#*                     Turn on/off the debug prints of reduction algorithm.
#*                     Default: off.
#*
#*   --help, --usage
#*                     Output a short usage message (this message) and exit.
#*   --version
#*                     Output version information and exit.
#**
@ARGV = getOptions(
    "--debug"    => sub{ $COD::Cell::Niggli::KG76::debug = 1 },
    "--no-debug" => sub{ $COD::Cell::Niggli::KG76::debug = 0 },

    "--compute-symops" => sub { $compute_symops = 1 },

    "--use-perl-parser" => sub { $use_parser = "perl" },
    "--use-c-parser"    => sub { $use_parser = "c" },

    '--options'      => sub { options; exit },
    '--help,--usage' => sub { usage; exit },
    '--version'      => sub { print get_version_string(), "\n"; exit }
);

@ARGV = ( "-" ) unless @ARGV;

binmode STDOUT, ':encoding(UTF-8)';
binmode STDERR, ':encoding(UTF-8)';

for my $filename (@ARGV) {

    my $options = { 'parser' => $use_parser, 'no_print' => 1 };
    my ( $data, $err_count, $messages ) = parse_cif( $filename, $options );
    process_parser_messages( $messages, $die_on_error_level );
    next if ( $err_count > 0 );

    canonicalize_all_names( $data );

    for my $datablock (@$data) {
        my $values = $datablock->{values};
        my $dataname = 'data_' . $datablock->{'name'};

        local $SIG{__WARN__} = sub {
            process_warnings( {
                'message'  => @_,
                'program'  => $0,
                'filename' => $filename,
                'add_pos'  => $dataname
            }, $die_on_error_level )
        };

        eval {
            my @cell = get_cell( $values );
            my $f2o = symop_ortho_from_fract( @cell );
            my @niggli = reduce( @cell );
            my $o2f = symop_fract_from_ortho( @niggli );
            my $CoB = pop( @niggli );

            $values->{_cell_length_a}[0] = $niggli[0];
            $values->{_cell_length_b}[0] = $niggli[1];
            $values->{_cell_length_c}[0] = $niggli[2];
            $values->{_cell_angle_alpha}[0] = $niggli[3];
            $values->{_cell_angle_beta}[0]  = $niggli[4];
            $values->{_cell_angle_gamma}[0] = $niggli[5];

            my( $a, $b, $c ) = @cell;
            my( $ca, $cb, $cg ) = map { cos( $Pi * $_ / 180 ) } @cell[3..5];

            my $atom_site_tag;
            for my $tag (qw( _atom_site_label
                             _atom_site_type_symbol )) {
                next if !exists $values->{$tag};
                $atom_site_tag = $tag;
                last;
            }
            if( !$atom_site_tag ) {
                die 'ERROR, neither \'_atom_site_label\' nor ' .
                    '\'_atom_site_type_symbol\' tag present' . "\n";
            }

            my $CoB_inv = mat3_inv( $CoB );

            for( my $i = 0; $i < @{$values->{$atom_site_tag}}; $i++ ) {
                my $coordinates = [ map { s/\([0-9]+\)$//; $_ }
                    (
                        $values->{'_atom_site_fract_x'}[$i],
                        $values->{'_atom_site_fract_y'}[$i],
                        $values->{'_atom_site_fract_z'}[$i],
                    )
                ];

                my $coordinates_now =
                    vector_modulo_1( matrix_vector_mul( $CoB_inv,
                                                        $coordinates ) );

                ( $values->{'_atom_site_fract_x'}[$i],
                  $values->{'_atom_site_fract_y'}[$i],
                  $values->{'_atom_site_fract_z'}[$i] ) =
                    map { sprintf( $fformat, $_ ) }
                        @$coordinates_now;
            }

            if( $compute_symops &&
                exists $values->{_symmetry_equiv_pos_as_xyz} ) {
                $CoB->[0][3] = 0;
                $CoB->[1][3] = 0;
                $CoB->[2][3] = 0;
                push( @$CoB, [ 0, 0, 0, 1 ] );

                my $CoBT = symop_transpose( $CoB );

                for( my $i = 0; $i < @{$values->{_symmetry_equiv_pos_as_xyz}}; $i++ ) {
                    my $S = symop_from_string( $values->{_symmetry_equiv_pos_as_xyz}[$i] );
                    $values->{_symmetry_equiv_pos_as_xyz}[$i] =
                        string_from_symop( symop_mul( symop_mul( $CoBT,
                                                                 $S ),
                                                      $CoB ) );
                }

                my $key = make_symop_key( $values->{_symmetry_equiv_pos_as_xyz} );
                if( exists $symop_lookup_table{$key} ) {
                    my $estimated_sg = $symop_lookup_table{$key};
                    set_tag( $datablock, '_space_group_name_H-M_alt',
                             $estimated_sg->{'universal_h_m'} );
                    set_tag( $datablock, '_space_group_name_Hall',
                             $estimated_sg->{'hall'} );
                    set_tag( $datablock, '_space_group_IT_number',
                             $estimated_sg->{'number'} );
                    for my $tag ('_symmetry_space_group_name_H-M',
                                 '_symmetry_space_group_name_Hall') {
                        next if !exists $values->{$tag};
                        exclude_tag( $datablock, $tag );
                    }
                }
            }

            print_cif( $datablock,
              {
                preserve_loop_order => 1,
                keep_tag_order => 1
              }
            );
        };
        if ($@) {
            process_errors( {
              'message'       => $@,
              'program'       => $0,
              'filename'      => $filename,
              'add_pos'       => $dataname
            }, $die_on_error_level->{'ERROR'} );
        }
    }
}

sub mat3_inv
{
    my( $m ) = @_;
    my $c = 1 / symop_det($m);
    return [[ $c * ( $m->[1][1] * $m->[2][2] - $m->[1][2] * $m->[2][1] ),
             -$c * ( $m->[0][1] * $m->[2][2] - $m->[0][2] * $m->[2][1] ),
              $c * ( $m->[0][1] * $m->[1][2] - $m->[0][2] * $m->[1][1] )],
            [-$c * ( $m->[1][0] * $m->[2][2] - $m->[1][2] * $m->[2][0] ),
              $c * ( $m->[0][0] * $m->[2][2] - $m->[0][2] * $m->[2][0] ),
             -$c * ( $m->[0][0] * $m->[1][2] - $m->[0][2] * $m->[1][0] )],
            [ $c * ( $m->[1][0] * $m->[2][1] - $m->[1][1] * $m->[2][0] ),
             -$c * ( $m->[0][0] * $m->[2][1] - $m->[0][1] * $m->[2][0] ),
              $c * ( $m->[0][0] * $m->[1][1] - $m->[0][1] * $m->[1][0] )]];
}
