program DtoD64;

{  Create 15x1 image file directly from 15x1 drive }
{  April 27, 1997  }

{$path "inc/"}
{$incl "lib/iec.lib"}

type block = array[0..255] of byte;
     track = record
               secs: byte;
               free: array[0..2] of byte
             end;
     entry = record
               fType,
               sT,
               sS: byte
             end;

var argsNG, fast, useBuffer, MSD, badType, mismatch: Boolean;
    bits, fill, typ: byte;
    devyce, buffernum, t, s, entryCount, offs, i, j: integer;
    option: string[8];
    outName: string[64];
    trkData: array[1..35] of track;
    im: file of block;
    VTOC, TrackBuffer: block;
    dirData: array[0..127] of entry;

function toBlk(trk, sec: integer): integer;
  var b: integer;
  begin
    if (trk < 1) or (trk > 35) or (sec > 20)
        then b := -1
      else if trk < 18
               then b := (trk - 1 ) * 21 + sec
      else if trk < 25
               then b := 357 + (trk - 18) * 19 + sec
      else if trk < 31
               then b := 490 + (trk - 25) * 18 + sec
      else b := 598 + (trk - 31) * 17 + sec;
    if b >= 683
        then toBlk := -1
      else toBlk := b
  end;

procedure readSector(t, s: integer);
  var ch: char;
      c, i: integer;
      command: string[16];
  begin
    Listen(devyce);
    Second(CMD_DATA + 15);
    command := 'U1: 2 0 ' + intstr(t) + ' ' + intstr(s);
    for i := 1 to length(command)
      do CIOut(command[i]);
    UnListen;
    Talk(devyce);
    TkSA(CMD_DATA + 2);
    c := 0;
    while IECBase^.iec_ST = ST_OK
      do begin
        TrackBuffer[c] := ord(ACPtr);
        c := c + 1
      end;
    UnTalk;
    writeln(#$9B, '1F', 'Reading: Track ', t, ', ', 'Sector ', s, '  ')
  end;

function freeTest(trk: integer): Boolean;
  var b: Boolean;
  begin
    b := true;
    if VTOC[4 + (trk - 1) * 4] = 0
        then b := false { This track has no free sectors }
      else if VTOC[5 + (trk - 1) * 4] = 0
                 then b := false; { Too lazy to search past sector 7 }
    freeTest := b
  end;

begin
  trkData[1].secs := 21;
  trkData[2].secs := 21;
  trkData[3].secs := 21;
  trkData[4].secs := 21;
  trkData[5].secs := 21;
  trkData[6].secs := 21;
  trkData[7].secs := 21;
  trkData[8].secs := 21;
  trkData[9].secs := 21;
  trkData[10].secs := 21;
  trkData[11].secs := 21;
  trkData[12].secs := 21;
  trkData[13].secs := 21;
  trkData[14].secs := 21;
  trkData[15].secs := 21;
  trkData[16].secs := 21;
  trkData[17].secs := 21;
  trkData[18].secs := 19;
  trkData[19].secs := 19;
  trkData[20].secs := 19;
  trkData[21].secs := 19;
  trkData[22].secs := 19;
  trkData[23].secs := 19;
  trkData[24].secs := 19;
  trkData[25].secs := 18;
  trkData[26].secs := 18;
  trkData[27].secs := 18;
  trkData[28].secs := 18;
  trkData[29].secs := 18;
  trkData[30].secs := 18;
  trkData[31].secs := 17;
  trkData[32].secs := 17;
  trkData[33].secs := 17;
  trkData[34].secs := 17;
  trkData[35].secs := 17;
  for i := 1 to 35
    do begin
      trkData[i].free[0] := $FF;
      trkData[i].free[1] := $FF;
      case trkData[i].secs of
        17: bits := $01;
        18: bits := $03;
        19: bits := $07;
        21: bits := $1F
      end;
      trkData[i].free[2] := bits
    end;
  argsNG := false;
  if (ParamCount < 1) or (ParamCount > 2)
      then argsNG := true
    else if ParamCount = 1
             then begin
               outName := ParamStr(1);
               fast := false
             end
    else begin
      outName := ParamStr(2);
      option := ParamStr(1);
      if option[1] <> '-'
          then argsNG := true
        else if UpCase(option[2]) <> 'F'
                 then argsNG := true
        else fast := true
    end;
  if argsNG
      then begin
        writeln('usage: DtoD64 [-f] filename');
        halt(20)
      end;
  OpenIEC;
  devyce := 8;
  { Open the command channel }
  Listen(devyce);        { OPEN 15,8,15 }
  Second(CMD_OPEN + 15);
  if IECBase^.iec_ST <> ST_OK
      then begin
        writeln('Device number ', devyce, ' not responding!')
        halt(20)
      end;
  { Reset the disk controller }
  CIOut('I');                { PRINT#15,"I" }
  UnListen;
  { Open the data channel and allocate a buffer in the 1541 memory }
  Listen(devyce);        { OPEN 2,8,2,"#" }
  Second(CMD_OPEN + 2);
  CIOut('#');
  UnListen;
  { Get the buffer number (unused) }
  Talk(devyce);        { GET #2,buffernum }
  TkSA(CMD_DATA + 2);
  buffernum := ord(ACPtr);
  UnTalk;
  { Open the D64 file to create }
  assign(im, outname + '.D64');
  rewrite(im);
  if fast
      then begin { copy only sectors in use }
        { Determine current formatting }
        writeln('Reading VTOC...');
        writeln;
        readSector(18, 0);
        VTOC := TrackBuffer;
        t := 1;
        useBuffer := freeTest(t);
        if not useBuffer
            then begin
              t := 35;
              useBuffer := freeTest(t)
            end;
        if useBuffer
            then begin
              writeln('Searching for unused sector...');
              writeln;
              bits := VTOC[5 + (t - 1) * 4];
              i := 8;
              repeat
                i := i - 1
              until bits and (1 shl i) <> 0;
              readSector(t, 7 - i);
              fill := TrackBuffer[1] + TrackBuffer[2] + TrackBuffer[3];
              if fill = 0
                  then begin { Found MSD formatting signature }
                    useBuffer := true;
                    MSD := true
                  end
                else if fill = 3
                         then begin { Found 1541 formatting signature }
                           useBuffer := true;
                           MSD := false
                         end
                else useBuffer := false;
            end
        { Create empty image file }
        writeln('Creating empty ''', outName, '.D64''...');
        if not useBuffer
            then begin
              TrackBuffer[0] := $00;
              for i := 1 to 255
                do TrackBuffer[i] := $01;
              MSD := false
            end;
        for i := 0 to 682
          do begin
            if not MSD and (i = 21)
                 then TrackBuffer[0] := $4B;
            write(im, TrackBuffer)
          end;
        writeln('Writing VTOC...');
        seek(im, toBlk(18, 0));
        write(im, VTOC);
        { Copy directory to image }
        writeln('Copying directory...');
        writeln;
        t := VTOC[0];
        s := VTOC[1];
        entryCount := 0;
        while t <> 0
          do begin
            readSector(t, s);
            seek(im, toBlk(t, s));
            write(im, TrackBuffer);
            t := TrackBuffer[0];
            s := TrackBuffer[1];
            badType := false;
            for i := 0 to 7
              do begin
                offs := i * 32;
                typ := TrackBuffer[offs + 2];
                if not (typ in [$00, $80..$82, $C0..$C2])
                    then badType := true;
                dirData[entryCount].fType := typ;
                dirData[entryCount].sT := TrackBuffer[offs + 3];
                dirData[entryCount].sS := TrackBuffer[offs + 4];
                entryCount := entryCount + 1
              end
          end;
        if badType
             then begin
               writeln;
               writeln('Found invalid file type!');
               writeln('Repair diskette or omit ''-f'' option')
             end
          else begin { Copy files to image }
            writeln('Copying files...');
            writeln;
            for i := 0 to entryCount - 1
              do begin
                typ := dirData[i].fType;
                if (typ = $81) or (typ = $82) or (typ = $C1) or (typ = $C2)
                    then begin
                      t := dirData[i].sT;
                      s := dirData[i].sS;
                      while t <> 0
                        do begin
                          readSector(t, s);
                          seek(im, toBlk(t, s));
                          write(im, TrackBuffer);
                          trkData[t].secs := trkData[t].secs - 1;
                          j := s div 8;
                          trkData[t].free[j] := trkData[t].free[j]
                                                 xor (1 shl (s mod 8));
                          t := TrackBuffer[0];
                          s := TrackBuffer[1]
                        end;
                    end
              end
            mismatch := false;
            for i := 1 to 17
              do if trkData[i].secs <> VTOC[4 + (i - 1) * 4]
                     then mismatch := true
                   else for j := 0 to 2
                          do if trkData[i].free[j] <> VTOC[5 + (i - 1) * 4 + j]
                                 then mismatch := true;
            for i := 19 to 35
              do if trkData[i].secs <> VTOC[4 + (i - 1) * 4]
                     then mismatch := true
                   else for j := 0 to 2
                          do if trkData[i].free[j] <> VTOC[5 + (i - 1) * 4 + j]
                                 then mismatch := true;
          end { Copy files to image }
      end { copy only sectors in use }
    else begin { copy all sectors }
      writeln;
      for t := 1 to 35
        do for s := 0 to trkData[t].secs - 1
             do begin
               readSector(t, s);
               write(im, TrackBuffer)
             end
    end; { copy all sectors }
  close(im);
  Listen(devyce);        { Close 2 }
  Second(CMD_CLOSE + 2);
  UnListen;
  Listen(devyce);        { Close 15 }
  Second(CMD_CLOSE + 15);
  UnListen;
  writeln;
  if fast and mismatch
      then writeln('Space occupied by source diskette files does not match original VTOC')
end.