AI-NNEasy
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
lib/AI/NNEasy/NN/backprop.hploo view on Meta::CPAN
#############################################################################
## Name: backprop.pm
## Purpose: AI::NNEasy::NN::backprop
## Author: Graciliano M. P.
## Modified by:
## Created: 2005-01-14
## RCS-ID:
## Copyright: (c) 2005 Graciliano M. P.
## Licence: This program is free software; you can redistribute it and/or
## modify it under the same terms as Perl itself
#############################################################################
use Class::HPLOO qw(base alloo) ;
class AI::NNEasy::NN::backprop[0.06] {
__[C]__
#define OBJ_HV(self) (HV*) SvRV( self )
#define OBJ_AV(self) (AV*) SvRV( self )
#define FETCH_ATTR(hv,k) *hv_fetch(hv, k , strlen(k) , 0)
#define FETCH_ATTR_PV(hv,k) SvPV( FETCH_ATTR(hv,k) , len)
#define FETCH_ATTR_NV(hv,k) SvNV( FETCH_ATTR(hv,k) )
#define FETCH_ATTR_IV(hv,k) SvIV( FETCH_ATTR(hv,k) )
#define FETCH_ATTR_HV(hv,k) (HV*) FETCH_ATTR(hv,k)
#define FETCH_ATTR_AV(hv,k) (AV*) FETCH_ATTR(hv,k)
#define FETCH_ATTR_HV_REF(hv,k) (HV*) SvRV( FETCH_ATTR(hv,k) )
#define FETCH_ATTR_AV_REF(hv,k) (AV*) SvRV( FETCH_ATTR(hv,k) )
#define FETCH_ELEM(av,i) *av_fetch(av,i,0)
#define FETCH_ELEM_HV_REF(av,i) (HV*) SvRV( FETCH_ELEM(av,i) )
#define FETCH_ELEM_AV_REF(av,i) (AV*) SvRV( FETCH_ELEM(av,i) )
__[C]__
sub calc_error ($outputPatternRef) {
my @outputPattern = @$outputPatternRef;
my $outputLayer = $this->{layers}->[-1]->{nodes} ;
return 0 if @$outputLayer != @outputPattern ;
my $counter = 0 ;
foreach my $node (@$outputLayer) {
$node->{error} = $node->{activation} - $outputPattern[$counter] ;
++$counter ;
}
}
sub learn ($outputPatternRef) {
$this->calc_error($outputPatternRef) ;
$this->hiddenToOutput ;
$this->hiddenOrInputToHidden if @{$this->{layers}} > 2 ;
return $this->RMSErr($outputPatternRef) ;
}
*hiddenToOutput = \&hiddenToOutput_c ;
sub hiddenToOutput_pl {
foreach my $node ( @{ $this->{layers}->[-1]->{nodes} } ) {
foreach my $connectedNode ( @{$node->{connectedNodesWest}->{nodes}} ) {
$node->{connectedNodesWest}->{weights}->{ $connectedNode->{nodeid} } -= $this->{learning_rate} * $node->{error} * $connectedNode->{activation} ;
$node->{connectedNodesWest}->{weights}->{ $connectedNode->{nodeid} } = 5 if $node->{connectedNodesWest}->{weights}->{ $connectedNode->{nodeid} } > 5 ;
$node->{connectedNodesWest}->{weights}->{ $connectedNode->{nodeid} } = -5 if $node->{connectedNodesWest}->{weights}->{ $connectedNode->{nodeid} } < -5 ;
}
}
}
sub[C] void hiddenToOutput_c( SV* self ) {
STRLEN len;
int i , j , k ;
HV* self_hv = OBJ_HV( self );
AV* nodes = FETCH_ATTR_AV_REF( FETCH_ELEM_HV_REF( FETCH_ATTR_AV_REF(self_hv , "layers") , -1) , "nodes") ;
for (i = 0 ; i <= av_len(nodes) ; ++i) {
HV* node = OBJ_HV( *av_fetch(nodes, i ,0) ) ;
AV* westNodes = FETCH_ATTR_AV_REF( FETCH_ATTR_HV_REF(node , "connectedNodesWest") , "nodes") ;
for (j = 0 ; j <= av_len(westNodes) ; ++j) {
HV* connectedNode = OBJ_HV( *av_fetch(westNodes, j ,0) ) ;
SV* weight = FETCH_ATTR( FETCH_ATTR_HV_REF( FETCH_ATTR_HV_REF(node , "connectedNodesWest") , "weights" ) , FETCH_ATTR_PV(connectedNode , "nodeid") );
double val = FETCH_ATTR_NV(self_hv , "learning_rate") * FETCH_ATTR_NV(node , "error") * FETCH_ATTR_NV(connectedNode , "activation") ;
val = SvNV(weight) - val ;
if ( val > 5 ) { val = 5 ;}
else if ( val < -5 ) { val = -5 ;}
sv_setnv(weight , val) ;
}
}
}
*hiddenOrInputToHidden = \&hiddenOrInputToHidden_c ;
sub hiddenOrInputToHidden_pl {
my ( $nodeid , $nodeError , $nodeActivation ) ;
my $learningRate = $this->{learning_rate} ;
foreach my $layer ( reverse @{$this->{layers}}[0 .. $#{$this->{layers}}-1 ] ) {
foreach my $node ( @{$layer->{nodes}} ) {
last if !$node->{connectedNodesWest} ;
$nodeid = $node->{nodeid} ;
$nodeError = 0 ;
foreach my $connectedNode ( @{$node->{connectedNodesEast}->{nodes}} ) {
my $noderr = $connectedNode->{error} * $connectedNode->{connectedNodesWest}->{weights}->{$nodeid} ;
$nodeError += $noderr ;
}
$node->{error} = $nodeError ;
$nodeActivation = $node->{activation} ;
# update the weights from nodes inputting to here
foreach my $westNodes ( @{$node->{connectedNodesWest}->{nodes}} ) {
$node->{connectedNodesWest}->{weights}->{ $westNodes->{nodeid} } -= ( 1 - ($nodeActivation*$nodeActivation) ) * $nodeError * $learningRate * $westNodes->{activation} ;
}
}
}
}
sub[C] void hiddenOrInputToHidden_c( SV* self ) {
STRLEN len;
int i , j , k ;
double nodeError , nodeActivation ;
char* nodeid ;
AV* layers ;
HV* self_hv = OBJ_HV( self );
double learningRate = FETCH_ATTR_NV(self_hv , "learning_rate") ;
layers = FETCH_ATTR_AV_REF(self_hv , "layers") ;
for (i = (av_len(layers)-1) ; i >= 0 ; --i) {
SV* layer = *av_fetch(layers, i ,0) ;
AV* nodes = FETCH_ATTR_AV_REF(OBJ_HV(layer) , "nodes") ;
for (j = 0 ; j <= av_len(nodes) ; ++j) {
HV* node = OBJ_HV( *av_fetch(nodes, j ,0) ) ;
AV* eastNodes ;
AV* westNodes ;
if (!SvTRUE( FETCH_ATTR(node , "connectedNodesWest") ) ) break ;
nodeid = FETCH_ATTR_PV(node , "nodeid") ;
nodeError = 0 ;
eastNodes = FETCH_ATTR_AV_REF( FETCH_ATTR_HV_REF(node , "connectedNodesEast") , "nodes") ;
for (k = 0 ; k <= av_len(eastNodes) ; ++k) {
HV* connectedNode = OBJ_HV( *av_fetch(eastNodes, k ,0) ) ;
nodeError += FETCH_ATTR_NV(connectedNode , "error") * FETCH_ATTR_NV( FETCH_ATTR_HV_REF( FETCH_ATTR_HV_REF(connectedNode , "connectedNodesWest") , "weights") , nodeid) ;
}
hv_store(node , "error" , 5 , newSVnv(nodeError) , 0) ;
nodeActivation = FETCH_ATTR_NV(node , "activation") ;
westNodes = FETCH_ATTR_AV_REF( FETCH_ATTR_HV_REF(node , "connectedNodesWest") , "nodes") ;
for (k = 0 ; k <= av_len(westNodes) ; ++k) {
HV* connectedNode = OBJ_HV( *av_fetch(westNodes, k ,0) ) ;
char* connectedNode_id = FETCH_ATTR_PV(connectedNode , "nodeid") ;
HV* hv = FETCH_ATTR_HV_REF( FETCH_ATTR_HV_REF(node , "connectedNodesWest") , "weights") ;
SV* weight_prev = FETCH_ATTR(hv , connectedNode_id) ;
double weight = SvNV(weight_prev) - ( (1 - (nodeActivation*nodeActivation)) * nodeError * learningRate * FETCH_ATTR_NV(connectedNode , "activation") ) ;
sv_setnv(weight_prev , weight) ;
}
}
}
}
*RMSErr = \&RMSErr_c ;
sub RMSErr_pl ($outputPatternRef) {
my $outputLayer = $this->{layers}->[-1]->{nodes} ;
my $sqrErr ;
my $counter = 0 ;
foreach my $node (@$outputLayer) {
$sqrErr += ($node->{activation} - $$outputPatternRef[$counter])**2 ;
++$counter ;
}
my $error = sqrt($sqrErr) ;
return $error;
}
sub[C] double RMSErr_c( SV* self , SV* outputPatternRef ) {
STRLEN len;
int i ;
HV* self_hv = OBJ_HV( self );
AV* outputLayer = FETCH_ATTR_AV_REF( FETCH_ELEM_HV_REF( FETCH_ATTR_AV_REF(self_hv , "layers") , -1) , "nodes") ;
int outputLayer_len = av_len(outputLayer) ;
AV* outputPattern = OBJ_AV(outputPatternRef) ;
double sqrErr = 0 ;
double error = 0 ;
for (i = 0 ; i <= av_len(outputLayer) ; ++i) {
HV* node = OBJ_HV( *av_fetch(outputLayer, i ,0) ) ;
double val ;
val = i <= outputLayer_len ? SvNV(*av_fetch(outputPattern, i ,0)) : 0 ;
val = FETCH_ATTR_NV(node , "activation") - val ;
sqrErr = val * val ;
}
error = Perl_sqrt(sqrErr) ;
return error ;
}
}
1;
view all matches for this distributionview release on metacpan - search on metacpan
( run in 0.524 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )