program d64;

uses dos;

type blocktype=array [0..255] of byte;

var ts: array [1..35, 0..20] of word;
    ms: array [1..35] of byte;
    dirlink: array [0..18] of byte;
    xlat: array [0..255] of byte;
    p1, p2: string;
    dir_info: searchrec;

procedure init_xlat;
var x: byte;
begin
  fillchar (xlat, 256, 0);
  for x:=32 to 64 do
    xlat [x]:=x;
  for x:=65 to 90 do
    xlat [x]:=x+32;
  for x:=193 to 218 do
    xlat [x]:=x-128;
end;
 
procedure init_ts;
var t, s: byte;
    x: word;
begin
  x:=0;
  fillchar (ts, sizeof (ts), 255);
  for t:=1 to 17 do
    for s:=0 to 20 do
    begin
      ms [t]:=20;
      ts [t,s]:=x;
      inc (x);
    end;
  for t:=18 to 24 do
    for s:=0 to 18 do
    begin
      ms [t]:=18;
      ts [t,s]:=x;
      inc (x);
    end;
  for t:=25 to 30 do
    for s:=0 to 17 do
    begin
      ms [t]:=17;
      ts [t,s]:=x;
      inc (x);
    end;
  for t:=31 to 35 do
    for s:=0 to 16 do
    begin
      ms [t]:=16;
      ts [t,s]:=x;
      inc (x);
    end;
  dirlink [0]:=0;
  for s:=0 to 5 do
  begin
    dirlink [s+1]:=s*3+1;
    dirlink [s+7]:=s*3+2;
    dirlink [s+13]:=s*3+3;
  end;
end;

function leftadj (t: string; c: byte): string;
var s: string;
begin
  s:=t;
  while (length (s) < c) do  s:=s+' ';
  leftadj:=s;
end;

function intstr (n: longint): string;
var s: string;
begin
  str (n, s);
  intstr:=s;
end;

function upper (s: string): string;
var u: string;
    x: byte;
begin
  upper:=s;
  for x:=1 to length (s) do
    upper [x]:=upcase (s [x]);
end;

procedure write_ts (t, s: byte; b: blocktype);
var f: file;
    o: longint;
begin
  o:=ts [t,s];
  o:=o*256;
  assign (f, dir_info.name);
  reset (f, 1);
  seek (f, o);
  blockwrite (f, b, 256);
  close (f);
end;

procedure read_ts (t, s: byte; var b: blocktype);
var f: file;
    o: longint;
begin
  o:=ts [t,s];
  o:=o*256;
  assign (f, dir_info.name);
  reset (f, 1);
  seek (f, o);
  blockread (f, b, 256);
  close (f);
end;

function allocate_ts (t,s:byte): integer;
var f: file;
    e: integer;
    o: longint;
    b: blocktype;
begin
  e:=0;
  o:=ts [18,0];
  o:=o*256;
  assign (f, dir_info.name);
  reset (f, 1);
  seek (f, o);
  blockread (f, b, 256);
  if (b [t*$04+1+s div 8] and (1 shl (s mod 8)) = 0) then e:=-1 else
  begin
    b [t*$04+1+s div 8]:=b [t*$04+1+s div 8] and (255-(1 shl (s mod 8)));
    dec (b [t*$04]);
    seek (f, o);
    write_ts (18,0, b);
  end;
  close (f);
end;

function find_free (var t, s: byte): integer;
var f: file;
    b: blocktype;
    o: longint;
    e: integer;
begin
  t:=0;
  s:=0;
  e:=0;
  o:=ts [18,0];
  o:=o*256;
  assign (f, dir_info.name);
  reset (f, 1);
  seek (f, o);
  blockread (f, b, 256);
  close (f);
  t:=0;
  repeat
    inc (t);
    if (t=18) then inc (t);
    s:=255;
    repeat
      inc (s);
      if (b[t*$04+1+s div 8] and (1 shl (s and 7)) > 0) then e:=1;
{      write (t:3, s:3, b[t*$04+1+s div 8]:5);
      write (e:3);
      writeln;
      delay (50);
      e:=0;}
    until (s=ms [t]) or (e>0);
  until (t=35) or (e>0);
  find_free:=e-1;
end;

function find_last_free (var t, s: byte): integer;
var f: file;
    b: blocktype;
    o: longint;
    e: integer;
begin
  t:=0;
  s:=0;
  e:=0;
  o:=ts [18,0];
  o:=o*256;
  assign (f, dir_info.name);
  reset (f, 1);
  seek (f, o);
  blockread (f, b, 256);
  close (f);
  t:=36;
  repeat
    dec (t);
    if (t=18) then dec (t);
    s:=ms [t]+1;
    repeat
      dec (s);
      if (b[t*$04+1+s div 8] and (1 shl (s and 7)) > 0) then e:=1;
{      write (t:3, s:3, b[t*$04+1+s div 8]:5);
      write (e:3);
      writeln;
      delay (50);
      e:=0;}
    until (s=0) or (e>0);
  until (t=0) or (e>0);
  find_last_free:=e-1;
end;

function find_dir (var t,s,p: byte): integer;
var f: file;
    b: blocktype;
    o: longint;
    e: integer;
    x: byte;
begin
  e:=0;
  o:=ts [18,1];
  o:=o*256;
  assign (f, dir_info.name);
  reset (f, 1);
  x:=0;
  repeat
    inc (x);
    o:=ts [18,dirlink [x]];
    o:=o*256;
    seek (f, o);
    blockread (f, b, 256);
    p:=255;
    repeat
      inc (p);
      if (b [p*$20+$02]=$00) then e:=1;
    until (p=8) or (e=1);
  until (x=ms [18]) or (e=1);
  t:=18;
  s:=dirlink [x];
  close (f);
  find_dir:=e-1;
end;

function blocks_free: word;
var b: blocktype;
    x: word;
    f: word;
begin
  read_ts (18,0,b);
  f:=0;
  for x:=1 to 17 do
    inc (f, b [(x-1)*4+4]);
  for x:=19 to 35 do
    inc (f, b [(x-1)*4+4]);
  blocks_free:=f;
end;

procedure d64copy;
var t,s,t1,s1: byte;
    b: blocktype;
    d: searchrec;
    f: file;
    i,o: word;
    p: byte;
    e: array [0..31] of byte;
begin
  writeln ('Disk Image File: ', dir_info.name);
  writeln ('     ',blocks_free, ' blocks free.');
  findfirst (p2, archive, d);
  while (doserror=0) do
  begin
    write ('   ', d.name,' - ',round (d.size/254),' blocks... ');
    if (round (d.size/254)>blocks_free) then
    begin
      write (' Not enough disk space');
    end else
    begin
      if (find_dir (t,s,p)=0) then
      begin

      fillchar (e, sizeof (e), 0);
      fillchar (e[$05],16,$a0);
      e[$02]:=$82;
      if (find_last_free (t1,s1)=0) then
      begin
        e[$03]:=t1;
        e[$04]:=s1;
      end;
      for i:=1 to length (d.name) do
        e[$04+i]:=ord (upcase(d.name [i]));
      e[30]:=lo (round (d.size/254));
      e[31]:=hi (round (d.size/254));
      read_ts (t,s,b);
      move (e[2], b [p*$20+2], 30);
      write_ts (t,s,b);
      s1:=s;
      p:=0;
      repeat
        inc (p);
      until (dirlink[p]=s);
      dec (p);
      read_ts (t,dirlink [p],b);
      b[0]:=t;
      b[1]:=s1;
      write_ts (t,dirlink [p],b);

      assign (f, d.name);
      reset (f,1);
      repeat
        write ('o');
        blockread (f, b[2], 254, i);
        if (find_last_free (t,s) = 0) then
        begin
{          write (t:3,s:3);}
          t1:=allocate_ts (t,s);
          if (i = 254) then
          begin
            if (find_last_free (t1,s1)=0) then
            begin
              b [0]:=t1;
              b [1]:=s1;
            end;
          end else
          begin
            b [0]:=0;
            b [1]:=i+1;
          end;
          write_ts (t,s,b);
        end;
      until (i=0) or (i<254);

      end;
      close (f);
      write ('  Copied');
    end;
    writeln;
    findnext (d);
  end;
end;

begin
  init_xlat;
  init_ts;
  writeln;
  writeln ('Copy 2 D64 - Copy files to C64S .D64 image');
  if (paramcount = 0) then
  begin
    writeln ('Usage: COPY2D64 <.D64 file> <file>');
  end else
  begin
    p1:=paramstr (1);
    findfirst (p1, anyfile, dir_info);
    if (doserror = 0) then
    begin
      p2:=upper (paramstr (2));
      d64copy;
    end else
    begin
      writeln ('ERROR: Unable to find '+p1);
      writeln;
    end;
  end;
end.