KGS/Game/Tree.pm

package KGS::Game::Tree;

use KGS::Constants;

# _should_ be unified, but the two types are slightly different
# (this really looks like a grown, as opposed to designed, protocol)
# despite the claim of "innovation" etc...
my %marker_type = (
   triangle => MARK_TRIANGLE,
   square   => MARK_SQUARE,
   circle   => MARK_CIRCLE,
   small_b  => MARK_SMALL_B,
   small_w  => MARK_SMALL_W,
);

# exclusion masks... the bit on the left excludes (removes) the ones on the right
my %exclude_type = (
   &MARK_TRIANGLE => MARK_SQUARE | MARK_TRIANGLE | MARK_CIRCLE | MARK_LABEL,
   &MARK_SQUARE   => MARK_SQUARE | MARK_TRIANGLE | MARK_CIRCLE | MARK_LABEL,
   &MARK_CIRCLE   => MARK_SQUARE | MARK_TRIANGLE | MARK_CIRCLE | MARK_LABEL,
   &MARK_LABEL    => MARK_SQUARE | MARK_TRIANGLE | MARK_CIRCLE | MARK_LABEL,
   &MARK_SMALL_B  => MARK_SMALL_B | MARK_SMALL_W | MARK_B | MARK_W | MARK_MOVE,
   &MARK_SMALL_W  => MARK_SMALL_B | MARK_SMALL_W | MARK_B | MARK_W | MARK_MOVE,
   &MARK_GRAY_B   =>                               MARK_B | MARK_W | MARK_MOVE | MARK_GRAY_B | MARK_GRAY_W,
   &MARK_GRAY_W   =>                               MARK_B | MARK_W | MARK_MOVE | MARK_GRAY_B | MARK_GRAY_W,
   &MARK_B        => MARK_SMALL_B | MARK_SMALL_W | MARK_B | MARK_W | MARK_MOVE | MARK_GRAY_B | MARK_GRAY_W,
   &MARK_W        => MARK_SMALL_B | MARK_SMALL_W | MARK_B | MARK_W | MARK_MOVE | MARK_GRAY_B | MARK_GRAY_W,
);

sub init_tree {
   my ($self) = @_;
   $self->{tree} = [ {
      id   => 0,
      move => -1,
   } ];
}

sub update_tree {
   my ($self, $tree) = @_;

   my $node = $self->{curnode};

   my $up_tree;
   my $up_move;

   #warn "update_tree = ".KGS::Listener::Debug::dumpval $tree;#d#

   for (@$tree)  {
      my ($type, @arg) = @$_;
      if ($type eq "add_child") {
         $up_tree = 1;
         $node = $self->{tree}[$arg[0] + 1]
            or die "FATAL: referencing nonexistent node $arg[0]+1!";

         my $new = {
            id     => scalar @{$self->{tree}},
            parent => $node->{id},
            move   => $node->{move} + 1,
         };

         push @{$self->{tree}}, $new;
         push @{$node->{children}}, $new->{id};

         $node = $new;

      } elsif (my $bit = $marker_type{$type}) {
         $up_tree = 1;
         my $ref = $node->{"$arg[1],$arg[2]"} ||= [];

         $ref->[0] &= ~$exclude_type{$bit};
         $ref->[0] |= $bit if $arg[0] != 2;
         $ref->[1] |= $exclude_type{$bit};

      } elsif ($type eq "label") {
         $up_tree = 1;
         my $ref = $node->{"$arg[1],$arg[2]"} ||= [];

         $ref->[0] &= ~$exclude_type{&MARK_LABEL};
         undef $ref->[2];

         if (length $arg[0]) {
            $ref->[0] |= MARK_LABEL;
            $ref->[1] |= $exclude_type{&MARK_LABEL};
            $ref->[2] = $arg[0];
         }

      } elsif ($type eq "move" or $type eq "addstone" or $type eq "gray") {
         $up_tree = 1;

         if ($type eq "move") {
            $self->{lastmove_time}   = $KGS::Protocol::NOW;
            $self->{lastmove_colour} = $arg[0];
            $up_move = 0 if $self->{loaded};
         }

         if ($arg[1] < 255) {
            my $ref = $node->{"$arg[1],$arg[2]"} ||= [];

            my $bit = $arg[0] == BLACK ? ($type eq "gray" ? MARK_GRAY_B : MARK_B)
                    : $arg[0] == WHITE ? ($type eq "gray" ? MARK_GRAY_W : MARK_W)
                                       : 0;

            $ref->[0] &= ~$exclude_type{$bit};
            $ref->[0] |= $bit | ($type eq "move" ? MARK_MOVE : 0);
            $ref->[1] |= $exclude_type{$bit};
         } else {
            warn "PLEASE REPORT: pass coordinates but type is $type" if $type ne "move";#d#

            $node->{pass} = 1;
         }

      } elsif ($type eq "comment") {
         $self->event_update_comments ($node, $arg[0], !exists $node->{comment});

         $node->{comment} .= $arg[0];

      } elsif ($type eq "player") {
         $node->{player}[$arg[0]] = $arg[1];

      } elsif ($type eq "rank") {
         $node->{rank}[$arg[0]] = $arg[1];

      } elsif ($type eq "set_timer") {
         $node->{timer}[$arg[0]] = [$arg[1], $arg[2]];

      } elsif ($type eq "more") {
         # server probably exceeded some packet size => request more moves
         # why this is not automatic escapes me, but there could be a very
         # good reason for this (bandwidth problems?)
         $up_tree = 0;
         $self->{more} = 1;
         $self->send(get_tree => channel => $self->{channel}, node => @{$self->{tree}} - 1);

      } elsif ($type eq "done") {
         $self->{loaded} = 1;
         # nop

      } else {
         $node->{$type} = $arg[0]; # rules, date etc..

         $self->event_update_rules ($arg[0]) if $type eq "rules";
      }
   }

   $self->{curnode} = $node;

   $self->event_update_tree if $up_tree;
   $self->event_move ($up_move) if defined $up_move;
}

sub get_path {
   my ($self) = @_;

   my @nodes;

   my $node = $self->{curnode};

   for(;;) {
      push @nodes, $node;
      last unless $node->{parent};
      $node = $self->{tree}[$node->{parent}];
   }

   [reverse @nodes];
}

sub set_node {
   my ($self, $node) = @_;

   $self->{curnode} = $self->{tree}[$node + 1]
      or die "set_node to undefined tree node $node+1";
}

sub event_move            { }
sub event_update_tree     { }
sub event_update_comments { }
sub event_update_rules    { }

1;

Revision:	1.18
Committed:	Fri Jun 6 05:50:34 2003 UTC (23 years, 5 months ago) by pcg
Branch:	MAIN
Changes since 1.17:	+2 -0 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	pcg	1.1	package KGS::Game::Tree;
2
3			use KGS::Constants;
4
5			# _should_ be unified, but the two types are slightly different
6			# (this really looks like a grown, as opposed to designed, protocol)
7	pcg	1.6	# despite the claim of "innovation" etc...
8	pcg	1.1	my %marker_type = (
9			triangle => MARK_TRIANGLE,
10			square => MARK_SQUARE,
11			circle => MARK_CIRCLE,
12			small_b => MARK_SMALL_B,
13			small_w => MARK_SMALL_W,
14			);
15
16			# exclusion masks... the bit on the left excludes (removes) the ones on the right
17			my %exclude_type = (
18			&MARK_TRIANGLE => MARK_SQUARE \| MARK_TRIANGLE \| MARK_CIRCLE \| MARK_LABEL,
19			&MARK_SQUARE => MARK_SQUARE \| MARK_TRIANGLE \| MARK_CIRCLE \| MARK_LABEL,
20			&MARK_CIRCLE => MARK_SQUARE \| MARK_TRIANGLE \| MARK_CIRCLE \| MARK_LABEL,
21			&MARK_LABEL => MARK_SQUARE \| MARK_TRIANGLE \| MARK_CIRCLE \| MARK_LABEL,
22			&MARK_SMALL_B => MARK_SMALL_B \| MARK_SMALL_W \| MARK_B \| MARK_W \| MARK_MOVE,
23			&MARK_SMALL_W => MARK_SMALL_B \| MARK_SMALL_W \| MARK_B \| MARK_W \| MARK_MOVE,
24	pcg	1.3	&MARK_GRAY_B => MARK_B \| MARK_W \| MARK_MOVE \| MARK_GRAY_B \| MARK_GRAY_W,
25			&MARK_GRAY_W => MARK_B \| MARK_W \| MARK_MOVE \| MARK_GRAY_B \| MARK_GRAY_W,
26			&MARK_B => MARK_SMALL_B \| MARK_SMALL_W \| MARK_B \| MARK_W \| MARK_MOVE \| MARK_GRAY_B \| MARK_GRAY_W,
27			&MARK_W => MARK_SMALL_B \| MARK_SMALL_W \| MARK_B \| MARK_W \| MARK_MOVE \| MARK_GRAY_B \| MARK_GRAY_W,
28	pcg	1.1	);
29
30			sub init_tree {
31			my ($self) = @_;
32	pcg	1.11	$self->{tree} = [ {
33			id => 0,
34	pcg	1.17	move => -1,
35	pcg	1.11	} ];
36	pcg	1.1	}
37
38			sub update_tree {
39	pcg	1.10	my ($self, $tree) = @_;
40	pcg	1.1
41			my $node = $self->{curnode};
42
43	pcg	1.12	my $up_tree;
44			my $up_move;
45
46	pcg	1.18	#warn "update_tree = ".KGS::Listener::Debug::dumpval $tree;#d#
47
48	pcg	1.1	for (@$tree) {
49			my ($type, @arg) = @$_;
50			if ($type eq "add_child") {
51	pcg	1.12	$up_tree = 1;
52	pcg	1.1	$node = $self->{tree}[$arg[0] + 1]
53	pcg	1.3	or die "FATAL: referencing nonexistent node $arg[0]+1!";
54	pcg	1.1
55	pcg	1.11	my $new = {
56			id => scalar @{$self->{tree}},
57			parent => $node->{id},
58			move => $node->{move} + 1,
59			};
60	pcg	1.1
61			push @{$self->{tree}}, $new;
62			push @{$node->{children}}, $new->{id};
63
64			$node = $new;
65
66			} elsif (my $bit = $marker_type{$type}) {
67	pcg	1.12	$up_tree = 1;
68	pcg	1.4	my $ref = $node->{"$arg[1],$arg[2]"} \|\|= [];
69	pcg	1.1
70	pcg	1.4	$ref->[0] &= ~$exclude_type{$bit};
71			$ref->[0] \|= $bit if $arg[0] != 2;
72			$ref->[1] \|= $exclude_type{$bit};
73	pcg	1.1
74			} elsif ($type eq "label") {
75	pcg	1.12	$up_tree = 1;
76	pcg	1.4	my $ref = $node->{"$arg[1],$arg[2]"} \|\|= [];
77	pcg	1.1
78	pcg	1.4	$ref->[0] &= ~$exclude_type{&MARK_LABEL};
79			undef $ref->[2];
80	pcg	1.1
81			if (length $arg[0]) {
82	pcg	1.4	$ref->[0] \|= MARK_LABEL;
83			$ref->[1] \|= $exclude_type{&MARK_LABEL};
84			$ref->[2] = $arg[0];
85	pcg	1.1	}
86
87	pcg	1.3	} elsif ($type eq "move" or $type eq "addstone" or $type eq "gray") {
88	pcg	1.12	$up_tree = 1;
89
90	pcg	1.13	if ($type eq "move") {
91			$self->{lastmove_time} = $KGS::Protocol::NOW;
92			$self->{lastmove_colour} = $arg[0];
93			$up_move = 0 if $self->{loaded};
94			}
95
96	pcg	1.7	if ($arg[1] < 255) {
97			my $ref = $node->{"$arg[1],$arg[2]"} \|\|= [];
98	pcg	1.4
99	pcg	1.13	my $bit = $arg[0] == BLACK ? ($type eq "gray" ? MARK_GRAY_B : MARK_B)
100			: $arg[0] == WHITE ? ($type eq "gray" ? MARK_GRAY_W : MARK_W)
101			: 0;
102	pcg	1.3
103	pcg	1.7	$ref->[0] &= ~$exclude_type{$bit};
104			$ref->[0] \|= $bit \| ($type eq "move" ? MARK_MOVE : 0);
105			$ref->[1] \|= $exclude_type{$bit};
106			} else {
107	pcg	1.10	warn "PLEASE REPORT: pass coordinates but type is $type" if $type ne "move";#d#
108	pcg	1.7
109			$node->{pass} = 1;
110			}
111	pcg	1.6
112	pcg	1.1	} elsif ($type eq "comment") {
113	pcg	1.11	$self->event_update_comments ($node, $arg[0], !exists $node->{comment});
114
115	pcg	1.3	$node->{comment} .= $arg[0];
116
117			} elsif ($type eq "player") {
118			$node->{player}[$arg[0]] = $arg[1];
119	pcg	1.1
120	pcg	1.9	} elsif ($type eq "rank") {
121			$node->{rank}[$arg[0]] = $arg[1];
122
123	pcg	1.8	} elsif ($type eq "set_timer") {
124	pcg	1.10	$node->{timer}[$arg[0]] = [$arg[1], $arg[2]];
125	pcg	1.3
126			} elsif ($type eq "more") {
127	pcg	1.11	# server probably exceeded some packet size => request more moves
128			# why this is not automatic escapes me, but there could be a very
129			# good reason for this (bandwidth problems?)
130	pcg	1.15	$up_tree = 0;
131	pcg	1.3	$self->{more} = 1;
132	pcg	1.16	$self->send(get_tree => channel => $self->{channel}, node => @{$self->{tree}} - 1);
133	pcg	1.3
134			} elsif ($type eq "done") {
135			$self->{loaded} = 1;
136			# nop
137	pcg	1.2
138	pcg	1.1	} else {
139	pcg	1.9	$node->{$type} = $arg[0]; # rules, date etc..
140	pcg	1.14
141			$self->event_update_rules ($arg[0]) if $type eq "rules";
142	pcg	1.1	}
143			}
144	pcg	1.12
145	pcg	1.17	$self->{curnode} = $node;
146
147	pcg	1.12	$self->event_update_tree if $up_tree;
148			$self->event_move ($up_move) if defined $up_move;
149	pcg	1.1	}
150
151			sub get_path {
152			my ($self) = @_;
153
154			my @nodes;
155
156			my $node = $self->{curnode};
157
158			for(;;) {
159			push @nodes, $node;
160			last unless $node->{parent};
161			$node = $self->{tree}[$node->{parent}];
162			}
163
164			[reverse @nodes];
165			}
166
167			sub set_node {
168			my ($self, $node) = @_;
169
170			$self->{curnode} = $self->{tree}[$node + 1]
171			or die "set_node to undefined tree node $node+1";
172			}
173
174	pcg	1.11	sub event_move { }
175			sub event_update_tree { }
176			sub event_update_comments { }
177	pcg	1.14	sub event_update_rules { }
178	pcg	1.5
179	pcg	1.1	1;
180