1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:

type
  // eine Fläche des Graphen
  TPlane = class(TObject)
  private
    FOwner: TPlanarGraph;
    //...
  public
    constructor Create(AOwner: TPlanarGraph; const AID,X,Y: Integer);
    destructor Destroy; override;
    property ID: Integer read FID; // ID der Fläche (=Index)
    property Point: TPoint read FPoint; // Koordinaten eines Punktes in der Fläche
    property Color: TColor read FColor write SetColor; // aktuelle Flächenfarbe (GUI)
    property ColorIndex: Integer read FColorIndex write FColorIndex; // Farbindex (für korrekte Färbung)
    procedure SetColorByIndex; // Farbe aus ColorIndex ableiten und setzen
    property Connections: TList read FConnections; // Liste der angrenzenden Flächen
    function IsColorIndexValid: Boolean; // haben angrenzende Flächen andere Farben?
  end;

  // der planare Graph als Flächenliste
  TPlanarGraph = class(TObjectList)
  private
    FImageRef: TImage;  // GUI-Image-Komponente, die die Kartengrafik enthält
    FPlaneMap: TBitmap; // interne Kartengrafik zur Flächenidentifikation
  public
    constructor Create;
    destructor Destroy; override;
    procedure Pickup(AImage: TImage); // Graph aus einer Kartengrafik ableiten und färben
    property Plane[const AIndex: Integer]: TPlane read GetPlane;
    function GetPlaneByPoint(Point: TPoint): TPlane;
    procedure SetColorByIndex; // alle Flächen passend zum ColorIndex färben (GUI)
  end;

implementation

// -----------------------------------------------------------------------------
// TPlane

// eine neue Fläche anlegen
constructor TPlane.Create(AOwner: TPlanarGraph; const AID,X,Y: Integer);
begin
  inherited Create;
  FConnections := TList.Create;
  FOwner := AOwner; // Eigentümer merken, wird für GUI-Zugriff und Flächenidentifikation benötigt
  FID := AID;
  FPoint.X := X;
  FPoint.Y := Y;
  FColorIndex := -1;
  with FOwner.FPlaneMap.Canvas do begin // Fläche mit der ID als Farbe markieren
    Brush.Color := FID; // Fläche mit dieser Farbe (=ID)...
    FloodFill(FPoint.X,FPoint.Y,Pixels[FPoint.X,FPoint.Y],fsSurface); // ...ausmalen
  end;
end;

// entsprechende Fläche im GUI-Image färben
procedure TPlane.SetColor(const Value: TColor);
begin
  if (FColor <> Value) then begin // notwendig?
    FColor := Value;
    with FOwner.FImageRef.Picture.Bitmap.Canvas do begin // GUI-Image-Referenz aus der Graphenklasse
      Brush.Color := FColor;
      FloodFill(FPoint.X,FPoint.Y,Pixels[FPoint.X,FPoint.Y],fsSurface);
    end;
  end;
end;

// ColorIndex in eine Farbe aus der Default-Farbtabelle umsetzen
procedure TPlane.SetColorByIndex;
begin
  SetColor(GraphColor[2,FColorIndex]);
end;

// herausfinden, ob die angrenzenden Flächen einen anderen ColorIndex haben
function TPlane.IsColorIndexValid: Boolean;
  var
    i: Integer;
begin
  Result := FALSE; // Default: ColorIndex kommt in der Umgebung vor
  for i := 0 to FConnections.Count-1 do // alle angrenzenden Flächen absuchen
    if (TPlane(FConnections.Items[i]).ColorIndex = FColorIndex) then // gleich dem eigenen?
      Exit; // ja, dann raus hier
  Result := TRUE; // alle angrenzenden Flächen sind anders gefärbt
end;

// -----------------------------------------------------------------------------
// TPlanarGraph

constructor TPlanarGraph.Create;
begin
  inherited Create;

  FPlaneMap := TBitmap.Create;
end;

// Wrapper-Array-Eigenschaft, um die Typecasts zu vermeiden
function TPlanarGraph.GetPlane(const AIndex: Integer): TPlane;
begin
  Result := TPlane(Items[AIndex]);
end;

// Fläche über die Koordinaten eines Punktes bestimmen (oder NIL liefern)
function TPlanarGraph.GetPlaneByPoint(Point: TPoint): TPlane;
  var
    PlaneID: Integer;
begin
  Result := NIL; // Default: an diesem Punkt ist keine Fläche
  if (Count > 0) then begin // überhaupt Flächen da?
    PlaneID := FPlaneMap.Canvas.Pixels[Point.X,Point.Y]; // Farbe ist Flächen-ID
    if (PlaneID <= Count) then // Randpixel haben $FEFEFE als Farbe
      Result := GetPlane(PlaneID); // Fläche über Index identifiziert
  end;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:

procedure TPlanarGraph.Pickup(AImage: TImage);
  var
    x,y: Integer;
    ScanLine: PByteArray;
    Plane: TPlane;
    TempPlanes: TList;

  procedure ExaminePixelEnvironment(const BaseX, BaseY: Integer); // siehe unten

  function Colorize(const APlaneID: Integer): Boolean; // siehe unten

begin
  Self.Clear; // alte Flächen entsorgen
  if Assigned(AImage) then begin // das GUI-Image muss gültig sein
    AImage.Picture.Bitmap.PixelFormat := pf24bit; // Pixelformat erzwingen
    FImageRef := AImage; // Referenz merken
    FPlaneMap.Assign(AImage.Picture.Bitmap); // Kopie anfertigen -> interner Gebrauch
    for y := 0 to FPlaneMap.Height-1 do begin // alle Zeilen der Kopie durchgehen
      ScanLine := FPlaneMap.ScanLine[y]; // Zeilenreferenz wg. Zugriffsgeschwindigkeit
      for x := 0 to 3*FPlaneMap.Width-1 do // alle Pixel normieren: weiß->weiß, schwarz->$FEFEFE
        Scanline^[x] := 254 or (Scanline^[x] and 1); // 255->255; 0->254
    end;
    // =A=Flächen=finden=====================================================================
    for y := 1 to FPlaneMap.Height-2 do // alle Zeilen
      for x := 1 to FPlaneMap.Width-2 do // und alle Spalten
        if (FPlaneMap.Canvas.Pixels[x,y] = clWhite) then // nach weißen Pixeln absuchen
          Add(TPlane.Create(Self,Self.Count,x,y)); // neue Fläche vermerken
    // ======================================================================================
    if (Self.Count > 0) then begin // sind überhaupt Flächen da?
      TempPlanes := TList.Create;
      try
        // =B=Flächenverbindungen=bestimmen======================================================
        for y := 1 to FPlaneMap.Height-2 do // Randlinien-Pixel und die 8 umliegenden untersuchen
          for x := 1 to FPlaneMap.Width-2 do
            if (FPlaneMap.Canvas.Pixels[x,y] = $FEFEFE) then // Rand gefunden
              ExaminePixelEnvironment(x,y); // 8 umliegende Pixel untersuchen
        // =C=Färbung=bestimmen==================================================================
        if NOT Colorize(0) then
          raise Exception.Create('Der Graph ist nicht planar!');
        // ======================================================================================
      finally
        TempPlanes.Free;
      end;
    end;
  end
  else
    raise Exception.Create('Referenz-Image ungültig!');
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:

  procedure ExaminePixelEnvironment(const BaseX, BaseY: Integer);
    var
      i,c: Integer;
  begin
    TempPlanes.Clear;
    with FPlaneMap.Canvas do
      for i := 0 to 8 do // umliegende 8 Pixel incl. Mitte = 9 Pixel
        if (i <> 4) then begin // Mitte auslassen: 8 Pixel
          c := Pixels[BaseX+(i div 3)-1,BaseY+(i mod 3)-1]; // Farbe des Punktes
          if (c <> $FEFEFE) then begin // Rand ignorieren
            Plane := GetPlane(c); // die Flächen sind mit der ID als Farbe eingefärbt
            if (TempPlanes.IndexOf(Plane) = -1) then // Verbindung ist neu
              TempPlanes.Add(Plane); // merken
          end;
        end;
    if (TempPlanes.Count = 2) then // nur Umgebungen mit 2 Verbindung akzeptieren
      for i := 0 to 1 do begin
        Plane := TPlane(TempPlanes.Items[i]);
        if (Plane.Connections.IndexOf(TempPlanes.Items[1-i]) = -1) then // neu?
          Plane.Connections.Add(TempPlanes.Items[1-i]); // ja, merken
      end;
  end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:

  function Colorize(const APlaneID: Integer): Boolean;
    var
      i: Integer;
  begin
    Result := (APlaneID < 0) or (APlaneID >= Count); // gültiger Flächenindex?
    if (NOT Result) then begin // ja, die Fläche färben
      for i := 0 to 3 do begin // jede Fläche hat 4 Freiheitsgrade
        GetPlane(APlaneID).ColorIndex := i; // aktuelle Farbe setzen und...
        if GetPlane(APlaneID).IsColorIndexValid then begin // ...prüfen, ob sie "passt"
          Result := Colorize(APlaneID +1); // bisher OK, nächste Fläche färben (rekursiv)
          if Result then // die untergeordnete Farbwahl ist OK...
            Exit; // ...dann sind wir hier fertig!
          // wenn wir hier ankommen, war die aktuelle Farbe "nicht gut"
        end;
        // nächste Farbe probieren
      end;
      // wenn wir hier ankommen, hat keine der 4 Farben gepasst, also...
      GetPlane(APlaneID).ColorIndex := -1; // Fläche wieder auf "ungefärbt" setzen und...
    end; // ...in der nächst höheren Rekursionsebene die nächste Farbe probieren
  end;