use Bio::PopGen::TagHaplotype;

    my $obj = Bio::PopGen::TagHaplotype -> new($hap);

#------------------------
    my ($class, @args) = @_;

    my $self = $class->SUPER::new(@args);

    my ($haplotype_block) = $self->_rearrange([qw(HAPLOTYPE_BLOCK)],@args);

    if ($haplotype_block) {
        $self->haplotype_block($haplotype_block);
    }
    else{
        $self->throw("haplotype has not been supplied\n$USAGE");
    }

    # check that the haplotype block is well formed.
    for (my $i=0; $i<$#$haplotype_block+1; $i++){
	if ( $#{$haplotype_block->[0]} !=
             $#{$haplotype_block->[$i]} ){

            $self->throw("The haplotype matrix is not well formed (Not squared)");
        }
    }

    # make the calculation
    my $tag_list =  _scan_snp( $self ->haplotype_block );

    if ($tag_list){
        $self ->tag_list($tag_list);
    }
    else { 
        $self ->tag_list(undef);
    }

    if ( defined $self->tag_list){
        $self ->tag_length(scalar @{$self->tag_list});
    }
    else {
        $self ->tag_length(0);  #"NO TAGS FOUND!"
    }

    return $self;

    my ($self) =shift;
    return $self->{'_haplotype_block'} = shift if @_;
    return $self->{'_haplotype_block'};

#------------------------
    my $self = shift;

    $self->warn(ref($self). "::input_block - deprecated method. Use haplotype_block() instead.");
    return $self->haplotype_block;

#------------------------
    my ($self) = shift;
    return $self->{'_tag_list'}= shift if @_;
    return $self->{'_tag_list'};

#------------------------
    my ($self) =shift;
    return $self ->{'_tag_length'} = shift if @_;
    return $self ->{'_tag_length'};

#------------------------
    my ($hap)=@_;

    my $hap_length = scalar @{$hap->[0]};    ## store the haplotype length

    for my $i(1..$hap_length){

        my $list = _gen_comb($hap_length, $i);

        my $snp_collection = _scan_combinations($hap, $list);

        # if there is any element on the collection.
        # We have reached our goal and 
        # we can stop the calculation.
        if($#$snp_collection>-1){
            return $snp_collection;
        }
    }

#------------------------

    my ($hap_length,$n) = @_;

    my @array = ();    # list with all elements we have to combine

    
    for(0..$hap_length-1){ push @array, $_ };

    #
    # we need some parameters to create the combination list.
    # This parameters can be changed if we can modify the list values
    #

    my $m = -1;      # this parameter start the calculation at value
                     # m+1 on the recursive cicle.

    my $value = [];  ## seems to have not too much sense here, but is
                     ## needed on the recursion and need to be started
                     ## from here
    my $list = [];

    _generateCombinations (\@ array,\$ m, \$n, $value, $list);

    return $list;

#------------------------
    my ($rarr, $rm, $rn, $rvalue,$rlist)=@_;

    for (my $i = ($$rm+1); $i<scalar @$rarr; $i++){
        push (my @value2,@$rvalue,$rarr->[$i]);
        if (scalar @value2<$$rn){
            _generateCombinations($rarr,\$i, $rn,\@ value2, $rlist);
        }
        if (scalar @value2==$$rn){
            push @$rlist, [@value2];
        }
        if(scalar @value2>$$rn){
            last;
        }
    }
}

# take the list of combinations
# i.e.: 1 2 3
#       1 2 4
#       1 3 4
#       2 3 4
#
# generate a sub array from the haplotype with the snp tag for the combination
# and check all haplotypes for these columns.
# if two haplotypes have the same value. we can not define the haplotype
# without ambiguity.
# Will return a list of valid combinations (SNP Tags)
#

#------------------------

    my($hap,$list) = @_;

    my $valid_combination = undef;

    # we have to check every snp combinations from the list
    for my $i (0..$#$list){

        # extract from the big array the one we will use for tag calculations
        my $subArray = _get_subArray ($hap, $list->[$i]);

        my $degeneration = _deg_test($subArray);

        if(!$degeneration){
            push @$valid_combination, [@{$list->[$i]}];
        }
    }
    return $valid_combination;
}

# return 1 if two arrays are degenerated (same haplotype)
#------------------------

#------------------------

    my ($hap)= @_;

    # for every sub array we compare each element with the rest
    for my $c1(0..$#$hap){
        for my $c2($c1+1..$#$hap){
            my $degeneration = compare_arrays($hap->[$c1], $hap->[$c2]);
            if ($degeneration){
                # if the two arrays are the same
                return 1;
            }
        }
    }
}

#------------------------

#------------------------
    my($hap, $combination) =@_;

    my $out = [];    # output array to be tested
 
    for my $i (0..$#$hap){
        foreach(@$combination){
            push @{$out->[$i]}, $hap->[$i][$_];
        }
    }
    return $out;
}

#
# take two arrays and compare their values
# Returns : 1 if the two values are the same
#           0 if the values are different
#

#------------------------

#------------------------
    my ($first, $second) = @_;
    return 0 unless @$first == @$second;
    for (my $i = 0; $i < @$first; $i++) {
        return 0 if $first->[$i] ne $second->[$i];
    }
    return 1;
}

1;

    my $obj = Bio::PopGen::TagHaplotype -> new($hap);

    were $hap is the reference to an array of array with the haplotype.

    $hap= [[0, 0, 0],
           [1, 0, 0],
           [0, 1, 1]
          ];

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

  https://redmine.open-bio.org/projects/bioperl/