SWE/Object/Graph.pm

package SWE::Object::Graph;
use strict;
use warnings;

sub new ($%) {
  my $class = shift;
  my $self = bless {@_}, $class;

  return $self;
}

sub db { $_[0]->{db} }

use constant EMPTY_NODE_RATIO => 0.2;
use constant INITIAL_DEGREE => 5;

sub add_nodes ($$) {
  my ($self, $new_doc_number) = @_;
  
  ## TODO: graph lock

  my $global_prop_db = $self->db->global_prop;
  
  my $last_node_index = ${$global_prop_db->get_data ('lastnodeindex') || \ 0};
  my $doc_on_node_number = ${$global_prop_db->get_data ('doconnodenumber') || \ 0};
  $doc_on_node_number += $new_doc_number;
  my $max_node_index = $doc_on_node_number / (1 - EMPTY_NODE_RATIO);
  $max_node_index = $last_node_index if $max_node_index < $last_node_index;
  $max_node_index = $last_node_index + $new_doc_number
      if $max_node_index < $last_node_index + $new_doc_number;
  $max_node_index = int $max_node_index;

  if ($last_node_index < $max_node_index) {
    my $new_edges = {};
    
    for my $index1 ($last_node_index + 1 .. $max_node_index) {
      for (1 .. INITIAL_DEGREE) {
        my $index2 = int rand $index1;
        
        $new_edges->{$index1}->{$index2} = 1;
        $new_edges->{$index2}->{$index1} = 1;
      }
    }
    
    my $graph_prop_db = $self->db->graph_prop;
    for my $index1 (keys %$new_edges) {
      my $node = $graph_prop_db->get_data ($index1);
      my $edges = $node->{neighbors} ||= {};
      for my $index2 (keys %{$new_edges->{$index1}}) {
        $edges->{$index2} = 1;
      }
      $graph_prop_db->set_data ($index1 => $node);
    }

    $global_prop_db->set_data (lastnodeindex => \$max_node_index);
  }
  $global_prop_db->set_data (doconnodenumber => \$doc_on_node_number);

  return ($last_node_index + 1 .. $max_node_index);
} # add_nodes

sub create_node ($$) {
  my ($self, $doc_id) = @_;

  ## TODO: docid lock
  
  my ($node_id) = $self->add_nodes (1);

  require SWE::Object::Node;
  my $node = SWE::Object::Node->new (db => $self->db);
  $node->create (id => $node_id);
  $node->prop->{ids}->{$doc_id} = 1;
  $node->save_prop;

  return $node;
} # create_node

sub get_node_by_id ($$) {
  my ($self, $node_id) = @_;
  
  ## TODO: cache
  
  require SWE::Object::Node;
  my $node = SWE::Object::Node->new (db => $self->db);
  $node->load (id => $node_id);

  return $node;
} # get_node_by_id

use constant RELATEDNESS_THRESHOLD => 0.9;

sub schelling_update ($$) {
  my ($self, $node_id) = @_;

  my $node = $self->get_node_by_id ($node_id);
  my $doc_id = $node->document_id // return;

  require SWE::Object::Repository;
  my $repo = SWE::Object::Repository->new (db => $self->db);

  my $related = 0;
  my $n = 0;
  
  my $neighbor_ids = $node->neighbor_ids;
  my $unused_nodes = [];
  for my $n_node_id (keys %$neighbor_ids) {
    $n++;
    my $n_node = $self->get_node_by_id ($n_node_id);
    my $n_doc_id = $n_node->document_id;
    unless (defined $n_doc_id) {
      push @$unused_nodes, $n_node;
      next;
    }
    $related++ if $repo->are_related_ids ($node_id, $n_doc_id);
  }

  my $v = 0;
  if ($n) {
    $v = $related / $n;
  }

  if ($v < RELATEDNESS_THRESHOLD and @$unused_nodes) {
    my $unused_node = $unused_nodes->[rand @$unused_nodes];

    my $id_prop_db = $self->db->id_prop;
    my $id_prop = $id_prop_db->get_data ($doc_id);
    
    $id_prop->{node_id} = $unused_node->id;
    $unused_node->prop->{ids}->{$doc_id} = 1;
    delete $node->prop->{ids}->{$doc_id};

    $unused_node->save_prop;
    $id_prop_db->set_data ($doc_id => $id_prop);
    $node->save_prop;
  }
} # schelling_update

1;
1	wakaba	1.1	package SWE::Object::Graph;
2			use strict;
3			use warnings;
4
5			sub new ($%) {
6			my $class = shift;
7			my $self = bless {@_}, $class;
8
9			return $self;
10			}
11
12	wakaba	1.3	sub db { $_[0]->{db} }
13	wakaba	1.1
14			use constant EMPTY_NODE_RATIO => 0.2;
15			use constant INITIAL_DEGREE => 5;
16
17			sub add_nodes ($$) {
18			my ($self, $new_doc_number) = @_;
19
20			## TODO: graph lock
21
22			my $global_prop_db = $self->db->global_prop;
23
24			my $last_node_index = ${$global_prop_db->get_data ('lastnodeindex') \|\| \ 0};
25	wakaba	1.4	my $doc_on_node_number = ${$global_prop_db->get_data ('doconnodenumber') \|\| \ 0};
26			$doc_on_node_number += $new_doc_number;
27			my $max_node_index = $doc_on_node_number / (1 - EMPTY_NODE_RATIO);
28			$max_node_index = $last_node_index if $max_node_index < $last_node_index;
29			$max_node_index = $last_node_index + $new_doc_number
30			if $max_node_index < $last_node_index + $new_doc_number;
31			$max_node_index = int $max_node_index;
32
33	wakaba	1.1	if ($last_node_index < $max_node_index) {
34			my $new_edges = {};
35
36			for my $index1 ($last_node_index + 1 .. $max_node_index) {
37			for (1 .. INITIAL_DEGREE) {
38			my $index2 = int rand $index1;
39
40			$new_edges->{$index1}->{$index2} = 1;
41			$new_edges->{$index2}->{$index1} = 1;
42			}
43			}
44
45			my $graph_prop_db = $self->db->graph_prop;
46			for my $index1 (keys %$new_edges) {
47			my $node = $graph_prop_db->get_data ($index1);
48			my $edges = $node->{neighbors} \|\|= {};
49			for my $index2 (keys %{$new_edges->{$index1}}) {
50			$edges->{$index2} = 1;
51			}
52			$graph_prop_db->set_data ($index1 => $node);
53			}
54
55			$global_prop_db->set_data (lastnodeindex => \$max_node_index);
56			}
57	wakaba	1.4	$global_prop_db->set_data (doconnodenumber => \$doc_on_node_number);
58	wakaba	1.1
59			return ($last_node_index + 1 .. $max_node_index);
60			} # add_nodes
61
62			sub create_node ($$) {
63			my ($self, $doc_id) = @_;
64
65			## TODO: docid lock
66
67			my ($node_id) = $self->add_nodes (1);
68	wakaba	1.2
69			require SWE::Object::Node;
70			my $node = SWE::Object::Node->new (db => $self->db);
71			$node->create (id => $node_id);
72			$node->prop->{ids}->{$doc_id} = 1;
73			$node->save_prop;
74
75			return $node;
76			} # create_node
77
78			sub get_node_by_id ($$) {
79			my ($self, $node_id) = @_;
80
81			## TODO: cache
82	wakaba	1.1
83	wakaba	1.2	require SWE::Object::Node;
84			my $node = SWE::Object::Node->new (db => $self->db);
85			$node->load (id => $node_id);
86	wakaba	1.1
87	wakaba	1.2	return $node;
88			} # get_node_by_id
89	wakaba	1.5
90			use constant RELATEDNESS_THRESHOLD => 0.9;
91
92			sub schelling_update ($$) {
93			my ($self, $node_id) = @_;
94
95			my $node = $self->get_node_by_id ($node_id);
96			my $doc_id = $node->document_id // return;
97
98			require SWE::Object::Repository;
99			my $repo = SWE::Object::Repository->new (db => $self->db);
100
101			my $related = 0;
102			my $n = 0;
103
104			my $neighbor_ids = $node->neighbor_ids;
105			my $unused_nodes = [];
106			for my $n_node_id (keys %$neighbor_ids) {
107			$n++;
108			my $n_node = $self->get_node_by_id ($n_node_id);
109			my $n_doc_id = $n_node->document_id;
110			unless (defined $n_doc_id) {
111			push @$unused_nodes, $n_node;
112			next;
113			}
114			$related++ if $repo->are_related_ids ($node_id, $n_doc_id);
115			}
116
117			my $v = 0;
118			if ($n) {
119			$v = $related / $n;
120			}
121
122			if ($v < RELATEDNESS_THRESHOLD and @$unused_nodes) {
123			my $unused_node = $unused_nodes->[rand @$unused_nodes];
124
125			my $id_prop_db = $self->db->id_prop;
126			my $id_prop = $id_prop_db->get_data ($doc_id);
127
128			$id_prop->{node_id} = $unused_node->id;
129			$unused_node->prop->{ids}->{$doc_id} = 1;
130			delete $node->prop->{ids}->{$doc_id};
131
132			$unused_node->save_prop;
133			$id_prop_db->set_data ($doc_id => $id_prop);
134			$node->save_prop;
135			}
136			} # schelling_update
137	wakaba	1.1
138			1;