#!/usr/bin/perl -w
######################################################################
# CARPE DIEM #
# Computer-Assisted Role Playing Engine #
# for Diverse Interactive Entertainment Modules #
# v2000.12.04 #
######################################################################
# Copyright (c)2000-2013, Chris Pressey, Cat's Eye Technologies.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
# notices, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notices, this list of conditions, and the following disclaimer in
# the documentation and/or other materials provided with the
# distribution.
# 3. Neither the names of the copyright holders nor the names of their
# contributors may be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
# COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
BEGIN
{
$| = 1; # auto-flush output
$::version = "v2000.12.04";
$::universe = $ARGV[0] || die "Need universe name";
$::username = $ENV{user} || $ENV{USER} || 'user';
print "Hello $::username! Loading '$::universe', please wait...\n";
restart_cfg:
%::setup = ();
# if carpe.cfg for current OS exists, include it
if (-r "carpe_$^O.cfg")
{
require "carpe_$^O.cfg";
if ($version ne $::setup{version})
{
print "Warning! Your current configuration file (carpe_$^O.cfg)\n";
print "contains a different version number ($::setup{version})\n";
print "than does your copy of carpe.pl ($version).\n\n";
print "Probable cause: you installed a new version of CARPE DIEM\n";
print "over an existing, older version.\n\n";
print "Recomendation: that you exit, delete all the files in this directory,\n";
print "and re-install the latest version of CARPE DIEM.\n\n";
print " a. Exit (with error code 1)\n";
print " b. Delete carpe_$^O.cfg and restart\n";
print " c. Do nothing (Not Recommended)\n";
print "Please select (a-c) : ";
my $f = <STDIN>;
print "\n";
chomp $f;
if ($f =~ /b/) { unlink "carpe_$^O.cfg"; goto restart_cfg; }
elsif ($f =~ /c/) { }
else { exit(1); }
}
} else
{
open SETUP, ">carpe_$^O.cfg";
print SETUP "# this file is automatically generated by carpe.pl when it does not exist\n\n";
my @k = ('display','color','input');
my @d = ('display driver','color map','input driver');
my @o = (['ANSI'],['ANSI16','Mono'],['Teletype']);
my $i;
my $c; my $fc = 0;
foreach $c (@INC)
{
if (-r "${c}/Curses.pm")
{
$fc = 1; last;
}
}
$o[0] = ['Win32','ANSI'] if $^O eq 'MSWin32' or $^O eq 'cygwin';
unshift @{$o[0]}, 'Curses' if $fc;
$o[1] = ['Win32','ANSI16','Mono'] if $^O eq 'MSWin32' or $^O eq 'cygwin';
unshift @{$o[1]}, 'Curses' if $fc;
$o[2] = ['POSIX','Teletype'] if $^O eq 'freebsd' or $^O eq 'linux' or $^O eq 'sunos' or $^O eq 'solaris' or $^O =~ /^sco/; # or any of a number of other POSIX systems I'm sure
$o[2] = ['Win32','Teletype'] if ($^O eq 'MSWin32');
$o[2] = ['POSIX','Win32','Teletype'] if ($^O eq 'cygwin');
unshift @{$o[2]}, 'Curses' if $fc;
print "Welcome to CARPE DIEM, the Computer-Assisted Role Playing Engine!\n\n";
print "carpe.pl has detected that is has not been run from this location before.\n";
print "(or you deleted your 'carpe_$^O.cfg' file)\n\n";
print "Configure the following settings, press Enter or Return for default value:\n";
for($i=0;$i<=$#k;$i++)
{
print "\nChoose your preferred $d[$i] (default is $o[$i][0]):\n";
my $f; my $ch;
for($f=1;$f<=$#{$o[$i]}+1;$f++)
{
$ch = chr($f+ord('a')-1);
print " $ch. $o[$i][$f-1]\n";
}
$f--;
print "Please select (a-$ch) : ";
$f = <STDIN>;
chomp $f;
if ($f !~ /^\s*[a-$ch]/)
{
$f = 'a';
}
$::setup{$k[$i]} = $o[$i][ord($f)-ord('a')];
print SETUP '$::setup{', $k[$i], '} = \'', $::setup{$k[$i]}, '\';', "\n";
}
print "Screen width (ENTER=80): ";
$f = <STDIN>;
chomp $f;
$::setup{screen_width} = $f || 80;
print SETUP '$::setup{screen_width} = ', $::setup{screen_width}, ';', "\n";
print "Screen height (ENTER=25): ";
$f = <STDIN>;
chomp $f;
$::setup{screen_height} = $f || 25;
print SETUP '$::setup{screen_height} = ', $::setup{screen_height}, ';', "\n";
print SETUP '$::setup{version} = \'', $version, '\';', "\n";
print SETUP "\n1;\n";
close SETUP;
}
# set up preferences
%::pref =
(
'wield' => 'body',
'bumpactor' => 'attack',
'bumpterrain' => 'nothing',
'throwspeed' => 'medium',
'bodymenu' => 'full',
'map_width' => $::setup{screen_width}-22,
'map_height' => $::setup{screen_height}-1,
'symbols' => 'ASCII',
'keymap' => 'Corona',
'supplementary' => 'Disabled',
'browser' => 'netscape.exe c:/carpe/temp.html',
'compression' => 'None',
);
$pref{browser} = 'netscape /carpe/temp.html' if $^O ne 'MSWin32';
$pref{symbols} = 'OEM' if $^O eq 'MSWin32' or
$^O eq 'linux' or
$^O eq 'freebsd' or
$^O eq 'cygwin';
$pref{symbols} = 'SemiOEM' if ($pref{symbols} eq 'OEM' and $::setup{display} eq 'Curses') or
$^O =~ /^sco/i;
require "${universe}_${username}.prefs" if -r "${universe}_${username}.prefs";
}
# This allows us to keep Console::Virtual in a subrepo located in
# the lib dir of this project
BEGIN
{
use File::Spec::Functions;
use File::Basename;
push @INC, catdir(dirname($0), '..', 'lib', 'console-virtual');
}
use Console::Virtual 2007.1122
qw(getkey display gotoxy clrscr clreol
normal inverse bold update_display color);
use _utility;
use _screen;
use Menu;
use Supplement;
use Cloneable;
use Saveable;
use Saleable;
use Fuses;
use Distribution;
use Dice;
use Adj;
use Force;
use Resistances;
use Attack;
use Physical;
use Talent;
use Item;
use Party;
use Actor;
use Terrain;
use Region;
use Encounter;
use _action;
require "$::universe/Distributions.pm";
require "$::universe/Attacks.pm";
require "$::universe/Talent.pm";
require "$::universe/Craftsmanship.pm";
require "$::universe/Weapon.pm";
require "$::universe/Food.pm";
require "$::universe/Wardrobe.pm";
require "$::universe/MagicItem.pm";
require "$::universe/Mineral.pm";
require "$::universe/Tool.pm";
require "$::universe/Monster.pm";
require "$::universe/Animal.pm";
require "$::universe/Guild.pm";
require "$::universe/Happenings.pm";
require "$::universe/Landscape.pm";
require "$::universe/Individuals.pm";
require "$::universe/World.pm";
require "menu/Corona.pm";
sub fix_keymap
{
$::keymap{$helpkey} = 'help';
$::keymap{$padmap->[0][0]} = 'move northwest';
$::keymap{$padmap->[0][1]} = 'move north';
$::keymap{$padmap->[0][2]} = 'move northeast';
$::keymap{$padmap->[1][0]} = 'move west';
$::keymap{$padmap->[1][1]} = 'rest';
$::keymap{$padmap->[1][2]} = 'move east';
$::keymap{$padmap->[2][0]} = 'move southwest';
$::keymap{$padmap->[2][1]} = 'move south';
$::keymap{$padmap->[2][2]} = 'move southeast';
}
sub preferences
{
my $option = ''; my $so = '';
while ($option ne 'OK')
{
::msg("Select your preferences for game operation.");
$option = Menu->new('label' => ["Wield: $::pref{wield}",
"Body: $::pref{bodymenu}",
"Bump: $::pref{bumpterrain}",
"Actor: $::pref{bumpactor}",
"Throw: $::pref{throwspeed}",
"Char: $::pref{symbols}",
"Key: $::pref{keymap}",
"Sup.M: $::pref{supplementary}",
"Compr: $::pref{compression}",
"Save Prefs",
"OK"], 'erase' => 1)->pick;
::clrmsg;
if($option =~ /^Save/)
{
::msg("Saving ${universe}_${username}.prefs...");
open PREFS, ">${universe}_${username}.prefs";
my $k;
foreach $k (keys %::pref)
{
print PREFS '$::pref{', $k, '} = \'', $::pref{$k}, '\';', "\n";
}
print PREFS "1;\n";
close PREFS;
::msg("Preferences saved to ${universe}_${username}.prefs successfully.");
}
if($option =~ /^Wield/)
{
::msg("Choose which menu appears first when wielding an item.");
$so = Menu->new('indent'=>1,'label'=>['body','item'])->pick;
if ($so ne 'Cancel') { $::pref{wield} = $so; }
}
if($option =~ /^Body/)
{
::msg("Choose whether menu of body parts is displayed in full or short form.");
$so = Menu->new('indent'=>1,'label'=>['full','short'])->pick;
if ($so ne 'Cancel') { $::pref{bodymenu} = $so; }
}
if($option =~ /^Actor/)
{
::msg("Choose what to do when moving into the same square as another creature.");
$so = Menu->new('indent'=>1,'label'=>['nothing','attack','interact','look'])->pick;
if ($so ne 'Cancel') { $::pref{bumpactor} = $so; }
}
if($option =~ /^Bump/)
{
::msg("Choose what to do when trying to move into an apparent obstacle.");
$so = Menu->new('indent'=>1,'label'=>['nothing','look','bash'])->pick;
if ($so ne 'Cancel') { $::pref{bumpterrain} = $so; }
}
if($option =~ /^Throw/)
{
::msg("Choose animation speed of missile weapons.");
$so = Menu->new('indent'=>1,'label'=>['slow','medium','fast'])->pick;
if ($so ne 'Cancel') { $::pref{throwspeed} = $so; }
}
if($option =~ /^Char/)
{
::msg("Choose symbol set used to represent world on game map.");
# TODO: DIR
$so = Menu->new('indent'=>1,'label'=>['ASCII','OEM','SemiOEM'])->pick;
if ($so ne 'Cancel') { $::pref{symbols} = $so; %::sc = (); do "sym/$::pref{symbols}.pm"; }
}
if($option =~ /^Key/)
{
::msg("Choose keypress mapping used to issue commonly-used commands.");
# TODO: DIR
$so = Menu->new('indent'=>1,'label'=>['Corona','Hack','Rogue','Larn','Angband_Roguelike','ADOM'])->pick;
if ($so ne 'Cancel')
{
$::pref{keymap} = $so;
%::keymap = ();
%::mnemonic = ();
do "key/$::pref{keymap}.pm";
fix_keymap;
}
}
if($option =~ /^Sup/)
{
::msg("Choose manner in which supplementary materials are acquired and provided.");
$so = Menu->new('indent'=>1,'label'=>['Disabled','Local','Internet','Cached','Browser...'])->pick;
if ($so ne 'Browser...')
{
if ($so ne 'Cancel') { $::pref{supplementary} = $so; }
} else
{
::clrmsg();
::msg("Currently '$::pref{browser}'.");
::msg("foo");
::clrmsg();
$::pref{browser} = ::ask("Browser:", 70);
}
}
if($option =~ /^Comp/)
{
::msg("Choose compression used for saved games (not currently implemented.)");
$so = Menu->new('indent'=>1,'label'=>['None','GNUZip'])->pick;
if ($so ne 'Cancel') { $::pref{compression} = $so; }
}
::clrmsg;
}
}
### INITIALIZATION ###
$::quit_flag = 0;
$::repeated_action = '';
$::start_time = ::d(1, (60*24*27*12*4));
$::game_time = $::start_time;
$::moves_without_input = 0;
$::fuses = Fuses->new;
fix_keymap;
require "$::universe/Name.pm";
### MAIN ###
::clrscr;
::game_frame;
require "$::universe/TitleScreen.pm";
my $goahead = 0;
while (not $goahead)
{
my $option = Menu->new('cancel' => 'Quit',
'erase' => 1,
'label' => ['New World','Load World','Preferences','Quit'])->pick;
if ($option eq 'Quit')
{
::normal;
::clrscr;
exit(0);
} elsif ($option eq 'Preferences')
{
preferences();
} elsif ($option eq 'New World')
{
my $i; my $j;
for($j=0;$j<=$#{$wmap};$j++)
{
for($i=0;$i<=$#{$wmap->[$j]};$i++)
{
$reg{$wmap->[$j][$i]}->{worldx} = $i;
$reg{$wmap->[$j][$i]}->{worldy} = $j;
}
}
$pname = ::ask("Enter a name for your party:", 20)
|| $party_name[::d(1,$#party_name+1)-1];
$party = Party->new($::leader = Actor->roll, $pname);
### Set up leader with initial equipment and talents.
outfit($::leader);
$goahead = 1;
} elsif ($option eq 'Load World')
{
::gotoxy(20,15);
::display("Loading world...");
# $leader = whatever
# $goahead = 1;
}
}
$leader->{location}->display($leader);
$leader->view('character');
$leader->light();
meta:
if (not $::repeated_action)
{
::clrmsg();
$cmd = '';
$char = ::getkey();
}
while (not $quit_flag)
{
### PROCESS PLAYER MOVE
$::notice = 0; # set to true if the leader notices something new
if ($::repeated_action)
{
$cmd = $::repeated_action;
$char = '';
}
if (defined $::leader->{using_talent})
{
# ::msg("using talent ($::leader->{using_talent}[0] moves left)");
$::leader->{using_talent}[0]--;
if ($::leader->{using_talent}[0] == 0)
{
my $t = $::leader->{using_talent}[1];
::script $t->{on_perform}, $::leader, $::leader->{using_talent}[2], $t;
$::leader->{using_talent} = undef;
}
goto npc_moves;
}
if ($::leader->{incapacitated}) # or sleeping
{
goto npc_moves;
}
if ($char eq chr(27))
{
$char = ::getkey();
if ($char eq chr(27))
{
$cmd = ::main_menu();
$leader->view;
goto meta if $cmd eq '';
} else
{
if($char eq '[')
{
# ANSI
$char = ::getkey;
$cmd = 'move north' if $char eq 'A';
$cmd = 'move south' if $char eq 'B';
$cmd = 'move east' if $char eq 'C';
$cmd = 'move west' if $char eq 'D';
}
}
} elsif($char eq $extkey) { $cmd = ::ask("Command: ", 70, '[\S ]'); }
elsif ($char ne '')
{
my $done = 0;
while (not $done)
{
if (not exists $::keymap{$char})
{
my $z = $char;
$z = 'BEL' if ord($z) == 7;
$z = 'Backspace' if ord($z) == 8;
$z = 'Tab' if ord($z) == 9;
$z = 'LF' if ord($z) == 10;
$z = 'FF' if ord($z) == 12;
$z = 'CR' if ord($z) == 13;
$z = '^C' if ord($z) == 3;
$z = '^Z' if ord($z) == 26;
::msg("Key '$z' (" . ord($char) . ") is not currently bound to any command. Press '$::helpkey' for help.");
goto meta;
}
$cmd = $::keymap{$char};
$done = 1;
if ($cmd eq 'extended')
{
$char .= ::getkey();
$done = 0;
}
}
}
$::redirect = $cmd;
while ($::redirect)
{
$cmd = $::redirect;
$::redirect = '';
my @arg = (); my $temp; # parse out arguments of command
if ($cmd =~ /^(\w+)\s+/)
{
$temp = $';
$cmd = $1;
while ($temp =~ /^(\w+)\s*/)
{
push @arg, $1;
$temp = $';
}
}
if (exists $::action{$cmd})
{
if (&{$::action{$cmd}}($leader, [@arg]) == 0)
{
goto meta;
}
} else
{
::msg("Action '$cmd' is not currently implemented. Press '$::helpkey' for help.");
goto meta;
}
}
### PROCESS NPC MOVES
npc_moves:
if ($leader->screenx < 3 or $leader->screenx > $::pref{map_width}-2 or
$leader->screeny < 3 or $leader->screeny > $::pref{map_height}-2)
{
$leader->{location}->display($leader);
}
$leader->light;
$leader->{location}->tick($leader);
$::fuses->tick;
$::game_time++;
if ($::notice)
{
$::notice = 0;
$::repeated_action = '';
}
if(not $quit_flag and
not defined $::leader->{using_talent} and
not $::leader->{incapacitated} and
not $::repeated_action)
{
if (not $::pending)
{
::clrmsg(1);
} else
{
::gotoxy($::setup{screen_width}-1,$::setup{screen_height});
::update_display;
}
$cmd = '';
$char = getkey;
$::moves_without_input = 0;
clrmsg();
} else
{
$cmd = 'rest';
$::moves_without_input++;
}
if ($::moves_without_input > 100)
{
::msg("Game interrupted after 100 moves without input, select course of action.");
my @ca = ('Continue', 'Switch Leader', 'Quit Game');
if ($::repeated_action) { unshift @ca, 'Cancel Repeat'; }
my $r = Menu->new('erase'=>1,
'label'=> [@ca])->pick;
clrmsg();
if ($r eq 'Continue' or $r eq 'Cancel')
{
$::moves_without_input = 0;
}
elsif ($r eq 'Switch Leader')
{
$::repeated_action = '';
$cmd = 'switch_leader';
$::moves_without_input = 0;
}
elsif ($r eq 'Cancel Repeat')
{
$::repeated_action = '';
$cmd = '';
$char = getkey;
$::moves_without_input = 0;
}
elsif ($r eq 'Quit Game')
{
$::quit_flag = 1;
}
$::leader->view;
}
}
::normal;
::clrscr;
### END ###