Program CIP1;
Uses Dos,U2580V10,UimagVaa,crt;
Type Pficsedo = ^Tficsedo;
     Tficsedo = record
      nom     : string[13];
      piste   : byte;
      secteur : byte;
      face    : byte;
      taille  : word;
      protege : boolean;
      next    : Pficsedo;
      numero  : word;
     end;

Const Titre  = '         Convert Image to PC V 1.0          Robert Cheramy 1997';
      LgnBas = 'Q:Quitter    E:avec Entete    S:Sans entete    R:Relit    I:file Info';

Var Maxfiles   : longint;
    E_Ficcour  : longint; {Fichier courrant … l'‚cran.}
    F_ficcour  : longint; {Numero de fichier courant. }
    Drive      : file;
    I          : word;
    K,S        : char;
    Erreur     : Word;
    Current,
    First,
    Last       : Pficsedo;
    P_heap     : pointer;

    Sauvesortie :pointer;
    M           : integer;
    lit         : array[1..8] of byte;
    Titre2      :string;


label recommence;


{***************************************}
function WhatMax:longint;
  {charge les coordon‚es (directory) des fichiers dans les pficsedo
   et renvoie le nombre de fichiers.}
Var J,
    K,
    secteur,
    piste,
    face       : byte;

Begin
 Mark(P_heap);

 New(First);
 First^.next:=NIL;
 First^.numero:=0;
 current:=First;

 Piste:=20;
 secteur:=4;
 face:=0;

 Repeat
   Read256(drive,piste,secteur,face);
   If Erreur<>0 then begin Erreur:=0; Exit; End;
   J:=1;

   While ( ((J<=$F) and(buf256[2]=0)) or (J<buf256[2] shr 4)) do
     Begin
       New(current^.next);
       I:=current^.numero+1;
       current:=current^.next;
       current^.numero:=I;

       current^.nom:='';
        For K:=0 to 8 do
         current^.nom:=current^.nom+chr(buf256[J shl 4+K]);
        current^.nom:=current^.nom+'.';
        For K:=9 to $B do
         current^.nom:=current^.nom+chr(buf256[J shl 4+K]);
       current^.piste   := buf256[J shl 4+$C] and $7F;
       current^.secteur := buf256[J shl 4+$D];
       current^.face    := buf256[J shl 4+$C] shr 7;
       current^.taille  := buf256[J shl 4+$E] +(buf256[J shl 4+$F]and $3F) shl 8;
       current^.protege := (buf256[J shl 4+$F] and $80 = $80);
       current^.next    := NIL;

       J:=J+1;
     End; {While}

   piste  := buf256[0] and $7F;
   secteur:= buf256[1];
   face   := buf256[0] shr 7;
 Until ((piste=0) and (face=0) and (secteur =0));

 first:=first^.next;
 last:=current;
 Whatmax:=last^.numero;

end; {Whatmax}



{***************************************}
Function Min(A,B:longint):longint;
Begin
 If A <= B then min:=A else min:=B;
End;


{***************************************}
Function Max(A,B:longint):longint;
Begin
 If A >= B then max:=A else max:=B;
End;


{***************************************}
Procedure surligne(numero:byte);
Begin
 invligne(1+((numero-1) mod 23),(((numero-1) div 23)*20),19+(((numero-1) div 23)*20));
End;


{***************************************}
Procedure affiche(fictablini, fictablfin:byte);
Var I             : word;
    Taille,Prot,T : string;
Begin
 Cls;

 Current:=first;
 While Current^.numero <> fictablini do current:=current^.next;

 For I:=fictablini to fictablfin do
 begin
  Str(current^.taille,Taille);
  Case length(Taille) of
   1 : Taille:='  '+Taille;
   2 : Taille:=' '+Taille;
  End;
  If Current^.Protege=true then Prot:='P' else Prot:=' ';
  putstr(((I-fictablini)mod 23)+1,((I-fictablini) div 23)*20+1,current^.nom+' '+taille+Prot,normal);
  Current:=current^.next;
 End;
 Putstr(0,0,titre2,normal);
 Putstr(24,0,lgnbas,normal);
end;


{***************************************}
Procedure Haut;
Begin
 If E_ficcour=1 then
  If F_ficcour<>1 then
   begin
    F_ficcour:=F_ficcour-1;
    affiche(F_ficcour,min(F_ficcour+91,maxfiles));
    Surligne(E_ficcour);
   end else

 Else begin  {E_ficcour >1}
  F_ficcour:=F_ficcour-1;
  Surligne(E_ficcour);
  E_ficcour:=E_ficcour-1;
  Surligne(E_ficcour);
 End;
End;


{***************************************}
Procedure Bas;
Begin
 If F_ficcour<maxfiles then
  If E_ficcour= 92 then
   begin
    F_ficcour:=F_ficcour+1;
    affiche(F_ficcour-91,F_ficcour);
    Surligne(E_ficcour);
   end  {E_ficcour=92}
 Else begin {E_ficcour<92}
  F_ficcour:=F_ficcour+1;
  Surligne(E_ficcour);
  E_ficcour:=E_ficcour+1;
  Surligne(E_ficcour);
 End; {E_ficcour<92}
End; {Bas}


{***************************************}
Function ficdest : string;
Var I  : word;
    st : string;
begin
 clrlgn(24);
 Current:=First;
 While current^.numero <> F_ficcour do current:=current^.next;
 putstr(24,0,'Veuillez entrer un fichier destination ('+current^.nom+' par d‚faut)',normal);
 clrlgn(0);
 gotoxy(1,1);
 curson;
 readln(st);
 cursoff;
 if st='' then
 begin
  for I:=1 to 8 do st:=st+current^.nom[I];
  for I:=10 to 13 do st:=st+current^.nom[I];
 end;
 ficdest:=st;
end;


{***************************************}
Procedure Sans;
Var I,J      : word;
    f        : file;
    Nomfic   : string;
    descript : T256;
    P,S,Fa   : byte;
    Ficlong  : longint;

Begin;
 Nomfic:=ficdest;
 Assign(f,nomfic);
 Rewrite(f,1);

 Current:=First;
 While current^.numero <> F_ficcour do current:=current^.next;

 P:=current^.piste;
 S:=current^.secteur;
 Fa:=current^.face;
 Repeat
  read256(drive,P,S,Fa);
  If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
  descript:=buf256;
  I:=buf256[5]*256+buf256[4];
  J:=buf256[7]*256+buf256[6];
  ficlong:=J-I+1;
  i:=$c;
  For J:=1 to (ficlong div 256) do
  Begin
   if i>$ff then
   begin
    i:=2;
    read256(drive,descript[0] and $7f,descript[1],descript[0] shr 7);
    If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
    descript:=buf256;
   end;
   read256(drive,descript[i] and $7f,descript[i+1],descript[I] shr 7);
   If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
   blockwrite(f,buf256,256);
   i:=i+2;
  End;
  If ficlong mod 256 <> 0 then
  begin
   read256(drive,descript[i] and $7f,descript[i+1],descript[I] shr 7);
   If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
   blockwrite(f,buf256,ficlong mod 256);
  end;
  P:=descript[0] and $7f;
  S:=descript[1];
  Fa:=descript[0] shr 7;
 until (descript[0]=0) and (descript[1]=0);
 Close(f);
 clrlgn(0);
 clrlgn(24);
 Putstr(0,0,titre2,normal);
 Putstr(24,0,lgnbas,normal);
End;



{***************************************}
Procedure Entete;
Var I,J      : word;
    f        : file;
    Nomfic   : string;
    descript : T256;
    P,S,Fa   : byte;
    Ficlong  : longint;
    ent      : array [1..26] of byte;
    R        : DirStr;
    N        : NameStr;
    E        : Extstr;

Begin;
 Nomfic:=ficdest;
 Assign(f,nomfic);
 Rewrite(f,1);
 Current:=First;
 While current^.numero <> F_ficcour do current:=current^.next;
 P:=current^.piste;
 S:=current^.secteur;
 Fa:=current^.face;
 Repeat
  read256(drive,P,S,Fa);
  If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
  descript:=buf256;
  I:=buf256[5]*256+buf256[4];
  J:=buf256[7]*256+buf256[6];
  ficlong:=J-I+1;

  For I:=1 to 3 do ent[I]:=$16;
  ent[4]:=$24;
  ent[5]:=0;
  ent[6]:=0;
  if (descript[3] = $80) or (descript[3]=$81) then ent[7]:=0 else ent[7]:=$80;
  ent[8]:=0;
  ent[9]:=descript[7];
  ent[10]:=descript[6];
  ent[11]:=descript[5];
  ent[12]:=descript[4];
  ent[13]:=0;
  FSplit(nomfic,R,N,E);
  R:=N+E;
  For I:=1 to length(R) do ent[13+I]:=ord(R[I]);
  ent[14+length(R)]:=0;
  blockwrite(f,ent,14+length(R));

  i:=$c;
  For J:=1 to (ficlong div 256) do
  Begin
   if i>$ff then
   begin
    i:=2;
    read256(drive,descript[0] and $7f,descript[1],descript[0] shr 7);
    If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
    descript:=buf256;
   end;
   read256(drive,descript[i] and $7f,descript[i+1],descript[I] shr 7);
   If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
   blockwrite(f,buf256,256);
   i:=i+2;
  End;
  If ficlong mod 256 <> 0 then
  begin
   read256(drive,descript[i] and $7f,descript[i+1],descript[I] shr 7);
   If Erreur<>0 then begin Erreur:=0; Close(f); Exit; End;
   blockwrite(f,buf256,ficlong mod 256);
  end;
  P:=descript[0] and $7f;
  S:=descript[1];
  Fa:=descript[0] shr 7;
 until (descript[0]=0) and (descript[1]=0);
 Close(f);
 clrlgn(0);
 clrlgn(24);
 Putstr(0,0,titre2,normal);
 Putstr(24,0,lgnbas,normal);
End;

{***************************************}
Procedure Driv;
Const mask : array[1..8] of byte = (77,70,77,95,68,73,83,75);
Var   st : string;
      ar : array[1..8] of byte;
      i,j  : word;
      recom : boolean;

Begin
 Clrlgn(24);
 Putstr(24,0,'Veuillez entrer un nom de fichier MFM_DISK',bleu);
 Repeat
  clrlgn(0);
  gotoxy(1,1);
  curson;
  readln(st);
  cursoff;
  {$I-}
  close(drive);
  i:=IOResult;
  assign(drive,st);
  reset(drive);
  {$I+}
  If IOResult <> 0 then
   begin
    Clrlgn(24);
    Putstr(24,0,'Fichier inexistant. Veuillez entrer un nom de fichier MFM_DISK',bleu);
    recom:=true;
   end
  else
   begin
    blockread(drive,ar,8,j);
    i:=0;
    repeat i:=i+1 until ((not(ar[i]=mask[i])) or (i = 9));
    if (i<>9) or (j <>8) then
   begin
      Close(drive);
      Putstr(24,0,'Fichier nom MFM_DISK. Veuillez entrer un nom de fichier MFM_DISK',bleu);
      recom:=true;
     end
    else recom:= false;
   end;
 until recom=false;
 clrlgn(0);
 clrlgn(24);
 Putstr(0,0,titre2,normal);
 Putstr(24,0,lgnbas,normal);
end; {Procedure Driv}

{***************************************}
Procedure gauche;
Var I:word;
Begin
 For I:=1 to 23 do haut;
End;

Procedure droite;
Var I:word;
Begin
 For I:=1 to 23 do bas;
End;


{***************************************}
{$F+}
Procedure MonErreur(Face,Piste,Secteur:byte);  {$F-}
Var F,P,S : string;
    K     : Char;
Begin
 Clrlgn(0);
 str(face,F);
 str(Piste,P);
 str(Secteur,s);
 Gotoxy(45,1);
 curson;
 Putstr(0,0,'Erreur de lecture Face '+F+' Piste '+P+' Secteur '+ S,normal);
 Clrlgn(24);
 Putstr(24,0,' I:Ignorer     A:Abandonner     Q:Quitter',normal);
 Repeat
  K:=Upcase(Readkey);
  Case K of
   'A' : Erreur:=1;
   'Q' : begin Cls; Gotoxy(1,1);
       Writeln('Remember, this Program is Cardware. Write to rcheramy@mail.dotcom.fr');
       Writeln('A bientot...'); Curson; Halt; End;
   'I' : Erreur:=0;
   End;
 Until (K='I') or (K='A');
 Cursoff;
 Putstr(24,0,lgnbas,normal);
 Putstr(0,0,titre2,normal);
End;


{***************************************}
Procedure Info;
Var K       : char;
    S,Hex,H : string;
    N,I     : word;
    P,Se,F  : byte;
    Sortir  :boolean;
Begin
 Current:=First;
 While current^.numero <> F_ficcour do current:=current^.next;
 P:=current^.piste;
 Se:=current^.secteur;
 F:=current^.face;
 Repeat
  Read256(Drive,P,Se,F);
  If Erreur<>0 then begin Erreur:=0; Exit; End;
  Clrlgn(0);

  N:=buf256[5]*256+buf256[4];
  Hex:=tohexstr(N);
  H:=Hex;
  For I:=3 downto length(Hex) do H:='0'+H;
  S:=H+' ';

  N:=buf256[7]*256+buf256[6];
  Hex:=tohexstr(N);
  H:=Hex;
  For I:=3 downto length(Hex) do H:='0'+H;
  S:=S+H+' ';

  N:=buf256[3];
  Hex:=tohexstr(N);
  H:=Hex;
  For I:=1 downto length(Hex) do H:='0'+H;
  S:=S+H+' ';

  N:=buf256[9]*256+buf256[8];
  Hex:=tohexstr(N);
  H:=Hex;
  For N:=3 downto length(Hex) do H:='0'+H;
  S:=S+H;

  Putstr(0,5,S,normal);
  Clrlgn(24);
  Putstr(24,0,'Appuyez sur une touche...',normal);


  While ((buf256[0]<>0) or (buf256[1]<>0)) and ((buf256[$FE]<>0) or (buf256[$FF]<>0)) do
   Read256(drive,buf256[0] and $7f,buf256[1],buf256[0] shr 7);


  If (buf256[0]<>0) or (buf256[1]<>0) then
  begin
   Putstr(0,25,'Fichier merg‚. Appuyez sur ''M'' pour les autres infos',normal);
   P:=buf256[0] and $7F;
   Se:=buf256[1];
   F:=buf256[0] shr 7;
   K:=readkey;
   If upcase(K)='M' then Sortir:=false else Sortir:=true;
   If K=#0 then K:=readkey;
  end
  else
  begin
   Sortir:=true;
   K:=readkey;
   If K=#0 then K:=readkey;
  end;
 Until Sortir;
 Putstr(0,0,titre2,normal);
 Putstr(24,0,lgnbas,normal);
End;


{********** Exit proc **********}
{$F+}
Procedure Masortie; {$F-}
Begin
{$I-}
close(drive);
{$I+}
Exitproc:=sauvesortie;
End; {exit proc}


{********** Programme Principal **********}

Begin
 Writeln('CIP V 1.0 par R. CHERAMY (Email: rcheramy@mail.dotcom.fr)');
 Writeln;
 Writeln('USAGE: CIP MFM_DISK_file_name');

 Erreur:=0;
 sauvesortie:=Exitproc;
 Exitproc:=@Masortie;
 Errorproc:=Monerreur;
 {$I-}
 Assign(drive,paramstr(1));
 reset(drive,1);
 {$I+}
 If (IOResult<>0) or (paramstr(1)='') then
  begin
   writeln('File does not exist');
   halt;
  end;
 Blockread(drive,lit,8,m);
 If (m<>8) or (not((lit[1]=77) and (lit[2]=70) and (lit[3]=77) and (lit[4]=95))) then
  begin
   writeln('File is not a MFM_DISK');
   halt;
  end;
{ Cursoff;
Cls;}

Recommence:
 Cursoff;
 Cls;
 Maxfiles:=Whatmax;
 str(maxfiles,titre2);
 While length(titre2)<4 do titre2:=' '+titre2;
 titre2:=titre2+' fichiers'+titre;
 If Maxfiles=0 then
 Begin
  putstr(1,1,'No files in disk',normal);
  Putstr(0,0,titre2,normal);
  Putstr(24,0,'Q:Quitter',normal);
  Repeat
   K:=upcase(readkey);
{  Case K of
   'D' : begin Driv; goto recommence; end;
   'R' : goto recommence;
  end;}
  Until K='Q';
  Cls;
  Gotoxy(1,1);
  Writeln('Remember, this Program is Cardware. Write to rcheramy@mail.dotcom.fr');
  Writeln('A bientot...');
  Curson;
  Halt;
 End;

 Affiche(1,min(92,maxfiles));
 Surligne(1);
 E_ficcour := 1;
 F_ficcour := 1;
 Repeat
  K:=upcase(readkey);
  Case K of
   #0:begin
    S:=readkey;
    Case ord(S) of
     72: haut;
     75: gauche;
     77: droite;
     80: bas;
    end;
    end;
{   'D'  : begin Driv; goto recommence; end;}
   'E'  : entete;
   'S'  : sans;
   'R'  : goto recommence;
   'I'  : info;
   end;
 Until K='Q';
 Cls;
 Gotoxy(1,1);
 Writeln('Remember, this Program is Cardware. Write to rcheramy@mail.dotcom.fr');
 Writeln('A bient“t...');
 curson;
end.