package Siru::CatalogoGLM;

# Catalogo compartido con el generador C. Los .din llevan una copia completa
# del descriptor expandido: una corrida independiente no necesita este JSON.
use strict;
use warnings;
use Carp qw(croak);
use JSON::PP qw(decode_json encode_json);
use File::Basename qw(dirname);
use File::Spec;
use POSIX qw(isfinite);
use Scalar::Util qw(looks_like_number);
use Siru::Donde;
use Siru::ControlPaso;

my $catalogo;
# en la biblioteca de d2datdinc: la del arbol o la instalada (Siru::Donde)
my $ruta_catalogo = File::Spec->catfile(Siru::Donde::biblioteca(), 'glm.json');
sub _catalogo {
    return $catalogo if $catalogo;
    my $ruta = $ruta_catalogo;
    open my $f, '<:raw', $ruta or croak "catalogo GLM $ruta: $!";
    local $/; my $c = decode_json(<$f>); close $f;
    croak 'version del catalogo GLM desconocida' unless ($c->{version} // 0) =~ /\A[12]\z/;
    return $catalogo = $c;
}

sub lista {
    my ($clase, $dato) = @_;
    my $controles = $dato->{GLOBAL}{control} || {};
    return undef unless exists $controles->{GLM};
    croak 'GLM y RK son excluyentes' if exists $controles->{RK};
    my $v = $controles->{GLM}{value};
    croak 'GLM requiere una lista numerica no vacia' unless ref($v) eq 'ARRAY' && @$v;
    for my $id (@$v) { $clase->metodo($id) }
    croak 'GLM inicial: se admite un metodo por corrida' unless @$v == 1;
    return [map { 0 + $_ } @$v];
}

sub metodo {
    my ($clase, $id) = @_;
    croak 'GLM requiere identificadores enteros no negativos'
        unless defined($id) && !ref($id) && $id =~ /\A(?:0|[1-9][0-9]*)\z/;
    my $c = _catalogo();
    my $m = $c->{methods}{$id} // croak "GLM=$id: identificador no definido en el catalogo";
    my $def = $c->{definitions}{$m->{definicion}} // croak 'definicion GLM ausente';
    my $d = decode_json(encode_json({%$def, %$m, capacidades => $c->{capacidades}, version => $c->{version}, id => 0+$id}));
    $clase->validar($d);
    return $d;
}

# Solo aritmetica y la razon r; nunca eval de codigo del archivo.
sub _atomo {
    my ($t, $p, $r) = @_;
    my $v = $t->[$$p++] // croak 'expresion GLM incompleta';
    return _atomo($t,$p,$r) if $v eq '+';
    return -_atomo($t,$p,$r) if $v eq '-';
    if ($v eq '(') {
        my $x = _suma($t,$p,$r);
        croak 'parentesis GLM sin cerrar' unless ($t->[$$p++] // '') eq ')';
        return $x;
    }
    return $r if $v eq 'r';
    croak 'coeficiente GLM invalido' unless looks_like_number($v);
    return 0+$v;
}
sub _producto {
    my ($t,$p,$r) = @_;
    my $x = _atomo($t,$p,$r);
    while (($t->[$$p] // '') =~ /\A[\/*]\z/) {
        my $op = $t->[$$p++]; my $y = _atomo($t,$p,$r);
        croak 'division por cero en coeficiente GLM' if $op eq '/' && !$y;
        $x = $op eq '*' ? $x*$y : $x/$y;
    }
    return $x;
}
sub _suma {
    my ($t,$p,$r) = @_;
    my $x = _producto($t,$p,$r);
    while (($t->[$$p] // '') =~ /\A[+-]\z/) {
        my $op = $t->[$$p++]; my $y = _producto($t,$p,$r);
        $x = $op eq '+' ? $x+$y : $x-$y;
    }
    return $x;
}
sub _coef {
    my ($v,$r) = @_;
    croak 'coeficiente GLM invalido' if !defined($v) || ref($v) || length($v) > 512;
    my @t;
    pos($v) = 0;
    while ($v =~ /\G\s*((?:\d+(?:\.\d*)?|\.\d+)(?:[eE][+-]?\d+)?|r|[()+*\/-])\s*/gc) { push @t, $1 }
    croak 'sintaxis de coeficiente GLM invalida' unless @t && @t <= 128 && (pos($v) // 0) == length($v);
    my $p=0; my $x=_suma(\@t,\$p,$r);
    croak 'coeficiente GLM no finito o incompleto' unless $p == @t && isfinite($x);
    return $x;
}

sub validar {
    my ($clase,$d) = @_;
    croak 'descriptor GLM invalido' unless ref($d) eq 'HASH';
    croak 'version GLM no admitida' unless ($d->{version}//0) =~ /\A[12]\z/;
    croak 'ID GLM invalido' unless defined($d->{id}) && !ref($d->{id}) && $d->{id} =~ /\A[0-9]+\z/;
    croak 'representacion GLM no admitida' unless ($d->{representacion}//'') =~ /\A(?:bloques|efectivos)\z/;
    my $cap = $d->{capacidades};
    croak 'capacidades GLM ausentes o no implementadas' unless ref($cap) eq 'HASH'
        && ($cap->{paso}//'') eq ($d->{version}==1 ? 'fijo_final_acortado' : 'variable_con_rearranque')
        && defined($cap->{adaptacion}) && !ref($cap->{adaptacion})
        && $cap->{adaptacion} eq ($d->{version}==1 ? '0' : '1')
        && !grep { !defined($cap->{$_}) || ref($cap->{$_}) || $cap->{$_} ne '0' } qw(listas topologia convoluciones);
    my $m = $d->{memoria};
    croak 'memoria GLM invalida' unless ref($m) eq 'ARRAY' && @$m && @$m <= 64 && $m->[0] eq 'estado';
    croak 'tipo de memoria GLM no admitido' if grep { !defined($_) || !/\A(?:estado|hderivada)\z/ } @$m;
    my $s;
    for my $modo (qw(bloques arranque)) {
        my $b=$d->{$modo};
        croak "faltan bloques GLM $modo" unless ref($b) eq 'HASH' && ref($b->{c}) eq 'ARRAY';
        $s //= @{$b->{c}};
        croak 'etapas GLM incompatibles' unless $s && $s <= 64 && @{$b->{c}} == $s;
        _coef($_,1) for @{$b->{c}};
        for my $k (qw(a u b v)) {
            my ($n,$cols) = ($k eq 'a' || $k eq 'u' ? $s : scalar(@$m), $k eq 'a' || $k eq 'b' ? $s : scalar(@$m));
            croak "dimension GLM $k invalida" unless ref($b->{$k}) eq 'ARRAY' && @{$b->{$k}} == $n;
            for my $fila (@{$b->{$k}}) {
                croak "fila GLM $k invalida" unless ref($fila) eq 'ARRAY' && @$fila == $cols;
                _coef($_,1) for @$fila;
            }
        }
    }
    if ($d->{representacion} eq 'efectivos') {
        croak 'adaptador efectivo solo admite BDF2 de dos estados'
            unless $d->{id} == 20 && $s == 1 && @$m == 2 && $m->[1] eq 'estado';
    }
    $d->{historia} = scalar @$m;
    croak 'capacidad de historia fisica GLM invalida' if exists($d->{historia_fisica})
        && (!defined($d->{historia_fisica}) || ref($d->{historia_fisica})
            || $d->{historia_fisica} !~ /\A[1-9][0-9]*\z/ || $d->{historia_fisica} > 1_000_000);
    $d->{etapas} = $s;
    return $d;
}

sub coeficientes {
    my ($clase,$d,$primero,$r) = @_;
    croak 'razon de pasos GLM invalida' unless defined($r) && looks_like_number($r) && isfinite($r) && $r > 0;
    my $b = $d->{$primero ? 'arranque' : 'bloques'};
    return { (map { my $k=$_; $k => [map { [map { _coef($_,$r) } @$_] } @{$b->{$k}}] } qw(a u b v)),
             c => [map { _coef($_,$r) } @{$b->{c}}] };
}

sub adaptacion {
    my ($clase, $d, $a, $estados) = @_;
    return undef unless defined($a) && (ref($a) ne 'HASH' || keys %$a);
    croak 'GLM: este descriptor no admite adaptacion; regenere el .din'
        unless $d->{version} == 2 && ($d->{estimador}//'') eq 'arranque_orden1';
    croak 'GLM: estimador requiere metodo glm_arranque y orden_error 2'
        unless ref($a) eq 'HASH' && ($a->{metodo}//'') eq 'glm_arranque' && ($a->{orden_error}//0) == 2;
    croak 'GLM: comparador solo validado con arranque Euler y orden principal 1 o 2'
        unless ($d->{orden}//0) =~ /\A[12]\z/ && $d->{etapas} == 1;
    my $b = $clase->coeficientes($d, 1, 1);
    croak 'GLM: el comparador requiere arranque Euler explicito o implicito'
        unless ($b->{c}[0] == 0 || $b->{c}[0] == 1) && $b->{a}[0][0] == $b->{c}[0]
        && $b->{b}[0][0] == 1 && $b->{u}[0][0] == 1 && $b->{v}[0][0] == 1
        && !grep { $b->{u}[0][$_] != 0 || $b->{v}[0][$_] != 0 } 1..$d->{historia}-1;
    my %permitidos = map {$_=>1} qw(metodo orden_error absoluto relativo paso_min paso_max intentos_max por_estado);
    croak 'GLM: control adaptativo desconocido' if grep {!$permitidos{$_}} keys %$a;
    my $v = Siru::ControlPaso->validar({%$a, metodo=>'doble'}, $estados);
    $v->{metodo} = 'glm_arranque';
    return $v;
}

1;