Unit Profile;

Interface

Uses Classes;

Type
  TCart = (ct2k,ct4k,ct8k,ct16k,ctSuperChip,ctParkerBros,ctMNetwork,
           ctStarpath,ctCBS,ctTigerVision,ctPitfall2,ctActivision,
           ctMegaBoy,ct32In1,ctCommaVid,ctCompumate,ctUnknown);
  TController = (crJoystick,crPaddle,crVTP,crDriving,crKeyboard,crBooster,crUnknown);
  TPaletteDef = (plNone,plNTSC,plPAL);
  TFileType = Class
    Name         : String;
    RealName     : String;
    Cart         : TCart;
    Cont         : TController;
    Pos200       : Integer;
    Pos204       : Integer;
    Pos215       : Integer;
    Pos250       : Integer;
    Pos305       : Integer;
    Manufacturer : String;
    Year         : Integer;
    DefaultSize  : Integer;
    Palette      : TPaletteDef;
  End;

Const
  MenuKey : Array[TCart] Of Char =
   (#13,#13,#13,#13,'R','P','M',#13,#13,'T','2','A','G','3','V','O',#13);
  NoPosSet = 999;

Var ProfileList: TList;

//Var
//  PosSet : Boolean;

Procedure MakeProfile(Path: String);
Function  FindProfile(Name: String;
                      Var Controller: TController;
                      Var Pos200: Integer;
                      Var Pos204: Integer;
                      Var Pos215: Integer;
                      Var Pos250: Integer;
                      Var Pos305: Integer;
                      Var FileRec: TFileType): TCart;
Procedure AddToProfile(Const Name: String;
                       Const RealName: String;
                       Const Cart: TCart;
                       Const Controller: TController;
                       Const Pos200: Integer;
                       Const Pos204: Integer;
                       Const Pos215: Integer;
                       Const Pos250: Integer;
                       Const Pos305: Integer;
                       Const Manufacturer: String;
                       Const Year: Integer;
                       Const DefaultSize: Integer;
                       Const Palette: TPaletteDef);
Function FindByTitle(Title: String): TFileType;
Function ConcatAllNames: PChar;

Implementation

Uses SysUtils,Forms;

Const
  OutFileName = 'PCAEWIN.PRO';

Type
  TIndex = Array[0..255] Of Integer;

Const
  CartID : Array[TCart] Of String[2] =
   ('2K','4K','8K','16','SC','PB','MN','SP','CB','TV','P2','AC','MB','32','CV','CM','??');
  ContID : Array[TController] Of String[2] =
   ('JY','PD','VT','DR','KB','BG','%%');

Var FileIndex: TIndex;

Function FindByTitle(Title: String): TFileType;
Var
  I     : Integer;
  Found : Boolean;
  F     : TFileType;
  St    : String;

Begin
  I     := 0;
  F     := Nil;
  Found := False;
  While (I < ProfileList.Count) And Not Found Do
  Begin
    F := ProfileList[I];
    If F.RealName <> '' Then St := F.RealName Else St := F.Name;
    If St = Title Then Found := True Else Inc(I);
  End; // While
  If Found Then FindByTitle := F Else FindByTitle := Nil;
End; // FindByTitle

Procedure Separate(Var St,St1: String);
{ ------------------------------------------------------------------ }
{ Takes an input string St, separates such that the left portion is  }
{ returned in St1 and the right portion is returned in St.  If the   }
{ string has no spaces, St1 returns the entire string and St returns }
{ a string containing two spaces.                                    }
{ ------------------------------------------------------------------ }
Var I: Integer;
Begin
  I := Pos(' ',St);
  If I <> 0 Then
  Begin
    St1 := UpperCase(Trim(Copy(St,1,I - 1)));
    St  := Trim(Copy(St,I + 1,Length(St) - I));
  End
  Else
  Begin
    St1 := UpperCase(St);
    St  := '  ';
  End;
End; { Separate }

Procedure SortFileList;
Var
  I,J   : Integer;
  F1,F2 : TFileType;
  F3    : TFileType;

Begin
  I := 0;
  While I < ProfileList.Count - 1 Do
  Begin
    F1 := ProfileList[I];
    J := I + 1;
    While J < ProfileList.Count Do
    Begin
      F2 := ProfileList[J];
      If F2.Name < F1.Name Then
      Begin
        F3 := F1;
        ProfileList[I] := F2;
        ProfileList[J] := F3;
        F1 := F2;
      End;
      Inc(J);
    End; { While }
    Inc(I);
  End;
End; { SortFileList }

Procedure SortFileListByTitle;
Var
  I,J   : Integer;
  F1,F2 : TFileType;
  F3    : TFileType;
  St1   : String;
  St2   : String;

Begin
  I := 0;
  While I < ProfileList.Count - 1 Do
  Begin
    F1 := ProfileList[I];
    If F1.RealName <> ''
     Then St1 := F1.RealName
     Else St1 := F1.Name;
    J := I + 1;
    While J < ProfileList.Count Do
    Begin
      F2 := ProfileList[J];
      If F2.RealName <> ''
       Then St2 := F2.RealName
       Else St2 := F2.Name;
      If St2 < St1 Then
      Begin
        F3 := F1;
        ProfileList[I] := F2;
        ProfileList[J] := F3;
        F1 := F2;
        St1 := St2;
      End;
      Inc(J);
    End; { While }
    Inc(I);
  End;
End; { SortFileListByTitle }

Function ConcatAllNames: PChar;
Var
  I     : Integer;
  F     : TFileType;
  Len   : Integer;
  P,P1  : PChar;

Begin
  SortFileListByTitle;
  Len := 0;
  For I := 0 To ProFileList.Count - 1 Do
  Begin
    F := ProfileList[I];
    If F.RealName <> ''
     Then Inc(Len,Length(F.RealName) + 1)
     Else Inc(Len,Length(F.Name) + 1);
  End; // For I
  Inc(Len);
  GetMem(P,Len);
  FillChar(P^,SizeOf(P^),#0);
  P1 := P;
  For I := 0 To ProFileList.Count - 1 Do
  Begin
    F := ProfileList[I];
    If F.RealName <> '' Then
    Begin
      StrPCopy(P1,F.RealName);
      Inc(LongInt(P1),Length(F.RealName) + 1);
    End
    Else
    Begin
      StrPCopy(P1,F.Name);
      Inc(LongInt(P1),Length(F.Name) + 1);
    End;
  End; // For I
  ConcatAllNames := P;
  SortFileList;
End; // ConcatAllNames

Procedure LoadFileList(Path: String);
Var
  S      : TSearchRec;
  F      : TFileType;
  Cont   : TController;
  Pos200 : Integer;
  Pos204 : Integer;
  Pos215 : Integer;
  Pos250 : Integer;
  Pos305 : Integer;

Begin
  If FindFirst(Path + '*.BIN',faArchive,S) = 0 Then
  Repeat
    FindProfile(UpperCase(S.Name),Cont,Pos200,Pos204,Pos215,Pos250,Pos305,F);
    If F = Nil Then
    Begin
      F              := TFileType.Create;
      F.Name         := UpperCase(S.Name);
      F.RealName     := '';
      F.Cart         := ctUnknown;
      F.Cont         := crUnknown;
      F.Pos200       := NoPosSet;
      F.Pos204       := NoPosSet;
      F.Pos215       := NoPosSet;
      F.Pos250       := NoPosSet;
      F.Pos305       := NoPosSet;
      F.Manufacturer := '';
      F.Year         := 0;
      F.DefaultSize  := 0;
      F.Palette      := plNone;
      ProfileList.Add(F);
    End;
  Until FindNext(S) <> 0;
  If FindFirst(Path + '*.PAL',faArchive,S) = 0 Then
  Repeat
    FindProfile(UpperCase(S.Name),Cont,Pos200,Pos204,Pos215,Pos250,Pos305,F);
    If F = Nil Then
    Begin
      F              := TFileType.Create;
      F.Name         := UpperCase(S.Name);
      F.RealName     := '';
      F.Cart         := ctUnknown;
      F.Cont         := crUnknown;
      F.Pos200       := NoPosSet;
      F.Pos204       := NoPosSet;
      F.Pos215       := NoPosSet;
      F.Pos250       := NoPosSet;
      F.Pos305       := NoPosSet;
      F.Manufacturer := '';
      F.Year         := 0;
      F.DefaultSize  := 0;
      F.Palette      := plNone;
      ProfileList.Add(F);
    End;
  Until FindNext(S) <> 0;
End; { LoadFileList }

Procedure Cleanup;
Var I: Integer;
Begin
  I := 0;
  While I < ProfileList.Count Do
  Begin
    TFileType(ProfileList[I]).Free;
    Inc(I);
  End; // While
  ProfileList.Free;
  FillChar(FileIndex,SizeOf(FileIndex),#0);
End; { Cleanup }

Procedure OutputFile(Path: String);
Var
  F       : TFileType;
  Loaded  : LongInt;
  Load    : LongInt;
  Cart    : TCart;
  B       : Byte;
  I       : Integer;
  Done    : Boolean;
  St      : String;
  C       : Char;
  Lines   : Integer;
  InFile  : File;
  OutFile : System.Text;
  Buf     : Array[0..255] Of Byte;

Begin
  C := #0;
  AssignFile(OutFile,Path + OutFileName);
  ReWrite(OutFile);
  WriteLn(OutFile,'; PCAE cartridge profile list');
  WriteLn(OutFile,'; Valid cart codes: 2K 4K 8K 16 SC PB MN SP CB TV P2 AC MB 32 CV ??');
  WriteLn(OutFile,'; Valid controller codes: JY PD VT DR KB %%');
  WriteLn(OutFile);
  Lines := 0;
  While Lines < ProfileList.Count Do
  Begin
    F := ProfileList[Lines];
    If F.Name[1] <> C Then C := F.Name[1];
    If FileExists(Path + F.Name) Then
    Begin
      AssignFile(InFile,Path + F.Name);
      Reset(InFile,1);
      Loaded := FileSize(InFile);
      Cart   := ctUnknown;
      If Loaded < 4096 Then Cart := ct2k Else
       If Loaded = 4096 Then Cart := ct4k Else
        If Loaded = 8192 Then Cart := ct8k Else
         If (Loaded Mod 8448) = 0 Then Cart := ctStarpath Else
          If Loaded = 12288 Then Cart := ctCBS Else
           If Loaded = 16384 Then Cart := ct16k Else
            If Loaded > 16384 Then Cart := ctSuperChip;
      If Loaded > 256 Then Load := 256 Else Load := Loaded;
      BlockRead(InFile,Buf,Load);
      CloseFile(InFile);

      If Loaded = 10495 Then
      Begin
        B    := Buf[0];
        Done := False;
        I := 0;
        While (I < 128) And Not Done Do
        Begin
          If Buf[I] <> B Then Done := True;
          Inc(I);
        End; { While }
        If Not Done Then Cart := ctPitfall2;
      End;
      If Loaded = 16384 Then
      Begin
        B := Buf[0];
        Done := False;
        I := 0;
        While (I < 256) And Not Done Do
        Begin
          If Buf[I] <> B Then Done := True;
          Inc(I);
        End; { While }
        If Not Done Then Cart := ctSuperChip;
      End;
      If F.Cart = ctUnknown Then F.Cart := Cart;
    End;
    St := '/' + F.Name + '/ ';
    While Length(St) < 15 Do St := St + ' ';

    // Title

    If (F.RealName <> '') And (F.RealName <> F.Name) Then
     St := St + '"' + F.RealName + '" ';
    While Length(St) < 58 Do St := St + ' ';

    // Manufacturer

    If F.Manufacturer <> '' Then St := St + 'MN[' + F.Manufacturer + ']MN ';
    While Length(St) < 80 Do St := St + ' ';

    // Year

    If F.Year <> 0 Then St := St + 'YR[' + IntToStr(F.Year) + ']YR ';
    While Length(St) < 95 Do St := St + ' ';

    // Default size

    If F.DefaultSize <> 0 Then St := St + 'DS[' + IntToStr(F.DefaultSize) + ']DS ';
    While Length(St) < 110 Do St := St + ' ';

    // Palette type

    If F.Palette <> plNone Then St := St + 'PL[' + IntToStr(Integer(F.Palette)) + ']PL ';
    While Length(St) < 120 Do St := St + ' ';

    // Cart type

    I  := 3 * Integer(F.Cart);
    While I > 0 Do
    Begin
      St := St + ' ';
      Dec(I);
    End; { While }
    St := St + CartID[F.Cart] + ' ' + ContID[F.Cont] + ' ' +
          IntToStr(F.Pos200) + ' ' +
          IntToStr(F.Pos204) + ' ' +
          IntToStr(F.Pos215) + ' ' +
          IntToStr(F.Pos250) + ' ' +
          IntToStr(F.Pos305);
    WriteLn(OutFile,St);
    Inc(Lines);
    If (Lines Mod 10) = 0 Then
     WriteLn(OutFile,'; ---------------------------------------------------');
  End; { While }
  CloseFile(OutFile);
End; { OutputFile }

Procedure IndexFileList;
Var
  FWork : TFileType;
  C     : Char;
  I     : Integer;

Begin
  FillChar(FileIndex,SizeOf(FileIndex),#0);
  I := 0;
  C     := '*';   { Choose a character that cannot be in the filename }
  While I < ProfileList.Count Do
  Begin
    FWork := ProfileList[I];
    If FWork.Name <> '' Then
    Begin
      If FWork.Name[1] <> C Then
      Begin
        C                 := FWork.Name[1];
        FileIndex[Ord(C)] := I;
      End;
    End;
    Inc(I);
  End; { While }
End; { IndexFileList }

Procedure MakeProfile(Path: String);
Begin
  If (Path <> '') And Not (Path[Length(Path)] In [':','\']) Then Path := Path + '\';
  LoadFileList(Path);
  SortFileList;
  IndexFileList;
  OutputFile(Path);
End; { MakeProfile }

Procedure LoadProfile;
Var
  St,St1  : String;
  I,J     : Integer;
  Cart    : TCart;
  Cont    : TController;
  OutFile : System.Text;
  F       : TFileType;

Begin
  If FileExists(ExtractFilePath(Application.ExeName) + OutFileName) Then
  Begin
    AssignFile(OutFile,OutFileName);
    Reset(OutFile);
    While Not Eof(OutFile) Do
    Begin
      ReadLn(OutFile,St);
      St := Trim(St);

      { Exclude remarks and blank lines }

      If (St <> '') And (St[1] <> ';') Then
      Begin

        { Locate the file name }

        St1 := St;
        I   := Pos('/',St);
        If I <> 0 Then
        Begin
          St := Copy(St,I + 1,Length(St) - I);
          I  := Pos('/',St);
          If I <> 0 Then
          Begin
            St1 := Trim(Copy(St,1,I - 1));
            St  := Trim(Copy(St,I + 1,Length(St) - I));
          End;
        End
        Else Separate(St,St1);

        F              := TFileType.Create;
        F.Name         := UpperCase(St1);
        F.RealName     := '';
        F.Cart         := ctUnknown;
        F.Cont         := crUnknown;
        F.Pos200       := NoPosSet;
        F.Pos204       := NoPosSet;
        F.Pos215       := NoPosSet;
        F.Pos250       := NoPosSet;
        F.Pos305       := NoPosSet;
        F.Manufacturer := '';
        F.Year         := 0;
        F.DefaultSize  := 0;
        F.Palette      := plNone;
        ProfileList.Add(F);

        { Locate the game's real name }

        I := Pos('"',St);
        If I <> 0 Then
        Begin
          St := Copy(St,I + 1,Length(St) - I);
          I := Pos('"',St);
          If I <> 0 Then
          Begin
            St1 := Trim(Copy(St,1,I - 1));
            St  := Trim(Copy(St,I + 1,Length(St) - I));
            If St1 <> '' Then F.RealName := St1;
          End;
        End;

        // Locate the game's manufacturer

        I := Pos('MN[',St);
        If I <> 0 Then
        Begin
          St := Copy(St,I + 3,Length(St) - I - 2);
          I := Pos(']MN',St);
          If I <> 0 Then
          Begin
            St1 := Trim(Copy(St,1,I - 1));
            St  := Trim(Copy(St,I + 3,Length(St) - I - 2));
            If St1 <> '' Then F.Manufacturer := St1;
          End;
        End;

        // Locate the year the game was made

        I := Pos('YR[',St);
        If I <> 0 Then
        Begin
          St := Copy(St,I + 3,Length(St) - I - 2);
          I := Pos(']YR',St);
          If I <> 0 Then
          Begin
            St1 := Trim(Copy(St,1,I - 1));
            St  := Trim(Copy(St,I + 3,Length(St) - I - 2));
            If St1 <> '' Then
            Begin
              Val(St1,I,J);
              If J = 0 Then F.Year := I;
            End;
          End;
        End;

        // Locate the game's default height in pixels

        I := Pos('DS[',St);
        If I <> 0 Then
        Begin
          St := Copy(St,I + 3,Length(St) - I - 2);
          I := Pos(']DS',St);
          If I <> 0 Then
          Begin
            St1 := Trim(Copy(St,1,I - 1));
            St  := Trim(Copy(St,I + 3,Length(St) - I - 2));
            If St1 <> '' Then
            Begin
              Val(St1,I,J);
              If J = 0 Then F.DefaultSize := I;
            End;
          End;
        End;

        // Locate the game's default palette type

        I := Pos('PL[',St);
        If I <> 0 Then
        Begin
          St := Copy(St,I + 3,Length(St) - I - 2);
          I := Pos(']PL',St);
          If I <> 0 Then
          Begin
            St1 := Trim(Copy(St,1,I - 1));
            St  := Trim(Copy(St,I + 3,Length(St) - I - 2));
            If St1 <> '' Then
            Begin
              Val(St1,I,J);
              If (J = 0) And (I >= 0) And (I <= 2) Then F.Palette := TPaletteDef(I);
            End;
          End;
        End;

        { Locate the first cartridge/controller mnemonic }

        Separate(St,St1);
        For Cart := ct2k To ctUnknown Do
         If CartID[Cart] = St1 Then F.Cart := Cart;
        For Cont := crJoystick To crUnknown Do
         If ContID[Cont] = St1 Then F.Cont := Cont;

        { Locate the second cartridge/controller mnemonic }

        Separate(St,St1);
        For Cart := ct2k To ctUnknown Do
         If CartID[Cart] = St1 Then F.Cart := Cart;
        For Cont := crJoystick To crUnknown Do
         If ContID[Cont] = St1 Then F.Cont := Cont;

        { Locate the 200-scan-line position value }

        Separate(St,St1);
        If St1 <> '' Then
        Begin
          Val(St1,I,J);
          If J = 0 Then F.Pos200 := I;
        End;

        { Locate the 204-scan-line position value }

        Separate(St,St1);
        If St1 <> '' Then
        Begin
          Val(St1,I,J);
          If J = 0 Then F.Pos204 := I;
        End;

        { Locate the 215-scan-line position value }

        Separate(St,St1);
        If St1 <> '' Then
        Begin
          Val(St1,I,J);
          If J = 0 Then F.Pos215 := I;
        End;

        { Locate the 250-scan-line position value }

        Separate(St,St1);
        If St1 <> '' Then
        Begin
          Val(St1,I,J);
          If J = 0 Then F.Pos250 := I;
        End;

        { Locate the 305-scan-line position value }

        Separate(St,St1);
        If St1 <> '' Then
        Begin
          Val(St1,I,J);
          If J = 0 Then F.Pos305 := I;
        End;
      End;
    End; { While }
    CloseFile(OutFile);
  End;
End; { LoadProfile }

Procedure KillProfile;
Begin
  MakeProfile(ExtractFilePath(Application.ExeName));
//  If PosSet Then OutputFile(ExtractFilePath(Application.ExeName));
  Cleanup;
End; { KillProfile }

Function FindProfile(Name: String;
                     Var Controller: TController;
                     Var Pos200: Integer;
                     Var Pos204: Integer;
                     Var Pos215: Integer;
                     Var Pos250: Integer;
                     Var Pos305: Integer;
                     Var FileRec: TFileType): TCart;
Var
  FWork : TFileType;
  Found : Boolean;
  I     : Integer;

Begin
  Name  := UpperCase(Name);
  Found := False;
  I     := 0;
  If Name <> '' Then
  Begin
    I := FileIndex[Ord(Name[1])];
    While (I >= 0) And (I < ProfileList.Count) And
          (TFileType(ProfileList[I]).Name[1] = Name[1]) And Not Found Do
    Begin
      If Name = TFileType(ProfileList[I]).Name Then Found := True Else Inc(I);
    End; { While }
  End;
  If Found Then
  Begin
    FWork       := ProfileList[I];
    FindProfile := FWork.Cart;
    Controller  := FWork.Cont;
    Pos200      := FWork.Pos200;
    Pos204      := FWork.Pos204;
    Pos215      := FWork.Pos215;
    Pos250      := FWork.Pos250;
    Pos305      := FWork.Pos305;
    FileRec     := FWork;
  End
  Else
  Begin
    FindProfile := ctUnknown;
    Controller  := crUnknown;
    Pos200      := NoPosSet;
    Pos204      := NoPosSet;
    Pos215      := NoPosSet;
    Pos250      := NoPosSet;
    Pos305      := NoPosSet;
    FileRec     := Nil;
  End;
End; { FindProfile }

Procedure AddToProfile(Const Name: String;
                       Const RealName: String;
                       Const Cart: TCart;
                       Const Controller: TController;
                       Const Pos200: Integer;
                       Const Pos204: Integer;
                       Const Pos215: Integer;
                       Const Pos250: Integer;
                       Const Pos305: Integer;
                       Const Manufacturer: String;
                       Const Year: Integer;
                       Const DefaultSize: Integer;
                       Const Palette: TPaletteDef);
Var F: TFileType;
Begin
  F              := TFileType.Create;
  F.Name         := Name;
  F.RealName     := RealName;
  F.Cart         := Cart;
  F.Cont         := Controller;
  F.Pos200       := Pos200;
  F.Pos204       := Pos204;
  F.Pos215       := Pos215;
  F.Pos250       := Pos250;
  F.Pos305       := Pos305;
  F.Manufacturer := Manufacturer;
  F.Year         := Year;
  F.DefaultSize  := DefaultSize;
  F.Palette      := Palette;
  ProfileList.Add(F);
  SortFileList;
  IndexFileList;
End; { AddToProfile }

Initialization
  ProfileList := TList.Create;
  LoadProfile;
  IndexFileList;
//  PosSet := False;
Finalization
  KillProfile;
End.

// ----------------------------------------------------------------------
// PCAE and PCAEWin - PC Atari Emulator - Atari 2600 emulator
// Copyright (C) 2000 John Dullea
//
//  This program is free software; you can redistribute it and/or modify
//  it under the terms of the GNU General Public License as published by
//  the Free Software Foundation; either version 2 of the License, or
//  (at your option) any later version.
//
//  This program is distributed in the hope that it will be useful,
//  but WITHOUT ANY WARRANTY; without even the implied warranty of
//  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
//  GNU General Public License for more details.
//
//  You should have received a copy of the GNU General Public License
//  along with this program; if not, write to the Free Software
//  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
// ----------------------------------------------------------------------
