program atari;
{ ATARI HarDisk simulator }
{    (c) by TSP & KMK     }
  
uses crt,dos;

type
  config =record
            ready :boolean;
            size_ :word;
          end;
  sector =array[0..255] of byte;
  partition =file of sector;

const
  data_reg =$300;
  ctrl_reg =$301;

var
  cdevic :byte;
  ccmnd  :byte;
  caux1  :byte;
  caux2  :byte;
  dev_num :byte;
  sect :sector;
  part :array[1..9] of partition;
  part_cfg :array[1..9] of config;
  part_name :array[1..9] of string[9];
  quit_   :boolean;
  not_brk :boolean;


{-------------------------------------------------------------------}


procedure key_chk;

begin
  if port[$60]=1 then
    begin
      quit_:=true;
      not_brk:=false;
    end;
  if port[$60]=57 then
    not_brk:=false;
end;



procedure get_byte(var d:byte);

begin
  while (port[ctrl_reg] and 64 =0) and not_brk do
    key_chk;
  d:=port[data_reg];
end;



procedure put_byte(d:byte);

begin
  while (port[ctrl_reg] and 128 =0) and not_brk do
    key_chk;
  port[data_reg]:=d;
end;



procedure get_sect;

var i:byte;

begin
  for i:=0 to 255 do
    get_byte(sect[i]);
end;



procedure put_sect;

var i:byte;

begin
  for i:=0 to 255 do
    put_byte(sect[i]);
end;



procedure get_cfb;

begin
  get_byte(cdevic);
  get_byte(ccmnd);
  get_byte(caux1);
  get_byte(caux2);
end;



procedure fill_part_name;

var i:byte;
    name :string[9];

begin
  for i:=1 to 9 do
    begin
      name:='atari.000';
      name[9]:=char(i+48);
      part_name[i]:=name;
    end;
end;


{$I-}
procedure part_init;

var i:byte;

begin
  for i:=1 to 9 do
    begin
      assign(part[i],part_name[i]);
      reset(part[i]);
      if ioresult=0 then
        begin
          part_cfg[i].ready:=true;
          part_cfg[i].size_:=word(filesize(part[i]));
          writeln('Partition ',i,' - ',part_cfg[i].size_,' sectors.');
        end
      else
        begin
          part_cfg[i].ready:=false;
          part_cfg[i].size_:=0;
        end;
    end;
end;
{$I+}


procedure part_close;

var i:byte;

begin
  for i:=1 to 9 do
    if part_cfg[i].ready then close(part[i]);
end;



procedure send_free;

var d :longint;
    i,a,b,c :byte;

begin
  put_byte($41);
  d:=diskfree(0) div 256;
  a:=byte(d mod 256);
  d:=d div 256;
  b:=byte(d mod 256);
  d:=d div 256;
  c:=byte(d mod 256);
  for i:=1 to 2 do
    begin
      put_byte(a);
      put_byte(b);
      put_byte(c);
    end;
  put_byte($43);
end;



procedure del_part;

var i,a,b,c:byte;

begin
  put_byte($41);
  get_byte(a);
  get_byte(b);
  get_byte(c);
  if (a=$28) and (b=$07) and (c=$70) then
    for i:=1 to 9 do
      if part_cfg[i].ready then
        begin
          close(part[i]);
          erase(part[i]);
        end;
  put_byte($43);
  part_init;
end;



procedure part_format(n,a,b: byte);

var i,j :word;

begin
  for i:=0 to 255 do
    sect[i]:=0;
  rewrite(part[n]);
  for i:=1 to b*256 do
    write(part[n],sect);
  for j:=1 to a do
    write(part[n],sect);
  close(part[n]);
end;



procedure create_part;

var i,a,b :byte;

begin
  for i:=1 to 9 do
    if part_cfg[i].ready then
      begin
        put_byte($4e);
        exit;
      end;
  put_byte($41);
  for i:=1 to 9 do
    begin
      get_byte(a);
      get_byte(b);
      if (a<>0) or (b<>0) then
        begin
          writeln('Creating partition ',i,' ...');
          part_format(i,a,b);
        end;
    end;
  put_byte($43);
  writeln('Creation complete.');
  part_init;
end;



procedure whole_disk;

begin
  case ccmnd of
    $3f: send_free;
    $51: del_part;
    $21: create_part;
  else
    put_byte($42);
  end;
end;



procedure send_cfg;

var lo,hi :byte;

begin
  put_byte($41);
  lo:=part_cfg[dev_num].size_ mod 256;
  hi:=part_cfg[dev_num].size_ div 256;
  put_byte(1);put_byte(0);
  put_byte(hi);put_byte(lo);
  put_byte(0);put_byte(4);
  put_byte(1);put_byte(0);
  put_byte(1);put_byte(0);
  put_byte(0);put_byte(0);
  put_byte($43);
end;



procedure wr_sect;

var l:word;

begin
  l:=caux2*256+caux1;
  if (l>part_cfg[dev_num].size_) or (l=0) then
    put_byte($4e)
  else
    begin
      put_byte($41);
      get_sect;
      seek(part[dev_num],l-1);
      write(part[dev_num],sect);
      put_byte($43);
    end;
end;



procedure rd_sect;

var l:word;

begin
  l:=caux2*256+caux1;
  if (l>part_cfg[dev_num].size_) or (l=0) then
    put_byte($4e)
  else
    begin
      put_byte($41);
      seek(part[dev_num],l-1);
      read(part[dev_num],sect);
      put_sect;
      put_byte($43);
    end;
end;



procedure send_status;

begin
  put_byte($41);
  put_byte($30);
  put_byte($ff);
  put_byte($e0);
  put_byte($10);
  put_byte($43);
end;



procedure wr_block;

begin
  put_byte($4e);
end;



procedure part_operate;

begin
  case ccmnd of
    $4e: send_cfg;
    $50: wr_sect;
    $52: rd_sect;
    $53: send_status;
    $57: wr_sect;
  else
    put_byte($4e);
  end;
end;



procedure part_chk;

begin
  if part_cfg[dev_num].ready then
    part_operate
  else
    put_byte($42);
end;



procedure part_dec;

begin
  case dev_num of
    1..9: part_chk;
    0   : whole_disk;
  else
    put_byte($42);
  end;
end;



procedure prn_dec;

begin
  put_byte($42);
end;



procedure com_dec;

begin
  put_byte($42);
end;



procedure cfb_dec;

begin
  get_cfb;
  dev_num:=cdevic and $0f;
  case (cdevic and $f0) of
    $30: part_dec;
    $40: prn_dec;
    $50: com_dec;
  else
    put_byte($42);
  end;
end;



procedure dev_chk;

var i:byte;

begin
  i:=port[data_reg];
  if port[ctrl_reg]=255 then
    begin
      quit_:=true;
      writeln;
      writeln('Device is not installed !');
    end
  else
    quit_:=false;
end;


{-------------------------------------------------------------------}


begin
  repeat
    dev_chk;
    if quit_ then exit;
    not_brk:=true;
    writeln;
    writeln;
    writeln('Now PC is a servant of your ATARI !');
    writeln;
    fill_part_name;
    part_init;
    writeln;
    writeln('Working ...');
    repeat
      cfb_dec;
    until not not_brk;
    part_close;
  until quit_
end.