#!/usr/bin/perl
############################################################################
#
# tkballs.pl 1.1 - Object-oriented Animation of a bunch of Balls in Perl/Tk.
# transcoded to Object::Pad by haj, January 2022.
#
# Copyright (C) 2015, 2017, Hauke Lubenow, Germany.
#
# License: GNU GPL (version 3 or above):
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
#
############################################################################
use warnings;
use strict;
use Tk;
use Object::Pad;
class BallWindow {
has $screenx :param = 640;
has $screeny :param = 480;
has $speed :param = 5;
has $running = 0;
has @balls;
has $mw;
has $cv;
has $fr1;
has $btn_start;
has $btn_stop;
has $btn_exit;
method runApplication {
$self->initBalls();
$self->showWindow();
}
method initBalls {
@balls = (Ball->new(name => "Ball1",
x => $self->toX(40),
y => $self->toY(30),
color => "red",
direction => "11"),
Ball->new(name => "Ball2",
x => $self->toY(1.5),
y => $self->toY(1.5),
color => "blue"),
Ball->new(name => "Ball3",
x => $self->toX(2.5),
y => $self->toY(2.5),
color => "green"),
Ball->new(name => "Ball4",
x => $self->toX(2),
y => $self->toY(10),
color => "cyan"),
Ball->new(name => "Ball5",
x => $self->toX(5),
y => $self->toY(5),
color => "yellow"))
}
method toX {
return $screenx / shift;
}
method toY {
return $screeny / shift;
}
method showWindow {
$mw = MainWindow->new();
$mw->optionAdd("*font", "Arial 12 normal");
$mw->title("TkBalls");
my $geomstr = int($screenx * 1.25);
$geomstr .= "x";
$geomstr .= int($screeny * 1.25);
$geomstr .= "+108+64";
$mw->geometry($geomstr);
$mw->bind('', sub { $mw->destroy() });
$cv = $mw->Canvas(bg => "white",
width => $screenx,
height => $screeny);
$cv->pack(-padx => 20, -pady => 20);
$fr1 = $mw->Frame();
$btn_start = $fr1->Button(-text => "Start",
-command => sub { $self->startMoving() });
$btn_start->focus();
$btn_stop = $fr1->Button(-text => "Stop",
-command => sub { $self->stopMoving() });
$btn_exit = $mw->Button(-text => "Exit",
-command => sub { $mw->destroy() });
$btn_start->pack(-side => "left", -padx => 50);
$btn_stop->pack(-side => "left", -padx => 50);
$fr1->pack();
$btn_exit->pack(-side => "right", -padx => 5, -pady => 5);
$self->moveBalls();
$mw->MainLoop();
}
method moveBalls {
my $i;
foreach $i (@balls) {
$i->clearDirChange();
$self->checkCollisions();
$i->moveBall($screenx, $screeny);
$mw->after($speed, sub { $self->drawBall($i) });
}
if ($running == 1) {
$mw->after($speed, sub { $self->moveBalls() });
}
}
method startMoving {
if ($running == 1) {
return;
}
$running = 1;
$self->moveBalls();
}
method stopMoving {
$running = 0;
}
method checkCollisions {
my $i;
my $u;
my @checkedballs = ();
foreach $i (@balls) {
foreach $u (@balls) {
if ($i->getName() eq $u->getName()) {
next;
}
if ($self->alreadyChecked($u, @checkedballs) == 1) {
next;
}
$i->checkCollision($u, $screenx, $screeny);
}
push(@checkedballs, $i);
}
}
method alreadyChecked {
my $ball = shift;
my @checkedballs = @_;
my $i;
foreach $i (@checkedballs) {
if($ball->getName() eq $i->getName()) {
return 1;
}
}
return 0;
}
method drawBall {
my $ball = shift;
my $id = $ball->getId();
if ($id != -1) {
$cv->delete($id);
}
my $x = $ball->getX();
my $y = $ball->getY();
my $color = $ball->getColor();
my $size = $ball->getSize();
$id = $cv->createOval($x - $size,
$y - $size,
$x + $size,
$y + $size, -fill => $color);
$ball->setId($id);
}
}
class Ball {
has $name :reader(getName) :param = "Ball1";
has $x :reader(getX) :writer(setX) :param = 0;
has $y :reader(getY) :writer(setY) :param = 0;
has $color :reader(getColor) :param = "black";
has $size :reader(getSize) :param = 15;
has $id :reader(getId) :writer(setId) :param = -1;
has $direction :param = "xx";
has $dirchanged = 0;
ADJUST {
if ($direction eq "xx") {
my @directions = ("00", "01", "10", "11");
$direction = $directions[int(rand(4))];
}
}
method moveBall ($screenx,$screeny) {
my $xdir = substr($direction, 0, 1);
my $newxdir = $xdir;
my $ydir = substr($direction, 1, 1);
my $newydir = $ydir;
if ($xdir == 0) {
if ($x <= $size) {
$newxdir = 1;
} else {
$x--;
}
}
if ($xdir == 1) {
if ($x >= $screenx - $size) {
$newxdir = 0;
} else {
$x++;
}
}
if ($ydir == 0) {
if ($y <= $size) {
$newydir = 1;
} else {
$y--;
}
}
if ($ydir == 1) {
if ($y >= $screeny - $size) {
$newydir = 0;
} else {
$y++;
}
}
$direction = "$newxdir$newydir";
}
method checkCollision ($otherball,$screenx,$screeny) {
if ($dirchanged == 1) {
return;
}
my $otherx = $otherball->getX();
my $othery = $otherball->getY();
my $othersize = $otherball->getSize();
if ($otherx - $othersize < $x + $size &&
$otherx + $othersize > $x - $size &&
$othery - $othersize < $y + $size &&
$othery + $othersize > $y - $size) {
$self->changeDirection();
# If the balls are too close , they keep changing directions
# and "stick" to each other. So at least on ball needs
# to be moved away a bit:
$self->moveBall($screenx, $screeny);
$otherball->changeDirection();
}
}
method changeDirection {
my $newdir = "";
if (substr($direction, 0, 1) eq "0") {
$newdir .= "1";
} else {
$newdir .= "0";
}
if (substr($direction, 1, 1) eq "0") {
$newdir .= "1";
} else {
$newdir .= "0";
}
$direction = $newdir;
$dirchanged = 1;
}
method clearDirChange {
$dirchanged = 0;
}
}
my $bw = BallWindow->new();
$bw->runApplication();