ACU/ACU/Grading.pm

#! /usr/bin/env perl

package Grading;

use v5.10.1;
use strict;
use warnings;
use XML::LibXML;

sub new
{
    my $class = shift;
    my $self = {
	operators => {
	    'add' => '$a+$b'
	    },
	tree => [],
	ids => {}
    };

    bless $self, $class;
    if ($#_ >= 0) {
	$self->_initialize(@_);
    }

    return $self;
}

sub _initialize
{
    my $self = shift;

    my $dom = XML::LibXML->load_xml(string => shift);
    $self->{tree} = $self->parseGrade($dom->documentElement());
    $self->{max} = $dom->documentElement()->getAttribute("max") // "20";
}

sub create_from_ids
{
    my $self = shift;
    my $trace_name = shift;
    my $ids = shift;

    my $trace_id = $trace_name;
    $trace_id =~ s/[^a-zA-Z0-9_]/_/g;

    my $g = Grade->new($trace_id, $trace_name);

    for my $id (sort( keys %{ $ids } ))
    {
	my $p = Point->new($ids->{$id}, $id, 0, 0);
	push @{ $g->{tree} }, $p;
    }

    push @{ $self->{tree} }, $g;
}

sub parseGrade ($$)
{
    my $self = shift;
    my $ret = [];
    my $node = shift;

    foreach my $grade ($node->childNodes())
    {
	if ($grade->nodeName eq "operator")
	{
	    my $tmp = $grade->textContent;
	    chomp($tmp);
	    $self->{operators}{ $grade->getAttribute("name") } = $tmp;
	}
	elsif ($grade->nodeName eq "grade")
	{
	    my $g = Grade->new(
		$grade->getAttribute("id"),
		$grade->getAttribute("title"),
		$grade->getAttribute("operator"),
		$grade->getAttribute("factor")
	    );
	    $g->append(@{ $self->parseGrade($grade) });
	    push @$ret, $g;
	}
	elsif ($grade->nodeName eq "point")
	{
	    my $n = Point->new(
		$grade->textContent,
		$grade->getAttribute("ref"),
		$grade->getAttribute("qversion"),
		$grade->getAttribute("not")
	    );
	    push @$ret, $n;
	}
    }

    return $ret;
}

sub reset ($)
{
    my $self = shift;

    $self->{ids} = {};
}

sub insert ($$$)
{
    my $self = shift;

    $self->{ids}{$_[0]} = $_[1];
}

sub fill ($$)
{
    my $self = shift;
    my $ids = shift;

    for my $k (keys %{ $ids }) {
	$self->{ids}{$k} = $ids->{$k};
    }
}

sub toString ($)
{
    my $self = shift;

    my $doc = XML::LibXML::Document->new('1.0');

    my $root = $doc->createElement("grading");

    for my $op (keys %{ $self->{operators} }) {
	my $ope = $doc->createElement("operator");
	$ope->addChild( $doc->createAttribute("name", $op) );
	$ope->appendText($self->{operators}{$op});
	$root->appendChild($ope);
    }

    for my $grade (@{ $self->{tree} }) {
	$grade->toString($doc, $root, $root);
    }

    $doc->setDocumentElement( $root );

    return $doc->toString();
}

sub compute ($)
{
    my $self = shift;
    my $sum = 0;

    for my $grade (@{ $self->{tree} }) {
	my $tmp = $grade->compute($self->{operators}, $self->{ids});
	$sum += $tmp if $tmp;
    }

    return $sum;
}

sub computeXML ($;$)
{
    my $self = shift;

    my $doc = XML::LibXML::Document->new('1.0');
    my $root = $doc->createElement("grading");

    for my $grade (@{ $self->{tree} }) {
	$grade->compute($self->{operators}, $self->{ids}, $doc, $root);
    }

    $root->addChild( $doc->createAttribute("max", $self->{max}) );

    $doc->setDocumentElement( $root );
    return $doc->toString();
}

package Grade;

use v5.10.1;
use strict;
use warnings;
use Carp;
use Safe;
use List::Util "reduce";
use XML::LibXML;

sub new ($$$;$$)
{
    my $class = shift;
    my $self = {
	id => shift,
	title => shift,
	operator => shift // "add",
	factor => shift // 1,
	tree => []
    };

    return bless $self;
}

sub toString ($$$)
{
    my $self = shift;
    my $doc = shift;
    my $parent = shift;

    my $grade = $doc->createElement("grade");
    $grade->addChild( $doc->createAttribute("id", $self->{id}) );
    $grade->addChild( $doc->createAttribute("title", $self->{title}) );
    $grade->addChild( $doc->createAttribute("operator", $self->{operator}) ) if ($self->{operator} ne "add");
    $grade->addChild( $doc->createAttribute("factor", $self->{factor}) ) if ($self->{factor} != 1);
    $parent->appendChild($grade);

    for my $item (@{ $self->{tree} }) {
	$item->toString($doc, $grade);
    }
}

sub append ($@)
{
    my $self = shift;

    push @{ $self->{tree} }, @_;
}

sub compute ($$$;$$)
{
    my $self = shift;
    my $operators = shift;
    my $ids = shift;
    my $doc = shift;
    my $parent = shift;
    my @current = ();

    my $grade;
    if ($doc && $parent)
    {
	$grade = $doc->createElement("grade");
	$grade->addChild( $doc->createAttribute("factor", $self->{factor}) );
	$grade->addChild( $doc->createAttribute("name", $self->{title}) );
	$parent->appendChild( $grade );
    }

    for my $node (@{ $self->{tree} })
    {
	my $t = $node->compute($operators, $ids, $doc, $grade);
	push @current, $t if (defined $t);
    }

    my $res;
    if (@current > 1)
    {
	my $operator = $self->{operator};

	my $cpt = new Safe;
	$cpt->permit_only(qw(:base_core :base_mem :base_loop padany rv2gv));
	$res = reduce {
	    $cpt->share('$a');
	    $cpt->share('$b');
	    $cpt->reval($operators->{ $operator }) // die "Safe alert: $@";
	}
	@current;
    }
    else {
	$res = $current[0] // 0;
    }

    $res = $res * $self->{factor};

    $ids->{ $self->{id} } = $res;

    $grade->addChild( $doc->createAttribute("value", $res) ) if ($grade);

    return $res;
}

sub add
{
    $a + $b;
}

package Point;

use v5.10.1;
use strict;
use warnings;
use Term::ANSIColor qw(:constants);

sub new ($$$$$)
{
    my $class = shift;
    my $self = {
	value => $_[0],
	ref => $_[1],
	qversion => $_[2],
	not => $_[3]
    };

    return bless $self;
}

sub toString ($$$)
{
    my $self = shift;
    my $doc = shift;
    my $parent = shift;

    my $point = $doc->createElement("point");
    $point->addChild( $doc->createAttribute("ref", $self->{ref}) ) if ($self->{ref} ne "");
    $point->addChild( $doc->createAttribute("qversion", $self->{qversion}) ) if ($self->{qversion} != 0);
    $point->addChild( $doc->createAttribute("not", $self->{not}) ) if ($self->{not} != 0);
    $point->appendText($self->{value});
    $parent->appendChild($point);
}

sub getValue ($$;$)
{
    my $self = shift;
    my $ids = shift;
    my $justMatch = shift;

    if ($self->{ref} && !$justMatch && !$ids->{ $self->{ref} } // 0) {
	return 0;
    }
    elsif ($self->{value} eq "") {
	return $ids->{ $self->{ref} } // 0;
    }
    else {
	return $self->{value};
    }
}

sub compute ($$$;$$)
{
    my $self = shift;
    my $operators = shift;
    my $ids = shift;
    my $ret = undef;

    if ((not $self->{ref}) || grep { $self->{ref} eq $_ } keys %$ids) {
	$ret = $self->getValue( $ids );
    }

    if ($self->{not})
    {
	if ($ret) {
	    $ret = undef;
	} else {
	    $ret = $self->getValue( $ids );
	}
    }

    if ($main::debug)
    {
	my $str = "not=".($self->{not}//0).", qversion".($self->{qversion}//"*").", ref=".($self->{ref}//"").",\tvalue=".$self->getValue( $ids, 1 ).", got=".($ret // 0);
	if ($ret) {
	    say GREEN, ">>>", RESET, " Matching point: ", $str;
	} else {
	    say RED, " * ", RESET, " Skipped point: ", $str;
	}
    }

    return $ret;
}


1;