Games-FrozenBubble

 view release on metacpan or  search on metacpan

bin/frozen-bubble  view on Meta::CPAN

sub add_bubble_image($) {
    my ($file) = @_;
    my $bubble = add_image($file);
    push @bubbles_images, $bubble;
    return $bubble;
}


#- ----------- generic game stuff -----------------------------------------

sub iter_players(&) {
    my ($f, @p) = @_;
    my $bt = backtrace();
    $bt =~ /\nmain::iter_players\b/ and die "iter_players: assert failed -- iter_players can't be called recursively sorry\n$bt";
    @p or @p = @PLAYERS;
    local $::p;
    foreach $::p (@p) {
        mini_graphics($::p) or goto normal_sizes;  #- can't use an if block because of local
        local $BUBBLE_SIZE = $BUBBLE_SIZE / 2;
        local $BUBBLE_SPEED = $BUBBLE_SPEED / 2;
        local $ROW_SIZE = $ROW_SIZE / 2;
        local $FREE_FALL_CONSTANT = $FREE_FALL_CONSTANT / 2;
      normal_sizes:
        &$f;
    }
}
sub iter_players_(&) {  #- so that I can do an iter_players_ from within an iter_players
    my ($f, @p) = @_;
    my $bt = backtrace();
    $bt =~ /\nmain::iter_players_\b/ and die "iter_players_: assert failed -- iter_players_ can't be called recursively sorry\n$bt";
    @p or @p = @PLAYERS;
    local $::p_;
    foreach $::p_ (@p) {
        &$f;
    }
}
sub iter_players_but_first(&) {
    my ($f) = @_;
    my (undef, @p) = @PLAYERS;
    &iter_players($f, @p);
}
sub iter_local_players(&) {
    my ($f) = @_;
    my @p = grep { !/rp/ } @PLAYERS;
    &iter_players($f, @p);
}
sub iter_distant_players(&) {
    my ($f) = @_;
    my @p = grep { /rp/ } @PLAYERS;
    &iter_players($f, @p);
}
sub iter_distant_players_(&) {
    my ($f) = @_;
    my @p = grep { /rp/ } @PLAYERS;
    &iter_players_($f, @p);
}

sub is_1p_game() { @PLAYERS == 1 }
sub is_mp_game() { any { /rp/ } @PLAYERS }
sub is_2p_game() { @PLAYERS == 2 && !is_mp_game() }

sub is_leader() {

bin/frozen-bubble  view on Meta::CPAN

sub create_bubble_given_img_num($) {
    my ($num) = @_;
    return create_bubble_given_img($bubbles_images[$num]);
}

sub validate_nextcolor($$) {
    my ($num, $player) = @_;
    return !is_1p_game() || member($num, map { get_bubble_num($_) } @{$sticked_bubbles{$player}});
}

sub each_index(&@) {
    my $f = shift;
    local $::i = 0;
    foreach (@_) {
        $f->();
        $::i++;
    }
}
sub get_bubble_num {
    my ($b) = @_;
    my $num = -1;
    each_index { $_ eq $b->{img} and $num = $::i } @bubbles_images;
    return $num;
}

sub iter_rowscols(&$) {
    my ($f, $oddswap) = @_;
    local $::row; local $::col;
    foreach $::row (0 .. 11) {
        foreach $::col (0 .. 7 - odd($::row+$oddswap)) {
            &$f;
        }
    }
}

sub each_index(&@) {
    my $f = shift;
    local $::i = 0;
    foreach (@_) {
        &$f($::i);
        $::i++;
    }
}
sub img2numb { my ($i, $f) = @_; each_index { $i eq $_ and $f = $::i } @bubbles_images; return defined($f) ? $f : '-' }

sub bubble_next_to($$$$$) {

lib/Games/FrozenBubble/LevelEditor.pm  view on Meta::CPAN

sub create_open_levelset_dialog_ok_only {

    $displaying_dialog = 'ls_open_ok_only';
    create_ok_dialog('SELECT LEVELSET TO OPEN');
    $list_browser_highlight_offset = -1;
    $list_browser_file_start_offset = -1;
    display_levelset_list_browser(0,0);

}

sub iter_rowscols(&) {
    my ($f) = @_;
    local ($::row, $::col);
    foreach $::row (0 .. $NUM_ROWS - 1) {
        foreach $::col (0 .. ($POS_1P{p1}{right_limit}-$POS_1P{p1}{left_limit})/$BUBBLE_SIZE - 1 - odd($::row)) {
            &$f;
        }
    }
}

sub save_file {

lib/Games/FrozenBubble/MDKCommon.pm  view on Meta::CPAN

    foreach (@_) { $e eq $_ and return 1 }
    0;
}

sub difference2 {
    my %l;
    @l{ @{ $_[1] } } = ();
    grep { !exists $l{$_} } @{ $_[0] };
}

sub any(&@) {
    my $f = shift;
    $f->($_) and return 1 foreach @_;
    0;
}

sub even { $_[0] % 2 == 0 }

sub odd { $_[0] % 2 == 1 }

sub sqr { $_[0] * $_[0] }

lib/Games/FrozenBubble/MDKCommon.pm  view on Meta::CPAN

sub if_($@) {
    my $b = shift;
    $b or return ();
    wantarray || @_ <= 1
      or die( "if_ called in scalar context with more than one argument "
          . join( ":", caller() ) );
    wantarray ? @_ : $_[0];
}

sub fold_left(&@) {
    my ( $f, $initial, @l ) = @_;
    local ( $::a, $::b );
    $::a = $initial;
    foreach $::b (@l) { $::a = &$f() }
    $::a;
}

sub output {
    my $f = shift;
    local *F;

lib/Games/FrozenBubble/Stuff.pm  view on Meta::CPAN

# to have a look at this library and use it, it would
# dramatically increase the efficiency and readability of your
# perl programs.
#
# Go to google and type in "perl-MDK-Common" if interested.
#
$PI = 3.1415926535897932384626433832795028841972;
sub cat_ { local *F; open F, $_[0] or return; my @l = <F>; wantarray ? @l : join '', @l }
sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 }
sub difference2 { my %l; @l{@{$_[1]}} = (); grep { !exists $l{$_} } @{$_[0]} }
sub any(&@) {
    my $f = shift;
    $f->($_) and return 1 foreach @_;
    0;
}
sub every(&@) {
    my $f = shift;
    $f->($_) or return 0 foreach @_;
    1;
}
sub even { $_[0] % 2 == 0 }
sub odd  { $_[0] % 2 == 1 }
sub sqr  { $_[0] * $_[0] }
sub to_bool { $_[0] ? 1 : 0 }
sub to_int { $_[0] =~ /(\d*)/; $1 }
sub if_($@) {
    my $b = shift;
    $b or return ();
    wantarray || @_ <= 1 or die("if_ called in scalar context with more than one argument " . join(":", caller()));
    wantarray ? @_ : $_[0];
}
sub fold_left(&@) {
    my ($f, $initial, @l) = @_;
    local ($::a, $::b);
    $::a = $initial;
    foreach $::b (@l) { $::a = &$f() }
    $::a
}
sub output {
        my $f = shift;
        local *F;
        chmod(0666, $f) if -e $f;

lib/Games/FrozenBubble/Stuff.pm  view on Meta::CPAN

sub all {
    my $d = shift;

    local *F;
    opendir F, $d or return;
    my @l = grep { $_ ne '.' && $_ ne '..' } readdir F;
    closedir F;

    @l;
}
sub partition(&@) {
    my $f = shift;
    my (@a, @b);
    foreach (@_) {
        $f->($_) ? push(@a, $_) : push(@b, $_);
    }
    \@a, \@b;
}
sub chomp_ { my @l = map { my $l = $_; chomp $l; $l } @_; wantarray() ? @l : $l[0] }
sub ssort(&@) {
    my $f = shift;
    sort { local $_ = $a; my $fa = $f->($a); local $_ = $b; $fa <=> $f->($b) } @_;
}
sub sum { my $n = 0; $n += $_ foreach @_; $n }
sub put_in_hash { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} = $v } $a }
sub smapn {
    my $f = shift;
    my $n = shift;
    my @r;
    for (my $i = 0; $i < $n; $i++) { push @r, &$f(map { $_->[$i] } @_) }
    @r
}
sub mapn(&@) {
    my $f = shift;
    smapn($f, min(map { scalar @$_ } @_), @_);
}
sub mapn_(&@) {
    my $f = shift;
    smapn($f, max(map { scalar @$_ } @_), @_);
}
sub add_f4before_leaving {
    my ($f, $b, $name) = @_;

    $Games::FrozenBubble::Stuff::before_leaving::_list->{$b}{$name} = $f;
    if (!$Games::FrozenBubble::Stuff::before_leaving::_added{$name}) {
        $Games::FrozenBubble::Stuff::before_leaving::_added{$name} = 1;
        no strict 'refs';
        *{"Games::FrozenBubble::Stuff::before_leaving::$name"} = sub {
            my $f = $Games::FrozenBubble::Stuff::before_leaving::_list->{$_[0]}{$name} or die '';
            $name eq 'DESTROY' and delete $Games::FrozenBubble::Stuff::before_leaving::_list->{$_[0]};
            &$f;
        };
    }
}
#- ! the functions are not called in the order wanted, in case of multiple before_leaving :(
sub before_leaving(&) {
    my ($f) = @_;
    my $b = bless {}, 'Games::FrozenBubble::Stuff::before_leaving';
    add_f4before_leaving($f, $b, 'DESTROY');
    $b;
}
# -=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=---=-=--

#- it doesn't keep ordering (but I don't care)
sub fastuniq { my %l; @l{@_} = @_; values %l }