Basic control interface
This commit is contained in:
parent
e546d6cb28
commit
383356f361
|
|
@ -8,33 +8,34 @@ use vars qw/$StackTraceLevel $LogLevel @InputCallbacks %ConsoleCommands @LogCall
|
||||||
@ISA = qw/Exporter/;
|
@ISA = qw/Exporter/;
|
||||||
|
|
||||||
use constant {
|
use constant {
|
||||||
DEBUG => 0,
|
DEVALL => 0,
|
||||||
INFO => 1,
|
DEBUG => 1,
|
||||||
STATUS => 2,
|
INFO => 2,
|
||||||
WARN => 3,
|
STATUS => 3,
|
||||||
ERROR => 4,
|
WARN => 4,
|
||||||
CRIT => 5,
|
ERROR => 5,
|
||||||
FATAL => 6,
|
CRIT => 6,
|
||||||
|
FATAL => 7,
|
||||||
};
|
};
|
||||||
my @debugnames=qw/DEBUG INFO STATUS WARN ERROR CRIT FATAL/;
|
my @debugnames=qw/DEVALL DEBUG INFO STATUS WARN ERROR CRIT FATAL/;
|
||||||
$StackTraceLevel = ERROR;
|
$StackTraceLevel = ERROR;
|
||||||
$LogLevel = DEBUG;
|
$LogLevel = DEBUG;
|
||||||
@LogCallbacks = ();
|
@LogCallbacks = ();
|
||||||
@InputCallbacks = (\&StdinConsole);
|
@InputCallbacks = (\&StdinConsole);
|
||||||
|
|
||||||
@EXPORT_OK = ();
|
@EXPORT_OK = ();
|
||||||
@EXPORT = qw/DEBUG INFO STATUS WARN ERROR CRIT FATAL LogData/;
|
@EXPORT = qw/DEVALL DEBUG INFO STATUS WARN ERROR CRIT FATAL LogData/;
|
||||||
|
|
||||||
sub LogData {
|
sub LogData {
|
||||||
my($level, $log, @args)=@_;
|
my($level, $log, @args)=@_;
|
||||||
my($file, $line);
|
my($file, $line);
|
||||||
(undef, $file, $line)=caller();
|
(undef, $file, $line)=caller();
|
||||||
if($level < DEBUG || $level > FATAL) {
|
if($level < 0 || $level > FATAL) {
|
||||||
$level = FATAL;
|
$level = FATAL;
|
||||||
}
|
}
|
||||||
return if($level < $LogLevel);
|
return if($level < $LogLevel);
|
||||||
|
|
||||||
my $str = sprintf("[%6s] %s $log\n", $debugnames[$level], scalar localtime(), @args);
|
my $str = sprintf("[%6s] %s %s:%i\t$log\n", $debugnames[$level], scalar localtime(), $file, $line, @args);
|
||||||
my $stack;
|
my $stack;
|
||||||
|
|
||||||
if($level >= $StackTraceLevel) {
|
if($level >= $StackTraceLevel) {
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,52 @@
|
||||||
|
package PerlRPG::Game;
|
||||||
|
use strict;
|
||||||
|
require Exporter;
|
||||||
|
use SDL;
|
||||||
|
use SDL::Event;
|
||||||
|
use SDLx::App;
|
||||||
|
use SDLx::Sprite;
|
||||||
|
use SDLx::Sprite::Animated;
|
||||||
|
use PerlRPG::Game;
|
||||||
|
use PerlRPG::Console;
|
||||||
|
use PerlRPG::Assets;
|
||||||
|
use PerlRPG::Drawing;
|
||||||
|
use PerlRPG::Script;
|
||||||
|
use vars qw/$app @ISA @EXPORT @EXPORT_OK %keymap/;
|
||||||
|
|
||||||
|
@ISA = qw/Exporter/;
|
||||||
|
@EXPORT = qw/KeyDown KeyUp MouseClick/;
|
||||||
|
@EXPORT_OK = @EXPORT;
|
||||||
|
|
||||||
|
%keymap = (
|
||||||
|
'space-down' => \&PerlRPG::Script::SkipText,
|
||||||
|
);
|
||||||
|
|
||||||
|
|
||||||
|
sub KeyPress {
|
||||||
|
foreach my $key (@_) {
|
||||||
|
if(exists($keymap{$key})) {
|
||||||
|
$keymap{$key}->($key);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub KeyDown {
|
||||||
|
my($key)=@_;
|
||||||
|
my $key2="$key-down";
|
||||||
|
LogData(DEVALL, "KeyDown($key)");
|
||||||
|
KeyPress($key, $key2);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub KeyUp {
|
||||||
|
my($key)=@_;
|
||||||
|
my $key2="$key-up";
|
||||||
|
LogData(DEVALL, "KeyUp($key)");
|
||||||
|
KeyPress($key, $key2);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub MouseClick {
|
||||||
|
my($x, $y, $btn)=@_;
|
||||||
|
|
||||||
|
LogData(DEBUG, "MouseClick($x, $y, $btn");
|
||||||
|
|
||||||
|
}
|
||||||
|
|
@ -6,18 +6,61 @@ use SDL::Event;
|
||||||
use SDLx::App;
|
use SDLx::App;
|
||||||
use SDLx::Sprite;
|
use SDLx::Sprite;
|
||||||
use SDLx::Sprite::Animated;
|
use SDLx::Sprite::Animated;
|
||||||
|
use SDLx::Text;
|
||||||
use PerlRPG::Console;
|
use PerlRPG::Console;
|
||||||
use PerlRPG::Game;
|
use PerlRPG::Game;
|
||||||
use PerlRPG::Assets;
|
use PerlRPG::Assets;
|
||||||
|
|
||||||
use vars qw/@ISA @EXPORT @EXPORT_OK %VisibleSprites/;
|
use vars qw/@ISA @EXPORT @EXPORT_OK %VisibleSprites/;
|
||||||
@ISA = qw/Exporter/;
|
@ISA = qw/Exporter/;
|
||||||
@EXPORT = qw/ ShowSprite HideSprite MoveSprite SetBackgroundColor RenderSprites /;
|
@EXPORT = qw/ ShowSprite HideSprite MoveSprite SetBackgroundColor RenderSprites DrawSpeech/;
|
||||||
@EXPORT_OK = ();
|
@EXPORT_OK = ();
|
||||||
|
|
||||||
# FIXME - This should be exported already?
|
# FIXME - This should be exported already?
|
||||||
*GetOption = \&PerlRPG::Game::GetOption;
|
*GetOption = \&PerlRPG::Game::GetOption;
|
||||||
|
|
||||||
|
my $speech_border = 5;
|
||||||
|
sub DrawSpeech {
|
||||||
|
my($sayer, $text)=@_;
|
||||||
|
my $app = GetOption('App');
|
||||||
|
|
||||||
|
my $sprite = GetAsset($sayer->{'Sprite'});
|
||||||
|
my $sprite_x = $app->width() - $sprite->w();
|
||||||
|
my $sprite_y = $app->height() - $sprite->h();
|
||||||
|
my $sprite_h = $sprite->h();
|
||||||
|
$sprite = undef; # ShowSprite may unload this, we don't want to keep a handle to it
|
||||||
|
ShowSprite('_SayerSprite', $sayer->{'Sprite'}, $sprite_x, $sprite_y, 254);
|
||||||
|
|
||||||
|
my $text_obj = SDLx::Text->new();
|
||||||
|
$text_obj->color( $sayer->{'TextColor'} );
|
||||||
|
$text_obj->text( $text );
|
||||||
|
|
||||||
|
my $surface = SDLx::Surface->new( width => $sprite_x,
|
||||||
|
height => $sprite_h,
|
||||||
|
color => [0, 0, 0, 255],
|
||||||
|
);
|
||||||
|
$surface->draw_rect( [ $speech_border,
|
||||||
|
$speech_border,
|
||||||
|
$surface->width()-2*$speech_border,
|
||||||
|
$surface->height()-2*$speech_border ],
|
||||||
|
[0, 0, 0, 192]
|
||||||
|
);
|
||||||
|
|
||||||
|
my $text_x = ($surface->width() - $text_obj->w())/2;
|
||||||
|
my $text_y = ($surface->height() - $text_obj->h())/2;
|
||||||
|
$text_obj->write_xy( $surface, $text_x, $text_y );
|
||||||
|
|
||||||
|
$sprite = SDLx::Sprite->new( surface => $surface );
|
||||||
|
$VisibleSprites{'_SayerText'} = {
|
||||||
|
'Depth' => 255,
|
||||||
|
'X' => 0,
|
||||||
|
'Y' => $app->height() - $surface->height(),
|
||||||
|
'Sprite' => $sprite,
|
||||||
|
};
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
sub ShowSprite {
|
sub ShowSprite {
|
||||||
my($name, $file, $x, $y, $d, @opt)=@_;
|
my($name, $file, $x, $y, $d, @opt)=@_;
|
||||||
LogData(DEBUG, "Showing sprite $file as $name");
|
LogData(DEBUG, "Showing sprite $file as $name");
|
||||||
|
|
|
||||||
|
|
@ -10,6 +10,7 @@ use PerlRPG::Console;
|
||||||
use PerlRPG::Assets;
|
use PerlRPG::Assets;
|
||||||
use PerlRPG::Drawing;
|
use PerlRPG::Drawing;
|
||||||
use PerlRPG::Script;
|
use PerlRPG::Script;
|
||||||
|
use PerlRPG::Controls;
|
||||||
use vars qw/$app @ISA @EXPORT @EXPORT_OK/;
|
use vars qw/$app @ISA @EXPORT @EXPORT_OK/;
|
||||||
|
|
||||||
@ISA = qw/Exporter/;
|
@ISA = qw/Exporter/;
|
||||||
|
|
@ -54,7 +55,7 @@ sub Run {
|
||||||
my $ticktime = SDL::get_ticks() - $tick;
|
my $ticktime = SDL::get_ticks() - $tick;
|
||||||
my $delta = 1000/$opt{'TargetFPS'} - $ticktime;
|
my $delta = 1000/$opt{'TargetFPS'} - $ticktime;
|
||||||
|
|
||||||
LogData(DEBUG, "TickTime = $ticktime, Delta = $delta");
|
LogData(DEVALL, "TickTime = $ticktime, Delta = $delta");
|
||||||
SDL::delay($delta) if($delta > 0);
|
SDL::delay($delta) if($delta > 0);
|
||||||
$tick = SDL::get_ticks();
|
$tick = SDL::get_ticks();
|
||||||
}
|
}
|
||||||
|
|
@ -66,10 +67,10 @@ sub EventDispatcher {
|
||||||
while(SDL::Events::poll_event($event)) {
|
while(SDL::Events::poll_event($event)) {
|
||||||
if($event->type == SDL_KEYDOWN) {
|
if($event->type == SDL_KEYDOWN) {
|
||||||
my $key = SDL::Events::get_key_name($event->key_sym);
|
my $key = SDL::Events::get_key_name($event->key_sym);
|
||||||
LogData(DEBUG, "KeyDown($key)");
|
KeyDown($key);
|
||||||
} elsif($event->type == SDL_KEYUP) {
|
} elsif($event->type == SDL_KEYUP) {
|
||||||
my $key = SDL::Events::get_key_name($event->key_sym);
|
my $key = SDL::Events::get_key_name($event->key_sym);
|
||||||
LogData(DEBUG, "KeyUp($key)");
|
KeyUp($key);
|
||||||
} elsif($event->type == SDL_QUIT) {
|
} elsif($event->type == SDL_QUIT) {
|
||||||
$opt{'Running'} = 0;
|
$opt{'Running'} = 0;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -9,6 +9,7 @@ use SDLx::Sprite::Animated;
|
||||||
use PerlRPG::Console;
|
use PerlRPG::Console;
|
||||||
use PerlRPG::Game;
|
use PerlRPG::Game;
|
||||||
use PerlRPG::Assets;
|
use PerlRPG::Assets;
|
||||||
|
use PerlRPG::Drawing;
|
||||||
|
|
||||||
use vars qw/@ISA @EXPORT @EXPORT_OK/;
|
use vars qw/@ISA @EXPORT @EXPORT_OK/;
|
||||||
@ISA = qw/Exporter/;
|
@ISA = qw/Exporter/;
|
||||||
|
|
@ -73,6 +74,7 @@ sub RunScript {
|
||||||
|
|
||||||
# Run script from current position until a wait condition
|
# Run script from current position until a wait condition
|
||||||
sub RunScriptTick {
|
sub RunScriptTick {
|
||||||
|
return 1 if($lastsayer);
|
||||||
for(;;) {
|
for(;;) {
|
||||||
my $script = GetAsset($current_file); # current_file can change in RunScriptLine, so reload each time
|
my $script = GetAsset($current_file); # current_file can change in RunScriptLine, so reload each time
|
||||||
my $file = $current_file;
|
my $file = $current_file;
|
||||||
|
|
@ -141,7 +143,29 @@ sub AddSayer {
|
||||||
sub SayLine {
|
sub SayLine {
|
||||||
my($ref, $text)=@_;
|
my($ref, $text)=@_;
|
||||||
LogData(INFO, "%s saying \"%s\"", $ref->{'DisplayName'}, $text);
|
LogData(INFO, "%s saying \"%s\"", $ref->{'DisplayName'}, $text);
|
||||||
|
|
||||||
|
$text=~s/\\n/\n/g;
|
||||||
|
DrawSpeech($ref, $text);
|
||||||
|
$lastsayer = $ref;
|
||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub SkipText {
|
||||||
|
$lastsayer = undef;
|
||||||
|
HideSprite('_SayerText');
|
||||||
|
HideSprite('_SayerSprite');
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
1;
|
1;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -6,14 +6,14 @@ __init__:
|
||||||
Show aka2 spritesheet.png 100 0 2 Reverse
|
Show aka2 spritesheet.png 100 0 2 Reverse
|
||||||
Show aka3 spritesheet.png 200 0 3 max_loops=10
|
Show aka3 spritesheet.png 200 0 3 max_loops=10
|
||||||
|
|
||||||
AddSayer h Hermione aka01.png
|
AddSayer h Hermione aka01.png 200 200 200 255
|
||||||
|
AddSayer h2 Hermione aka05.png 255 0 0 255
|
||||||
#Show aka aka.vs 0 0 1 type Reverse
|
|
||||||
#Show aka2 aka.vs 100 0 2
|
|
||||||
|
|
||||||
Jump donothing
|
Jump donothing
|
||||||
|
|
||||||
donothing:
|
donothing:
|
||||||
Wait
|
Wait
|
||||||
h "Some text here"
|
Wait
|
||||||
|
h "Some text here\nNext line"
|
||||||
|
h2 "Different text here"
|
||||||
Jump donothing
|
Jump donothing
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue