Sorry your browser is not supported!

// grab Memory Block pixels into an array from screen to store each fill area as a seperate value
function StoreFillPixels ( memBlockInput, img_width, img_height, colour_back )
		
	for y = 0 to img_height
		for x = 0 to img_width
			pixelStore [ img_width, img_height ] = 0
		next x
	next y
	for i = 0 to 20000
		pixelStoreStack [ i ] = 0
	next i 
	
			
	newFillAreaRow = 0
	
	for rows = 1 to img_height
		for columns = 1 to img_width
			
			colour_test = GetPixel ( memBlockInput, columns-1, rows-1, img_width )
			
			if colour_test = colour_back
				colourAbove = 0
				colourLeft = 0
				if rows > 1 then colourAbove = pixelStore [ columns, rows - 1 ]
				if columns > 1 then colourLeft = pixelStore [ columns - 1 , rows ]
				
				if colourAbove = 0 and colourLeft = 0
					newFillAreaRow = newFillAreaRow + 1
					fillAreaNum = newFillAreaRow
					pixelStoreStack [ newFillAreaRow ] = rows
				else
					if colourLeft <> 0 and colourAbove <> 0
						if colourLeft = colourAbove
							fillAreaNum = colourLeft
						else
							newColour = colourAbove
							oldColour = colourLeft
							
							// Checks rows/columns for new number that should be same as current fill and changes to this
							for rowsAgain = pixelStoreStack [ oldColour ] to rows
								for columnsAgain = 1 to img_width
									if pixelStore [ columnsAgain, rowsAgain ] = oldColour
										pixelStore [ columnsAgain, rowsAgain ] = newColour
										if rowsAgain < pixelStoreStack [ newColour ] then pixelStoreStack [ newColour ] = rowsAgain
									endif
								next columnsAgain
							next rowsAgain
							
							fillAreaNum = newColour
						endif
					else
						fillAreaNum = colourLeft + colourAbove
					endif
				endif
				pixelStore [ columns, rows ] = fillAreaNum
			endif
			
		next columns
	next rows
	
endfunction

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtDlgs, Vcl.ExtCtrls, Vcl.Menus,pngImage,
  Vcl.StdCtrls;
type
  TYminmax = record
    iLeft,iTop,iWidth,iHeight: integer;
  end;
type
  TForm_main = class(TForm)
    Panel1: TPanel;
    MainMenu1: TMainMenu;
    Files1: TMenuItem;
    Openimage1: TMenuItem;
    Image1: TImage;
    Image2: TImage;
    OpenPictureDialog1: TOpenPictureDialog;
    Button_scan: TButton;
    ListBox1: TListBox;
    SaveDialog1: TSaveDialog;
    Options1: TMenuItem;
    Mainpicturetransparent1: TMenuItem;
    procedure Openimage1Click(Sender: TObject);
    procedure Button_scanClick(Sender: TObject);
    procedure Mainpicturetransparent1Click(Sender: TObject);
  private
    { Private declarations }
    fFilename : TFileName;
    pwidth,pheight : integer;
    cBackground, cEdge: TColor;
    fillsdone : integer;
    bmp : tbitmap;
    minyindex: array[0..255] of TYminmax;
    function GetColours: boolean;
    function DoFills:boolean;
    procedure rep(const s : string);
    procedure BitmapFileToPNG(const inbmp: TBitmap;Dest: String;trans: boolean = true);
    procedure GetMaxIndex;
    procedure MakePNGs;
  public
    { Public declarations }
  end;

var
  Form_main: TForm_main;

implementation
Uses system.zip;
type
  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array[0..4095] of TRGBTriple;
{$R *.dfm}
procedure TForm_main.BitmapFileToPNG(const inbmp: TBitmap;Dest: String;trans:boolean = true);
var

  PNG: TPNGImage;
begin

  PNG := TPNGImage.Create;
  png.CompressionLevel := 9;
  {In case something goes wrong, free both Bitmap and PNG}
  try
    PNG.Assign(inbmp);    //Convert data into png
    if trans then PNG.TransparentColor := clBlack;
    PNG.SaveToFile(Dest);
  finally
    PNG.Free;
  end
end;

procedure TForm_main.Button_scanClick(Sender: TObject);

begin
  cursor := crHourGlass;

  try
    bmp := tBitmap.Create;
    bmp.Width := pWidth;
    bmp.Height := pHeight;
    bmp.PixelFormat := pf24bit;
    Bmp.Canvas.Draw(0, 0, image1.Picture.Graphic);
    rep('Scanning key colours');
    if not GetColours then
    begin
      rep('Get key colours error');
      ShowMessage('ERROR: Could not get the key colours!');
      exit;
    end;
    rep('Flood filling');
    DoFills;

   GetMaxIndex;

   Rep('Saving files...');
   MakePNGs;
   rep('Done');
  finally
    bmp.Free;
    button_scan.enabled := false;
    cursor := crDefault;
  end;
end;

function TForm_main.DoFills: boolean;
var x,y : integer;
     cv : TCanvas;
begin
  result := true;
  fillsdone := 0;
  fillchar(minYIndex,sizeof(MinYIndex),#0);

  cursor := crHourGlass;
  cv := bmp.Canvas;
  cv.Brush.Style := bsSolid;

  for y := 0 to pHeight-1 do
    begin

      for x := 0 to pWidth-1 do
        begin
          if cv.Pixels[x,y]=cBackground then
          begin
            inc(fillsdone);
            cv.Brush.Color := TColor(fillsdone);
            cv.FloodFill(x,y,cEdge,fsBorder);
          end;
        end;
    end;
 image2.Picture.Bitmap.Assign(bmp);
 cursor := crDefault;
 rep('There are '+inttostr(fillsdone)+' regions');

end;


function TForm_main.GetColours:boolean;
var x,y : integer;
    errors : integer;

begin
 result := true; errors := 0;
 try

   cBackground := bmp.Canvas.Pixels[0,0];
   if bmp.PixelFormat= pf24bit then rep('Pixel format 24-bit') else rep('Pixelformat<>pf24-bit');
   

   for x := 0 to pwidth-1 do
     for y:= 0 to pHeight-1 do
     begin
       if bmp.Canvas.Pixels[x,y]<>cBackground then
       begin
         cEdge := bmp.Canvas.Pixels[x,y];
         break;
       end;

     end;

    for x := 0 to pwidth-1 do
     for y:= 0 to pHeight-1 do
     begin
       if (bmp.Canvas.Pixels[x,y]<>cBackground) and (bmp.Canvas.Pixels[x,y]<>cEdge) then
       begin
         bmp.Canvas.Pixels[x,y]:=cBackground;
         inc(errors);
       end;

     end;

     rep ('Colour errors = '+inttostr(errors));
 except
   result := false;
 end;
end;

procedure TForm_main.GetMaxIndex;

var x, y : integer;
    idx  :integer;
    I    : Integer;
   C     : tcolor;
  cval   : TRGBTriple;
  row    : PRGBTripleArray;

begin
 rep('Computing bounds');
  fillchar(MinYIndex,sizeof(MinYIndex), #0);
  for I := low(Minyindex) to High(minYindex) do
  begin
    minyindex[I].iLeft := MAXINT;
    minyindex[I].iTop := MAXINT;
  end;

 for idx := 1 to fillsdone do
 begin

 cval.rgbtRed := idx;

  for y :=0 to pheight-1 do
  begin
   row := bmp.ScanLine[Y];

    for x := 0 to pwidth-1 do
      begin
        C :=row[x].rgbtRed;
        if C=cval.rgbtRed then
        begin

          if X<MinYIndex[idx].iLeft then MinYIndex[idx].iLeft := X;
          if Y<MinYIndex[idx].iTop then MinYIndex[idx].iTop := Y;
          if X>MinYIndex[idx].iWidth then MinYIndex[idx].iWidth := X;
          if Y>MinYIndex[idx].iheight then MinYIndex[idx].iHeight := Y;
        end;

      end;
    end;
  end;

for i := 1 to fillsdone do
  begin
    MinYIndex[I].iWidth := MinYIndex[I].iWidth - MinYIndex[I].iLeft + 1;
    MinYIndex[I].iHeight := MinYIndex[I].iHeight - MinYIndex[I].iTop;
  end;

end;

procedure TForm_main.Mainpicturetransparent1Click(Sender: TObject);
begin
   Mainpicturetransparent1.Checked := not Mainpicturetransparent1.Checked;
end;

procedure TForm_main.MakePNGs;
var x,y : integer;
   idx  : integer;
   fname : string;
   newbitmap : TBitmap;
   C : tcolor;
   cval : TRGBTriple;
   inrow,outrow :PRGBTripleArray;
   outy, off: integer;
   frag : string;
   zf : TZipFile;
   tfs : TFileStream;
begin
 // create all the sub-images
 newbitmap := nil; inrow := nil;
 zf:= TZipFile.Create;
 zf.Open(ffilename+'.zip',zmWrite);
 for idx := 1 to fillsdone  do
   begin
    cval.rgbtRed := idx;
    outy := 0;
      try
       newbitmap := tBitmap.Create;
       newbitmap.PixelFormat := pf24bit;
       newbitmap.Width := MinYIndex[idx].iWidth;
       newbitmap.Height := MinYIndex[idx].iHeight;

      // blit the required values

       for y := MinYIndex[idx].iTop to (MinYIndex[idx].iTop+ (MinYIndex[idx].iHeight-1))  do
       begin

         if y>=pheight then continue;
         
         try
         inrow := bmp.ScanLine[y];
         except
          showmessage('Except: '+inttostr(y));
          exit;
         end;
         outrow:= newbitmap.ScanLine[outy];//newbitmap.ScanLine[y-MinYIndex[idx].iTop];
         off := 0;
         for x := MinYIndex[idx].iLeft to MinYIndex[idx].iLeft + MinYIndex[idx].iWidth Do
           begin
              C :=inrow[x].rgbtRed;
             if C=cval.rgbtRed then begin
               outrow[off].rgbtred := 255;

             end else begin
               outrow[off].rgbtred := 0;
               outrow[off].rgbtblue := 0;
               outrow[off].rgbtgreen := 0;
             end;
             inc(off);
           end;

         inc(outy);
       end;
       frag := inttostr(idx);

       if idx<10 then frag := '00'+frag
       else
       if idx<100 then frag := '0'+ frag;

       fname := 'op'+frag+'.png';
       BitMapFiletoPNG(newbitmap,fname);
       zf.Add(fname);
       Deletefile(fname);
      finally
       newbitmap.Free;
      end;

   end;
   // save the master image

   BitMapFileToPNG(bmp,'master.png',mainpicturetransparent1.checked);
   zf.Add('master.png');
   deletefile('master.png');
  // tfs := nil;
   try
     tfs := TFileStream.Create('map.dat', fmCreate or fmShareDenyWrite);
     minyindex[0].iLeft:= fillsdone;
     tfs.write(minyindex,sizeof(minYIndex));
     tfs.Free;
     zf.Add('map.dat');
     deletefile('map.dat');
   finally
     // had to free it before this!
   end;
   zf.Close;
end;

procedure TForm_main.Openimage1Click(Sender: TObject);
begin
  if openpicturedialog1.execute then
  begin
   listbox1.Clear;
   try
    fFilename := openpicturedialog1.FileName;
    image1.Picture.LoadFromFile(fFilename);
    image2.Picture.Assign(image1.picture);
    pwidth := image1.Width;
    pheight := image1.Height;
    rep(Format('Dimensions %dx%d',[pwidth,pheight]));
    button_scan.Enabled := true;
   except
     rep('IMAGE LOAD ERROR');
     ShowMessage('ERROR: Unable to load this picture!');
   end;
  end;
end;

procedure TForm_main.rep(const s: string);
begin
   listbox1.Items.Add(s);
   listbox1.Update;
end;

end.

// Project: Pixel Store

// Variables and Array setup
/*
Type BoxType
	xTop as integer
	yTop as integer
	xBottom as integer
	yBottom as integer
Endtype

box as Boxtype[800]
*/
global pixelStore as integer[ 1150, 800 ]
global pixelStoreStack as integer[ 20000 ]

imgWidth = 1150
imgHeight = 800

drawImageScrNum = 1

// set screen properties and images

drawImage = LoadImage ( "/media/PIC1.png" )
memBlock = CreateMemblockFromImage ( drawImage )

// Grab first pixel and set the colour as background colour, this will not be a black line on the pic
colour_backGrnd = GetPixel ( memBlock, 0, 0, imgWidth ) // In this case RGB - white


// set display properties
SetVirtualResolution( imgWidth, imgHeight )
SetOrientationAllowed( 1, 1, 1, 1 ) 
SetSyncRate ( 60, 0 )

StoreFillPixels ( memBlock, imgWidth, imgHeight, colour_backGrnd ) 

CreateSprite ( drawImageScrNum, drawImage )
SetSpritePosition ( drawImageScrNum, 0, 0 )

sync ()
ColNumber = 0
SetPrintColor( 0, 0, 100 )


// ***** Main Game Loop *****
do
	if GetPointerPressed()=1
	
		mouseX = GetPointerX()
		mouseY = GetPointerY()
		while GetPointerReleased()=0
			Sync()
		endwhile
		
		if mouseX >= 0 and mouseX <= imgWidth and mouseY >= 0 and mouseY <= imgHeight
			pixelcheck = pixelStore [ mouseX+1, mouseY+1 ]
		endif
	endif
	
	Print(pixelcheck)
	
    Sync()
   	
loop

// grab Memory Block pixels into an array from screen to store each fill area as a seperate value
function StoreFillPixels ( memBlockInput, img_width, img_height, colour_back )
		
	for y = 0 to img_height
		for x = 0 to img_width
			pixelStore [ img_width, img_height ] = 0
		next x
	next y
	for i = 0 to 20000
		pixelStoreStack [ i ] = 0
	next i 
				
	newFillAreaRow = 0
	/*
	This For/Next routine checks every pixel in the memBlock and also checks the pixel
	above and to the left for areas to fill with numbers.
	This creates an Array with numbers similar to a Picture By Numbers card.
	*/
	for rows = 1 to img_height
		for columns = 1 to img_width
			// Sets colour_test to pixel value at co-ords in the memBlock
			colour_test = GetPixel ( memBlockInput, columns-1, rows-1, img_width )
			// If the colour_test is equal to the background colour then find fill area (zero is a black line so will leave Array value as zero)
			if colour_test = colour_back
				// Sets pixels above and left to zero incase rows and columns are at the edge of the screen
				colourAbove = 0
				colourLeft = 0
				// Checks for edge of screen
				if rows > 1 then colourAbove = pixelStore [ columns, rows - 1 ]
				if columns > 1 then colourLeft = pixelStore [ columns - 1 , rows ]
				
				if colourAbove = 0 and colourLeft = 0
					newFillAreaRow = newFillAreaRow + 1
					fillAreaNum = newFillAreaRow
					pixelStoreStack [ newFillAreaRow ] = rows
				else
					if colourLeft <> 0 and colourAbove <> 0
						if colourLeft = colourAbove
							fillAreaNum = colourLeft
						else
							newColour = colourAbove
							oldColour = colourLeft
							/*
							The below For/Next Stack:
							Checks rows/columns for new fill area number that
							has been created and if this area is not enclosed
							with a black line changes these numbers to the correct
							fill area number							
							*/
							for rowsAgain = pixelStoreStack [ oldColour ] to rows
								for columnsAgain = 1 to img_width
									if pixelStore [ columnsAgain, rowsAgain ] = oldColour
										pixelStore [ columnsAgain, rowsAgain ] = newColour
										if rowsAgain < pixelStoreStack [ newColour ] then pixelStoreStack [ newColour ] = rowsAgain
									endif
								next columnsAgain
							next rowsAgain
							
							fillAreaNum = newColour
						endif
					else
						fillAreaNum = colourLeft + colourAbove
					endif
				endif
				// Sets a fill area value to the pixelStore Array - This Array is the same size as the colouring screen
				pixelStore [ columns, rows ] = fillAreaNum
			endif
			
		next columns
	next rows
endfunction

function GetPixel ( memBlockIn, x, y, width )
	
	offsetPixel = 12 + (( x + ( y * width )) * 4 )
	PixelColourRGB = GetMemBlockInt ( memBlockIn, offsetPixel )
	
endfunction PixelColourRGB