#!/usr/bin/perl -w

#############################################################################
# Bunch - a Thingie and a bunch of Thingies (aka a container)
#
# Copyright (C) 1999-2000 by Tels. All rights reserved.
#############################################################################

package CoW::Bunch;
use vars qw($VERSION);
$VERSION = 1.00;    # Current version of this package
require  5.005;     # requires this Perl version or later

use base Exporter;
@EXPORT_OK	= qw( );
@EXPORT		= qw( );
use strict;
use vars qw($AUTOLOAD);

sub new
  {
  # create a new data thingy (with named parameters)
  my $class = shift;
  $class = ref($class) || $class;
  #print "$class\n";
  my $args;
  if (!defined $_[0])   # ()
    {
    $args = {};
    }
  else
    {
    $args = ref($_[0]) ? $_[0] : { @_ }; # ( reftohash ) or ( array )
    }
  my $self = {};
  bless $self, $class;
  $self->_init($args);
  return $self;
  }
   
#############################################################################
# private, initialize self 

sub _init
  {
  my $self = shift;
  my $args = shift;
  
  # simple make copy
  foreach my $k (keys %$args)
    {
    next if $k =~ /_parent/;	# simple ignore parent settings
    die "Can't set private $k in $self." if $k =~ /^_/;
    $self->{$k} = $args->{$k};
    } 
  $self->{_things} = [ ];
  # stuff that is inside of us
  $self->{contains} = [] if !defined $self->{contains};
  $self->insert ( @{$self->{contains}} );
  delete $self->{contains};
  $self->{_parent} = undef;
  return $self;
  }

sub _default
  {
  # check wether the given args exist and are defined, if not, set
  # defaults
  my $self = shift;
  my $args = shift;
  foreach my $k (keys %$args)
    {
    die "Can't require private $k in $self." if $k =~ /^_/;
    $self->{$k} = $args->{$k} if (!defined $self->{$k});
    }
  return $self;
  }

#############################################################################
# public stuff

sub copy
  {
  # make a copy of yourself
  my $self = shift;
 
  my $class = ref($self);
  my $new = $class->new();
  foreach (keys %$self)
    {
    next if /^_/; 		# skip internals
    $new->{$_} = $self->{$_};	# make copy of public fields
    }
  # now copy over all childs (recursively)
  my $items = $self->items();
  for (my $i = 0; $i < $items; $i++)
    {
    $new->insert($self->{_things}->[$i]->copy());
    }
  return $new;
  }

sub items
  {
  # how many thingies belong to us, counts our childs, too.
  my $self = shift;
  my $recursive = shift || 0;
  my $sum = shift; 
  my $s = 0; $sum = \$s if !defined $sum;
 
  $$sum += scalar @{$self->{_things}};
  return $$sum if $recursive;
  $self->for_each ( 'items', 1, $sum );
  return $$sum;
  }

sub for_each
  {
  # for each of the thingies, call callback ($thing,@params);
  my $self = shift;
  my $callback = shift || sub {};
  my $th = $self->{_things};
  foreach my $c (@$th) { $c->_callback($callback,@_); }
  return $self;
  }

sub traverse
  {
  # for each of the thingies including yourself:
  # call traverse and callback ($thing,@params);
  # order = 0: depth-first, order 1= => level-first

  my $self = shift;
  my $callback = shift || sub {};
  my $order = shift || 0;
  
  $self->_callback($callback,@_) if $order != 0;
  my $th = $self->{_things};
  foreach my $c (@$th) { $c->traverse($callback,$order,@_); }
  $self->_callback($callback,@_) if $order == 0;
  return $self;
  }

sub _callback
  {
  # from a given callback, call it with params and yourself
  my $self = shift;
  my $callback = shift;

  if (!ref($callback))
    {
    $self->$callback (@_);
    }
  else
    {
    if (ref($callback) eq 'HASH')
      {
      &{$callback->{callback}}($self,@_) 
        if defined $callback->{callback}; 
      my $cb = "$self"; $cb =~ s/=.*//; $cb = $callback->{$cb};
      &$cb($self,@_) if defined $cb; 
      }
    else
      {
      die ("Need code ref in $self callback") if !ref $callback eq 'CODE';
      &$callback($self,@_); 
      }
    }
  }

sub delete
  {
  # delete a thing from the container, by it's reference
  # returns number of things left
  my $self = shift;

  my ($t,$c,$i);
  my $th = $self->{_things};
  foreach $t (@_)
    {
    next unless exists $self->{_hashed}->{"$t"};
    $i = 0;
    foreach $c (@$th)
      {
      if ($t == $c)
        {
        $t->{_parent} = undef;		# it no longer belongs to us
        delete $self->{_hashed}->{"$t"};
        splice (@$th,$i,1); last;
        }
      $i++;
      }
    }
  return scalar @{$self->{_things}};
  }

sub insert
  {
  # inert one ore more things into the container, by their reference
  # returns new number of things
  my $self = shift;

  my ($t,$c,$i);
  my $th = $self->{_things};
  my @inserted;
  foreach $t (@_)
    {
    next if exists $self->{_hashed}->{"$t"};
    #die "Can't insert myself into myself" 
    next if $t eq $self;
    if (defined $t->{_parent})
      {
      # already belongs to someone, so make us a fresh copy
      $t = $t->copy();
      }
    # now add it to ourself
    $self->{_hashed}->{"$t"} = $t;
    $t->{_parent} = $self;		# we () \v/ |\| it now
    push @$th, $t;
    push @inserted,$t;
    }
  return wantarray ? @inserted : scalar @inserted;
  }

sub empty
  {
  # remove any contained things
  my $self = shift;

  foreach my $c (@{$self->{_things}})
    {
    $c->{_parent} = undef;		# it no longer belongs to us
    }
  $self->{_things} = [];
  $self->{_hashed} = {};
  return $self;
  }

sub contains
  {
  # return number of things contained in us
  my $self = shift;
  my ($t,@contained);
  foreach $t (@_)
    {
    push @contained, $t if exists $self->{_hashed}->{"$t"};
    } 
  return wantarry ? scalar @contained : @contained;
  }

sub as_string
  {
  my $self = shift;
  # recursively traverse yourself and print as text
  # if a scalar reference is given, add yourself to this
  my $t = shift;
  #print "$self $t\n";
  if (!defined $t) { my $c = ""; $t = \$c; }
  my $level = shift || 0;
  my $a; my $space = " " x $level;
  $$t .= "$space".ref($self)." {\n";
  foreach my $f (sort keys %$self)
    {
    next if $f =~ /^_/;               # skip internals
    if (ref ($self->{$f}))
      {
      $a = ''; $self->{$f}->as_string(\$a,$level+2); $a =~ s/^\s+//;
      }
    else
      {
      $a = $self->{$f}; 
      warn ("field $f undefined in $self") if !defined $a;
      $a = $a || '';
      $a = "\"$a\"" unless $a =~ /^[a-z0-9_.]+$/; 
      $a .= "\n";
      }
    $$t .= "$space  $f = $a";
    }
  if (scalar @{$self->{_things}} != 0)
    {
    $$t .= "$space  contains {\n";
    $self->for_each ( "as_string", $t, $level+4);
    $$t .= "$space  }\n";
    }
  $$t .= "$space}\n";
  return $$t;
  }

sub by_field
  {
  # find all contained things by matching their field against match,
  # and return a list of the matches. Works case insensitive.
  # the second parameter tells to search more than one level
  my $self = shift;
  my $field = shift || "";
  my $match = shift || "";
  my $level = shift || 0;	# default is depth search
  my $list = shift;
 
  my $down = 1;
  if (defined $list)
    {
    my $f = $self->{$field} || return @$list;
    push @$list, $self if $f =~ /$match/i;
    }
  else
    {
    $list = []; $down = 0;
    }
  $self->for_each ( 'by_field', $field, $match, $level, $list )
   if $level == 0 || $down == 0; # go at least one level deep
  return @$list;
  }

sub count
  {
  # count contained things and return hash
  my $self = shift;
  my $deep = shift;

  my $cnt = {};
  $self->traverse ( sub { my ($t,$c) = @_; $c->{ref($t)}++; }, $deep, $cnt);
  return $cnt;
  }

1; 

__END__

#############################################################################

=pod

=head1 NAME

Bunch - a bunch of Thingies (aka a container)

=head1 SYNOPSIS

	use CoW::Bunch;

	my $bunch = new CoW::Bunch ( contains => [ $this, $that, @more ] );

	print $bunch->items();
	print $bunch->as_string();

=head1 REQUIRES

perl5.005, Exporter

=head1 EXPORTS

Exports nothing.

=head1 DESCRIPTION

This is a two-headed beast. It is a thing I<AND> a container for things,
simultanously.

It offers a C<new()> method which provides I<named parameters>, and
an C<_init()> method, which you can override to do any initialisation your
object needs.

A B<Bunch> can contain other things, these are given with the parameter
C<contains>.

The module as a container holds references to other Bunches,
things or anything else. It offers a method to count them (C<items()>),
methods for walking the list (C<for_each>), removing/adding things by their 
reference (C<delete>, C<insert>) and checking wether something is contained
(named appropriately C<contains>).

=head1 FIELDS

Private fields are:

=over 2

=item _things

Contains the list of all contained things.

=item _hashed

Contains a hash of all thing referneces (to weed out doubles).

=item _parent

A reference to the C<Bunch> that contains us. Undefined if we are the
I<Mother of all Bunches>.

=back

=head1 METHODS

=head2 copy

Make recursively a copy of yourself and all things it contains 
and return reference to a new Bunch.

	use CoW::Bunch;

	$one = new CoW::Bunch();	# create a new one

	$two = $one;			# two simple points to one!
	$three = $one->copy();		# three is now a new bunch

=head2 items

Return number of things in container inclusive childs. 
If you give it something not 0, it will only count the things belonging to
itself:

	$bunch->items();	# ALL of them
	$bunch->items(1);	# only the things directly in bunch

=head2 delete

Delete one or more things from the container, by their reference. Returns
number of items left.

=head2 empty

Delete all contained things. This is faster than deleting them manually.

=head2 insert

Insert one or more things to the container, by their reference. Does not insert
things twice. In scalar context, returns the number of items actually inserted.
In list context, returns a list of actually inserted items.

Each of the inserted items/things has set it's field C<_parent> to self. If a
thing already contains a defined C<_parent> field, this means it already
belongs to some other Bunch. In this case Bunch automatically makes a copy
of the object and inserts the copy into itself. Thus the following works as
expected:

	use CoW::Bunch;
	use CoW::Item;

	$mine = new Bunch ( name => 'mine' );
	$yours = new Bunch ( name => 'yours' );
 	$money = new Item ( amount => 128 );
	$mine->insert($money);
	($your_money) =	$yours->insert($money);
	$your_money->{amount} -= 64;		# you spent some, but I dont

	# prints 128 and 64, respectively
	print "I have $money->{amount}, and you have $your_money->{amount}.\n";

=head2 count

Walks along the tree of all contained things via C<traverse()> and constructs
and returns a hash, whose keys are the classes of the things, and the values
are their count. Will thus report you how many CoW::Cell, CoW::Thing etc are
in this bunch altogether.

	print "The world contains:\n";
	my $cnt = $bunch->count(1);
	foreach (keys %$cnt)
	  {
	  my $n = "$_: "; $n .= ' ' while (length($n) < 32);
	  print " $n $cnt->{$_}\n";
	  }

=head2 contains

In scalar context return number of the given things that are contained in us,
0 for none. In list context, return a list of the things that are
contained, or an empty list.
	
	print $bunch->contains($one,$two);	# 0,1 or 2
	@inside = $bunch->contains($one);	# a list of 0 or 1 element

=head2 for_each

For each of the thingies, call callback ($thing,@params):

	$bunch->for_each ( \&print_it, '1', );

This will call for each of the thingies:

	print_it ($thing, 1);

You can get the parent of $thing from 

	$bunch = $thing->{_parent};

If callback is a string, the method with this name of the respective thingie
will be called:

	$bunch->for_each ( "as_string", $text );

This will add all things in bunch to $text by calling

	$thing->as_string($text);

Callback can be emitted, then an empty sub will be used and called. This is
effectively an expensive no-op.

You can give as callback a reference to a hash instead a code reference. The
hash can contain the key 'callback', the value must be a code reference.
This will be called for each of the things. The hash can also contain
strings that are matched against the class of the things. If for a given
thing's class a key exists, it will called, too.
	
	$bunch->for_each ( { callback => \&general,
          'CoW::Bunch' => \&bunch, }, 0, 1 );

This will call C<general($thing,1)> for all things, and for these things that
are a 'CoW::Bunch', C<bunch($thing,1)> will be called, too.

=head2 traverse

Traverse the entire contained tree, e.g. all things contained, plus the things
they contain and so on. For each of them, including yourself, call 
C<callback ($thing,@params)>:

	$bunch->traverse ( \&print_it, 0, 'foo' );

This will call for each of the thingies:

	print_it ($thing, 'foo');

You can get the parent of $thing from $thing->{_parent};

The order is either 0 (depth-first traverse) or != 0 for a node-first
traverse.

You can give as callback a reference to a hash instead a code reference. The
hash can contain the key 'callback', the value must be a code reference.
This will be called for each of the things. The hash can also contain
strings that are matched against the class of the things. If for a given
thing's class a key exists, it will called, too.
	
	$bunch->for_each ( { callback => \&general,
          'CoW::Bunch' => \&bunch, }, 0, 1 );

This will call C<general($thing,1)> for all things, and for these things that
are a 'CoW::Bunch', C<bunch($thing,1)> will be called, too.

Here is an example:

	use CoW::Bunch;
	
	my $bunch = 0;
	my $general = 0;

	$one = new CoW::Bunch ( x => 1, y => 2, z => 3, name => 'one thing' );
	$two = new CoW::Bunch ( x => 3, y => 4, z => 5, name => 'another',);
	$another = new CoW::Bunch ( contains => [ $one, $two ] );
	$another->traverse ( { callback => \&general, 
	'CoW::Bunch' => \&bunch }, 0, 7);
	print "First run done\n";
	$another->traverse ( { callback => \&general, 
	'CoW::Bunch' => \&bunch }, 1, 7);

	print "Done: bunch: $bunch, general: $general\n";
	1;

	sub bunch
	  {
	  my ($self,$x) = @_;
	  $bunch += $x; print "bunch '$self->{name}' $x\n";
	  }

	sub general
	  {	
	  my ($self,$x) = @_;
	  $general += $x; print "gen '$self->{name}' $x\n";
	  }      

This will print:

	gen 'one thing' 7
	bunch 'one thing' 7
	gen 'another' 7
	bunch 'another' 7
	gen '' 7
	bunch '' 7
	First run done
	gen '' 7
	bunch '' 7
	gen 'one thing' 7
	bunch 'one thing' 7
	gen 'another' 7
	bunch 'another' 7
	Done: bunch: 42, general: 42
	
=head2 by_field

Will return all contained things (excluding itself) that match the given
regular expression. The third parameter tells wether to search only the
contained things, or their contained things, too. Default is deep search:
	
	@list = $bunch->by_field ('name','lamp');	# return all lamps
	@list = $house->by_field ('name','cell',1);	# return all rooms, but
							# only one level deep

=head1 BUGS

=over 2

=item *

copy()  does not work recursively:

	$a = new Bunch ();
	$b = new Bunch ( contains => [ $a ] );

	$c = new Bunch ( contains => [ $b ] );

$c contains now a copy of $b, but $b still contains $a.

=item *

That is actually a feature:

The C<new()> stores inside a thing in B<_parent> a reference to the bunch 
the thing belongs to (aka it self). This means a thing can never belong to 
two bunches simultanously. If you try to stick something into yet another
bunch, a copy will be (silently) made and inserted into the other bunch
instead of the original.

=back

=head1 AUTHOR

Tels http://bloodgate.com in late 2000.

=cut

