Stars of Shareware: Programmierung/SOURCE.mdf/programm/msdos/pascal/rehack/convers/scripter.pas

Pascal/Delphi Source File | 1993-06-09 | 15.3 KB | 601 lines

program Scripter (input,output);

uses Crt,IOError;

{D+,L+}

const

{ Program headers display }

  Program_Name = 'Scripter';

  System_Name  = 'DEGAS';
  SysDesc_1    = 'Development Environment for';
  SysDesc_2    = 'Graphic Adventures with Sound';
  Version      = '1.0';
  Year         = '1993';

  Message_Lines = 10;
  Message_Data : array[1..Message_Lines] of string[30] =
                 ('',
                  System_Name,
                  '',
                  SysDesc_1,
                  SysDesc_2,
                  '',
                  Program_Name+' V '+Version,
                  '',
                  '(c) '+Year+' Mark ''SAM'' Baker',
                  '');
  Message_Frame : array[1..Message_Lines] of string[3] =
                  ('╔═╗',
                   '║ ║',
                   '╟─╢',
                   '║ ║',
                   '║ ║',
                   '╟─╢',
                   '║ ║',
                   '╠═╣',
                   '║ ║',
                   '╚═╝');

{ Program help display }

  Help_Lines        = 9;
  Description_Start = 1;
  Syntax_Start      = 5;
  Help : array[1..Help_Lines] of string[65] =
         ('',
          'SCRIPTER '+Version+'- This program processes a compiled script for an',
          '          adventure game written using '+System_Name+' :',
          '          '+SysDesc_1+' '+SysDesc_2,
          '',
          'The Syntax for running is :-',
          '',
          'SCRIPTER /I=<Inputfile>',
          '         <Inputfile>  is the filename of Compiled Script code)');

{ General Constants }
  TAB   = #09;
  DOT   = '.';
  SLASH = '/';
  SPACE = ' ';

{ File extensions }
  MSGFileExt = 'MSC';
  LNEFileExt = 'LNC';
  SCRFileExt = 'SCC';


{ For the sake of this demo, we'll hard code the base information that
  would normally be derived from the character record }
  Start_Message = 1;
  Start_Script  = 1;

  OFF = false;
  ON  = true;


type

  StrArrayPtr = ^StrArray;
  StrArray    = array[1..640] of string[80];
  ScrArrayPtr = ^ScrArray;
  ScrArray    = array[1..16384] of word;

  Script_Record = record
      Line,
      RspOffs : word;
    end; { Script_Reocrd }


var

{ For the sake of this demo, I've just set up the messages and lines as an
  array of string, with no encryption or run-time replacement }
{ Character messages }
  Messages     : StrArrayPtr;
{ Player options }
  Lines        : StrArrayPtr;
{ Script data }
  Script_Index : ScrArrayPtr;
  Script_Data  : ScrArrayPtr;

{ Parameters }
  IP_Name : string;

{ Input File Variables }
  MSGFileName,LNEFileName,
  SCRFileName     : string;
  MSGFile,LNEFile : text;
  SCRFile         : file;
  MSGFile_Open,LNEFile_Open,
  SCRFile_Open    : boolean;

{ Error handling }
  Error_Message     : string;
  Status,Error_Type : byte;

{ Message and Line variables }
  MsgNbr,LneNbr,
  TotMsg,TotLne : word;

{ Script variables }
  ScrNbr,
  ScrDataSize,
  No_of_Scripts,
  Valid_Lines,
  No_of_Lines : word;
  End_Conversation : boolean;
  Thread : array[1..10] of Script_Record;

{ Flags (for test purposes only) }
  Flags : array[1..64] of boolean;


{ Various functions used by the program }

function StrUpCase (IS : string) : string;
var
  SI : byte;
begin
  for SI:=1 to Length(IS) do
    IS[SI] := UpCase(IS[SI]);
  StrUpCase := IS;
end; { StrUpCase }

function StripSpace (IS : string) : string;
begin
  while (Pos(SPACE,IS) = 1) do
    Delete(IS,1,1);
  StripSpace := IS;
end; { StripSpace }

function StripTAB (IS : string) : string;
var
  SI : byte;
begin
  for SI:=1 to Length(IS) do
    if (IS[SI] = TAB) then IS[SI] := SPACE;
  StripTAB := IS;
end; { StripTAB }


{ File handling routines }

{ Set open file status to FALSE for all Input files }
procedure Initialise_IP_Files;
begin
  MSGFile_Open := false;
  LNEFile_Open := false;
  SCRFile_Open := false;
end; { Initialise_IP_Files }

{ Close a specified text file if it has been opened }
procedure Close_Text_File
          (var FileOpen : boolean; var FileHandle : text);
begin
  if (FileOpen) then
     Close(FileHandle);
  FileOpen := false;
end; { Close_Text_File }

{ Close a specified block file if it has been opened }
procedure Close_Block_File
          (var FileOpen : boolean; var FileHandle : file);
begin
  if (FileOpen) then
     Close(FileHandle);
  FileOpen := false;
end; { Close_Block_File }

{ Close all Input files that are open }
procedure Close_IP_Files;
begin
  Close_Text_File(MSGFile_Open,MSGFile);
  Close_Text_File(LNEFile_Open,LNEFile);
  Close_Block_File(SCRFile_Open,SCRFile);
end; { Close_IP_Files }

{ Report any IO Errors, and terminate the program }
procedure IOError_Report
          (FileName : string);
begin
  Close_IP_Files;
  IOError_Message(Status,Error_Message,Error_Type);
  TextColor(Red);
  WriteLn('');
  WriteLn('ERROR with file '+FileName+' - '+Error_Message);
  WriteLn('');
  WriteLn('                 ****  SCRIPTING HAS BEEN ABORTED  ****');
  Halt(1);
end; { IOError_Report }

{ Test if a text Input file exists, and open it }
procedure Open_Text_IP_File
          (var FileName : string; FileExt : string;
           var FileHandle : text; var FileOpen : boolean);
begin
  FileName := IP_Name+DOT+FileExt;
  FileOpen := false;
  Assign(FileHandle,FileName);
{$I-}
  Reset(FileHandle);
{$I+}
  Status := IOResult;
  if (Status = Success) then FileOpen := true
  else IOError_Report(FileName);
end; { Open_Text_IP_File }

{ Test if a block Input file exists, and open it }
procedure Open_Block_IP_File
          (var FileName : string; FileExt : string; BlockSize : word;
           var FileHandle : file; var FileOpen : boolean);
begin
  FileName := IP_Name+DOT+FileExt;
  FileOpen := false;
  Assign(FileHandle,FileName);
{$I-}
  Reset(FileHandle,BlockSize);
{$I+}
  Status := IOResult;
  if (Status = Success) then FileOpen := true
  else IOError_Report(FileName);
end; { Open_Block_IP_File }

{ Seeing as this is just a demo, we'll not be fussy about how much memory
  we grab }

{ Read the Character response messages to the player }
procedure Read_Messages;
var
  MsgLine : word;
  MsgText : string;
begin
  GetMem(Messages,SizeOf(Messages^));
  MsgLine := 1;
  while (not Eof(MsgFile)) do
    begin
      ReadLn(MsgFile,Messages^[MsgLine]);
      Inc(MsgLine);
    end;
  TotMsg := MsgLine - 1;
end; { Read_Messages }

{ Read the player's conversation line options }
procedure Read_Lines;
var
  LneLine : word;
begin
  GetMem(Lines,SizeOf(Lines^));
  LneLine := 1;
  while (not Eof(LneFile)) do
    begin
      ReadLn(LneFile,Lines^[LneLine]);
      Inc(LneLine);
    end;
  TotLne := LneLine - 1;
end; { Read_Lines }

procedure Script_File_Error;
begin
  Status := 255;
  IOError_Report(SCRFileName);
end; { Script_File_Error }

{ Read the thread data in the script file }
procedure Read_Script_Data;
var
  Verify : word;
begin
  ScrDataSize := FileSize(ScrFile);
{ The number of scripts stored }
  BlockRead(ScrFile,No_of_Scripts,1,Verify);
  if (Verify <> 1) then Script_File_Error;
{ The script index; a set of word pointers to the individual elements of
  script data }
  GetMem(Script_Index,2 * No_of_Scripts);
  BlockRead(ScrFile,Script_Index^,No_of_Scripts,Verify);
  if (Verify <> No_of_Scripts) then Script_File_Error;
{ The script data itself }
  ScrDataSize := ScrDataSize - No_of_Scripts - 1;
  GetMem(Script_Data,2 * ScrDataSize);
  BlockRead(ScrFile,Script_Data^,ScrDataSize,Verify);
  if (Verify <> ScrDataSize) then Script_File_Error;
end; { Read_Script_Data }


{ Now we get to the heart of the program; the script processor }

{ Display the Character's response message }
procedure Display_Character_Message;
begin
  TextColor(Red);
  WriteLn('');
  WriteLn(Messages^[MsgNbr]);
  WriteLn('');
end; { Display_Character_Message }

{ Test if this is a valid line to add to our array }
{ Seeing as I've disabled most conditions for this demo (as they're too
  tied to the structure of DEGAS as a whole) we'll just work with a simple
  checking flag states (Flag_Is_On) }
procedure Process_Line_Conditions
          (var Valid_Line : boolean; var Data_Offset : word);
var
  F,C,No_of_Conditions : word;
begin
  No_of_Conditions := Script_Data^[Data_Offset];
  Inc(Data_Offset);
  C := 0;
{ We continue the Condition test loop, even when we've hit a false condition
  to ensure that we adjust Data_Offset correctly }
  while (C <> No_of_Conditions) do
    begin
      F := Script_Data^[Data_Offset];
      if (Flags[F] = OFF) then Valid_Line := false;
      Inc(Data_Offset);
      Inc(C);
    end;
end; { Process_Line_Conditions }

{ Perform the actions associated with the selected response }
{ Seeing as I've disabled most actions for this demo (as they're too tied to
  the structure of DEGAS as a whole) we'll just work with turning flags on }
procedure Process_Line_Actions
          (var Data_Offset : word);
var
  A,F,No_of_Actions : word;
begin
  No_of_Actions := Script_Data^[Data_Offset];
  Inc(Data_Offset);
  A := 0;
  while (A <> No_of_Actions) do
    begin
      F := Script_Data^[Data_Offset];
      Flags[F] := ON;
      Inc(Data_Offset);
      Inc(A);
    end;
end; { Process_Line_Actions }

{ Determine which line options we want to display, storing them in our
  Thread array }
procedure Process_Thread_Options;
var
  Valid_Line : boolean;
  L,
  Thread_Offset,
  Data_Offset,
  Line_Offset : word;
begin
  Thread_Offset := Script_Index^[ScrNbr];
  No_of_Lines   := Script_Data^[Thread_Offset];
  Line_Offset   := Thread_Offset;
  Valid_Lines   := 0;
  for L:=1 to No_of_Lines do
    begin
      Inc(Line_Offset);
      Data_Offset := Script_Data^[Line_Offset];
      Valid_Line  := true;
      Process_Line_Conditions(Valid_Line,Data_Offset);
      if (Valid_Line) then
         begin
           Inc(Valid_Lines);
           Thread[L].Line    := Script_Data^[Data_Offset];
           Inc(Data_Offset);
           Thread[L].RspOffs := Data_Offset;
         end;
    end;
end; { Process_Thread_Options }

{ Display the array options, and find which one the player wants to use as
  his response }
procedure Select_Thread_Option
          (var Line_Nbr : word);
var
  L : word;
  C : integer;
  LS : string;
begin
{ Display the options available at this point }
  TextColor(Blue);
  for L:=1 to Valid_Lines do
    begin
      Str(L:2,LS);
      Write(LS);
      Write('  ');
      WriteLn(Lines^[Thread[L].Line]);
    end;
{ Use a simple numeric input to indicate the player's choice }
  Write('Select response option : ');
  Line_Nbr := 0;
  while (Line_Nbr = 0) do
    begin
      ReadLn(LS);
      Val(LS,Line_Nbr,C);
      if ((Line_Nbr > Valid_Lines) or (C <> 0)) then Line_Nbr := 0;
    end;
{ And highlight the chosen option }
  TextColor(Yellow);
  WriteLn('');
  WriteLn(Lines^[Thread[Line_Nbr].Line]);
end; { Select_Thread_Option }

procedure Process_Selected_Option
          (Line_Nbr : word);
var
  Data_Offset : word;
begin
  Data_Offset := Thread[Line_Nbr].RspOffs;
  MsgNbr := Script_Data^[Data_Offset];
  Inc(Data_Offset);
  ScrNbr := Script_Data^[Data_Offset];
  End_Conversation := (ScrNbr and $8000) <> 0;
  ScrNbr := (ScrNbr or $8000) xor $8000;
  if (ScrNbr = 0) then End_Conversation := true;
  Inc(Data_Offset);
  Process_Line_Actions(Data_Offset);
end; { Process_Selected_Option }

procedure Process_Script;
var
  Line_Nbr : word;
begin
  while (not End_Conversation) do
    begin
      if (MsgNbr <> 0) then Display_Character_Message;
      if (ScrNbr <> 0) then
         begin
           Process_Thread_Options;
           if (Valid_Lines <> 0) then
              begin
                Select_Thread_Option(Line_Nbr);
                Process_Selected_Option(Line_Nbr);
              end
           else ScrNbr := 0;
         end;
    end;
{ Final display of any character response to the last selection }
  if (MsgNbr <> 0) then Display_Character_Message;
end; { Process_Script }


procedure Parameter_Help
          (Start_Line : byte);
var
  Help_Line : byte;
begin
  for Help_Line:=Start_Line to Help_Lines do
    WriteLn(Help[Help_Line]);
  Halt(1);
end; { Parameter Help }

procedure Parameter_Error
          (Error_Message : string);
begin
  WriteLn('');
  WriteLn(Error_Message);
  Parameter_Help(Syntax_Start);
end; { Parameter_Error }

procedure File_Parameter
          (FT : string; var PStr,Name : string);
var
  K : byte;
begin
  if (PStr[2] = '=') then
     begin
       Delete(PStr,1,2);
       K := Pos(SLASH,PStr);
       if (K = 0) then Name := PStr
       else Name := Copy(PStr,1,K-1);
       if (Name = '') then Parameter_Error(FT+' filename must be specified');
     end
  else Parameter_Error(FT+' filename incorrectly specified');
end; { File_Parameter }

procedure Get_Parameters;
var
  I,J : byte;
  PStr : string;
  EndParams : boolean;
begin
  IP_Name     := '';
  if (ParamCount = 0) then Parameter_Help(Description_Start);
  I := 1;
  while (I <= ParamCount) do
    begin
      PStr := StrUpCase(ParamStr(I));
      EndParams := false;
      if PStr[1] <> SLASH then
         Parameter_Error('Parameter incorrectly specified - '+PStr)
      else while not EndParams do
           begin
             Delete(PStr,1,1);
             if PStr = '' then Parameter_Error('Parameter Error');
             case PStr[1] of
               'I' : File_Parameter('Input',PStr,IP_Name);
               else Parameter_Error('Invalid Parameter - '+PStr);
             end;
             J:=Pos(SLASH,PStr);
             if J <> 0 then PStr:=Copy(PStr,J,Length(PStr)-J+1)
             else EndParams:=true;
           end;
      Inc(I);
    end;
  if (IP_Name = '') then Parameter_Error('Input filename MUST be specified');
end; { Get_Parameters }


procedure Display_Message;
var
  S   : string[80];
  F,L,
  X,Y : byte;
begin
  ClrScr;
  L := 0;
  TextColor(LightRed);
  for Y:=1 to Message_Lines do
    begin
      if (Length(Message_Data[Y]) > L) then L := Length(Message_Data[Y]);
      X := (80 - Length(Message_Data[Y])) div 2;
      GotoXY(X,Y+1);
      Write(Message_Data[Y]);
    end;
  TextColor(Yellow);
  X := ((80 - L) div 2) - 2;
  Inc(L,3);
  for Y:=1 to Message_Lines do
    begin
      GotoXY(X,Y+1);
      Write(Message_Frame[Y,1]);
      if (Message_Frame[Y,2] = SPACE) then GotoXY(X+L,Y+1)
      else begin
             S := '';
             for F:=1 to (L-1) do
               S := S + Message_Frame[Y,2];
             Write(S);
           end;
      Write(Message_Frame[Y,3]);
    end;
  TextColor(LightBlue);
  Window(1,Message_Lines+2,80,25);
end; { Display_Message }


procedure Initialise_Flags;
var
  F : byte;
begin
  for F:=1 to 64 do Flags[F] := OFF;
end; { Initialise_Flags }

procedure Initialise;
begin
  Initialise_IP_Files;
  Open_Text_IP_File(MSGFileName,MSGFileExt,MSGFile,MSGFile_Open);
  Open_Text_IP_File(LNEFileName,LNEFileExt,LNEFile,LNEFile_Open);
  Open_Block_IP_File(SCRFileName,SCRFileExt,2,SCRFile,SCRFile_Open);
  Read_Messages;
  Read_Lines;
  Read_Script_Data;
  Initialise_Flags;
  Close_IP_Files;
end; { Initialise }


begin
  Get_Parameters;
  Display_Message;
  Initialise;

  MsgNbr := Start_Message;
  ScrNbr := Start_Script;
  End_Conversation := false;
  Process_Script;
end. { main program }