unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    Timer1: TTimer;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure CheckBox2Click(Sender: TObject);
    procedure CheckBox3Click(Sender: TObject);
    procedure CheckBox4Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

 function Inp32(PortAdr: word): byte; stdcall; external 'inpout32.dll';
 function Out32(PortAdr: word; Data: byte): byte; stdcall; external 'inpout32.dll';

implementation

{$R *.dfm}

{==============================================================================}
{               THE PIC18 MEGA-PROGRAMMER CODE STARTS HERE                     }
{                                                                              }
{ This code is (c) by TimN, http://timn.ho.ua, E-mail: tim_mail(a|)ukt.net     }
{ You may modify and reuse this code in your application if the above          }
{  copyright note is preserved in your code AND your product documentation     }
{ Created 24.06.2012; Version: 24.06.2012                                      }
{==============================================================================}

{------------------}{------------------}{------------------}{------------------}
{                                  0) HARDWARE LEVEL                           }

procedure _Delay;
var i: Integer;
begin
   for i:=1 to 200000 do asm nop end; // the >= 15 uS delay
   // adjust the '200000' according to your CPU speed
   // might be replaced with Windows sleep(1), but it is to slow!!!
end;

procedure _ChangePortState(port: word; mask: byte; state: byte);
begin
  if state<>0 then
    out32(port, inp32(port)  or mask) // set mask bit to 1
  else
    out32(port, (inp32(port) and (not mask))); // set mask bit to 1
  {}
end;

// ----------------------------------------------------------------------------

const //Invert_Data = true; Invert_Clock = False;
      Invert_Data = False; Invert_Clock = False;
      Invert_Vdd = true; Invert_Vpp = true;


// signals to PIC - adjust according to your hardware !!!
// switch on/off the VDD pin
procedure _Vdd(b: byte);
begin     if Invert_Vdd xor (b<>0) then _ChangePortState($378, 4, 1) else _ChangePortState($378, 4, 0); sleep(10); _Delay; end;

// switch on/off the MCLR pin
procedure _Vpp(b: byte);
begin     if Invert_Vpp xor (b<>0) then _ChangePortState($378, 8, 1) else _ChangePortState($378, 8, 0); _Delay; end;

// change state of PGC line and wait some time...
procedure _Clock(b: byte);
begin     if Invert_Clock xor (b<>0) then _ChangePortState($378, 2, 1) else _ChangePortState($378, 2, 0); _Delay; end;

// change state of PGD line
procedure _DataOut(b: byte);
begin     if Invert_Data xor (b<>0) then _ChangePortState($378, 1, 1) else _ChangePortState($378, 1, 0); _Delay; end;

procedure _Make_PGD_Readable;
begin _DataOut(1); { disconnect PGD wire from ground to make PIC able to change its voltage} end;

// read the state of PGD line (zero means return value '0', non-zero return value means '1'); 
function _DataIn: byte;
begin
     result:=inp32($379 {port address} ) and (128 {the mask of bsy signal} );
end;
{------------------}{------------------}{------------------}{------------------}
{                             1) BIT TRANSFER LEVEL                            }


procedure _Init;
begin
 _Clock(0);
 _DataOut(0);
 _Vdd(0);
 _Vpp(0);
end;


procedure Enter_ProgMode;
begin
 form1.Timer1.Enabled:=false;
 sleep(10);
 _Clock(0);
 _DataOut(0);
 {}
 _Vpp(1);
 _Delay;
 _Vdd(1);
end;

procedure Exit_ProgMode;
begin
 _Clock(0);
 _DataOut(0);
 {}
 _Vpp(0);
 _Delay;
 _Vdd(0);
 {}
  form1.Timer1.Enabled:=True;
end;

procedure _Send_Bit(b: byte);
begin
 // Commands and data are transmitted on the rising edge of PGC, latched on the
 // falling edge of PGC
 _Clock(1);
 _DataOut(b);  // east Significant bit (LSb) first.
 _Clock(0);
end;

{------------------}{------------------}{------------------}{------------------}
{                             2) COMMAND TRANSFER LEVEL                        }

// Depending on the 4-bit command, the 16-bit operand
// represents 16 bits of input data ...
procedure Send_Command(c3,c2,c1,c0: byte{command bits}; op1{high}, op2{low}: byte{operands});
var i: Integer;
 mask: byte;
begin
 _Clock(0);
 _Send_Bit(c0);
 _Send_Bit(c1);
 _Send_Bit(c2);
 _Send_Bit(c3);
 {}
 mask:=1;
 // send low byte
 for i:=1 to 8 do begin
   if (op2 and mask)<>0 then        _Send_Bit(1)    else        _Send_Bit(0);
   mask:=mask shl 1;
 end;
 {}
 mask:=1;
 // send low byte
 for i:=1 to 8 do begin
   if (op1 and mask)<>0 then        _Send_Bit(1)    else        _Send_Bit(0);
   mask:=mask shl 1;
 end;
end;


/// ... or 8 bits of input data, and 8 bits of output data.
function _ReadFrom_PIC(c3,c2,c1,c0: byte{command bits}; op: byte{operands}): byte;
var i: Integer;
 mask: byte;
begin
 _Clock(0);
 _Send_Bit(c0);
 _Send_Bit(c1);
 _Send_Bit(c2);
 _Send_Bit(c3);
 {}
 mask:=1;
 // send single operand byte
 for i:=1 to 8 do begin
   if (op and mask)<>0 then        _Send_Bit(1)    else        _Send_Bit(0);
   mask:=mask shl 1;
 end;
 {}
 result:=0;
 {}
 _Make_PGD_Readable;           // rise data line high OR switch it to high-impedance input state
 mask:=1;
 // send low byte
 for i:=1 to 8 do begin
    _Clock(1);
     if _DataIn<>0 then Result:=Result or mask;
    _Clock(0);                                 
    mask:=mask shl 1;
 end;
 // _DataOut(0);
end;
{------------------}{------------------}{------------------}{------------------}
{                       3) PROGRAMMING COMMANDS LEVEL                          }

// writes address to TBLPTRU, TBLPTRH, TBLPTRL registers
procedure PIC_Set_Table_Address(b3{high}, b2, b1{low}: byte);
begin
// write('*** ADDR: ',inttohex(b3,2),':',inttohex(b2,2),':',inttohex(b1,2),' ***');
    Send_Command(0,0,0,0,  $0E, b3);  // MOVLW b3
    Send_Command(0,0,0,0,  $6E, $F8); // MOVWF TBLPTRU
    Send_Command(0,0,0,0,  $0E, b2);  // MOVLW b2
    Send_Command(0,0,0,0,  $6E, $F7); // MOVWF TBLPTRH
    Send_Command(0,0,0,0,  $0E, b1);  // MOVLW b1
    Send_Command(0,0,0,0,  $6E, $F6); // MOVWF TBLPTRL
    {}
end;
{--------------------------------------------------------------------}

// controller-specific constanfs
const
 Reg_EECON1       = $00A6;      // EECON1 register address
 bit_EECON1_EEPGD = 7;
 bit_EECON1_CFGS  = 6;
 bit_EECON1_FREE  = 4;
 bit_EECON1_WRERR = 3;
 bit_EECON1_WREN  = 2;
 bit_EECON1_WR    = 1;
 bit_EECON1_RD    = 0;
 {}
 nWordsMax = 8;                 // write buffer capacity (in words)
 ConfigAddrBegin = $00300000;   // first byte of Configuration words
 nCodeLinesToPrint = 10;        // for visual code verification

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

// FLAG MANIPULATIONS:
// 1) execute BSF ('set flag') command for a given bit
procedure PIC_Set_Flag(Regstr, BitNum: byte);
var cmd: word;
begin
 // BSF command code:  1000 bbba ffff ffff
 // where  ffff ffff = register address ($A6 for EECON1), a=0 to select the Access Bank
 // and bbb is bit number inside register
 cmd:=$8000{1000 0000 0000 0000} or Regstr or (word(BitNum) shl 9);
 Send_Command(0,0,0,0,  (cmd shr 8), cmd and $FF); // send high and low bytes of cmd
end;


// 2) execute BCF ('clear flag') command for a given bit
procedure PIC_Clear_Flag(Regstr, BitNum: byte);
var cmd: word;
begin
 // BCF command code:  1001 bbba ffff ffff
 // where  ffff ffff = register address ($A6 for EECON1), a=0 to select the Access Bank
 // and bbb is bit number inside register
 cmd:=$9000{1001 0000 0000 0000} or Regstr or (word(BitNum) shl 9);
 Send_Command(0,0,0,0,  (cmd shr 8), cmd and $FF); // send high and low bytes of cmd
end;


// reads EECON1 register until its WR bit become clear - useful for 'self-timed' write operations
function PIC_WAIT_WR_Clear: byte;
var nCycles: Integer; // prevent infinite loop
const N_Cycles_MAX = 1000;
begin
    nCycles:=0;
    repeat
       inc(nCycles);
       Send_Command(0,0,0,0,  $50, $A6); // MOVF EECON1, W, 0
       Send_Command(0,0,0,0,  $6E, $F5); // MOVWF TABLAT
       Send_Command(0,0,0,0,  $00, $00); // NOP 
       Result:=_ReadFrom_PIC(0,0,1,0, $00);
       // Repeat until bit WR is clear.
    until (nCycles > N_Cycles_MAX) or ((Result and (1 shl bit_EECON1_WR)) = 0);
end;


// erases the whole buffer of code (~64 bytes) starting at current addres
procedure PIC_ERASE_BLOCK;
begin
    // Enable memory writes and setup an erase
    PIC_Set_Flag(Reg_EECON1, bit_EECON1_WREN);
    PIC_Set_Flag(Reg_EECON1, bit_EECON1_FREE);
        {The WREN bit must be set (EECON1<2> =  1) to
        enable writes of any sort (e.g., erases) and this must be
        done prior to initiating a write sequence. The FREE bit
        must be set (EECON1<4> = 1) in order to erase the
        program space being pointed to by the Table Pointer.}
    {}
    // Initiate erase.
    PIC_Set_Flag(Reg_EECON1, bit_EECON1_FREE);
    PIC_Set_Flag(Reg_EECON1, bit_EECON1_WR);
    Send_Command(0,0,0,0,  $00, $00); // NOP
    Send_Command(0,0,0,0,  $00, $00); // NOP , Erase starts on the 4th clock of this instruction
        {The erase or write sequence is initiated by setting the
        WR bit (EECON1<1> = 1). It is strongly recommended
        that the WREN bit only be set immediately, prior to a
        program or erase}
    {}
    // Step 6: Poll WR bit. Repeat until bit is clear.
    PIC_WAIT_WR_Clear;
end;
{--------------------------------------------------------------------}

procedure PIC_Flash_Write_Enable;
begin
    // Allow access to program Flash.
    PIC_Set_Flag(  Reg_EECON1, bit_EECON1_EEPGD);
    PIC_Clear_Flag(Reg_EECON1, bit_EECON1_CFGS);
        {When using the EECON1 register to act on program
        Flash, the EEPGD bit must be set (EECON1<7> = 1)
        and the CFGS bit must be cleared (EECON1<6> = 0).}
end;

// Disable writes.
procedure PIC_Write_Disable;
begin
    PIC_Clear_Flag(Reg_EECON1, bit_EECON1_WREN);
end;

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

// send 1110, b1, b2, 'Start programming + incr.' command
procedure PIC_FLUSH_WRITE_BUFFER(b1,b2: byte);
begin
    Send_Command(1,1,1,0, b1,b2);
    Send_Command(0,0,0,0,  $00, $00); // NOP
end;
{--------------------------------------------------------------------}

// write byte to configuration registers;
// PIC_Set_Table_Address() with proper address ($30:$00:$xx) should be called BEFORE
procedure PIC_Write_Config(b: byte);
begin

    PIC_Set_Flag(Reg_EECON1, bit_EECON1_EEPGD);
    PIC_Set_Flag(Reg_EECON1, bit_EECON1_CFGS);
    PIC_Set_Flag(Reg_EECON1, bit_EECON1_WREN);

    Send_Command(1,1,0,0,  b, b); // LSB ignored for 1,3,5,7 (odd addresses); MSB ignored for 2,4,6,8 (even addresses);
    // MOVLW <value>; MOVF TABLAT could be used instead, but it writes only 4 lower bits of TABLAT (???)

    PIC_Set_Flag(Reg_EECON1, bit_EECON1_WR); // Start write!
    {}
    PIC_WAIT_WR_Clear;
end;

{--------------------------------------------------------------------}
procedure PIC_BULK_ERASE;
var i: Integer;
begin
    {}
    PIC_Set_Table_Address($3C, $00, $05);
    Send_Command(1,1,0,0,  $0F, $0F); // Write 0Fh to 3C0005h
    PIC_Set_Table_Address($3C, $00, $04);
    Send_Command(1,1,0,0,  $8F, $8F); // Write 8F8Fh TO 3C0004h to erase entire device.
    {}
    {}
    _DataOut(0);
    {}
    for i:=1 to 100 do begin
      _Clock(0);
      sleep(1);
      _Clock(1);  // NOP - hold PGC high for time P9 and low for time P10.
      sleep(1);
    end;
end;
{--------------------------------------------------------------------}

procedure PIC_ERASE_CONFIG;
var i: Integer;
begin
    {}
    PIC_Set_Table_Address($3C, $00, $05);
    Send_Command(1,1,0,0,  $00, $00); // Write 00h to 3C0005h
    PIC_Set_Table_Address($3C, $00, $04);
    Send_Command(1,1,0,0,  $82, $82); // Write 82h TO 3C0004h to erase entire device.
    {}
    {}
    _DataOut(0);
    {}
    for i:=1 to 100 do begin
      _Clock(0);
      sleep(1);
      _Clock(1);  // NOP - hold PGC high for time P9 and low for time P10.
      sleep(1);
    end;
end;

{--------------------------------------------------------------------}
// simple string - to hex conversion routines

function _hex_char_to_int(c: char): byte;
begin
  if c in ['0'..'9'] then
        result:=ord(c)-ord('0')
  else
    {'A'..'F'} result:=ord(uppercase(c)[1])-ord('A')+10;
end;

function _hex_byte_to_int(c1,c2: char): byte;
begin
  result:=_hex_char_to_int(c2) or (byte(_hex_char_to_int(c1)) shl 4);
end;
{--------------------------------------------------------------------}

// MAIN SUBROUTINE
// Writes .hex file (program memory and/or configuration) to PIC controller
// BULK ERASE or BLOCK_ERASE should be done on Program flash before calling this
procedure PIC_WRITE_Hex(fname: string; a1,a2,a3: byte{address});
var f: system.text; s: string; i, len: Integer; w: word; _pos: Integer;
 typ: byte;
 BaseAddr: dword;
 AddrsIsConfig: Boolean;
 nDummyFFFF: Integer;
 WordsToWrite: Integer;
 TrueAddr, DesiredAddr: Dword;
 {}
 // convert 4 text chars to 16-bit word and increase _pos by 4
 function _READ_WORD: word;
 begin
                Result:=_hex_byte_to_int(s[_pos],s[_pos+1]); // low byte
                inc(_pos,2);
                Result:=(Result shl 8)or word(_hex_byte_to_int(s[_pos],s[_pos+1])); // high byte
                inc(_pos,2);
 end;
 {}
begin
    BaseAddr:=0;
    assignfile(f,fname);
    reset(f);
    {}
    TrueAddr:=a3 or (dword(a2) shl 8) or (dword(a1) shl 16);
    PIC_Set_Table_Address((TrueAddr shr 16) and $FF, (TrueAddr shr 8) and $FF, TrueAddr and $FF);
    {}
    while not eof(f) do begin
      readln(f,s);
      _pos:=1;
      if (length(s)>0) and (s[_pos]=':') then begin
        inc(_pos);
        len:=_hex_byte_to_int(s[_pos],s[_pos+1]); // length
        inc(_pos, 2); // first 2 charters are already read
        DesiredAddr:=_READ_WORD; // 4 chars - the address
        DesiredAddr:=BaseAddr + DesiredAddr;
        AddrsIsConfig := (DesiredAddr  >= ConfigAddrBegin);
        {}
        typ:=_hex_byte_to_int(s[_pos],s[_pos+1]); // the type of data in this line
        inc(_pos, 2);
        {}
        case typ of
        00: BEGIN {just a data}
           write(#13#10'',inttohex(TrueAddr,8),': ');
           IF not AddrsIsConfig then begin                // where to write: Program flash memory or Configuration words?
                {}
                // check for 'skipped' 0xFFFFs
                nDummyFFFF:=(DesiredAddr-TrueAddr) div 2; // 2 is the word size
                {}
                // if a jump from, e.g., 0001 to FF01 was desired...
                if (nDummyFFFF > (nWordsMax * 2)) then begin
                    // calculate nearest address, which is: 1) smaller than DesiredAddr
                    // and 2) aligned with nWordsMax*2
                    TrueAddr:=DesiredAddr - (DesiredAddr mod (nWordsMax * 2));
                    // move pointer there
                    PIC_Set_Table_Address((TrueAddr shr 16) and $FF, (TrueAddr shr 8) and $FF, TrueAddr and $FF);
                    // update new dymmy FFFF count
                    nDummyFFFF:=(DesiredAddr-TrueAddr) div 2;
                end;
                {}
                WordsToWrite:=nDummyFFFF + (len div 2);   // total number of words to be written
                {}
                PIC_Flash_Write_Enable;
                {}
                // read word from file and write them
                for i:=1 to WordsToWrite do begin
                   // a word to write: is it a real word, or one on nDummyFFFF 'skipped' 0xFFFFs ?
                   if i <= nDummyFFFF then w:=$FFFF else w:=_READ_WORD;
                   write(inttohex(w,4),', ');             // print the word to screen
                   inc(TrueAddr,2);                       // we are goind to increment TrueAddr by the Write instruction
                   if  ((TrueAddr mod nWordsMax)=0) OR    // the write buffer is full!!! => Issue a 'Start programming command
                       (i = WordsToWrite) then begin      // the final byte => Issue a 'Start programming command (probably, with unfilled buffer!)
                     write('[WRITE] ');
                     PIC_FLUSH_WRITE_BUFFER(w and $FF, w shr 8);        // Low byte, High Byte
                     sleep(5);
                   end else begin
                     // do 1101 write command with post-increment - write word to write buffer
                     Send_Command(1,1,0,1, w and $FF, w shr 8);         //  Low byte, High Byte
                     sleep(5);
                   end; // if
                   {}
                end; // for i
           end else begin
                // read bytes from file and write them, one byte at time
                for i:=1 to len do begin
                   w:=_hex_byte_to_int(s[_pos],s[_pos+1]);// read a byte
                   inc(_pos,2);                           // i.e., 2 chars
                   write(inttohex(w and $FF, 2),', ');    // print to screen
                   // set address individually for each byte !
                   PIC_Set_Table_Address((DesiredAddr shr 16) and $FF, (DesiredAddr shr 8) and $FF, DesiredAddr and $FF);
                   inc(DesiredAddr);
                   // write a byte (stored in lower byte of word w)
                   PIC_Write_Config(w and $FF);
                end; // for i
           end; // if
         END;
        04: BEGIN
           BaseAddr:=dword(_READ_WORD) shl 16; {new base address higher 16 bits}
           write('[NEW BASE: ',inttohex(Baseaddr,4),']');
           END;
        end; // case
      end;
    end;
    {}
    closefile(f);
    {}
    {}
    PIC_WRITE_Disable;
end;


{------------------}{------------------}{------------------}{------------------}
{                              4) USER-APPLICATION LEVEL                       }

procedure TForm1.Button1Click(Sender: TObject);
var k: Integer; n: Integer;
begin
  allocconsole;
  {}
  {Enter_ProgMode;
  PIC_WRITE_Enable;
  PIC_Set_Table_Address($00, $00, 0);
  PIC_ERASE_BLOCK;
  PIC_Set_Table_Address($00, $00, 64); // address step must be 64
  PIC_ERASE_BLOCK;
  PIC_WRITE_Disable;
  Exit_ProgMode;}

{  Enter_ProgMode;
  PIC_ERASE_CONFIG;
  Exit_ProgMode;
  sleep(10);     }
  {}
  {}
  Enter_ProgMode;
  writeln('==== CONFIG =====');
  PIC_Set_Table_Address($30, $00, $00);
  for k:=1 to 10 do begin
    for n:=1 to 8 do begin
      write(inttohex(_ReadFrom_PIC(1,0,0,1,{table read, post-increment} 00), 2),' ');
      write(inttohex(_ReadFrom_PIC(1,0,0,1,{table read, post-increment} 00), 2),'   ');
    end;
    writeln;
  end;
  Exit_ProgMode;
  {}
  Enter_ProgMode;
  {}
  if messagebox(handle,'Perform BULK ERASE?',pchar(caption),mb_iconquestion or mb_yesno or MB_DEFBUTTON2) = id_yes then begin
      PIC_BULK_ERASE;
  end;
  {}
  // if no .hex file has been selected
  if opendialog1.Execute then begin
      PIC_WRITE_Hex(opendialog1.FileName {'D:\My\Digital\PIC18F\usb1_p18f14k50\usb1_p18f14k50.hex'}, 0,0,0);
  end;
  {}
  Exit_ProgMode;

(*  Enter_ProgMode;
   PIC_Set_Table_Address($30, $00, $01);
   PIC_Write_Config($20 or (1 shl 5{PLLEN}) or 2{HS osc.});
   PIC_Set_Table_Address($30, $00, $05);
   PIC_Write_Config($08); // MCLRE = 0
  Exit_ProgMode;*)

  

  writeln('reading...');
  {}
  Enter_ProgMode;
  
  writeln('==== CONFIG =====');
  PIC_Set_Table_Address($30, $00, $00);
  for k:=1 to 10 do begin
    for n:=1 to 8 do begin
      write(inttohex(_ReadFrom_PIC(1,0,0,1,{table read, post-increment} 00), 2),' ');
      write(inttohex(_ReadFrom_PIC(1,0,0,1,{table read, post-increment} 00), 2),'   ');
    end;
    writeln;
  end;

  writeln('====  CODE  =====');
  PIC_Set_Table_Address($00, $00, $00);
  for k:=1 to nCodeLinesToPrint do begin
    for n:=1 to 8 do begin
      write(inttohex(_ReadFrom_PIC(1,0,0,1,{table read, post-increment} 00), 2),' ');
      write(inttohex(_ReadFrom_PIC(1,0,0,1,{table read, post-increment} 00), 2),'   ');
    end;
    writeln;
  end;
  
  {}
  Exit_ProgMode;
end;

{==============================================================================}
{                    END OF PIC18 MEGA-PROGRAMMER CODE                         }
{==============================================================================}

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
 if checkbox1.Checked then _DataOut(1) else _DataOut(0); 
end;

procedure TForm1.CheckBox2Click(Sender: TObject);
begin
 if checkbox2.Checked then
        _Clock(1) else
        _Clock(0); 
end;

procedure TForm1.CheckBox3Click(Sender: TObject);
begin
 if checkbox3.Checked then
 _Vdd(1) else
 _Vdd(0);
end;

procedure TForm1.CheckBox4Click(Sender: TObject);
begin
 if checkbox4.Checked then _Vpp(1) else _Vpp(0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 _Init;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
 label1.Caption := 'Data In = '+inttostr(_DataIn);
// if _DataIn<>0 then windows.Beep(1000,01);
end;


end.
