Adding legacy fwrpg code

PerlRPG/Assets.pm

@@ -21,7 +21,7 @@ sub FindFile {
 		return $files{$filename}{'Location'};
 	}
 
-	my $full = FindFileInDir(GetOption('ResourceDir'), $filename);
+	my $full = FindFileInDir(GetGameVar('ResourceDir'), $filename);
 	if($full) {
 		$files{$filename}={
 			'Loaded'	=> 0,
@@ -105,13 +105,14 @@ sub GetAssetType {
 }
 
 sub UnloadAsset {
-	my($file)=@_;
+	foreach my $file (@_) {
 		if(exists $files{$file}) {
 			$files{$file}{'Loaded'} = 0;
 			delete $files{$file}{ $files{$file}{'Type'} };
 			$files{$file}{'Type'} = '';
 		}
 	}
+}
 
 sub SetAssetOption {
 	my($file, $opt)=@_;
@@ -135,7 +136,8 @@ sub LoadAsset {
 
 	if(!$filename && !($filename = FindFile($file))) {
 		LogData(FATAL, "Unable to load asset file '$file'; Unable to find file.");
-		SetOption('Running', 0);
+		ExitGame();
+		return;
 	}
 
 	if(exists $files{$file}) {

PerlRPG/Drawing.pm

@@ -10,6 +10,7 @@ use SDLx::Text;
 use PerlRPG::Console;
 use PerlRPG::Game;
 use PerlRPG::Assets;
+use PerlRPG::Math;
 
 use vars qw/@ISA @EXPORT @EXPORT_OK %VisibleSprites/;
 @ISA = qw/Exporter/;
@@ -19,45 +20,82 @@ use vars qw/@ISA @EXPORT @EXPORT_OK %VisibleSprites/;
 # FIXME - This should be exported already?
 *GetOption = \&PerlRPG::Game::GetOption;
 
-# FIXME - This should be a setable option
-my $speech_border = 5;
-
 sub DrawSpeech {
 	my($sayer, $text)=@_;
 	my $app = GetOption('App');
+	my $speech_border = GetOption('SpeechBorderSize');
+	my $speech_border_color = [split(/\s+/,GetOption('SpeechBorderColor'))];
+	my $speech_bg_color = [split(/\s+/,GetOption('SpeechBGColor'))];
+	my $speech_name_bg_color = [split(/\s+/,GetOption('SpeechNameBGColor'))];
 
 	my $sprite = GetAsset($sayer->{'Sprite'});
-	my $sprite_x = $app->width() - $sprite->clip()->w();
+	my $sprite_x = 0;
-	my $sprite_y = $app->height() - $sprite->clip()->h();
+	my $speech_x = 0;
+
+	my $sprite_w = $sprite->clip()->w();
 	my $sprite_h = $sprite->clip()->h();
+
+	my $sprite_y = $app->height() - $sprite_h;
+	my $speech_y = $sprite_y;
+
+	if($sayer->{'DrawLeft'}) {
+		$speech_x = $sprite_w;
+	} else {
+		$sprite_x = $app->width() - $sprite_w;
+	}
 	$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, @{ $sayer->{'SpriteOpts'} });
 
+	my $name_obj = SDLx::Text->new();
+	$name_obj->color( $sayer->{'TextColor'} );
+	$name_obj->text( $sayer->{'DisplayName'} );
+
 	my $text_obj = SDLx::Text->new();
 	$text_obj->color( $sayer->{'TextColor'} );
 	$text_obj->text( $text );
 
-	my $surface = SDLx::Surface->new(	width	=> $sprite_x,
+	my $surface = SDLx::Surface->new(	width	=> $app->width() - $sprite_w,
 						height	=> $sprite_h,
-						color	=> [0, 0, 0, 255],
+						color	=> $speech_border_color,
 					);
+	$surface->draw_rect(	[0, 0, $surface->width(), $name_obj->h()], [@$speech_name_bg_color[0,1,2], 255] );
 	$surface->draw_rect(	[	$speech_border,
-					$speech_border,
+					$name_obj->h() + $speech_border,
 					$surface->width()-2*$speech_border,
-					$surface->height()-2*$speech_border	],
+					$surface->height()-$name_obj->h()-(2*$speech_border)	],
-				[0, 0, 0, 192]
+				[@$speech_bg_color[0,1,2], 255]
 			   );
 
 	my $text_x = ($surface->width() - $text_obj->w())/2;
-	my $text_y = ($surface->height() - $text_obj->h())/2;
+	my $text_y = $name_obj->h() + ($surface->height()-$name_obj->h() - $text_obj->h())/2;
+	$name_obj->write_xy( $surface, 0, 0 );
 	$text_obj->write_xy( $surface, $text_x, $text_y );
 
-	$sprite = SDLx::Sprite->new( surface => $surface );
+	# Recreate alpha channels
+	if($speech_name_bg_color->[3] != 255) {
+		Surface_ChangeColor(
+			$surface,
+			[@$speech_name_bg_color[0,1,2],255],
+			$speech_name_bg_color,
+			[0, 0, $surface->width(), $name_obj->h()]
+		);
+	}
+
+	if($speech_bg_color->[3] != 255) {
+		Surface_ChangeColor( $surface, [@$speech_bg_color[0,1,2],255], $speech_bg_color,
+					[	$speech_border,
+						$name_obj->h() + $speech_border,
+						$surface->width() - 2 * $speech_border,
+						$surface->height() - $name_obj->h() - 2 * $speech_border
+					]
+					);
+	}
+
 	$VisibleSprites{'_SayerText'} = {
 		'Depth'		=> 255,
-		'X'		=> 0,
+		'X'		=> $speech_x,
-		'Y'		=> $app->height() - $surface->height(),
+		'Y'		=> $speech_y,
-		'Sprite'	=> $sprite,
+		'Sprite'	=> SDLx::Sprite->new( surface => $surface ),
 	};
 		
 	return 1;
@@ -76,6 +114,7 @@ sub ShowSprite {
 	my $a = GetAsset($file);
 	if($t eq 'ASprite') {
 		# Unload the asset so that future versions of the same name will be fresh copies
+		# This is necessary for instances where the frame position doesn't match
 		UnloadAsset($file);
 
 		# Start animation
@@ -85,17 +124,33 @@ sub ShowSprite {
 	foreach my $o (@opt) {
 		my($name, $val)=$o=~/^\s*(\S+?)=(\S*)/;
 		$name = $o unless($name);
-		if($o eq 'Reverse' || $o eq 'Circular') {
+		$name = lc($name);
-			$a->type($o);
+		if($name eq 'reverse' || $name eq 'circular') {
+			if($t eq 'ASprite') {
+				$a->type($name);
+			} else {
+				LogData(WARN, "%s - Non animated sprite can't have %s property", GetScriptPosition(), $name);
+			}
 		} elsif($name eq 'max_loops') {
+			if($t eq 'ASprite') {
 				$a->max_loops($val);
-		} elsif($o eq 'flip') {
+			} else {
+				LogData(WARN, "%s - Non animated sprite can't have %s property", GetScriptPisition(), $name);
+			}
+		} elsif($name eq 'flip') {
 			# Don't want to flip back and forth every time
 			UnloadAsset($file);
 			my $s=$a->surface();
-			$a->surface( FlipSurface($s) );
+			$a->surface( Surface_Flip($s) );
+		} elsif($name eq 'ticks') {
+			if($t eq 'ASprite') {
+				$val = 1 unless($val);
+				$a->ticks_per_frame($val);
 			} else {
-			LogData(WARN, "Unknown option in ShowSprite '$o' - '$name'='$val'");
+				LogData(WARN, "%s - Non animated sprite can't have %s property", GetScriptPosition(), $name);
+			}
+		} else {
+			LogData(WARN, "%s - Unknown sprite property '%s'", GetScriptPosition(), $name);
 		}
 	}
 
@@ -113,6 +168,13 @@ sub HideSprite {
 	delete $VisibleSprites{$name};
 }
 
+sub ClearScreen {
+	foreach (keys %VisibleSprites) {
+		next if($_ eq 'Background');
+		HideSprite($_);
+	}
+}
+
 sub MoveSprite {
 	my($name, $x, $y)=@_;
 	return undef unless(exists $VisibleSprites{$name});
@@ -155,8 +217,7 @@ sub RenderSprites {
 	}
 }
 
-# Fixme -- Still appears broken, but closer
+sub Surface_Flip {
-sub FlipSurface {
 	my $src=shift(@_);
 	my $dst = SDLx::Surface->new(	width	=> $src->width(),
 					height	=> $src->height(),
@@ -179,10 +240,28 @@ sub FlipSurface {
 	
 }
 
+# Per pixel, search for $from and change to $to
+# Searches within @$rect if provided
+sub Surface_ChangeColor {
+	my($surface, $from, $to, $rect)=@_;
+	my($start_x, $start_y, $w, $h)=(0,0,$surface->w(),$surface->h());
+	if($rect && ref $rect) {
+		$start_x = Constrain( $rect->[0], 0, $surface->w());
+		$start_y = Constrain( $rect->[1], 0, $surface->h());
+		$w = Constrain( $rect->[2], 0, $surface->w() - $start_x);
+		$h = Constrain( $rect->[3], 0, $surface->h() - $start_y);
+	}
 
+	my $frompix = SDL::Video::map_RGBA( $surface->format(), @$from);
+	my $topix = SDL::Video::map_RGBA( $surface->format(), @$to);
 
-
+	for(my $y=$start_y; $y<$start_y + $h; $y++) {
-
+		for(my $x=$start_x; $x<$start_x + $w; $x++) {
-
+			if($surface->get_pixel( $y, $x ) == $frompix) {
+				$surface->set_pixel( $y, $x, $topix );
+			}
+		}
+	}
+}
 
 1;

PerlRPG/Game.pm

@@ -14,50 +14,64 @@ use PerlRPG::Controls;
 use vars qw/$app @ISA @EXPORT @EXPORT_OK/;
 
 @ISA = qw/Exporter/;
-@EXPORT = qw/InitApp Run RunScript GetOption SetOption ExitGame/;
+@EXPORT = qw/InitApp Run GetOption ExitGame/;
 @EXPORT_OK = @EXPORT;
 
 $app = undef;
 my %opt = (
 	'App'		=> undef,
-	'Running'	=> 1,
-	'TargetFPS'	=> 5,
-	'ResourceDir'	=> '.',
-	'Status'	=> 'WaitForFrame',
 );
 
-sub GetOption { return (exists $opt{$_[0]} ? $opt{$_[0]} : undef); }
+my %default_gamevars = (
-sub SetOption { $opt{$_[0]} = $_[1]; }
+	'TargetFPS'		=> 10,
+	'GameRunning'		=> 1,
+	'ResourceDir'		=> '"."',
+	'SpeechBorderSize'	=> 3,
+	'SpeechBorderColor'	=> '"255 255 255 255"',
+	'SpeechBGColor'		=> '"192 192 192 255"',
+	'SpeechNameBGColor'	=> '"0 0 0 0"',
+);
 
+sub GetOption {
+	my $key = shift(@_);
+	if(exists($opt{$key})) {
+		return $opt{$key};
+	} elsif(exists $PerlRPG::Script::game_vars{$key}) {
+		return GetGameVar($key);
+	} else {
+		LogData(WARN, "Request for unknown option '$key'");
+		return undef;
+	}
+}
 
 sub InitApp {
 	my($width, $height)=@_;
-
 	return undef if($app);
-
 	LogData(INFO, "Creating SDL instance");
-	$app = SDLx::App->new(
+
-		width => $width,
+	foreach (keys %default_gamevars) {
-		height => $height,
+		DefGameVar($_, $default_gamevars{$_});
-		);
+	}
+
+	$app = SDLx::App->new( width => $width, height => $height);
 	$opt{'App'}=$app;
 	LogData(DEBUG, "SDL Instance created");
 	return $app;
 }
 
 sub ExitGame {
-	SetOption('Running', 0);
+	SetGameVar('GameRunning', 0);
 }
 
 sub Run {
 	my $tick = SDL::get_ticks();
-	while($opt{'Running'}) {
+	while(GetGameVar('GameRunning')) {
 		EventDispatcher();
 		RunScriptTick();
 		RenderScreen();
 
 		my $ticktime = SDL::get_ticks() - $tick;
-		my $delta = 1000/$opt{'TargetFPS'} - $ticktime;
+		my $delta = 1000/GetGameVar('TargetFPS') - $ticktime;
 
 		LogData(DEVALL, "TickTime = $ticktime, Delta = $delta");
 		SDL::delay($delta) if($delta > 0);
@@ -90,7 +104,7 @@ sub EventDispatcher {
 					SDL::Events::get_mod_state()
 				);
 		} elsif($event->type == SDL_QUIT) {
-			$opt{'Running'} = 0;
+			SetGameVar('GameRunning', 0);
 		}
 	}
 }
@@ -100,8 +114,4 @@ sub RenderScreen {
 	$app->update();
 }
 
-sub RunScript {
-
-}
-
 1;

PerlRPG/Math.pm

@@ -0,0 +1,23 @@
+package PerlRPG::Math;
+use strict;
+require Exporter;
+
+use vars qw/@ISA @EXPORT @EXPORT_OK/;
+@ISA = qw/Exporter/;
+@EXPORT = qw/Constrain MIN MAX/;
+@EXPORT_OK = ();
+
+sub MIN {
+	return ($_[0] > $_[1] ? $_[0] : $_[1]);
+}
+
+sub MAX {
+	return ($_[0] > $_[1] ? $_[1] : $_[0]);
+}
+
+sub Constrain {
+	my($val, $min, $max)=@_;
+	return MAX(MIN($val, $min),$max);
+}
+
+1;

PerlRPG/Script.pm

@@ -11,9 +11,9 @@ use PerlRPG::Game;
 use PerlRPG::Assets;
 use PerlRPG::Drawing;
 
-use vars qw/@ISA @EXPORT @EXPORT_OK/;
+use vars qw/@ISA @EXPORT @EXPORT_OK %game_vars/;
 @ISA = qw/Exporter/;
-@EXPORT = qw/CompileScripts RunScript RunScriptTick GetGameVar SetGameVar DefGameVar EvalString/;
+@EXPORT = qw/CompileScripts RunScript RunScriptTick GetGameVar SetGameVar DefGameVar EvalString GetScriptPosition/;
 @EXPORT_OK = @EXPORT;
 
 my %labels;
@@ -26,22 +26,47 @@ my %script_commands = (
 	'Define'		=> {'sub' => \&DefGameVar,				'wait'	=> 0},
 	'ExitGame'		=> {'sub' => \&PerlRPG::Game::ExitGame,			'wait'	=> 1},
 	
-	'Jump'			=> {'sub' => \&PerlRPG::Script::RunScript,		'wait'	=> 0},
+	'Jump'			=> {'sub' => \&RunScript,				'wait'	=> 0},
+	'Call'			=> {'sub' => \&Call,					'wait'	=> 0},
+	'Return'		=> {'sub' => \&Return,					'wait'	=> 0},
+	
 
 	'Show'			=> {'sub' => \&PerlRPG::Drawing::ShowSprite,		'wait'	=> 0},
 	'Hide'			=> {'sub' => \&PerlRPG::Drawing::HideSprite,		'wait'	=> 0},
 	'SetBackground'		=> {'sub' => \&PerlRPG::Drawing::SetBackgroundColor,	'wait'	=> 0},
+	'ClearScreen'		=> {'sub' => \&PerlRPG::Drawing::ClearScreen,		'wait'	=> 0},
 
 	'ScanDirectory'		=> {'sub' => \&PerlRPG::Assets::ScanDirectory,		'wait'	=> 0},
 	'LoadAssets'		=> {'sub' => \&PerlRPG::Assets::LoadAssets,		'wait'	=> 0},
 	'UnloadAsset'		=> {'sub' => \&PerlRPG::Assets::UnloadAsset,		'wait'	=> 0},
 	'SetAssetOption'	=> {'sub' => \&PerlRPG::Assets::SetAssetOption,		'wait'	=> 0},
+	'RecompileScripts'	=> {'sub' => \&RecompileScripts,			'wait'	=> 1},
 );
 
 my %sayers = ();
 my $lastsayer=undef;
+my @CallStack;
 
-my %game_vars = ();
+%game_vars = ();
+
+sub Call {
+	my($label)=@_;
+	my @pos = ($current_file, $current_line+1);
+	if(RunScript($label)) {
+		push @CallStack, \@pos;
+	} else {
+		LogData(ERROR, "%s Unable to call '$label': Undefined label.", GetScriptPosition());
+	}
+}
+
+sub Return {
+	if(!@CallStack) {
+		LogData(ERROR, "%s Call stack underrun.", GetScriptPosition());
+		return;
+	}
+	my $ref = pop(@CallStack);
+	($current_file, $current_line) = @$ref;
+}
 
 sub GetGameVar {
 	my $key = shift(@_);
@@ -70,9 +95,20 @@ sub DefGameVar {
 	my($key, $val)=@_;
 	if(!exists $game_vars{$key}) {
 		$game_vars{$key} = StringSubst($val);
+		LogData(DEBUG, "Defined variable '$key' as '$game_vars{$key}'");
 	}
 }
 
+sub RecompileScripts {
+	my $jumpto = (shift(@_) || '__init__');
+	my @scripts = LoadAssets('gs');
+
+	LogData(INFO, "Doing full script recompile and jumping to '$jumpto'");
+	UnloadAsset(@scripts);
+	CompileScripts();
+	RunScript($jumpto);
+}
+		
 # Load script files, locate labels
 sub CompileScripts {
 	my @scripts = sort { $a cmp $b } LoadAssets('gs');
@@ -100,25 +136,35 @@ sub RunScript {
 	if(exists $labels{$label}) {
 		$current_file = $labels{$label}{'File'};
 		$current_line = $labels{$label}{'Line'};
-		LogData(DEBUG, "RunScript($label) moving to $current_file:$current_line");
+		return 1;
 	} else {
 		LogData(ERROR, "RunScript($label) unknown label");
+		return 0;
 	}
 }
 
+sub GetScriptPosition {
+	return "$current_file:$current_line";
+}
+
 # Run script from current position until a wait condition
 sub RunScriptTick {
 	return 1 if($lastsayer);
 	for(;;) {
 		my $script = GetAsset($current_file); # current_file can change in RunScriptLine, so reload each time
 		my $file = $current_file;
-		my $line = $current_line++;
+		my $line = $current_line;
 		if($line >= @$script) {
 			LogData(ERROR, "Script file ended");
-			SetOption('Running', 0);
+			SetGameVar('GameRunning', 0);
 			return;
 		}
-		if(RunScriptLine($file, $line, $script->[$line])) {
+		my $r=RunScriptLine($file, $line, $script->[$line]);
+		if($current_line == $line && $current_file eq $file) {
+			# Advance the line number if RunScriptLine didn't move us
+			$current_line++;
+		}
+		if($r) {
 			return;
 		}
 	}
@@ -175,12 +221,25 @@ sub AddSayer {
 	my @textcolor=($r, $g, $b, $a);
 	$textcolor[3] = 255 unless(defined $a);
 
+	my $drawleft = 0;
+	my @sprite_opts;
+
+	foreach my $opt (@opts) {
+		if(lc($opt) eq 'left') {
+			$drawleft = 1;
+		} else {
+			push @sprite_opts, $opt;
+		}
+	}
+	
+
 	$sayers{$name} = {
 		'Name'		=> $name,
 		'DisplayName'	=> StringSubst($displayname),
 		'Sprite'	=> $sprite,
 		'TextColor'	=> \@textcolor,
-		'SpriteOpts'	=> \@opts,
+		'DrawLeft'	=> $drawleft,
+		'SpriteOpts'	=> \@sprite_opts,
 	};
 }
 
@@ -218,9 +277,26 @@ sub EvalString {
 
 	#LogData(DEBUG, "Val is '$val'");
 
-	# Tokenize
+	# Pretokenize quoted strings
-	my @tokens = split(/\s+/,$val);
+	my @pretokens;
+	$val=~s/\\"/\x01/g;
+	while(my($start,$quote,$left)=$val=~/^(.*?)(".*?")(.*)$/) {
+		push @pretokens, $start if($start);
+		push @pretokens, $quote;
+		$val = $left;
+	}
+	push @pretokens, $val if($val);
 
+	# Tokenize
+	my @tokens;
+	foreach my $token (@pretokens) {
+		$token=~s/\x01/\\"/g;
+		if(IsString($token)) {
+			push @tokens, $token;
+		} else {
+			push @tokens, split(/\s+/, $token);
+		}
+	}
 
 	#for(my $i=0;$i<@tokens-0;$i++) { LogData(DEBUG, "Pass 1 Token [%i], '%s'", $i, $tokens[$i]); }
 

Resources/fire.vs

@@ -0,0 +1,10 @@
+fire_01.png
+fire_02.png
+fire_03.png
+fire_04.png
+fire_05.png
+fire_06.png
+fire_07.png
+fire_08.png
+fire_09.png
+fire_10.png

Resources/fireplace_fire.vs

@@ -0,0 +1,8 @@
+fireplace_fire_01.png
+fireplace_fire_02.png
+fireplace_fire_03.png
+fireplace_fire_04.png
+fireplace_fire_05.png
+fireplace_fire_06.png
+fireplace_fire_07.png
+fireplace_fire_08.png

Resources/script.gs

@@ -1,26 +1,42 @@
 __init__:
-	SetBackground 128 128 128 255
+	ResourceDir = "Resources"
+	TargetFPS = 20
+
+drawroom:
+	ClearScreen
+	SetBackground 0 0 0 255
 	SetAssetOption spritesheet.png Animated
-	Define LoopCount 0
+	AddSayer h "Hermione" aka01.png 255 0 0 255
+
+	SpeechBorderSize = 3
+	SpeechBorderColor = "128 128 128 255"
+	SpeechBGColor = "192 192 192 255"
+	SpeechNameBGColor = "0 0 0 0"
+
+	Show bg		main_room_day.png	0 0 10
+	Show window	05_window.png		350 100 11
+	Show cupboard	cupboard.png		120 72 11
+	Show door	door.png		840 177 11
+	Show fireplace	fireplace.png		600 150 11
+	Show candler	candle.png		400 100 11 flip
+	Show candlel	candle.png		240 100 11
+
+	Show fireplacea	fireplace_fire.vs	575 147 12 ticks=2
+	Show candlera	fire.vs			400 95 12 flip ticks=2
+	Show candlela	fire.vs			240 95 12 ticks=2
+
+
+	Show desk	11_genie_00.png		230 220 13
+	Show hermione	spritesheet.png		450 310 14 reverse ticks=4
+
+convo:
+	Call subtest
+
+	RecompileScripts drawroom
+	Jump convo
+
+subtest:
 	Define TestVar 1
-
+	h "Loop [TestVar]..."
-	Show aka spritesheet.png 0 0 1 flip
+	TestVar = TestVar + 1
-	Show aka2 aka.vs 100 0 2
+	Return
-	Show aka3 aka.vs 200 0 3 Reverse flip
-	Show aka4 spritesheet.png 300 0 1 max_loops=1
-
-	AddSayer h "Hermione" aka01.png 200 200 200 255 flip
-	AddSayer h2 "Topless\ Hermione" aka05.png 255 0 0 255
-	AddSayer h3 "Stripping\ Hermione" spritesheet.png 255 0 0 255 Reverse
-	
-	Jump donothing
-
-donothing:
-	Wait
-	LoopCount=LoopCount+1
-	h "Loop number [LoopCount]"
-	TestVar=lc("Foo").uc(lc("Foo"))
-	h2 "TestVar [TestVar]"
-	TestVar = uc("[TestVar]")
-	h3 "TestVar2 [TestVar]"
-	Jump donothing

Tests/Script.pl

@@ -26,5 +26,7 @@ ok( PerlRPG::Script::IsString(5)==0,			"'5' is not a string");
 ok( EvalString("\"[TestVar]\"") eq '3',			"\"[TestVar]\" is 3");
 ok( EvalString("3 + 3") == 6,				"\"3 + 3\" == 6");
 ok( EvalString("lc('FoO') . uc('FoO')") eq 'fooFOO',	"String function test");
+SetGameVar("TestVar", "\"FoO\"");
+ok( EvalString("uc(\" [TestVar] \")") eq ' FOO ',	"Complex string function test");
 
 done_testing();