{*****************************************************************************}
{                             T E L E C A R D . PAS                           }
{*****************************************************************************}
{   This program enable you to dumb the memory of electronics phonecards      }
{   from all over the world, so that you will be able to see which country    }
{   the card is from how many units are left and so on ....                   }
{*****************************************************************************}
{                                                                             }
{                        Written by Stephane BAUSSON (1993)                   }
{                                                                             }
{                         Email: sbausson@ensem.u-nancy.fr                    }
{                                                                             }
{                       Snail Mail Address: 4, Rue de Grand                   }
{                                           F-88630 CHERMISEY                 }
{                                           France                            }
{                                                                             }
{*****************************************************************************}
{* Thanks to: Tomi Engdahl (Tomi.Engdahl@hut.fi)                             *}
{*****************************************************************************}

USES crt,dos;

CONST port_address=$378;     { lpr1 chosen }

TYPE string8=string[8];
     string2=string[2];

VAR reg         : registers;
    i,j         : integer;
    Data        : array[1..32] of byte;
    car         : char;
    byte_number : integer;
    displaying  : char;

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

PROCEDURE Send(b:byte);

  BEGIN port[port_address]:=b;
  END;

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

FUNCTION Get:byte;

  BEGIN get:=port[port_address+1];
  END;

{-----------------------------------------------------------------------------}
{ FUNCTION dec2hexa_one(decimal_value):hexa_character_representation;         }
{                                                                             }
{       - convert a 4 bit long decimal number to hexadecimal.                 }
{-----------------------------------------------------------------------------}

FUNCTION dec2hexa_one(value:byte):char;

  BEGIN case value of
          0..9   : dec2hexa_one:=chr(value+$30);
          10..15 : dec2hexa_one:=chr(value+$37);
        END;
  END;

{-----------------------------------------------------------------------------}
{ FUNCTION d2h(decimal_byte):string2;                                         }
{                                                                             }
{       - convert a decimal byte to its hexadecimal representation.           }
{-----------------------------------------------------------------------------}

FUNCTION d2h(value:byte):string2;

  VAR msbb,lsbb:byte;

  BEGIN msbb:=0;
        if ( value >= $80 ) then
        BEGIN msbb:=msbb+8;
              value:=value-$80;
        END;
        if ( value >= $40 ) then
        BEGIN msbb:=msbb+4;
              value:=value-$40;
        END;
        if ( value >= $20 ) then
        BEGIN msbb:=msbb+2;
              value:=value-$20;
        END;
        if ( value >= $10 ) then
        BEGIN msbb:=msbb+1;
              value:=value-$10;
        END;

        lsbb:=0;
        if ( value >= $08 ) then
        BEGIN lsbb:=lsbb+8;
              value:=value-$08;
        END;
        if ( value >= $04 ) then
        BEGIN lsbb:=lsbb+4;
              value:=value-$04;
        END;
        if ( value >= $02 ) then
        BEGIN lsbb:=lsbb+2;
              value:=value-$02;
        END;
        if ( value >= $01 ) then
        BEGIN lsbb:=lsbb+1;
              value:=value-$01;
        END;
        d2h := dec2hexa_one(msbb) + dec2hexa_one(lsbb);
  END;

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

Function Binary( b : byte):string8;

  var weigth : byte;
      s      : string8;

  BEGIN weigth:=$80;
        s:='';
        while (weigth > 0) do
        BEGIN if ((b and weigth) = weigth) then s:=s+'1'
              else s:=s+'0';
              weigth:=weigth div $02;
        END;
        Binary:=s;
  END;

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

FUNCTION Units:byte;

  VAR  u, i : integer;
       s    : string8;

  BEGIN u:=0;
        i:=13;
        while (Data[i] = $FF) do
        BEGIN u:=u+8;
              i:=i+1;
        END;
        s:=Binary(Data[i]);
        while(s[1]='1') do
              BEGIN inc(u);
              s:=copy(s,2,length(s));
        END;
        units:=u;
  END;

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

function Units_2:LongInt;

  BEGIN Units_2:=4096*Data[9]+512*Data[10]+64*Data[11]+8*Data[12]+Data[13];
  END;

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

PROCEDURE Card_Type;

  BEGIN case Data[2] of
         $03: BEGIN write('Telecard - France - ');
                    case Data[12] of
                     $13: write('120 Units - ',units-130,' Units left');
                     $06: write('50 Units - ',units-60,' Units left');
                     $15: write('40 Units - ',units-40,' Units left');
                    END;
              END;
         $2F:BEGIN write('Telecard - Germany - ', Units_2, ' Units left');
             END;
         $3B:BEGIN write('Telecard - Greece - ', Units_2, ' Units left');
             END;
         $83:BEGIN write('Telecard');
                   case Data[12] of
                     $1E: write(' - Sweden');
                     $30: write(' - Norway');
                     $33: write(' - Andorra');
                     $3C: write(' - Ireland');
                     $47: write(' - Portugal');
                     $55: write(' - Czech Republic');
                     $5F: write(' - Gabon');
                     $65: write(' - Finland');
                   END;
                   if (Data[12] in [$30,$33,$3C,$47,$55,$65]) then
                   BEGIN case ((Data[3] and $0F)*$100+Data[4]) of
                          $012: write (' - 10 Units - ',units-12,' Units left');
                          $024: write (' - 22 Units - ',units-24,' Units left');
                          $027: write (' - 25 Units - ',units-27,' Units left');
                          $032: write (' - 30 Units - ',units-32,' Units left');
                          $052: write (' - 50 Units - ',units-52,' Units left');
                          $067: write (' - 65 Units - ',units-62,' Units left');
                          $070: write (' - 70 Units - ',units-70,' Units left');
                          $102: write (' - 100 Units - ',units-102,' Units left');
                          $152: write (' - 150 Units -  ',units-152,' Units left');
                         END;
                    END;
{                    write(' - N° ',Data[5]*$100+Data[6]);}
              END;
        END;
  END;

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

PROCEDURE waiting;

  BEGIN send($00);
        write('Enter a card in the reader and press a key ...');
        repeat until keypressed;
        gotoxy(1, wherey);
        clreol;
  END;

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

PROCEDURE Full_Displaying;

  BEGIN writeln('Memory dump:');
        for i:=1 to 80 do write('-');
        for i:=1 to (byte_number div 6 + 1) do
        BEGIN for j:=1 to 6 do
              BEGIN if j+6*(i-1) <= byte_number then write(binary(Data[j+6*(i-1)]):9);
              END;
              gotoxy(60,wherey);
              for j:=1 to 6 do
              if j+6*(i-1) <= byte_number then write(d2h(Data[j+6*(i-1)]),' ');
              writeln;
        END;
        for i:=1 to 80 do write('-');
        Card_Type;
        writeln;
  END;

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

PROCEDURE Short_Displaying;

  VAR j : integer;

  BEGIN for j:=1 to byte_number do
        BEGIN write(d2h(Data[j]),' ');
        END;
        writeln;
  END;

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

PROCEDURE Reading;

  VAR i, j  : integer;
      Value : byte;

  BEGIN send($FE);
        send($F8);
        for i:=1 to 32 do
        BEGIN Value:=0;
              for j:=1 to 8 do
              BEGIN Value:=Value*$02 + ((get and $08) div $08);
                    send($FB);
                    delay(1);
                    send($F8);
              END;
              Data[i]:=Value;
        END;
        case displaying of
          'F':full_displaying;
          'S':short_displaying;
        END;
  END;

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

PROCEDURE writting;

  VAR i,n:integer;
      car:char;

  BEGIN write('Which bit do you want to set to "1" : ');
        readln(n);

        waiting;
        car:=readkey;

        send($FA);
        send($F8);
        for i:=1 to n do
        BEGIN send($F9);
              if i=n then
              BEGIN send($FD);
                    delay(20);
                    send($FF);
                    delay(20);
              END;
              send($FB);
        END;
        reading;
  END;

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

PROCEDURE Saving;

  VAR filename : string;
      f        : text;
      i        : word;

  BEGIN write('Enter the filename: ');
        readln(filename);
        assign(f, filename);
        rewrite(f);
        for i:=1 to byte_number do write(f,d2h(Data[i]),' ');
        close(f);
  END;

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

PROCEDURE initialize;

  VAR i : integer;

  BEGIN byte_number:=32;
        displaying:='F';
        clrscr;
        writeln(' 1 - to dump a 256 bits card');
        writeln(' 2 - to dump a 128 bits card');
        writeln(' F - to display in full format');
        window(41,1,80,25);
        writeln(' S  - to display in short format');
        writeln(' F2 - to save in a file');
        writeln(' Q  - to exit the program');
        window(1,4,80,25);
        for i:=1 to 80 do write('=');
        window(1,5,80,25);
  END;

{=============================================================================}

BEGIN initialize;
      repeat waiting;
             car:=upcase(readkey);
             case car of
              'W':writting;
              'Q':;
              '1':byte_number:=32;
              '2':byte_number:=16;
              'F','S':displaying:=car;
              #00: BEGIN car:=readkey;
                         if car=#60 then saving;
                   END;
              else reading;
             END;
      until car='Q';
END.