HyperlightTop

Hyperlight is a code highlighter for PHP.

DownloadTop

UsageTop

require_once "/path/to/hyperlight/hyperlight.php";

if (HyperLanguage::exists($language))
{
  $hyperlight = new Hyperlight($language);
  echo $hyperlight->render($code);
}
else
{
  echo "Sorry, language $language does not exist.";
}

TestsTop

Bellow are some Pascal files to test the Pascal highlighter for Hyperlight.

File 1Top

{
  PCI driver
  sa -- 2015
}

unit pci;

{$i sos.inc}
{$BITPACKING ON}

interface

uses
  ktypes;

const
  PCI_COMMAND          = $04;
  PCI_STATUS           = $06;
  PCI_COMMAND_IO       = $01;
  PCI_COMMAND_MEMORY   = $02;
  PCI_CACHE_LINE_SIZE  = $0C;
  PCI_COMMAND_MASTER   = $04;

  PCI_LATENCY_TIMER    = $0D;
  PCI_BASE_REG         = $CFC;
  PCI_DATA_REG         = $CF8;

  PCI_INTERRUPT_LINE   = $3C;
  PCI_INTERRUPT_PIN    = $3D;

  PCI_HEADER_TYPE_NORMAL   = 0;
  PCI_HEADER_TYPE_BRIDGE   = 1;
  PCI_HEADER_TYPE_CARDBUS  = 2;

  L1_CACHE_BYTES      = (1 shl 4); //for 386

type
  TPCICommon = packed record
    VendorId: Word;              // 2
    DeviceId: Word;              // 4
    CmdReg: Word;                // 6
    StatusReg: Word;             // 8
    RevisionId: Byte;            // 9
    ProgIf: Byte;                // 10
    Subclass: Byte;              // 11
    Classcode: Byte;             // 12
    CachelineSize: Byte;         // 13
    Latency: Byte;               // 14
    HeaderType: Byte;            // 15
    BIST: Byte;                  // 16
  end;
  PPCICommon = ^TPCICommon;

  TNonBridge = packed record
    BaseAddress0: Cardinal;
    BaseAddress1: Cardinal;
    BaseAddress2: Cardinal;
    BaseAddress3: Cardinal;
    BaseAddress4: Cardinal;
    BaseAddress5: Cardinal;
    CardBusCIS: Cardinal;
    SubsystemVendorId: Word;
    SubsystemDeviceId: Word;
    ExpansionRom: Cardinal;
    CapPtr: Byte;
    Reserved1: array[0..2] of Byte;
    Reserved2: array[0..1] of Cardinal;
    InterruptLine: Byte;
    InterruptPin: Byte;
    MinGrant: Byte;
    MaxLatency: Byte;
    DeviceSpecific: array[0..47] of Cardinal;
  end;

  TBridge = packed record
    base_address0: Cardinal;
    base_address1: Cardinal;
  end;

  TCardbus = packed record
  end;

  // 4 Byte
  TConfAdd = bitpacked record
    Reg: UInt_8;
    Func: UInt_3;
    Dev: UInt_5;
    Bus: UInt_8;
    Rsvd: UInt_7;
    Enable: UInt_1;
  end;

  PPciDev = ^TPciDev;
  TPciDev = record
    Bus, Dev, Func: Cardinal;
    Common: TPCICommon;
    Irq: Byte;
    Devi: array[0..59] of Cardinal;
    Next: PPciDev;
    Prev: PPciDev;
  end;

  TBarType = (
    BAR_TYPE_MEM,
    BYR_TYPEIO
  );

  TPciBus = class
  private
    FPciList: PPciDev;
    FEnd: PPciDev;
    FNumDev: Cardinal;
  public
    constructor Create;
    destructor Destroy; override;
    procedure List;
    procedure Scan;
    procedure Clear;
    function Get(const AVendor, ADevice: Word): PPciDev; overload;
    function Get(const AClassCode, ASubClass: Byte): PPciDev; overload;
    function GetByClass(const AClassCode: Byte): PPciDev;

    property Count: Cardinal read FNumDev;

    class procedure Init;
    class function Instance: TPciBus; inline;
  end;

{$i pcidefs.inc}

function PciReadConfigByte(const Bus, Dev, Func, Reg: Integer): Byte;
function PciReadConfigWord(const Bus, Dev, Func, Reg: Integer): Word;
function PciReadConfigDWord(const Bus, Dev, Func, Reg: Integer): Cardinal;
procedure PciWriteConfigByte(const Bus, Dev, Func, Reg: Integer; const Value: Byte);
procedure PciWriteConfigWord(const Bus, Dev, Func, Reg: Integer; const Value: Word);
procedure PciWriteConfigDWord(const Bus, Dev, Func, Reg: Integer; const Value: Cardinal);

function PciReadIrq(const Bus, Dev, Func: Integer): Byte;
function PciIsPresent: boolean;

function PciClassToString(const ClassCode, Subclass: Byte): string;
function PciGetBar(PDev: PPciDev; BarNum: integer): Cardinal;

procedure FreePciDev(var ADev: PPciDev);

implementation

uses
  x86, kernel, strutils, console;

var
  gPciBus: TPciBus = nil;

type
  TU = record
    case Integer of
      0: (c: TConfAdd);
      1: (n: Cardinal);
  end;

procedure FreePciDev(var ADev: PPciDev);
var
  dev, next: PPciDev;
begin
  dev := ADev;
  while (dev <> nil) do begin
    next := dev^.Next;
    Dispose(dev);
    dev := next;
  end;
  ADev := nil;
end;

{
  Read PCI Bus
  Takes bus number, device number, function number register and type.
  Returns the value.
}
function ReadPci(const Bus, Dev, Func, Reg, ASize: Cardinal): Cardinal;
var
  base: Word;
  u: TU;
begin
  u.n := 0;
  u.c.Enable := 1;
  u.c.Rsvd := 0;
  u.c.Bus := Bus;
  u.c.Dev := Dev;
  u.c.Func := Func;
  u.c.Reg := Reg and $fc;
  WritePortL(PCI_DATA_REG, u.n);
  base := PCI_BASE_REG + (Reg and $03);
  case ASize of
    1: Result := ReadPortB(base);
    2: Result := ReadPortW(base);
    4: Result := ReadPortL(base);
  else
    Result := 0;
  end;
end;

{
  Writes a config byte/word/dword to.
}
procedure WritePci(const Bus, Dev, Func, Reg: Integer; Value: Cardinal; ASize: Cardinal);
var
  base: Word;
  u: TU;
begin
  u.n := 0;
  u.c.Enable := 1;
  u.c.Rsvd := 0;
  u.c.Bus := Bus;
  u.c.Dev := Dev;
  u.c.Func := Func;
  u.c.Reg := Reg and $fc;
  base := PCI_BASE_REG + (Reg and $03);
  WritePortL(PCI_DATA_REG, u.n);
  case ASize of
    1: WritePortB(base, Byte(Value));
    2: WritePortW(base, Word(Value));
    4: WritePortL(base, Value);
  end;
end;

function PciReadConfigByte(const Bus, Dev, Func, Reg: Integer): Byte;
begin
  Result := ReadPci(Bus, Dev, Func, Reg, SizeOf(Byte));
end;
function PciReadConfigWord(const Bus, Dev, Func, Reg: Integer): Word;
begin
  Result := ReadPci(Bus, Dev, Func, Reg, SizeOf(Word));
end;
function PciReadConfigDWord(const Bus, Dev, Func, Reg: Integer): Cardinal;
begin
  Result := ReadPci(Bus, Dev, Func, Reg, SizeOf(Cardinal));
end;

procedure PciWriteConfigByte(const Bus, Dev, Func, Reg: Integer; const Value: Byte);
begin
  WritePci(Bus, Dev, Func, Reg, Value, SizeOf(Byte));
end;
procedure PciWriteConfigWord(const Bus, Dev, Func, Reg: Integer; const Value: Word);
begin
  WritePci(Bus, Dev, Func, Reg, Value, SizeOf(Word));
end;
procedure PciWriteConfigDWord(const Bus, Dev, Func, Reg: Integer; const Value: Cardinal);
begin
  WritePci(Bus, Dev, Func, Reg, Value, SizeOf(Cardinal));
end;

function PciReadIrq(const Bus, Dev, Func: Integer): Byte;
begin
  Result := PciReadConfigByte(Bus, Dev, Func, PCI_INTERRUPT_PIN);
  if Result <> 0 then
    Result := PciReadConfigByte(Bus, Dev, Func, PCI_INTERRUPT_LINE);
end;

function PciIsPresent: boolean;
var
  res: Cardinal;
begin
  res := ReadPortL(PCI_DATA_REG);
  Result := res <> $FFFFFFFF;
end;

function PciGetBar(PDev: PPciDev; BarNum: integer): Cardinal;
var
  temp: Cardinal;
begin
  temp := PciReadConfigDWord(PDev^.Bus, PDev^.Dev, PDev^.Func, $10 + (BarNum shl 2));
//  KDebugMsg('PciGetBar: temp = ' + IntToStr(temp));
  if (temp and $00000001) <> 0 then
    Result := temp and (not $03)
  else
    Result := temp and (not $0f);
end;

function PciEnableDeviceIo(PDev: PPciDev): Byte;
var
  cmd, old_cmd: Word;
  i: integer;
begin
//  KDebugMsg('PciEnableDeviceIo Enabling device ' + IntToStr(PDev^.Bus) + ':' + IntToStr(PDev^.Dev) + ':' + IntToStr(PDev^.Func));
  cmd := PciReadConfigWord(PDev^.Bus, PDev^.Dev, PDev^.Func, PCI_COMMAND);
  old_cmd := cmd;

  for i := 0 to 5 do begin
    if (PciGetBar(PDev, i) = PCI_COMMAND_IO) then
      cmd := cmd or PCI_COMMAND_IO;
  end;

  if (cmd and PCI_COMMAND_IO) = 0 then begin
    // Device not IO based
//    KWarnMsg('PciEnableDeviceIo: Device is not IO based');
    Result := $0e;
    Exit;
  end;

  if (PDev^.Common.HeaderType and $7f) = PCI_HEADER_TYPE_BRIDGE then begin
    // Any PCI-to-PCI bridge must be enabled by setting
    // both I/O space and memory space access bits in the
    // command register.
    cmd := cmd or PCI_COMMAND_MEMORY;
  end;

  // Always enable bus master
  cmd := cmd or PCI_COMMAND_MASTER;

  if (cmd <> old_cmd) then begin
    PciWriteConfigWord(PDev^.Bus, PDev^.Dev, PDev^.Func, PCI_CACHE_LINE_SIZE,
      (32 shl 8) or (L1_CACHE_BYTES div SizeOf(Cardinal)));
    PciWriteConfigWord(PDev^.Bus, PDev^.Dev, PDev^.Func, PCI_COMMAND, cmd);
  end;

  Result := 0;
end;

procedure PciSetMaster(PDev: PPciDev);
var
  cmd: Word;
  lat: Byte;
begin
  cmd := PciReadConfigWord(PDev^.Bus, PDev^.Dev, PDev^.Func, PCI_COMMAND);
  if (cmd and PCI_COMMAND_MASTER) = 0 then begin
    // Enable bus master
    cmd := cmd or PCI_COMMAND_MASTER;
    PciWriteConfigWord(PDev^.Bus, PDev^.Dev, PDev^.Func, PCI_COMMAND, cmd);
  end;

  // Check the latency time, because certain BIOSes forget to set it properly...
  lat := PciReadConfigByte(PDev^.Bus, PDev^.Dev, PDev^.Func, PCI_LATENCY_TIMER);
  if (lat < 16) then
    lat := 255         // 255 is max latency
  else if (Cardinal(lat) > 255) then
    lat := 255
  else
    Exit;

  PciWriteConfigByte(PDev^.Bus, PDev^.Dev, PDev^.Func, PCI_LATENCY_TIMER, lat);

  // Enabling device
  if PciEnableDeviceIo(PDev) <> 0 then begin
//    KWarnMsg('Unable to enable device ' + IntToStr(PDev^.Bus) + ':' + IntToStr(PDev^.Dev) + ':' + IntToStr(PDev^.Func));
  end;
end;

function PciClassToString(const ClassCode, Subclass: Byte): string;
var
  code: Cardinal;
begin
  code := (ClassCode shl 8) + Subclass;
  case code of
    PCI_CLASS_NOT_DEFINED:       Result := 'Unknown device/VGA';
    PCI_CLASS_NOT_DEFINED_VGA:   Result := 'Unknown/VGA';

    PCI_CLASS_STORAGE_SCSI:      Result := 'SCSI disk';
    PCI_CLASS_STORAGE_IDE:       Result := 'IDE disk';
    PCI_CLASS_STORAGE_FLOPPY:    Result := 'Floppy disk';
    PCI_CLASS_STORAGE_IPI:       Result := 'IPI disk';
    PCI_CLASS_STORAGE_RAID:      Result := 'RAID';
    PCI_CLASS_STORAGE_SATA:      Result := 'SATA';
    PCI_CLASS_STORAGE_SATA_AHCI: Result := 'SATA AHCI';
    PCI_CLASS_STORAGE_SAS:       Result := 'SAS';
    PCI_CLASS_STORAGE_OTHER:     Result := 'Other storage';

    PCI_CLASS_NETWORK_ETHERNET:  Result := 'Ethernet';
    PCI_CLASS_NETWORK_TOKEN_RING: Result := 'Tokenring';
    PCI_CLASS_NETWORK_FDDI:      Result := 'FDDI';
    PCI_CLASS_NETWORK_ATM:       Result := 'ATM';
    PCI_CLASS_NETWORK_OTHER:     Result := 'Other network';

    PCI_CLASS_DISPLAY_VGA:       Result := 'VGA';
    PCI_CLASS_DISPLAY_XGA:       Result := 'XGA';
    PCI_CLASS_DISPLAY_3D:        Result := '3D';
    PCI_CLASS_DISPLAY_OTHER:     Result := 'Other display';

    PCI_CLASS_MULTIMEDIA_VIDEO:  Result := 'Video';
    PCI_CLASS_MULTIMEDIA_AUDIO:  Result := 'Audio';
    PCI_CLASS_MULTIMEDIA_PHONE:  Result := 'Phone';
    PCI_CLASS_MULTIMEDIA_OTHER:  Result := 'Other media';

    PCI_CLASS_MEMORY_RAM:        Result := 'RAM';
    PCI_CLASS_MEMORY_FLASH:      Result := 'Flash';
    PCI_CLASS_MEMORY_OTHER:      Result := 'Other memory';

    PCI_CLASS_BRIDGE_HOST:       Result := 'Host bridge';
    PCI_CLASS_BRIDGE_ISA:        Result := 'ISA bridge';
    PCI_CLASS_BRIDGE_EISA:       Result := 'EISA bridge';
    PCI_CLASS_BRIDGE_MC:         Result := 'MC bridge';
    PCI_CLASS_BRIDGE_PCI:        Result := 'PCI bridge';
    PCI_CLASS_BRIDGE_PCMCIA:     Result := 'PCMCIA bridge';
    PCI_CLASS_BRIDGE_NUBUS:      Result := 'NUBUS bridge';
    PCI_CLASS_BRIDGE_CARDBUS:    Result := 'CardBus bridge';
    PCI_CLASS_BRIDGE_RACEWAY:    Result := 'Raceway bridge';
    PCI_CLASS_BRIDGE_OTHER:      Result := 'Other bridge';

    PCI_CLASS_COMMUNICATION_SERIAL:        Result := 'Serial';
    PCI_CLASS_COMMUNICATION_PARALLEL:      Result := 'Parallel';
    PCI_CLASS_COMMUNICATION_MULTISERIAL:   Result := 'Multiserial';
    PCI_CLASS_COMMUNICATION_MODEM:         Result := 'Modem';
    PCI_CLASS_COMMUNICATION_OTHER:         Result := 'Other communication';

    PCI_CLASS_SYSTEM_PIC:          Result := 'PIC';
    PCI_CLASS_SYSTEM_PIC_IOAPIC:   Result := 'IOAPIC';
    PCI_CLASS_SYSTEM_PIC_IOXAPIC:  Result := 'IOXAPIC';
    PCI_CLASS_SYSTEM_DMA:          Result := 'DMA';
    PCI_CLASS_SYSTEM_TIMER:        Result := 'Timer';
    PCI_CLASS_SYSTEM_RTC:          Result := 'RTC';
    PCI_CLASS_SYSTEM_PCI_HOTPLUG:  Result := 'PCI Hotplug';
    PCI_CLASS_SYSTEM_SDHCI:        Result := 'SDHCI';
    PCI_CLASS_SYSTEM_OTHER:        Result := 'Other system';

    PCI_CLASS_INPUT_KEYBOARD:      Result := 'Keyboard';
    PCI_CLASS_INPUT_PEN:           Result := 'Pen';
    PCI_CLASS_INPUT_MOUSE:         Result := 'Mouse';
    PCI_CLASS_INPUT_SCANNER:       Result := 'Scanner';
    PCI_CLASS_INPUT_GAMEPORT:      Result := 'Gameport';
    PCI_CLASS_INPUT_OTHER:         Result := 'Other input';

    PCI_CLASS_DOCKING_GENERIC:     Result := 'Docking generic';
    PCI_CLASS_DOCKING_OTHER:       Result := 'Docking other';

    PCI_CLASS_PROCESSOR_386:       Result := 'i386 processor';
    PCI_CLASS_PROCESSOR_486:       Result := 'i486 processor';
    PCI_CLASS_PROCESSOR_PENTIUM:   Result := 'Pentium processor';
    PCI_CLASS_PROCESSOR_ALPHA:     Result := 'Alpha processor';
    PCI_CLASS_PROCESSOR_MIPS:      Result := 'MIPS processor';
    PCI_CLASS_PROCESSOR_CO:        Result := 'Co processor';

    PCI_CLASS_SERIAL_FIREWIRE:     Result := 'Firewire';
    PCI_CLASS_SERIAL_FIREWIRE_OHCI: Result := 'Firewire OHCI';
    PCI_CLASS_SERIAL_SSA:          Result := 'SSA';
    PCI_CLASS_SERIAL_USB:          Result := 'USB';
    PCI_CLASS_SERIAL_USB_UHCI:     Result := 'USB UHCI';
    PCI_CLASS_SERIAL_USB_OHCI:     Result := 'USB OHCI';
    PCI_CLASS_SERIAL_USB_EHCI:     Result := 'USB EHCI';
    PCI_CLASS_SERIAL_FIBER:        Result := 'Fiber';
    PCI_CLASS_SERIAL_SMBUS:        Result := 'SMBUS';

    PCI_CLASS_WIRELESS_RF_CONTROLLER: Result := 'Wireless RF controller';
    PCI_CLASS_WIRELESS_WHCI:       Result := 'WHCI';

    PCI_CLASS_INTELLIGENT_I2O:     Result := 'Intelligent I20';

    PCI_CLASS_SATELLITE_TV:        Result := 'Satellite TV';
    PCI_CLASS_SATELLITE_AUDIO:     Result := 'Satellite audio';
    PCI_CLASS_SATELLITE_VOICE:     Result := 'Satellite voice';
    PCI_CLASS_SATELLITE_DATA:      Result := 'Satellite data';

    PCI_CLASS_CRYPT_NETWORK:       Result := 'Crypt network';
    PCI_CLASS_CRYPT_ENTERTAINMENT: Result := 'Crypt entertainment';
    PCI_CLASS_CRYPT_OTHER:         Result := 'Crypt other';

    PCI_CLASS_SP_DPIO:             Result := 'DPIO';
    PCI_CLASS_SP_OTHER:            Result := 'SP other';
  else
    Result := 'Invalid class';
  end;
end;

{ TPciBus }

constructor TPciBus.Create;
begin
  inherited;
  FPciList := nil;
  FEnd := nil;
  FNumDev := 0;
end;

destructor TPciBus.Destroy;
begin
  Clear;
  inherited;
end;

procedure TPciBus.Clear;
var
  dev, next: PPciDev;
begin
  dev := FPciList;
  while (dev <> nil) do begin
    next := dev^.Next;
    Dispose(dev);
    dev := next;
  end;

  FPciList := nil;
  FEnd := nil;
  FNumDev := 0;
end;

procedure TPciBus.List;
var
  dev: PPciDev;
begin
  dev := FPciList;
  while (dev <> nil) do begin
    Write(' ' + IntToStr(dev^.Bus));
    Write(':' + IntToStr(dev^.Dev));
    Write(':' + IntToStr(dev^.Func));
    Write(' ' + PciClassToString(dev^.Common.ClassCode, dev^.Common.Subclass));
    Write(' ' + IntToStr(dev^.Common.Classcode));
    Write(':' + IntToStr(dev^.Common.Subclass));
    Write(':' + IntToStr(dev^.Common.ProgIf));
    Write(':' + IntToStr(dev^.Common.HeaderType));
    Write(' irq:' + IntToStr(dev^.Irq));
    WriteLn;

    dev := dev^.Next;
  end;
end;

procedure TPciBus.Scan;
type
  TPciCommonCast = record
    case Integer of
      0: (c: TPCICommon);                       // 16 Byte
      1: (t: packed array[0..3] of Cardinal);   // 16 Byte
  end;
var
  bus, dev, fun, num_fun: Cardinal;
  i: Integer;
  cmn: TPciCommonCast;
  pd: PPciDev;
begin
  Clear;
  if not PciIsPresent then
    Exit;

  for bus := 0 to 254 do begin
    for dev := 0 to 31 do begin
      if (PciReadConfigByte(bus, dev, 0, $0e) = $80) then
        num_fun := 8
      else
        num_fun := 1;

      for fun := 0 to num_fun - 1 do begin
        for i := 0 to 3 do begin
          cmn.t[i] := PciReadConfigDWord(bus, dev, fun, i shl 2);
        end;

        if (cmn.c.VendorId = $ffff) or (cmn.c.VendorId = $0000) then
          Continue;

        Inc(FNumDev);
        New(pd);
        if (pd = nil) then
          Panic('Out of memory');

        pd^.Bus := bus;
        pd^.Dev := dev;
        pd^.Func := fun;
        for i := 0 to 59 do begin
          pd^.Devi[i] := PciReadConfigDWord(bus, dev, fun, (i shl 2) + 16);
        end;
        pd^.Prev := nil;
        pd^.Next := nil;
        Move(cmn, pd^.Common, SizeOf(TPCICommon));
        pd^.Irq := PciReadIrq(bus, dev, fun);
        PciSetMaster(pd);

        if (FPciList = nil) then begin
          // First
          FPciList := pd;
          FEnd := FPciList;
          FPciList^.Next := nil;
          FPciList^.Prev := nil;
        end else begin
          pd^.Prev := FEnd;
          FEnd^.Next := pd;
          pd^.Next := nil;
          FEnd := pd;
        end;
      end;
    end;
  end;
end;

function TPciBus.Get(const AVendor, ADevice: Word): PPciDev;
var
  temp: PPciDev;
begin
  temp := FPciList;
  while (temp <> nil) do begin
    if (temp^.Common.VendorId = AVendor) and (temp^.Common.DeviceId = ADevice) then begin
      Result := temp;
      Exit;
    end;
    temp := temp^.Next;
  end;

  Result := nil;
end;

{
  Get a list of the requested
}
function TPciBus.Get(const AClassCode, ASubClass: Byte): PPciDev;
var
  temp, temp2, cur: PPciDev;
begin
  temp := FPciList;
  temp2 := nil;
  while (temp <> nil) do begin
    if (temp^.Common.ClassCode = AClassCode) and (temp^.Common.Subclass = ASubClass) then begin
      if (temp2 = nil) then begin
        New(temp2);
        Move(temp^, temp2^, SizeOf(TPciDev));
        cur := temp2;
        cur^.Next := nil;
      end else begin
        New(cur^.Next);
        Move(temp^, cur^.Next^, SizeOf(TPciDev));
        cur := cur^.Next;
        cur^.Next := nil;
      end;
    end;
    temp := temp^.Next;
  end;
  cur^.Next := nil;
  Result := temp2;
end;

function TPciBus.GetByClass(const AClassCode: Byte): PPciDev;
begin
  // TODO: not implemented
  Result := nil;
end;

class procedure TPciBus.Init;
begin
  if gPciBus = nil then
    gPciBus := TPciBus.Create;
end;

class function TPciBus.Instance: TPciBus;
begin
  if gPciBus = nil then
    TPciBus.Init;
  Result := gPciBus;
end;

initialization

finalization
  if gPciBus <> nil then begin
    gPciBus.Free;
    gPciBus := nil;
  end;
end.

File 2Top

{
  Timer
  sa -- 2015
}

unit timer;

{$i sos.inc}

interface

uses
  x86, irq, kutils;

type
  TTimer = class(TNonRefInterfacedObject, IIntListener)
  private
    FTicks: UInt64;
    FSeconds: UInt64;
    { IIntListener }
    procedure OnInt(const AINum: Byte; var r: TRegisters);
    procedure Phase(const Hz: Cardinal);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Sleep(const AMs: Cardinal);

    property Ticks: UInt64 read FTicks;
    { Uptime in seconds }
    property Seconds: UInt64 read FSeconds;

    class procedure Install;
    class function Instance: TTimer; inline;
  end;

procedure TimerWait(Ticks: LongWord);

implementation

uses
  vfs, sysfs, strutils;

var
  gTimer: TTimer = nil;

function SysFsUptime: string;
begin
  Result := IntToStr(TTimer.Instance.Seconds);
end;

class procedure TTimer.Install;
begin
  if not Assigned(gTimer) then begin
    gTimer := TTimer.Create;
    TFileSystemSys(TVirtualFileSystem.Instance.GetSysFs).SetDynamicValue('uptime', @SysFsUptime);
  end;
end;

class function TTimer.Instance: TTimer;
begin
  if not Assigned(gTimer) then
    TTimer.Install;
  Result := gTimer;
end;

constructor TTimer.Create;
begin
  inherited;
  FTicks := 0;
  FSeconds := 0;
  // 1000 ticks per second
  Phase(1000);
  IrqInstallHandler(0, Self);
end;

destructor TTimer.Destroy;
begin
  TFileSystemSys(TVirtualFileSystem.Instance.GetSysFs).DeleteValue('uptime');
  IrqUninstallHandler(0);
  inherited;
end;

procedure TTimer.Sleep(const AMs: Cardinal);
var
  cur: Cardinal;
begin
  cur := FTicks;
  asm
    cli
  end;
  while (FTicks < (UInt64(cur) + UInt64(AMs))) do begin
    asm
       sti
       nop
       nop
       nop
       nop
       nop
    end;
  end;
end;

procedure TTimer.Phase(const Hz: Cardinal);
var
  divisor: integer;
begin
  divisor := 1193180 div Hz;               // Calculate our divisor
  WritePortB($43, $36);                    // Set our command byte $36
  WritePortB($40, divisor and $FF);        // Set low byte of divisor
  WritePortB($40, divisor shr 8);          // Set high byte of divisor
end;

procedure TTimer.OnInt(const AINum: Byte; var r: TRegisters);
begin
  Inc(FTicks);
  if ((FTicks mod 1000) = 0) then
    Inc(FSeconds);
end;

procedure TimerWait(Ticks: LongWord); [public, alias: 'TimerWait'];
begin
  TTimer.Instance.Sleep(Ticks * 10);
end;

initialization

finalization
  if gTimer <> nil then begin
    gTimer.Free;
    gTimer := nil;
  end;

end.

File 3Top

{*
 * windivert.pas
 * (C) 2014, all rights reserved,
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *}

{
  Translation of windivert.h
}

unit windivert;

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

interface

uses
  SysUtils, Windows;

type
  BOOL = LongBool;
  INT8 = Byte;
  UINT8 = Byte;
  INT16 = ShortInt;
  UINT16 = Word;
  INT32 = Integer;
  UINT32 = Cardinal;
  PUINT32 = ^UINT32;
  UINT64 = Int64;
  UINT = Cardinal;
  PUINT = ^UINT;

type
  WINDIVERT_ADDRESS = record
    IfIdx: UINT32;
    SubIfIdx: UINT32;
    Direction: UINT8;
  end;
  TWinDivertAddress = WINDIVERT_ADDRESS;
  PWinDivertAddress = ^TWinDivertAddress;

const
  WINDIVERT_DIRECTION_OUTBOUND = 0;
  WINDIVERT_DIRECTION_INBOUND = 1;

type
  WINDIVERT_LAYER = (
    WINDIVERT_LAYER_NETWORK,
    WINDIVERT_LAYER_NETWORK_FORWARD
  );
  TWinDivertLayer = WINDIVERT_LAYER;

const
  WINDIVERT_FLAG_SNIFF = 1;
  WINDIVERT_FLAG_DROP = 2;
  WINDIVERT_FLAG_NO_CHECKSUM = 1024;

type
  WINDIVERT_PARAM = (
    WINDIVERT_PARAM_QUEUE_LEN,
    WINDIVERT_PARAM_QUEUE_TIME
  );
  TWinDivertParam = WINDIVERT_PARAM;

const
  WINDIVERT_PARAM_MAX = WINDIVERT_PARAM_QUEUE_TIME;

{*
 * Open a WinDivert handle.
 *}
function WinDivertOpen(
  const filter: PAnsiChar;
  layer: TWinDivertLayer;
  priority: INT16;
  flags: UINT64
): THandle; cdecl; external 'windivert.dll';

{*
 * Receive (read) a packet from a WinDivert handle.
 *}
function WinDivertRecv(
  handle: THandle;
  var pPacket;
  packetLen: UINT;
  out pAdd: TWinDivertAddress;
  out readLen: UINT
): BOOL; cdecl; external 'windivert.dll';

{*
 * Receive (read) a packet from a WinDivert handle.
 *}
function WinDivertRecvEx(
  handle: THandle;
  pPacket: Pointer;
  packetLen: UINT;
  flags: UINT64;
  out pAdd: TWinDivertAddress;
  out readLen: UINT;
  var lpOverlapped: TOverlapped
): BOOL; cdecl; external 'windivert.dll';

{*
 * Send (write/inject) a packet to a WinDivert handle.
 *}
function WinDivertSend(
  handle: THandle;
  var pPacket;
  packetLen: UINT;
  pAdd: PWinDivertAddress;
  out writeLen: UINT
): BOOL; cdecl; external 'windivert.dll';

{*
 * Send (write/inject) a packet to a WinDivert handle.
 *}
function WinDivertSendEx(
  handle: THandle;
  pPacket: Pointer;
  packetLen: UINT;
  flags: UINT64;
  pAdd: PWinDivertAddress;
  out writeLen: UINT;
  var lpOverlapped: TOverlapped
): BOOL; cdecl; external 'windivert.dll';

{*
 * Close a WinDivert handle.
 *}
function WinDivertClose(
  handle: THandle
): BOOL; cdecl; external 'windivert.dll';

{*
 * Set a WinDivert handle parameter.
 *}
function WinDivertSetParam(
  handle: THandle;
  param: TWinDivertParam;
  value: UINT64
): BOOL; cdecl; external 'windivert.dll';

{*
 * Get a WinDivert handle parameter.
 *}
function WinDivertGetParam(
  handle: THandle;
  param: TWinDivertParam;
  out pValue: UINT64
): BOOL; cdecl; external 'windivert.dll';

{****************************************************************************}
{* WINDIVERT HELPER API                                                     *}
{****************************************************************************}

{*
 * IPv4/IPv6/ICMP/ICMPv6/TCP/UDP header definitions.
 *}
type
  // http://rvelthuis.de/articles/articles-convert.html#bitfields
  // SizeOf(WINDIVERT_IPHDR) = 20
  WINDIVERT_IPHDR = record
    HdrLength_Version: UINT8; // 1
    TOS: UINT8;              // 1
    Length: UINT16;           // 2
    Id: UINT16;               // 2
    FragOff0: UINT16;         // 2
    TTL: UINT8;               // 1
    Protocol: UINT8;          // 1
    Checksum: UINT16;         // 2
    SrcAddr: UINT32;          // 4
    DstAddr: UINT32;          // 4
  end;
  TWinDivertIpHdr = WINDIVERT_IPHDR;
  PWinDivertIpHdr = ^TWinDivertIpHdr;
  PPWinDivertIpHdr = ^PWinDivertIpHdr;

// Macros
function WINDIVERT_IPHDR_GET_FRAGOFF(hdr: PWinDivertIpHdr): UINT16;
function WINDIVERT_IPHDR_GET_MF(hdr: PWinDivertIpHdr): UINT16;
function WINDIVERT_IPHDR_GET_DF(hdr: PWinDivertIpHdr): UINT16;
function WINDIVERT_IPHDR_GET_RESERVED(hdr: PWinDivertIpHdr): UINT16;

type
  // SizeOf(WINDIVERT_IPV6HDR) = 40
  WINDIVERT_IPV6HDR = record
//    UINT8  TrafficClass0:4;
//    UINT8  Version:4;
    TrafficClass0_Version: UINT8;
//    UINT8  FlowLabel0:4;
//    UINT8  TrafficClass1:4;
    FlowLabel0_TrafficClass1: UINT8;
    FlowLabel1: UINT16;
    Length: UINT16;
    NextHdr: UINT8;
    HopLimit: UINT8;
    SrcAddr: array[0..3] of UINT32;
    DstAddr: array[0..3] of UINT32;
  end;
  TWinDivertIpv6Hdr = WINDIVERT_IPV6HDR;
  PWinDivertIpv6Hdr = ^TWinDivertIpv6Hdr;
  PPWinDivertIpv6Hdr = ^PWinDivertIpv6Hdr;

// Macros
function WINDIVERT_IPV6HDR_GET_TRAFFICCLASS(hdr: PWinDivertIpv6Hdr): UINT8;
function WINDIVERT_IPV6HDR_GET_FLOWLABEL(hdr: PWinDivertIpv6Hdr): UINT32;

type
  WINDIVERT_ICMPHDR = record
    _Type: UINT8;
    Code: UINT8;
    Checksum: UINT16;
    Body: UINT32;
  end;
  TWinDivertIcmpHdr = WINDIVERT_ICMPHDR;
  PWinDivertIcmpHdr = ^TWinDivertIcmpHdr;
  PPWinDivertIcmpHdr = ^PWinDivertIcmpHdr;

  WINDIVERT_ICMPV6HDR = record
    _Type: UINT8;
    Code: UINT8;
    Checksum: UINT16;
    Body: UINT32;
  end;
  TWinDivertIcmpv6Hdr = WINDIVERT_ICMPV6HDR;
  PWinDivertIcmpv6Hdr = ^TWinDivertIcmpv6Hdr;
  PPWinDivertIcmpv6Hdr = ^PWinDivertIcmpv6Hdr;

  // Bitfields are tricky in Delphi
  TTcpHdrFlag = (
    fFin,
    fSyn,
    fRst,
    fPsh,
    fAck,
    fUrg,
    fReserved20, fReserved21
  );
  // This should have approx. 8 Bit, because a set is always 1 Byte (255 elements)
  TTcpHdrFlags = set of TTcpHdrFlag;

const
  TCPHDR_FLAG_FIN   = $01;
  TCPHDR_FLAG_SYN   = $02;
  TCPHDR_FLAG_RST   = $04;
  TCPHDR_FLAG_PSH   = $08;
  TCPHDR_FLAG_ACK   = $10;
  TCPHDR_FLAG_URG   = $20;
  TCPHDR_FLAG_RES20 = $40;
  TCPHDR_FLAG_RES21 = $80;

type
  // SizeOf(WINDIVERT_IPV6HDR) = 20
  WINDIVERT_TCPHDR = record
    SrcPort: UINT16;
    DstPort: UINT16;
    SeqNum: UINT32;
    AckNum: UINT32;
//    UINT16 Reserved1:4;
//    UINT16 HdrLength:4;
    Reserved1_HdrLength: UINT8;
    Flags: UINT8;
    Window: UINT16;
    Checksum: UINT16;
    UrgPtr: UINT16;
  end;
  TWinDivertTcpHdr = WINDIVERT_TCPHDR;
  PWinDivertTcpHdr = ^TWinDivertTcpHdr;
  PPWinDivertTcpHdr = ^PWinDivertTcpHdr;

type
  WINDIVERT_UDPHDR = record
    SrcPort: UINT16;
    DstPort: UINT16;
    Length: UINT16;
    Checksum: UINT16;
  end;
  TWinDivertUdpHdr = WINDIVERT_UDPHDR;
  PWinDivertUdpHdr = ^TWinDivertUdpHdr;
  PPWinDivertUdpHdr = ^PWinDivertUdpHdr;

{*
 * Flags for DivertHelperCalcChecksums()
 *}
const
  WINDIVERT_HELPER_NO_IP_CHECKSUM     =  1;
  WINDIVERT_HELPER_NO_ICMP_CHECKSUM   =  2;
  WINDIVERT_HELPER_NO_ICMPV6_CHECKSUM =  4;
  WINDIVERT_HELPER_NO_TCP_CHECKSUM    =  8;
  WINDIVERT_HELPER_NO_UDP_CHECKSUM    = 16;

{*
 * Parse IPv4/IPv6/ICMP/ICMPv6/TCP/UDP headers from a raw packet.
 *}
function WinDivertHelperParsePacket(
  var pPacket;
  packetLen: UINT;
  ppIpHdr: PPWinDivertIpHdr;
  ppIpv6Hdr: PPWinDivertIpv6Hdr;
  ppIcmpHdr: PPWinDivertIcmpHdr;
  ppIcmpv6Hdr: PPWinDivertIcmpv6Hdr;
  ppTcpHdr: PPWinDivertTcpHdr;
  ppUdpHdr: PPWinDivertUdpHdr;
  ppData: PPointer;
  pDataLen: PUINT
): BOOL; cdecl; external 'windivert.dll';

{*
 * Parse an IPv4 address.
 *}
function WinDivertHelperParseIPv4Address(
  const addrStr: PAnsiChar;
  out pAddr: UINT32
): BOOL; cdecl; external 'windivert.dll';

{*
 * Parse an IPv6 address.
 *}
function WinDivertHelperParseIPv6Address(
  const addrStr: PAnsiChar;
  out pAddr: UINT32
): BOOL; cdecl; external 'windivert.dll';

{*
 * Calculate IPv4/IPv6/ICMP/ICMPv6/TCP/UDP checksums.
 *}
function WinDivertHelperCalcChecksums(
  var pPacket;
  packetLen: UINT;
  flags: UINT64
): UINT; cdecl; external 'windivert.dll';

// Helper
procedure Get4Bits(const X: UINT8; out Lower, Upper: UINT8);
function GetTcpHdrFlags(const TcpHdr: PWinDivertTcpHdr; out Reserved2: UINT8): TTcpHdrFlags;

implementation

{
  Split one 8 Bit value (Byte) into two 4 Bit values.
  @param Lower The lower 4 Bits.
  @param Upper The upper 4 Bits.
}
procedure Get4Bits(const X: UINT8; out Lower, Upper: UINT8);
begin
  Upper := (X shr 4);
  Lower := X - (Upper shl 4);
end;

function GetTcpHdrFlags(const TcpHdr: PWinDivertTcpHdr; out Reserved2: UINT8): TTcpHdrFlags;
begin
  Result := [];
  if TcpHdr = nil then
    Exit;

  if TcpHdr^.Flags and TCPHDR_FLAG_FIN = TCPHDR_FLAG_FIN then
    Include(Result, fFin);
  if TcpHdr^.Flags and TCPHDR_FLAG_SYN = TCPHDR_FLAG_SYN then
    Include(Result, fSyn);
  if TcpHdr^.Flags and TCPHDR_FLAG_RST = TCPHDR_FLAG_RST then
    Include(Result, fRst);
  if TcpHdr^.Flags and TCPHDR_FLAG_PSH = TCPHDR_FLAG_PSH then
    Include(Result, fPsh);
  if TcpHdr^.Flags and TCPHDR_FLAG_ACK = TCPHDR_FLAG_ACK then
    Include(Result, fAck);
  if TcpHdr^.Flags and TCPHDR_FLAG_URG = TCPHDR_FLAG_URG then
    Include(Result, fUrg);
  Reserved2 := 0;
  if TcpHdr^.Flags and TCPHDR_FLAG_RES20 = TCPHDR_FLAG_RES20 then
    Inc(Reserved2);
  if TcpHdr^.Flags and TCPHDR_FLAG_RES21 = TCPHDR_FLAG_RES21 then
    Inc(Reserved2, 2);
end;

function WINDIVERT_IPHDR_GET_FRAGOFF(hdr: PWinDivertIpHdr): UINT16;
begin
  Result := hdr^.FragOff0 and $FF1F;
end;

function WINDIVERT_IPHDR_GET_MF(hdr: PWinDivertIpHdr): UINT16;
begin
  if (hdr^.FragOff0 and $0020) <> 0 then
    Result := 1
  else
    Result := 0;
end;

function WINDIVERT_IPHDR_GET_DF(hdr: PWinDivertIpHdr): UINT16;
begin
  if (hdr^.FragOff0 and $0040) <> 0 then
    Result := 1
  else
    Result := 0;
end;

function WINDIVERT_IPHDR_GET_RESERVED(hdr: PWinDivertIpHdr): UINT16;
begin
  if (hdr^.FragOff0 and $0080) <> 0 then
    Result := 1
  else
    Result := 0;
end;

function WINDIVERT_IPV6HDR_GET_TRAFFICCLASS(hdr: PWinDivertIpv6Hdr): UINT8;
var
  TrafficClass0,
  TrafficClass1: UINT8;
  dummy: UINT8;
begin
  Get4Bits(hdr^.TrafficClass0_Version, TrafficClass0, dummy);
  Get4Bits(hdr^.FlowLabel0_TrafficClass1, dummy, TrafficClass1);
  Result := (TrafficClass0 shl 4) or TrafficClass1;
end;

function WINDIVERT_IPV6HDR_GET_FLOWLABEL(hdr: PWinDivertIpv6Hdr): UINT32;
var
  FlowLabel0: UINT8;
  dummy: UINT8;
begin
  Get4Bits(hdr^.FlowLabel0_TrafficClass1, FlowLabel0, dummy);
  Result := (UINT32(FlowLabel0) shl 16) or (UINT32(hdr^.FlowLabel1));
end;

end.

File 4Top

{
  MapDraw
  Copyright (C) 2010-2012, Stefan Ascher

  @abstract(CCL vectorisation)

  @bold(References)
  @unorderedList(
    @item(http://www.codeproject.com/Articles/407172/Connected-Component-Labeling-and-Vectorization)
    @item(http://www.iis.sinica.edu.tw/papers/fchang/1362-F.pdf)
  )

  @author(Stefan Ascher <sa@stievie.net>)
  @created(20-06-2012)
}

unit uMDCcl;

// Comment out
{$i martis.inc}
{$M+}

interface

uses
  SysUtils, Windows, Classes, Graphics;

const
  { limits.h }
  SHRT_MIN = -32768;
  SHRT_MAX =  32767;

type
  TCclType = Byte;

  { Contour direction flags. }
  TContourDir = (
    dirCW,                // Clockwise contour direction
    dirCCW,               // Counter clockwise contour direction
    dirUnknown            // Unknown contour direction
  );
  TVertexType = LongInt;
  TSDir = record
    _0: SmallInt;
    _1: SmallInt;
  end;

const
  { These are flags for our vertex points above for our shape. }
  VF_NORMAL     = $00;
  VF_DIRECTIONS = $07;    // Lower 3 bits = direction flags (0-7)
  VF_LIFTCLOSE  = $08;    // Open contour .. close vertexes in air

  OUTSIDE_EDGE  = SHRT_MIN;
  INSIDE_EDGE   = SHRT_MIN + 1;

type
  PCclMap2D = ^TCclMap2D;
  TCclMap2D = record
    Width: Smallint;         // CCL map width
    Height: Smallint;        // CCL map height
    Data: PByte;             // CCL map data
  end;

  {
    VERTEX2D BACKGROUND

    Each vertex has flags an co-ords and links to a next and previous vertex.
    A contour consists of a double linked vertex list which is fully circular.
    Thus by definition a contour is always closed if you start at a vertex and
    walk along the vertex list you will come back to that vertex, hence there
    is no notional start and end point.
  }
  PVertex2D = ^TVertex2D;
  TVertex2D = record
    v_flags: Smallint;        // Vertex flags
    x: TVertexType;           // Vertex x co-ord
    y: TVertexType;           // Vertex y co-ord
    next: PVertex2D;          // Next vertex
    prev: PVertex2D;          // Prev vertex
  end;

  {
    CONTOUR2D BACKGROUND

    A contour defines at least one closed vertex list the first vertex of which
    is held in FirstVertex. Direction and CCL index number also recorded.
    Some contours have holes in them which are paired inside contours, for
    example letter B drawn with thickness has an outside contour and two
    inside contours which are the two holes. Any contour can also be linked
    to a previous and next contour to make up the full shape that is defined.
    This record simply provides the appropriate structures to do that.
  }
  PContour2D = ^TContour2D;
  TContour2D = record
    Direction: TContourDir;               // Direction of contour
    Index: Integer;                       // Label index of contour
    FirstVertex: PVertex2D;               // First vertex on this contour
    inside_contours: PContour2D;          // Inside paired contours
    nextpeer: PContour2D;                 // Next peer contour
    prevpeer: PContour2D;                 // Prev peer contour
  end;

  TWordArray = array of Smallint;
  PWordArray = ^TWordArray;
  TWordMatrix = array of TWordArray;
  PWordMatrix = ^TWordMatrix;

  TIntArray = array of Integer;
  TIntMatrix = array of TIntArray;

  TByteArray = array of Byte;
  PByteArray = ^TByteArray;
  TByteMatrix = array of TByteArray;

  TCCLProgressEvent = procedure(Sender: TObject; const PercentDone: integer; var AAbort: boolean) of object;

type
  TMDCcl = class
  private
    fBitmap: TBitmap;
    fHeight: Integer;
    fWidth: Integer;
    fMap: TByteMatrix;
    fLabelMap: TIntMatrix;
    fCount: integer;
    fOnProgress: TCCLProgressEvent;
    // Linked list with contours
    fFirstContour: PContour2D;
    fShowNodes: boolean;
    fMaxProgress: integer;
    fProgressValue: integer;
    function Tracer(var cy, cx: TVertexType;
      var dir: Smallint;
      color: TCclType;
      _label: Integer;
      edgelabel: Integer): boolean;
    procedure SetBitmap(Value: TBitmap);
    function GetData(const x, y: Integer): Byte;
    procedure SetData(const x, y: Integer; AData: Byte);
    function ScanPixels: boolean;
    procedure FreeContour(C: PContour2D);
    procedure DisposeVertexList(firstvertex: PVertex2D);
    {
      Raster to vector conversion of a given image.
      Conversion of code from: "A Linear-Time Component-Labeling Algorithm
      Using Contour Tracing Technique" by Fu Chang, Chun-Jen Chen, and Chi-Jen Lu

      @returns ConnectedComponentsCount
    }
    function Ras2Vec2D(const depthlabel: Word; var connectedcomponentscount: Integer): PContour2D;
    function ContourTracing(const sy, sx: TVertexType;
      _label: Integer;
      colour: TCclType;
      edgelabel: Integer): PVertex2D;
    function CreateVertex2D(const x, y: TVertexType; const flags: Smallint): PVertex2D;
    procedure CreateCCLMap2D(const AWidth, AHeight: Smallint; const AInitLabel: TCclType);
    procedure CreateLabelMap(const AWidth, AHeight: Smallint);
    procedure ProgressStep(var AAbort: boolean);
  protected
    procedure DoOnProgress(const PercentDone: integer; var AAbort: boolean); dynamic;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Process;
    {
      Draw contours to a Canvas
    }
    procedure Draw(x, y: Integer; ACanvas: TCanvas);

    property Data[const x, y: Integer]: Byte read GetData;
    property Count: integer read fCount;
    property Width: integer read fWidth;
    property Height: Integer read fHeight;
    property FirstContour: PContour2D read fFirstContour;
  published
    property ShowNodes: boolean read fShowNodes write fShowNodes; 
    property Bitmap: TBitmap read fBitmap write SetBitmap;
    property OnProgress: TCCLProgressEvent read fOnProgress write fOnProgress;
  end;

implementation

{$ifdef MAPDRAW_PACK}
uses
  uMDTools
{$ifdef DEBUG}
  , uMDUnitTest
{$endif}
  ;
{$endif}

function RgbToGreyscale(Col: COLORREF): Byte;
var
  r, g, b: Byte;
  Grey: Single;
begin
  r := GetRValue(Col);
  g := GetGValue(Col);
  b := GetBValue(Col);
  Grey := 0.30 * r + 0.59 * g + 0.11 * b;
  Result := FastTrunc(Grey);
end;

{ TMDCcl }

constructor TMDCcl.Create;
begin
  inherited;
  fBitmap := TBitmap.Create;
  fFirstContour := nil;
end;

destructor TMDCcl.Destroy;
begin
  if fFirstContour <> nil then
    FreeContour(fFirstContour);
  fBitmap.Free;
  fMap := nil;
  fLabelMap := nil;  
  inherited;
end;

procedure TMDCcl.DoOnProgress(const PercentDone: integer; var AAbort: boolean);
begin
  if Assigned(fOnProgress) then
    fOnProgress(Self, PercentDone, AAbort);
end;

function TMDCcl.GetData(const x, y: Integer): Byte;
begin
  Assert(y <= High(fMap));
  Assert(x <= High(fMap[y]));
  Result := fMap[y][x];
end;

procedure TMDCcl.SetData(const x, y: Integer; AData: Byte);
begin
  fMap[y][x] := AData;
end;

procedure TMDCcl.DisposeVertexList(firstvertex: PVertex2D);
var
  p, q: PVertex2D;
begin
  p := firstvertex;
  while (p <> nil) do begin
    q := p^.next;
    Dispose(p);
    p := q;
    if (p = firstvertex) then
      p := nil;
  end;
end;

procedure TMDCcl.FreeContour(C: PContour2D);
var
  p, q: PContour2D;
begin
  p := C;
  while (p <> nil) do begin
    if p^.FirstVertex <> nil then
      DisposeVertexList(p^.FirstVertex);
    if p^.inside_contours <> nil then
      FreeContour(p^.inside_contours);
    q := p^.nextpeer;
    Dispose(p);
    p := q;
    if (p = c) then
      p := nil;
  end;
end;

procedure TMDCcl.SetBitmap(Value: TBitmap);
begin
  fBitmap.Assign(Value);
  fHeight := fBitmap.Height;
  fWidth := fBitmap.Width;
  fBitmap.PixelFormat := pf24Bit;
end;

procedure TMDCcl.Draw(x, y: Integer; ACanvas: TCanvas);
var
  X1, Y1, Tx, Ty: integer;
  P: PVertex2D;
  Q, PQ, IQ: PContour2D;
begin
  SelectObject(ACanvas.Handle, GetStockObject(DC_PEN));
  SetDCPenColor(ACanvas.Handle, RGB($FF, $FF, $FF));
  X1 := x;
  Y1 := y;
  PQ := fFirstContour;
  if (PQ <> nil) then
    IQ := PQ^.inside_contours
  else
    IQ := nil;

  while (PQ <> nil) do begin
    if (IQ <> nil) then begin
      Q := IQ;
      IQ := IQ^.nextpeer;
    end else begin
      Q := PQ;
      PQ := PQ^.nextpeer;
      if (PQ <> nil) then
        IQ := PQ^.inside_contours
      else
        IQ := nil;
    end;

    case Q^.Direction of
      dirCW:
        SetDCPenColor(ACanvas.Handle, RGB($00,$00,$FF));
      dirCCW:
        SetDCPenColor(ACanvas.Handle, RGB($FF,$00,$00));
      dirUnknown:
        SetDCPenColor(ACanvas.Handle, RGB($00,$FF,$FF));
    end;

    P := Q^.FirstVertex;
    ACanvas.MoveTo(X1 + P^.x, Y1 + P^.y);

    repeat
      P := P^.next;
      if (P^.v_flags and VF_LIFTCLOSE) = 0 then
        ACanvas.LineTo(X1 + P^.x, Y1 + P^.y);
    until (P = Q^.FirstVertex);

    if fShowNodes then begin
      SetDCPenColor(ACanvas.Handle, RGB($FF,$00,$00));
      P := Q^.FirstVertex;
      repeat
        Tx := X1 + P^.x;
        Ty := Y1 + P^.y;
        ACanvas.MoveTo(Tx - 3, Ty - 3);
        ACanvas.LineTo(Tx + 4, Ty + 4);
        ACanvas.MoveTo(Tx + 3, Ty - 3);
        ACanvas.LineTo(Tx - 4, Ty + 4);
        if (P = Q^.FirstVertex) then
          SetDCPenColor(ACanvas.Handle, RGB($FF,$FF,$FF));
        P := P^.next;
      until (P = Q^.FirstVertex);
    end;
  end;
end;

function TMDCcl.ScanPixels: boolean;
type
  TRGBTripleRow = array[0..High(Word)-1] of TRGBTriple;
  PRGBTripleRow = ^TRGBTripleRow;
var
  x, y: integer;
  Col: COLORREF;
  i: Byte;
  cancel: boolean;
  pp: PRGBTripleRow;
begin
  // FILLING THE CCL_MAP WIH B/W DATA FROM THE BITMAP LOOP
  cancel := false;

  for y := 0 to fHeight - 1 do begin

    ProgressStep(cancel);
    if cancel then
      Break;
    pp := fBitmap.ScanLine[y];

    for x := 0 to fWidth - 1 do begin
      Col := RGB(pp[x].rgbtRed, pp[x].rgbtGreen, pp[x].rgbtBlue);
      if RgbToGreyscale(Col) < 128 then
        i := 1
      else
        i := 0;
      SetData(x+1, y+1, i);
    end;
  end;

  Result := not cancel;
end;

procedure TMDCcl.CreateLabelMap(const AWidth, AHeight: Smallint);
var
  i, j: integer;
begin
  SetLength(fLabelMap, AHeight);
  for i := 0 to AHeight - 1 do begin
    SetLength(fLabelMap[i], AWidth);
    for j := 0 to AWidth - 1 do begin
      fLabelMap[i][j] := 0;
    end;
  end;
end;

procedure TMDCcl.CreateCCLMap2D(const AWidth, AHeight: Smallint; const AInitLabel: TCclType);
var
  i, j: integer;
begin
  SetLength(fMap, AHeight);
  for i := 0 to AHeight - 1 do begin
    SetLength(fMap[i], AWidth);
    for j := 0 to AWidth - 1 do begin
      fMap[i][j] := AInitLabel;
    end;
  end;
end;

procedure TMDCcl.Process;
var
  c: Integer;
begin
  if fFirstContour <> nil then
    FreeContour(fFirstContour);
  if (fWidth > High(Word)-2) or (fHeight > High(Word)-2) then
    raise Exception.Create('Bitmap too large');

  fProgressValue := 0;
  fMaxProgress := fHeight * 2;
  fMap := nil;
  CreateCCLMap2D(fWidth + 2, fHeight + 2, 0);

  ScanPixels;
  c := 0;
  fFirstContour := Ras2Vec2D(0, c);
  fCount := c;
end;

function TMDCcl.CreateVertex2D(const x, y: TVertexType; const flags: Smallint): PVertex2D;
begin
  New(Result);
  Result^.x := x;
  Result^.y := y;
  Result^.v_flags := flags;
end;

function TMDCcl.Tracer(var cy, cx: TVertexType;
  var dir: Smallint;
  color: TCclType;
  _label: Integer;
  edgelabel: Integer): boolean;
const
  {
    This is does a connect 8 test on the pixels adjacent to the given pixel.
    It starts at the given direction and tests clockwise thru each of the 8
    neighbour pixels looking for a colour match or already marked pixel.
  }
  SearchDirection: array[0..7] of TSDir = (
    (_0:  0; _1:  1),
    (_0:  1; _1:  1),
    (_0:  1; _1:  0),
    (_0:  1; _1: -1),
    (_0:  0; _1: -1),
    (_0: -1; _1: -1),
    (_0: -1; _1:  0),
    (_0: -1; _1:  1)
  );
var
  i: Smallint;
  x, y: TVertexType;
begin
  for i := 0 to 6 do begin
    y := cy + SearchDirection[dir]._0;
    x := cx + SearchDirection[dir]._1;
    if (GetData(x, y) = color) and
      ((fLabelMap[y][x] = 0) or (fLabelMap[y][x] = _label)) then begin
      fLabelMap[y][x] := _label;
      cy := y;
      cx := x;
      Result := true;
      Exit;
    end else begin
      if (fLabelMap[y][x] = 0) then
        fLabelMap[y][x] := edgelabel;
      dir := (dir + 1) mod 8;
    end;
  end;

  Result := false;
end;

function TMDCcl.ContourTracing(const sy, sx: TVertexType;
  _label: Integer;
  colour: TCclType;
  edgelabel: Integer): PVertex2D;
var
  Fv, Cv, P: PVertex2D;
  cx, cy: TVertexType;
  dir, ldir: Smallint;
begin
  cx := sx;
  cy := sy;
  Fv := nil;
  dir := 0;
  if Tracer(cy, cx, dir, colour, _label, edgelabel) then begin
    Fv := CreateVertex2D(sx, sy, dir);
    Fv^.next := nil;
    Fv^.prev := nil;
    Cv := Fv;
    ldir := dir;
    P := CreateVertex2D(cx, cy, 0);
    P^.prev := Cv;
    Cv^.next := P;
    P^.next := nil;
    Cv := P;
    repeat
      dir := (dir + 6) mod 8;
      Tracer(cy, cx, dir, colour, _label, edgelabel);
      if (ldir <> dir) then begin
        Cv^.v_flags := dir;
        P := CreateVertex2D(cx, cy, 0);
        P^.prev := Cv;
        Cv^.next := P;
        P^.next := nil;
        Cv := P;
      end else begin
        Cv^.v_flags := ldir;
        Cv^.x := cx;
        Cv^.y := cy;
      end;
      ldir := dir;
    until (cx = sx) and (cy = sy);
    Fv^.prev := Cv^.prev;
    Cv^.prev^.next := Fv;
    Dispose(Cv);
  end;
  Result := Fv;
end;

function TMDCcl.Ras2Vec2D(const depthlabel: Word; var connectedcomponentscount: Integer): PContour2D;
var
  colour, bc: Byte;
  lc, labelindex: Integer;
  cx, cy: TVertexType;
  colormap: array of Byte;
  colormap_size: Cardinal;
  vertex: PVertex2D;
  p, cc, sc: PContour2D;
  cancel: boolean;

  procedure SetColor(const i: integer; const c: Byte);
  begin
    if Cardinal(i) > colormap_size - 1 then begin
      if i >= MaxInt then
        raise EOutOfMemory.Create('Out of memory');
      colormap_size := i + 4096;
      if colormap_size > Cardinal(MaxInt) then
        raise EOutOfMemory.Create('Out of memory');
      SetLength(colormap, colormap_size);
    end;
    colormap[i] := c;
  end;

begin
  connectedcomponentscount := 0;
  cancel := false;
  CreateLabelMap(fWidth + 2, fHeight + 2);

  colormap_size := SHRT_MAX + 2;
  SetLength(colormap, colormap_size);

  // Background colour set
  colormap[0] := GetData(0, 0);
  cc := nil;

  for cy := 1 to fHeight do begin
    ProgressStep(cancel);
    if cancel then
      Break;

    labelindex := 0;
    bc := colormap[0];
    for cx := 1 to fWidth do begin
      if fLabelMap[cy][cx] = 0 then begin
        colour := GetData(cx, cy);
        if colour <> bc then begin
          if labelindex = 0 then begin
            lc := connectedcomponentscount + 1;
            SetColor(lc, colour);
            bc := colour;
            vertex := ContourTracing(cy, cx, lc, colour, OUTSIDE_EDGE);
            if vertex <> nil then begin
              Inc(connectedcomponentscount);
              labelindex := lc;
              New(p);
              p^.Direction := dirCW;
              p^.Index := labelindex;
              p^.FirstVertex := vertex;
              p^.nextpeer := cc;
              p^.prevpeer := nil;
              p^.inside_contours := nil;
              if (cc <> nil) then
                cc^.prevpeer := p;
              cc := p;
            end;
          end else begin
            vertex := ContourTracing(cy, cx, INSIDE_EDGE, colour, labelindex);
            if vertex <> nil then begin
              New(p);
              p^.FirstVertex := vertex;
              p^.inside_contours := nil;
              if depthlabel = 0 then
                p^.Direction := dirCCW
              else
                p^.Direction := dirCW;
              p^.Index := depthlabel;
              p^.nextpeer := nil;
              sc := cc;
              while (sc <> nil) and (sc^.Index <> labelindex) do begin
                sc := sc^.nextpeer;
              end;
              if (sc <> nil) then begin
                p^.nextpeer := sc^.inside_contours;
                if (sc^.inside_contours <> nil) then
                  sc^.inside_contours^.prevpeer := p;
                sc^.inside_contours := p;
              end else begin
                // SHOULD BE IMPOSSIBLE TO GET HERE BUT FOR SAFETY
                Dispose(p);
              end;
            end;
          end;
        end else begin
          fLabelMap[cy][cx] := labelindex;
        end;
      end else if (fLabelMap[cy][cx] = OUTSIDE_EDGE) or (fLabelMap[cy][cx] = INSIDE_EDGE) then begin
        labelindex := 0;
        if fLabelMap[cy][cx] = INSIDE_EDGE then
          bc := GetData(cx, cy)
        else
          bc := colormap[0];
      end else begin
        labelindex := fLabelMap[cy][cx];
        bc := colormap[labelindex];
      end;
    end;
  end;
  colormap := nil;

  if not cancel then begin
    sc := cc;
    while (sc <> nil) do begin
      sc^.Index := depthlabel;
      sc := sc.nextpeer;
    end;
    Result := cc;
  end else begin
    Result := nil;
  end;
end;

procedure TMDCcl.ProgressStep(var AAbort: boolean);
begin
  Inc(fProgressValue);
  DoOnProgress(GetPercent(fMaxProgress, fProgressValue), AAbort);
end;

end.