program BImage;
{  Copy disk in drive 1 to file in RAMDisk  }
{  June 2, 1994  }

type mem = array[0..16383] of char;

var match: boolean;
    high, low, ch: char;
    first, second, size, i, j: integer;
    image: file of char;
    buff: mem;

procedure GetTrack(t: integer; var b: mem);
  begin
#A
;
;
;
PTR     EQU     _T+2
LEN     EQU     _T+4
;
;       ROM routine
;
DELAY   EQU     $FCA8
;
;       Disk I/O selects
;
DRVSM0  EQU     $C080
DRVSM1  EQU     $C081
DRVSM2  EQU     $C082
DRVSM4  EQU     $C084
DRVSM6  EQU     $C086
DRVOFF  EQU     $C088
DRVON   EQU     $C089
DRVSL1  EQU     $C08A
DRVRD   EQU     $C08C
DRVRDM  EQU     $C08E
;
;       Get pointer to buffer
;
        LDY     #5
        LDA     (_SP),Y
        STA     PTR
        INY
        LDA     (_SP),Y
        STA     PTR+1
;
;       Get track number
;
        INY
        LDA     (_SP),Y
        STA     TRACK
;
;
;
        JMP     START
;
;       Work areas
;
TRACK   DB      $00
UNITNUM DB      $60
SLOT    DB      $60
DESTRK  DB      $00
CURTRK  DB      $00
DELTA   DB      $00
FLAG    DB      $00
;
;
;
RECALC  LDA     #$30
        STA     CURTRK
        LDA     #$00
        STA     DESTRK
        JSR     ARMOVE
        LDX     SLOT
        LDA     DRVSM0,X
        LDA     DRVSM2,X
        LDA     DRVSM4,X
        LDA     DRVSM6,X
        RTS
;
;
;
ARMOVE  LDA     #$00
        STA     FLAG
        LDA     CURTRK
        CLB
        SBB     DESTRK
        BE      DONE
        BNB     OK
        EOR     #$FF
        ADC     #1
OK      STA     DELTA
        ROL     FLAG
        LSR     CURTRK
        ROL     FLAG
        ASL     FLAG
        LDY     FLAG
LOOP    LDA     TABLE,Y
        JSR     PHASE
        LDA     TABLE+1,Y
        JSR     PHASE
        TYA
        EOR     #$02
        TAY
        DEC     DELTA
        LDA     DELTA
        BNE     LOOP
        LDA     DESTRK
        STA     CURTRK
DONE    RTS
;
;
;
PHASE   ORA     SLOT
        TAX
        LDA     DRVSM1,X
        JSR     WAIT
        LDA     DRVSM0,X
        RTS
;
;
;
WAIT    LDA     #$56
        JSR     DELAY
        RTS
;
;
;
TABLE   DB      $02,$04,$06,$00
        DB      $06,$04,$02,$00
;
;
;
START   LDA     UNITNUM
        PHA
        AND     #$70
        STA     SLOT
        TAX
        PLA
        BNM     DRIVE1
        INX
DRIVE1  LDA     DRVSL1,X
        LDX     SLOT
        LDA     DRVON,X
        LDA     DRVRDM,X
        JSR     RECALC
        LDA     TRACK
        STA     DESTRK
        JSR     ARMOVE
;
;       Set page count
;
        LDA     #64
        STA     LEN
;
;
;
        LDY     #0
;
;
;
        LDX     SLOT
LOOP1   LDA     DRVRD,X
        BNM     LOOP1
        CMP     #$FF
        BNE     LOOP1
LOOP2   LDA     DRVRD,X
        BNM     LOOP2
        CMP     #$FF
        BNE     LOOP1
LOOP3   LDA     DRVRD,X
        BNM     LOOP3
        CMP     #$FF
        BE      LOOP3
        BNE     LOOP4
;
;
;
LOOPD   LDA     DRVRD,X
        BNM     LOOPD
;
;
;
LOOP4   STA     (PTR),Y
;
;       Increment low byte of pointer
;
        INC     PTR
        BNE     LOOPD
        INC     PTR+1
;
;       Decrement page count
;
        DEC     LEN
        BNZ     LOOPD
;
;       Turn motor off
;
        LDX     SLOT
        LDA     DRVOFF,X
#
  end;

function FindAddrField(p: integer): integer;
  var found: boolean;
      i: integer;
  begin
    i := p;
    found := false;
    repeat
      if ord(buff[i]) = 213 {$D5}
          then if ord(buff[i + 1]) = 170 {$AA}
                   then if ord(buff[i + 2]) = 150 {$96}
                            then if ord(buff[i + 11]) = 222 {$DE}
                                     then if ord(buff[i + 12]) = 170 {$AA}
                                              then found := true;
      if not found
          then i := i + 1
    until found;
    FindAddrField := i
  end;

begin
  writeln('Source disk in drive 1');
  writeln('Output file will be on "/R"');
  writeln('Ready? ');
  readln(ch);
  rewrite(image, '/R/BITIMAGE');
  for i := 0 to 34
    do begin
writeln('Begin reading track ',i);
      GetTrack(i, buff);
{
writeln('Done');
}
      first := FindAddrField(2);
      second := FindAddrField(first + 5502);
      repeat
        match := true;
        j := 2;
        repeat
          j := j + 1;
          match := buff[first + j] = buff[second + j]
        until not match or (j = 10);
        if not match
            then second := FindAddrField(second + 1)
      until match;
      size := second - first;
      writeln(size);
      high := chr(size div 256);
      low := chr(size mod 256);
      buff[first - 2] := low;
      buff[first - 1] := high;
      buff[second] := low;
      buff[second + 1] := high;
      for j := first - 2 to second + 1
        do write(image, buff[j])
    end
end.