Move Assets into module, create Drawing module
This commit is contained in:
Ryan Shepherd
parent
6fa0b11897
commit
8f5bbd7d82
|
|
@ -0,0 +1,220 @@
|
|||
package PerlRPG::Assets;
|
||||
use strict;
|
||||
require Exporter;
|
||||
use SDL;
|
||||
use SDL::Event;
|
||||
use SDLx::App;
|
||||
use SDLx::Sprite;
|
||||
use SDLx::Sprite::Animated;
|
||||
use PerlRPG::Console;
|
||||
use PerlRPG::Game;
|
||||
|
||||
use vars qw/%files @ISA @EXPORT @EXPORT_OK/;
|
||||
@ISA = qw/Exporter/;
|
||||
@EXPORT = qw/ScanDirectory GetAsset GetAssetType LoadAssets UnloadAsset/;
|
||||
@EXPORT_OK = ();
|
||||
|
||||
# Check %files cache for file location, otherwise search in path
|
||||
sub FindFile {
|
||||
my $filename=shift(@_);
|
||||
if(exists $files{$filename}) {
|
||||
return $files{$filename}{'Location'};
|
||||
}
|
||||
|
||||
my $full = FindFileInDir(GetOption('ResourceDir'), $filename);
|
||||
if($full) {
|
||||
$files{$filename}={
|
||||
'Loaded' => 0,
|
||||
'Location' => $full,
|
||||
};
|
||||
LogData(DEBUG, "Located '$filename' at '$full'");
|
||||
return $full;
|
||||
}
|
||||
LogData(WARN, "Unable to locate file '$filename' in Resource Path");
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Search for filename in path given and all sub-directories (Recursive)
|
||||
sub FindFileInDir {
|
||||
my($dir, $filename)=@_;
|
||||
if(-f "$dir/$filename") {
|
||||
return "$dir/$filename";
|
||||
}
|
||||
|
||||
foreach my $file (<$dir/*>) {
|
||||
next unless(-d $file);
|
||||
if(my $res = FindFileInDir($file, $filename)) {
|
||||
return $res;
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Scan every file in path given and add to %files (Recursive)
|
||||
sub ScanDirectory {
|
||||
my $path = shift(@_);
|
||||
|
||||
foreach my $file (<$path/*>) {
|
||||
if(-d $file) {
|
||||
ScanDirectory($file);
|
||||
} else {
|
||||
my($fname)=$file=~/.+\/(.+?)$/;
|
||||
$files{$fname}={
|
||||
'Loaded' => 0,
|
||||
'Location' => $file,
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Load all assets with given file extension
|
||||
sub LoadAssets {
|
||||
foreach my $ext (@_) {
|
||||
LogData(DEBUG, "Loading *.$ext assets");
|
||||
foreach my $file (grep { /\.$ext$/i } (keys %files)) {
|
||||
LoadAsset($file, $files{$file}{'Location'}) unless($files{$file}{'Loaded'});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Return the asset object
|
||||
sub GetAsset {
|
||||
my($file)=@_;
|
||||
|
||||
if(!exists $files{$file} || !$files{$file}{'Loaded'}) {
|
||||
if(!LoadAsset($file)) {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
return $files{$file}{ $files{$file}{'Type'} };
|
||||
}
|
||||
|
||||
# Return asset object type
|
||||
sub GetAssetType {
|
||||
my($file)=@_;
|
||||
|
||||
if(!exists $files{$file} || !$files{$file}{'Loaded'}) {
|
||||
if(!LoadAsset($file)) {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
return $files{$file}{'Type'};
|
||||
}
|
||||
|
||||
sub UnloadAsset {
|
||||
my($file)=@_;
|
||||
if(exists $files{$file}) {
|
||||
$files{$file}{'Loaded'} = 0;
|
||||
delete $files{$file}{ $files{$file}{'Type'} };
|
||||
$files{$file}{'Type'} = '';
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub LoadAsset {
|
||||
my($file, $filename)=@_;
|
||||
|
||||
if(!$filename && !($filename = FindFile($file))) {
|
||||
LogData(FATAL, "Unable to load asset file '$file'; Unable to find file.");
|
||||
SetOption('Running', 0);
|
||||
}
|
||||
|
||||
if(exists $files{$file}) {
|
||||
if($files{$file}{'Loaded'}) {
|
||||
return $files{$file};
|
||||
}
|
||||
} else {
|
||||
$files{$file}={
|
||||
'Loaded' => 0,
|
||||
'Location' => $filename,
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
my($ext)=$file=~/.+\.(.+?)$/;
|
||||
$ext = lc($ext);
|
||||
if(grep { $_ eq $ext } (qw/png jpg jpeg bmp/)) {
|
||||
$files{$file}{'Type'} = 'Sprite';
|
||||
my $sprite = SDLx::Sprite->new(
|
||||
image => $files{$file}{'Location'},
|
||||
);
|
||||
if(!$sprite) {
|
||||
LogData(ERROR, "Unable to load sprite '$filename': $!");
|
||||
return undef;
|
||||
}
|
||||
$files{$file}{'Sprite'} = $sprite;
|
||||
} elsif($ext eq 'vs') {
|
||||
unless(open(IN, $filename)) {
|
||||
LogData(ERROR, "Unable to load '$filename': $!");
|
||||
return undef;
|
||||
}
|
||||
my @frames = <IN>;
|
||||
chomp(@frames);
|
||||
close(IN);
|
||||
LoadVirtualSprite($file, @frames);
|
||||
} elsif($ext eq 'gs') {
|
||||
unless(open(IN, $filename)) {
|
||||
LogData(ERROR, "Unable to load '$filename': $!");
|
||||
return undef;
|
||||
}
|
||||
$files{$file}{'Type'} = 'Script';
|
||||
$files{$file}{'Script'} = join('', <IN>);
|
||||
close(IN);
|
||||
} else {
|
||||
LogData(WARN, "Unable to pre-load asset of type '$ext'");
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
$files{$file}{'Loaded'} = 1;
|
||||
return $files{$file};
|
||||
}
|
||||
|
||||
sub LoadVirtualSprite {
|
||||
my($name, @files)=@_;
|
||||
|
||||
if(exists $files{$name} && $files{$name}{'Loaded'}) {
|
||||
return $files{$name};
|
||||
}
|
||||
|
||||
foreach (@files) {
|
||||
if(!LoadAsset($_)) {
|
||||
LogData(ERROR, "Unable to load virtual sprite, error loading one or more assets.");
|
||||
return undef;
|
||||
}
|
||||
LogData(DEBUG, "Adding asset $_ to virtual sprite $name");
|
||||
}
|
||||
|
||||
my @frames = map { $files{$_}{'Sprite'}->surface() } (@files);
|
||||
my $h = $frames[0]->height();
|
||||
my $hp = 0;
|
||||
|
||||
my $newsurface = SDLx::Surface->new( width => $frames[0]->width(),
|
||||
height => $h * (@frames-0),
|
||||
format => $frames[0]->format(),
|
||||
pitch => $frames[0]->pitch(),
|
||||
flags => $frames[0]->flags(),
|
||||
);
|
||||
$newsurface->draw_rect( [0, 0, $newsurface->width(), $newsurface->height()], [0, 0, 0, 255]);
|
||||
#SDL::Video::set_alpha( $newsurface, SDL::Video::SDL_SRCALPHA, 0);
|
||||
foreach (@frames) {
|
||||
#SDL::Video::set_alpha( $_, SDL::Video::SDL_SRCALPHA, 255);
|
||||
#FIXME - This call ignores the source alpha channel
|
||||
$_->blit( $newsurface, undef, [0, $hp, $_->width(), $_->height()]);
|
||||
$hp += $h;
|
||||
}
|
||||
|
||||
my $anim = SDLx::Sprite::Animated->new( surface => $newsurface,
|
||||
width => $newsurface->width(),
|
||||
height => $h,
|
||||
step_x => $newsurface->width(),
|
||||
step_y => $h,
|
||||
);
|
||||
$files{$name}{'Loaded'} = 1;
|
||||
$files{$name}{'Type'} = 'ASprite';
|
||||
$files{$name}{'ASprite'} = $anim;
|
||||
return $anim;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
package PerlRPG::Drawing;
|
||||
use strict;
|
||||
require Exporter;
|
||||
use SDL;
|
||||
use SDL::Event;
|
||||
use SDLx::App;
|
||||
use SDLx::Sprite;
|
||||
use SDLx::Sprite::Animated;
|
||||
use PerlRPG::Console;
|
||||
use PerlRPG::Game;
|
||||
use PerlRPG::Assets;
|
||||
use Storable qw/dclone/;
|
||||
|
||||
use vars qw/@ISA @EXPORT @EXPORT_OK %VisibleSprites/;
|
||||
@ISA = qw/Exporter/;
|
||||
@EXPORT = qw/ ShowSprite HideSprite MoveSprite SetBackgroundColor RenderSprites /;
|
||||
@EXPORT_OK = ();
|
||||
|
||||
# FIXME - This should be exported
|
||||
*GetOption = \&PerlRPG::Game::GetOption;
|
||||
|
||||
sub ShowSprite {
|
||||
my($name, $file, $x, $y, $d)=@_;
|
||||
LogData(DEBUG, "Showing sprite $file as $name");
|
||||
|
||||
my $t = GetAssetType($file);
|
||||
if($t ne 'Sprite' && $t ne 'ASprite') {
|
||||
LogData(WARN, "Unable to ShowSprite on non-sprite asset '$file'");
|
||||
return;
|
||||
}
|
||||
|
||||
my $a = GetAsset($file);
|
||||
# Unload the asset so that future versions of the same name will be fresh copies
|
||||
UnloadAsset($file);
|
||||
|
||||
if($t eq 'ASprite') {
|
||||
$a->start();
|
||||
}
|
||||
|
||||
$VisibleSprites{$name}={
|
||||
'Depth' => $d,
|
||||
'X' => $x,
|
||||
'Y' => $y,
|
||||
'Sprite' => $a,
|
||||
};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub HideSprite {
|
||||
my($name)=@_;
|
||||
delete $VisibleSprites{$name};
|
||||
}
|
||||
|
||||
sub MoveSprite {
|
||||
my($name, $x, $y)=@_;
|
||||
return undef unless(exists $VisibleSprites{$name});
|
||||
$VisibleSprites{$name}{'X'} = $x;
|
||||
$VisibleSprites{$name}{'Y'} = $y;
|
||||
}
|
||||
|
||||
sub SetBackgroundColor {
|
||||
my $color;
|
||||
if(!@_) {
|
||||
$color = [0, 0, 0, 255];
|
||||
} elsif(ref $_[0]) {
|
||||
$color = $_[0];
|
||||
} else {
|
||||
$color = [@_];
|
||||
}
|
||||
|
||||
# Force alpha channel?
|
||||
$color->[3]=255;
|
||||
|
||||
my $app = GetOption('App');
|
||||
my $surface = SDLx::Surface->new(width => $app->width(), height => $app->height());
|
||||
$surface->draw_rect([0, 0, $surface->width(), $surface->height()], $color);
|
||||
my $sprite = SDLx::Sprite->new( surface => $surface );
|
||||
$VisibleSprites{'Background'}={
|
||||
'Depth' => -1,
|
||||
'X' => 0,
|
||||
'Y' => 0,
|
||||
'Sprite' => $sprite
|
||||
};
|
||||
}
|
||||
|
||||
sub RenderSprites {
|
||||
my $app = GetOption('App');
|
||||
my @names = sort { $VisibleSprites{$a}{'Depth'} <=> $VisibleSprites{$b}{'Depth'} } (keys %VisibleSprites);
|
||||
foreach my $name (@names) {
|
||||
my $x = $VisibleSprites{$name}{'X'};
|
||||
my $y = $VisibleSprites{$name}{'Y'};
|
||||
$VisibleSprites{$name}{'Sprite'}->draw_xy($app, $x, $y);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
230
PerlRPG/Game.pm
230
PerlRPG/Game.pm
|
|
@ -1,22 +1,32 @@
|
|||
package PerlRPG::Game;
|
||||
use strict;
|
||||
require Exporter;
|
||||
use SDL;
|
||||
use SDL::Event;
|
||||
use SDLx::App;
|
||||
use SDLx::Sprite;
|
||||
use SDLx::Sprite::Animated;
|
||||
use PerlRPG::Console;
|
||||
use vars qw/$app/;
|
||||
use PerlRPG::Assets;
|
||||
use PerlRPG::Drawing;
|
||||
use vars qw/$app @ISA @EXPORT @EXPORT_OK/;
|
||||
|
||||
@ISA = qw/Exporter/;
|
||||
@EXPORT = qw/InitApp Run RunScript GetOption SetOption/;
|
||||
@EXPORT_OK = @EXPORT;
|
||||
|
||||
$app = undef;
|
||||
my %opt = (
|
||||
'App' => undef,
|
||||
'Running' => 1,
|
||||
'TargetFPS' => 5,
|
||||
'ResourceDir' => '.',
|
||||
'Status' => 'WaitForFrame',
|
||||
);
|
||||
|
||||
my %files;
|
||||
sub GetOption { return (exists $opt{$_[0]} ? $opt{$_[0]} : undef); }
|
||||
sub SetOption { $opt{$_[0]} = $_[1]; }
|
||||
|
||||
|
||||
sub InitApp {
|
||||
my($width, $height)=@_;
|
||||
|
|
@ -28,6 +38,7 @@ sub InitApp {
|
|||
width => $width,
|
||||
height => $height,
|
||||
);
|
||||
$opt{'App'}=$app;
|
||||
LogData(DEBUG, "SDL Instance created");
|
||||
return $app;
|
||||
}
|
||||
|
|
@ -65,225 +76,12 @@ sub EventDispatcher {
|
|||
}
|
||||
|
||||
sub RenderScreen {
|
||||
RenderSprites();
|
||||
$app->update();
|
||||
}
|
||||
|
||||
# Check %files cache for file location, otherwise search in path
|
||||
sub FindFile {
|
||||
my $filename=shift(@_);
|
||||
if(exists $files{$filename}) {
|
||||
return $files{$filename}{'Location'};
|
||||
}
|
||||
|
||||
my $full = FindFileInDir($opt{'ResourceDir'}, $filename);
|
||||
if($full) {
|
||||
$files{$filename}={
|
||||
'Loaded' => 0,
|
||||
'Location' => $full,
|
||||
};
|
||||
LogData(DEBUG, "Located '$filename' at '$full'");
|
||||
return $full;
|
||||
}
|
||||
LogData(WARN, "Unable to locate file '$filename' in Resource Path");
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Search for filename in path given and all sub-directories (Recursive)
|
||||
sub FindFileInDir {
|
||||
my($dir, $filename)=@_;
|
||||
if(-f "$dir/$filename") {
|
||||
return "$dir/$filename";
|
||||
}
|
||||
|
||||
foreach my $file (<$dir/*>) {
|
||||
next unless(-d $file);
|
||||
if(my $res = FindFileInDir($file, $filename)) {
|
||||
return $res;
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Scan every file in path given and add to %files (Recursive)
|
||||
sub ScanDirectory {
|
||||
my $path = shift(@_);
|
||||
|
||||
foreach my $file (<$path/*>) {
|
||||
if(-d $file) {
|
||||
ScanDirectory($file);
|
||||
} else {
|
||||
my($fname)=$file=~/.+\/(.+?)$/;
|
||||
$files{$fname}={
|
||||
'Loaded' => 0,
|
||||
'Location' => $file,
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub LoadAssets {
|
||||
foreach my $ext (@_) {
|
||||
LogData(DEBUG, "Loading *.$ext assets");
|
||||
foreach my $file (grep { /\.$ext$/i } (keys %files)) {
|
||||
LoadAsset($file, $files{$file}{'Location'}) unless($files{$file}{'Loaded'});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub GetAsset {
|
||||
my($file)=@_;
|
||||
|
||||
if(!exists $files{$file} || !$files{$file}{'Loaded'}) {
|
||||
if(!LoadAsset($file)) {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
return $files{$file}{ $files{$file}{'Type'} };
|
||||
}
|
||||
|
||||
sub GetAssetType {
|
||||
my($file)=@_;
|
||||
|
||||
if(!exists $files{$file} || !$files{$file}{'Loaded'}) {
|
||||
if(!LoadAsset($file)) {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
return $files{$file}{'Type'};
|
||||
}
|
||||
|
||||
sub LoadAsset {
|
||||
my($file, $filename)=@_;
|
||||
|
||||
if(!$filename && !($filename = FindFile($file))) {
|
||||
LogData(FATAL, "Unable to load asset file '$file'; Unable to find file.");
|
||||
$opt{'Running'}=0;
|
||||
}
|
||||
|
||||
if(exists $files{$file}) {
|
||||
if($files{$file}{'Loaded'}) {
|
||||
return $files{$file};
|
||||
}
|
||||
} else {
|
||||
$files{$file}={
|
||||
'Loaded' => 0,
|
||||
'Location' => $filename,
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
my($ext)=$file=~/.+\.(.+?)$/;
|
||||
$ext = lc($ext);
|
||||
if(grep { $_ eq $ext } (qw/png jpg jpeg bmp/)) {
|
||||
$files{$file}{'Type'} = 'Sprite';
|
||||
my $sprite = SDLx::Sprite->new(
|
||||
image => $files{$file}{'Location'},
|
||||
);
|
||||
if(!$sprite) {
|
||||
LogData(ERROR, "Unable to load sprite '$filename': $!");
|
||||
return undef;
|
||||
}
|
||||
$files{$file}{'Sprite'} = $sprite;
|
||||
} elsif($ext eq 'vs') {
|
||||
unless(open(IN, $filename)) {
|
||||
LogData(ERROR, "Unable to load '$filename': $!");
|
||||
return undef;
|
||||
}
|
||||
my @frames = <IN>;
|
||||
chomp(@frames);
|
||||
close(IN);
|
||||
return LoadVirtualSprite($file, @frames);
|
||||
} elsif($ext eq 'gs') {
|
||||
unless(open(IN, $filename)) {
|
||||
LogData(ERROR, "Unable to load '$filename': $!");
|
||||
return undef;
|
||||
}
|
||||
$files{$file}{'Type'} = 'Script';
|
||||
$files{$file}{'Script'} = join('', <IN>);
|
||||
close(IN);
|
||||
} else {
|
||||
LogData(WARN, "Unable to pre-load asset of type '$ext'");
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
$files{$file}{'Loaded'} = 1;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub LoadVirtualSprite {
|
||||
my($name, @files)=@_;
|
||||
|
||||
if(exists $files{$name} && $files{$name}{'Loaded'}) {
|
||||
return $files{$name}{'ASprite'};
|
||||
}
|
||||
|
||||
foreach (@files) {
|
||||
if(!LoadAsset($_)) {
|
||||
LogData(ERROR, "Unable to load virtual sprite, error loading one or more assets.");
|
||||
return undef;
|
||||
}
|
||||
LogData(DEBUG, "Adding asset $_ to virtual sprite $name");
|
||||
}
|
||||
|
||||
my @frames = map { $files{$_}{'Sprite'}->surface() } (@files);
|
||||
my $h = $frames[0]->height();
|
||||
my $hp = 0;
|
||||
|
||||
my $newsurface = SDLx::Surface->new( width => $frames[0]->width(),
|
||||
height => $h * (@frames-0),
|
||||
format => $frames[0]->format(),
|
||||
pitch => $frames[0]->pitch(),
|
||||
flags => $frames[0]->flags(),
|
||||
);
|
||||
$newsurface->draw_rect( [0, 0, $newsurface->width(), $newsurface->height()], [0, 0, 0, 255]);
|
||||
#SDL::Video::set_alpha( $newsurface, SDL::Video::SDL_SRCALPHA, 0);
|
||||
foreach (@frames) {
|
||||
#SDL::Video::set_alpha( $_, SDL::Video::SDL_SRCALPHA, 255);
|
||||
$_->blit( $newsurface, undef, [0, $hp, $_->width(), $_->height()]);
|
||||
$hp += $h;
|
||||
}
|
||||
|
||||
my $testsprite = SDLx::Sprite->new( surface => $newsurface );
|
||||
|
||||
my $anim = SDLx::Sprite::Animated->new( surface => $newsurface,
|
||||
width => $newsurface->width(),
|
||||
height => $h,
|
||||
step_x => $newsurface->width(),
|
||||
step_y => $h,
|
||||
);
|
||||
#$anim->surface($newsurface);
|
||||
|
||||
$files{$name}{'Loaded'} = 1;
|
||||
$files{$name}{'Type'} = 'ASprite';
|
||||
$files{$name}{'ASprite'} = $anim;
|
||||
return $anim;
|
||||
}
|
||||
|
||||
sub ShowImage {
|
||||
my($file, $x, $y)=@_;
|
||||
if(!exists $files{$file} || !$files{$file}{'Loaded'}) {
|
||||
LogData(DEBUG, "Loading image on first use '$file'");
|
||||
if(!LoadAsset($file)) {
|
||||
LogData(WARN, "Failed to load image '$file'");
|
||||
return;
|
||||
}
|
||||
}
|
||||
if($files{$file}{'Type'} ne 'Sprite') {
|
||||
LogData(WARN, "ShowImage called on non-Image asset");
|
||||
return;
|
||||
}
|
||||
LogData(DEBUG, "Drawing $file at $x,$y");
|
||||
$files{$file}{'Sprite'}->draw_xy( $app, $x, $y );
|
||||
}
|
||||
|
||||
sub RunScript {
|
||||
# Blank Screen
|
||||
$app->draw_rect( [0, 0, $app->width(), $app->height()], [128, 128, 128, 255]);
|
||||
|
||||
my $a=GetAsset('aka.vs');
|
||||
$a->draw_xy($app, 0, 0);
|
||||
$app->update();
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -2,20 +2,22 @@
|
|||
use strict;
|
||||
use PerlRPG::Game;
|
||||
use PerlRPG::Console;
|
||||
use PerlRPG::Assets;
|
||||
use PerlRPG::Drawing;
|
||||
|
||||
my $screen_width = 1024;
|
||||
my $screen_height = 768;
|
||||
my $asset_directory = 'Resources';
|
||||
|
||||
LogData(STATUS, "Starting up");
|
||||
PerlRPG::Game::ScanDirectory('.');
|
||||
my $app = PerlRPG::Game::InitApp($screen_width, $screen_height);
|
||||
{
|
||||
my $a=PerlRPG::Game::GetAsset('aka.vs');
|
||||
$a->start();
|
||||
|
||||
}
|
||||
PerlRPG::Game::RunScript('__init__');
|
||||
PerlRPG::Game::Run();
|
||||
ScanDirectory($asset_directory);
|
||||
my $app = InitApp($screen_width, $screen_height);
|
||||
#GetAsset('aka.vs')->start();
|
||||
SetBackgroundColor(128, 128, 128, 255);
|
||||
ShowSprite('aka', 'aka.vs', 10, 10, 1);
|
||||
ShowSprite('aka2', 'aka.vs', 200, 10, 1);
|
||||
|
||||
Run();
|
||||
|
||||
LogData(STATUS, "Tearing down");
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue