Coke Commander - Another attempt for a NC-clone

cc.pas

{
Coke Commander - The Kick Ass NC Clone (1996)
}

uses

QText,XStr,Views,Dialogs,App,Memory,XBuf,TVX,Drivers,Exec,Dos,XIO,Objects;

const

  locLeft  = 1;
  locRight = 2;

type

  TMain = object(TXApp)
    constructor Init;
    destructor Done;virtual;
    procedure HandleEvent(var Event:TEvent);virtual;
    procedure InitBackground;virtual;
  end;

  PTransBack = ^TTransBack;
  TTransBack = object(TDumbView)
    procedure Draw;virtual;
  end;

  PFileRec = ^TFileRec;
  TFileRec = record
    Name   : string[12];
    Attr   : byte;
    Size   : longint;
    Time   : longint;
    Tagged : boolean;
  end;

  PFileColl = ^TFileColl;
  TFileColl = object(TSortedCollection)
    procedure FreeItem(item:pointer);virtual;
    function Compare(k1,k2:pointer):integer;virtual;
  end;

  PFileLister = ^TFileLister;
  TFileLister = object(TXTagLister)
    Location  : FNameStr;
    constructor Init(var abounds:TRect; where:FnameStr);
    procedure Update(where:FnameStr);virtual;
    procedure Refresh;virtual;
    procedure HandleEvent(var Event:TEvent);virtual;
    function  GetText(item,maxlen:integer):string;virtual;
    function  isTagged(item:integer):boolean;virtual;
    function  GetColor(item:integer):byte;virtual;
    procedure SetTag(item:integer; enable:boolean);virtual;
  end;

  PPanel = ^TPanel;
  TPanel = object(TXWindow)
    constructor Init(location:byte; header:fnameStr);
    procedure HandleEvent(var Event:TEvent);virtual;
  end;

  PFilePanel = ^TFilePanel;
  TFilePanel = object(TPanel)
    Lister : PFileLister;
    constructor Init(location:byte; where:FnameStr);
    procedure   HandleEvent(var Event:TEvent);virtual;
  end;

  TEXEHeader = Record
    Id           : Word;
    LastPageSize : Word;
    FileSize     : Word; { in 512 byte pages }
    RelCount     : word;
    HdrSize      : Word; { in 16 byte paragraphs}
    MinMem       : word; { in 16 byte paragraphs}
    MaxMem       : Word; { in 16 byte paragraphs}
    SSInit       : Word;
    SPInit       : Word;
    NegSum       : Word;
    IPInit       : Word;
    CSInit       : Word;
    RelOfs       : Word;
    OverlayCount : Word;
    Unused1      : word;
    Unused2      : word;
  end;

const

  ccVersion = '0.1 alpha';

var

  DosBack : array[1..4000] of char;

procedure Error(h,b:FnameStr);
begin
  asm
    mov ax,3
    int 10h
  end;
  writeln(h+': '+b);
  halt(1);
end;

procedure ValidateEXE;
var
  h:TEXEHeader;
  T:TDosStream;
  crc:word;
  buf:pointer;
  bufsize:word;
begin
  T.Init(ParamStr(0),stOpenRead);
  T.Read(h,SizeOf(h));
  crc := 0;
  while T.GetPos < T.GetSize do begin
    bufSize := 65000;
    if bufSize > T.GetSize-T.GetPos then bufSize := T.GetSize-T.GetPos;
    GetMem(buf,BufSize);
    T.Read(buf^,bufSize);
    inc(crc,GetChecksum(buf^,bufSize));
    FreeMem(buf,bufSize);
  end;
  T.Done;
  if h.NegSum <> crc then Error('Coke Commander','EXE corrupt');
end;

{---- tfilecoll ----}
procedure TFileColl.FreeItem;
begin
  Dispose(PFileRec(item));
end;

function TFileColl.Compare;
var
  pf1,pf2:PFileRec;
  function isdir(a:PFileRec):boolean;
  begin
    isdir := a^.Attr and Directory > 0;
  end;
begin
  pf1 := k1;
  pf2 := k2;
  if isdir(pf1) and not isdir(pf2) then Compare := -1 else
  if (not isdir(pf1)) and isdir(pf2) then Compare := 1 else begin
    if pf1^.Name > pf2^.Name then Compare := 1 else
    if pf1^.Name < pf2^.Name then Compare := -1 else Compare := 0;
  end;
end;

{---- tfilelister ----}

constructor TFileLister.init;
begin
  inherited Init(abounds,NIL);
  Update(where);
end;

procedure TFileLister.Update;
var
  P:PFileColl;
  Pf:PFileRec;
  dirinfo:SearchRec;
begin
  XMakeDirStr(where,true);
  Location := where;
  New(P,Init(10,10));
  FindFirst(where+'*.*',Directory+Archive+Readonly+Hidden+SysFile,dirinfo);
  while DosError = 0 do begin
    if dirinfo.name <> '.' then begin
      New(Pf);
      with Pf^ do begin
        Name := dirinfo.name;
        Size := dirinfo.size;
        Time := dirinfo.Time;
        attr := dirinfo.attr;
        tagged := false;
      end;
      P^.Insert(Pf);
    end;
    FindNext(dirinfo);
  end;
  NewList(P);
end;

procedure TFileLister.Refresh;
begin
  Update(Location);
end;

procedure TFileLister.HandleEvent;
begin
  inherited HandleEvent(Event);
end;

function TFileLister.GetText;
var
  Pf:PFileRec;
  s:string;
  b:byte;
begin
  Pf := List^.At(item);
  b := pos('.',Pf^.Name);
  if (b = 0) or (Pf^.Name = '..') then s := Fix(Pf^.Name,12)
                                  else s := Fix(copy(Pf^.Name,1,b-1),9)+Fix(copy(Pf^.Name,b+1,255),3);
  if pf^.Attr and Directory = 0 then FastLower(s);
  GetText := s;
end;

function TFileLister.isTagged(item:integer):boolean;
var
  Pf:PFileRec;
begin
  Pf := List^.At(item);
  isTagged := Pf^.Tagged;
end;

procedure TFileLister.SetTag(item:integer; enable:boolean);
var
  Pf:PFileRec;
begin
  Pf := List^.At(item);
  Pf^.Tagged := enable;
end;

function TFileLister.GetColor;
var
  color:byte;
begin
  if istagged(item) then color := $4e else color := $4f;
  if (focused = item) and GetState(sfFocused) then color := (color and $0f) or $50;
  GetColor := color;
end;

{---- TPANEL ----}
constructor TPanel.Init;
var
  R:TRect;
begin
  Application^.GetExtent(R);
  R.B.X := r.b.x div 2;
  dec(r.b.y,2);
  if location = locright then R.Move(Application^.Size.X div 2,0);
  inherited Init(R,header,location);
  Flags := Flags and not (wfGrow+wfClose);
end;

procedure TPanel.HandleEvent;
begin
  if Event.What = evKeydown then case Event.KeyCode of
    kbTab : begin
              Owner^.SelectNext(False);
              ClearEvent(Event);
              exit;
            end;
  end;
  inherited HandleEvent(Event);

end;

{---- TFILEPANEL ----}

constructor TFilePanel.Init;
var
  R:TRect;
begin
  where := FExpand(where);
  inherited Init(location,where);
  GetExtent(R);
  R.Grow(-2,-1);
  inc(r.a.y);
  New(Lister,Init(R,Where));
  Insert(Lister);
end;

procedure TFilePanel.HandleEvent;
var
  Pf:PFileRec;
  procedure Go(where:FnameStr);
  begin
    where := FExpand(where);
    Lister^.Update(where);
    DisposeStr(Title);
    Title := NewStr(where);
    Draw;
  end;
begin
  inherited HandleEvent(Event);
  if Event.What = evKeyDown then case Event.KeyCode of
    kbEnter : if Lister^.List^.Count > 0 then begin
                Pf := Lister^.List^.At(Lister^.Focused);
                if Pf^.Attr and Directory > 0 then Go(Lister^.Location+Pf^.Name);
              end;
  end; {case}
end;

{---- TMAIN ----}
procedure GetBackground;
begin
  Move32(Mem[segb800:0],DosBack,4000);
end;

constructor TMain.Init;
  procedure InitPanels;
  begin
    Insert(New(PFilePanel,Init(locLeft,'C:\')));
    Insert(New(PFilePanel,Init(locRight,'C:\BP')));
  end;
  procedure InitPrompt;
  begin

  end;
  procedure InitMode;
  begin
    if Mem[Seg0040:$49] <> 3 then asm
      mov ax,3
      int 10h
    end;
    qLocate(0,24);
    qWriteln(#13#10'Coke Commander '+ccVersion+' - (c) 1996 Sedat Kapanoglu'#13#10#13#10);
  end;
begin
{  if XIsParam('DEVPARM') = 0 then ValidateEXE;}
  InitMode;
  GetBackground;
  CustomPalette := false;
  inherited Init;
  InitPanels;
  InitPrompt;
end;

procedure TMain.InitBackground;
var
  R:TRect;
begin
  GetExtent(R);
  Background := New(PTransBack,Init(R));
end;

procedure TTransBack.Draw;
begin
  WriteBuf(0,0,Size.X,Size.Y,DosBack);
end;

destructor TMain.Done;
begin
  Move32(dosBack,mem[segb800:0],4000);
  DoneSysError;
  DoneEvents;
  DoneMemory;
  DoneVideo;
  TProgram.Done;
  Move32(dosBack,mem[segb800:0],4000);
end;

procedure TMain.HandleEvent;
begin
  inherited HandleEvent(Event);
  if Event.What = evKeyDown then case Event.KeyCode of
    kbTab : SelectNext(False);
    kbF10 : Message(@Self,evCommand,cmQuit,NIL);
  end; {case}
end;

var
  CC:TMain;
begin
  CC.Init;
  CC.Run;
  CC.Done;
end.