unit yatc_Block;
{YATC - Unit Block
Autor : Tobias Mark aka Colenzo (tobiasmark@gmx.de)

Stellt das Objekt TTcube bereit
 - Bewegungsfunktionen im Spielfeld

Version
0.1 - 17.7 : - Erste version
}
interface

uses  GLObjects,Classes,
      yatc_global,yatc_field,GLTexture;

type TTcube = class(TGLcube)      //Ein Spielblock
              public
                linked : array[rdir] of TTcube;    //Verbundene Nachbarn
                field : TBlockField;      //Verbindung zum Array das normal benutzt wird

                //Bringt den Block an eine Bestimmte Position
                procedure SetBlock(x,y : integer);

                //Schreibt die Farben
                procedure SetColor(b,g,r : real);

                //Bewegunsfunktionen - Keine Plausibilitäts Prüfung!
                procedure domove(dir : Rdir);            //Bewegt sich und verbunden um 1 in die Angegeben Richtung
                procedure dorotate(rotdir : Rrotdir);     //Dreht sich und verbunden um 90 Grand in der angegeben Richtung

                //Testfunktion ob Bewegung Möglich
                function isrotate(rotdir:Rrotdir):boolean; //überprüft ob dorotate möglich ist
                function isfree(dir : Rdir) : boolean;   //prüft ob domove möglich ist

                function getMaterial : TGLMaterial;
                procedure setMaterial(material : TGLMaterial);

                constructor Create(AOwner: TComponent); override;
                destructor Destroy; override;
              protected
                checking,moving,drawing : boolean;   //zur Verhinderung von endlos schleifen bei den Rekursiven Aufrufen

                //hilfsfunktionen
                procedure markup(target:RCubeArray);          //trägt alle linked eines Objekts ins cubearay ein
                procedure markdown(target:RCubeArray);          //trägt alle linked eines Objekts aus dem cubearry aus

                procedure unlockdraw; //setzt alle flags zurück
                procedure unlockcheck;
                procedure unlockmove;

                //Eigentliche Bewegunsfunktion      - Keine Plausibilitätsprüfung!
                procedure shift(shiftx,shifty:integer);    //Bewegt sich und verbunden um shiftx und shifty in x und y richtung !!!Rekrusiv!!!
                procedure rotate(mutx,muty:integer;rotx,roty:integer;rotdir:rrotdir);  //Dreht sich und andere
                //mutx, muty : Multiplikator für Drehung (left : 1,-1; right: -1;1) rotx,roty : Drehmittelpunkt; rotdir: Drehrichtung !!!Rekrusiv!!!

                //Eigentlich Überprüfungsfunktion
                function checkshift(target:Rcubearray;shiftx,shifty:integer;dir:Rdir) : boolean; //überprüft ob shift möglich ist im  target: verwendetes Feld
                function checkrotate(target:RCubearray;rotx,roty : integer;rotdir:Rrotdir):boolean;  //überprüft ob rotate möglich ist im  target: verwendetes Feld

                procedure setallmaterial(material : TGLMaterial);
              end;


implementation

constructor TTcube.Create(AOwner: TComponent);

var j : Rdir;

begin
  inherited create(aowner);
  //init
  drawing:= false;
  moving:= false;
  checking := false;
  for j := Low(linked) to high(linked) do
  begin
     linked[j] := nil;              //init zur sicherheit
  end;
end;

destructor TTcube.Destroy;      //zerstört den einzelnen Würfel

begin      //Wenn im Feld rausnehmen
  if field.cubearray[trunc(position.x),trunc(position.Y)] = self then
  begin
    field.cubearray[trunc(position.x),trunc(position.Y)] := nil;
  end;

  //Verbindungen der Nachbarn auf nil setzten um Probleme zu vermeiden
  if linked[dright] <> nil then linked[dright].linked[dleft] := nil;
  if linked[dleft] <> nil then linked[dleft].linked[dright] := nil;
  if linked[dup] <> nil then linked[dup].linked[ddown] := nil;
  if linked[ddown] <> nil then linked[ddown].linked[dup] := nil;

  inherited destroy;
end;


//Setzt den Block an bestimmte Positon
procedure TTcube.SetBlock(x,y : integer);

begin
  Position.Y := y;  //Darstellung
  Position.X := x;
  if field.cubearray <> nil then
    field.cubearray[x,y] := self; //Feld
end;


//Stellt Farben ein
procedure TTcube.SetColor(b,g,r : real);

begin
  Material.FrontProperties.emission.Blue := b;
  Material.FrontProperties.emission.green := g;
  Material.FrontProperties.emission.red := r;
end;



function TTCube.isrotate(rotdir:Rrotdir):boolean;           //Prüft Rotation (nach außen anwenden)

begin
  result := checkrotate(field.cubearray,trunc(Position.X),trunc(Position.Y),rotdir);   //Verwende Eigne Position als Mittelpunkt
end;

function TTcube.checkrotate(target:RCubearray;rotx,roty : integer;rotdir:Rrotdir) : boolean;  //Prüft ob Rotation möglich

var test : RCubearray;  //Hilfs-Spielfeld
    i,j : integer;       //Zähler
    temp : boolean;      //Prüfungs-ergebnis
    ax,bx,cx,dx,ay,by,cy,dy : integer;  //eck-koordinaten      a - links oben b - rechts oben c - links unten d - rechts unten

  procedure getoutercorner;    //ermittelt eine rechteck fläche des Blocks&verbunden und gibt die eck-koordniaten zurück

  var s : integer;            //Gefunde Koordinate - Hilfswert
      i,j : integer;          //noch mehr zähler

  begin
    s := -1;        //abbruch bedingung setzen
    for i := 0 to high(test) do
    begin
      for j := 0 to high(test[i]) do
      begin
        if test[i,j] <> nil then  //Suchen des ersten Würfels im Testfeld in x-richtung
        begin
          s := i;
          break;
        end;
      end;
      if s <> -1 then break;         //etwas gefunden -> schleife abbrechen
    end;
    ax := s;       //x-Koordinaten der beiden linken ecken
    cx := s;
    s := -1;
    for i := high(test) downto 0 do
    begin
      for j := high(test[i]) downto 0 do
      begin
        if test[i,j] <> nil then     //Suchen des ersten würfels in x-richtung vom anderen ende
        begin
          s := i;
          break;
        end;
      end;
      if s <> -1 then break;
    end;
    bx := s;     //x der beiden rechten ecken
    dx := s;
    s := -1;
    for i := 0 to high(test[0]) do
    begin
      for j := 0 to high(test) do
      begin
        if test[j,i] <> nil then
        begin
          s := i;
          break;
        end;
      end;
      if s <> -1 then break;
    end;
    ay := s;     //y  der oberen ecken
    by := s;
    s := -1; 
    for i := high(test[0]) downto 0 do
    begin
      for j := high(test) downto 0 do
      begin
        if test[j,i] <> nil then
        begin
          s := i;
          break;
        end;
      end;
      if s <> -1 then break;
    end;
    cy := s;     //y der unteren ecken
    dy := s;
  end;

  procedure singlerotate(x,y,mutx,muty:integer);

  var newx,newy,help : integer;  //relativkoordinaten

  begin
    newx := x-rotx;              //relativ zum drehmittelpunkt  errechnen
    newy := y-roty;
    if (newx <> 0) or (newy <> 0) then //wenn beide 0 mittelpunkt selbst keinen drehen nötig
    begin      //Drehung, Koordinaten und vorzeichen werden vertauscht
      //die relativen x und y koordinaten werden getauscht, und dabei mit der richtungs Multiplikatoren die vorzeichen entsprechend Geändert
      help := newy;
      newy := mutx*newx;
      newx := muty*help;
    end;
    x := newx+rotx;              //absolute koordinaten   zurückrechnen
    y := newy+roty;
    if (x >= low(test)) and (x <= high(test)) and (y >= 0) and (y <= high(test[high(test)])) then
    begin    //Wenn Koordinate noch im Feld dann punkt setzen
      test[x,y] := self;
    end
    else temp := false;          //=> äußere kante überschnitten nicht möglich
  end;

begin
  temp := true;             //unser test-dreh-feld
  setlength(test,field.sizex+1);        //Test Feld erstellen und vorbereiten
  for i := 0 to high(test) do
  begin
    setlength(test[i],field.sizey+1+3);
    for j := 0 to high(test[i]) do
    begin
      test[i,j] := nil;
    end;
  end;
  //Maximale Ausdehnen in x und y ermitteln
  markup(test);  //objekt in feld malen
  unlockdraw;
  getoutercorner; //ausecken des ungedrehten objekts
  test[ax,ay] := self;  //ausecken einmalen
  test[bx,by] := self;
  test[cx,cy] := self;
  test[dx,dy] := self;
  case rotdir of       //die äußeren ecken im testfeld drehen und einschreiben
    drotleft : begin
                 singlerotate(ax,ay,1,-1);
                 singlerotate(bx,by,1,-1);
                 singlerotate(cx,cy,1,-1);
                 singlerotate(dx,dy,1,-1);
               end;
    drotright : begin
                  singlerotate(ax,ay,-1,1);
                  singlerotate(bx,by,-1,1);
                  singlerotate(cx,cy,-1,1);
                  singlerotate(dx,dy,-1,1);
                end;
  end;
  if temp = true then
  begin  //keine probleme bei drehen also weiter
    getoutercorner;  //die neuen gesamten äußeren ecken ermitteln für fläche die bei drehen berüht wird
    markdown(target);             //objekt zum überprüfen entfernen
    unlockdraw;
    for i := ax to bx do
    begin
      for j := ay to cy do
      begin                 //bereich der ermittelten äußeren ecken abklappern
        if target[i,j] <> nil then
        begin
          temp := false;  //überschneidung irgendwo mit anderm objekt => nicht möglich
          break;
        end;
      end;
    end;
    markup(target);    //objekt wieder eintragen
    unlockdraw;
  end;
  result := temp;
end;

procedure Ttcube.markup(target:RCubeArray);   //objekt ins spielfeld eintragen

var i : rdir;           //zähler

begin
  if drawing = false then      //überprüfung ob schon in arbeit da !!rekrusiv!!
  begin
    drawing := true;                    //look
    for i := low(linked) to high(linked) do
    begin   //weitergeben an alle verbundenen
      if linked[i] <> nil then if linked[i].drawing = false then
      begin
        linked[i].markup(target);
      end;
    end;
    target[trunc(position.X),trunc(position.y)]:= self;    //im feld eintragen nach den Koordinaten des dargestellen Würfels!
//    drawing := false;             //unlook
  end;
end;

procedure Ttcube.markdown(target:RCubeArray);       //objekt aus feld entfernen

var i : rdir;  //zähler

begin
  if drawing = false then     //überprüfung ob schon in arbeit da !!rekrusiv!!
  begin
    drawing := true;       //look
    for i := low(linked) to high(linked) do
    begin   //weitergeben an alle verbundenen
      if linked[i] <> nil then if linked[i].drawing = false then
      begin
        linked[i].markdown(target);
      end;
    end;
    target[trunc(position.X),trunc(position.y)]:= nil;    //nach koordinaten des Orginal Würfels austragen!
  //  drawing := false;        //unlook
  end;
end;

procedure TTcube.unlockdraw;    //hebt alle flags wieder auf

var i : rdir;

begin
  drawing := false;
  for i := low(linked) to high(linked) do
  begin   //weitergeben an alle verbundenen
    if linked[i] <> nil then
    if linked[i].drawing = true then
    begin
      linked[i].unlockdraw;
    end;
  end;
end;

procedure TTcube.unlockcheck;    //hebt alle flags wieder auf

var i : rdir;

begin
  checking := false;
  for i := low(linked) to high(linked) do
  begin   //weitergeben an alle verbundenen
    if linked[i] <> nil then
    if linked[i].checking = true then
    begin
      linked[i].unlockcheck;
    end;
  end;
end;

procedure TTcube.unlockmove;    //hebt alle flags wieder auf

var i : rdir;

begin
  moving := false;
  for i := low(linked) to high(linked) do
  begin   //weitergeben an alle verbundenen
    if linked[i] <> nil then
    if linked[i].moving = true then
    begin
      linked[i].unlockmove;
    end;
  end;
end;

procedure TTcube.rotate(mutx,muty:integer;rotx,roty:integer;rotdir:rrotdir);  //Rotiert Objekt

var i : rdir;    //zähler
    newx,newy,help : integer;  //relativkoordinaten  und tausch hilfs variable
    temp,temp2 : TTcube; //Zwischenspeicher beim drehen

begin
  if moving = false then    //überprüfung ob schon in arbeit da !!rekrusiv!!
  begin
    moving := true;  //look
    newx := trunc(position.X)-rotx;              //relativ zum drehmittelpunkt
    newy := trunc(position.Y)-roty;

    if (newx <> 0) or (newy <> 0) then //wenn beide 0 mittelpunkt selbst keinen drehen nötig
    begin      //Drehung, Koordinaten und vorzeichen werden vertauscht
      //die relativen x und y koordinaten werden getauscht, und dabei mit der richtungs Multiplikatoren die vorzeichen entsprechend Geändert
      help := newy;
      newy := mutx*newx;
      newx := muty*help;
    end;

    for i := low(linked) to high(linked) do
    begin   //weitergeben an alle verbundenen
      if linked[i] <> nil then if linked[i].moving = false then
      begin
        linked[i].rotate(mutx,muty,rotx,roty,rotdir);
      end;
    end;

    case rotdir of         //abhängig von der verbindung die verbunden entsprechen ändern
      drotleft : begin
                    temp := linked[dup];
                    linked[dup] := linked[dright];
                    temp2 := linked[dleft];
                    linked[dleft] := temp;
                    temp := linked[ddown];
                    linked[ddown] := temp2;
                    linked[dright] := temp;
                  end;
      drotright : begin
                    temp := linked[ddown];
                    linked[ddown] := linked[dright];
                    temp2 := linked[dleft];
                    linked[dleft] := temp;
                    temp := linked[dup];
                    linked[dup] := temp2;
                    linked[dright] := temp;
                  end;
    end;
    position.X := newx+rotx;   //relative Koordinaten zurückholen
    position.Y := newy+roty;
 //   moving := false;        //unlook
  end;
end;


procedure TTcube.dorotate(rotdir : Rrotdir);      //Rotiert das Objekt und verbunden (von außen benutzen) Mittelpunkt ist Würfel

begin
  case rotdir of
      drotleft : begin
                   markdown(field.cubearray);
                   unlockdraw;
                   rotate(1,-1,trunc(Position.X),trunc(Position.Y),rotdir);
                   unlockmove;
                   markup(field.cubearray);
                   unlockdraw;
               end;
      drotright : begin
                     markdown(field.cubearray);
                     unlockdraw;
                   rotate(-1,1,trunc(Position.X),trunc(Position.Y),rotdir);
                   unlockmove;
                   markup(field.cubearray);
                   unlockdraw;
              end;
    end;

end;

function TTcube.checkshift(target:Rcubearray;shiftx,shifty:integer;dir:Rdir) : boolean;     //überprüft ob bewegeung möglich

var i : rdir;    //zähler
    temp : boolean;   //Ergebnis Zwischenspeicher
    x,y : integer;    //hilfsvariable wegen häufiger verwendung

begin
  temp := true;           //init
  if checking = false then      //schauen ob schon in arbeit da !!rekrusiv!!
  begin
    checking := true;          //look
    x := trunc(position.X);
    y := trunc(position.Y);
    if ((shiftx = 1) and (x < field.sizeX)) or ((shiftx = -1) and (x > 0)) or ((shifty = 1) and (y < field.sizeY)) or ((shifty=-1)and (y>0)) then
    begin  //nicht die grenze des feldes überschreiten
      if (target[x+shiftx,y+shifty] <> nil) and (target[x+shiftx,y+shifty] <> linked[dir]) then
      begin         //test ob lehr und ob verbunderen nachbar (wenn voll aber nicht verbunden dann hier zuende)
        temp := false;
      end
      else
      for i := Low(linked) to high(linked) do
      begin   //weitergeben an alle verbundenen
        if linked[i] <> nil then if linked[i].checking = false then
        begin
          if linked[i].checkshift(field.cubearray,shiftx,shifty,dir) = false then temp := false;
        end;
      end;
    end
    else temp := false;
  //  checking := false;        //unlook
  end;
  result := temp;
end;


function TTcube.isfree(dir : Rdir) : boolean;   //überprüft ob Bewegung möglich (nach außen verwenden)

begin
  case dir of
    dright : begin
               result := checkshift(field.cubearray,1,0,dright);
               unlockcheck;
             end;
     dleft : begin
               result := checkshift(field.cubearray,-1,0,dleft);
               unlockcheck;
             end;
     dup : begin
             result := checkshift(field.cubearray,0,1,dup);
             unlockcheck;
           end;
     ddown : begin
               result := checkshift(field.cubearray,0,-1,ddown);
               unlockcheck;
             end
     else result := false;
  end;
end;


procedure TTcube.shift(shiftx,shifty:integer);    //bewegt objekt in x und y richtung (nicht im feld!)

var i : rdir;     //Zähler

begin
  if moving=false then      //überprüft ob schon in arbeit da !!rekrusiv!!
  begin
    moving := true;                //look
    if ((shiftx = 1) and (position.x < field.sizeX)) or ((shiftx = -1) and (position.x > 0)) or ((shifty = 1) and (position.y < field.sizeY)) or ((shifty=-1)and (position.y>0)) then
    begin   //prüfe ob Grenzen eingehalten werden
      for i := Low(linked) to High(linked) do
      begin
        if linked[i] <> nil then if linked[i].moving = false then
        begin
          linked[i].shift(shiftx,shifty);  //weitergabe an verbundene
        end;
      end;

      position.x := position.x +shiftx;          //Bewegung des Cubes in anzeige
      position.y := position.y +shifty;

    end;
   // moving := false;       //unlook
  end;
end;

procedure TTcube.domove(dir : Rdir);  //Bewegt objekt um 1 in richtung (nach außen verwenden)


begin
  case dir of
    dright : begin
               markdown(field.cubearray);
               unlockdraw;
               shift(1,0);
               unlockmove;
               markup(field.cubearray);
               unlockdraw;
             end;
     dleft : begin
               markdown(field.cubearray);
               unlockdraw;
               shift(-1,0);
               unlockmove;
               markup(field.cubearray);
               unlockdraw;
             end;
     dup : begin
             markdown(field.cubearray);
             unlockdraw;
             shift(0,1);
             unlockmove;
             markup(field.cubearray);
             unlockdraw;
           end;
     ddown : begin
               markdown(field.cubearray);
               unlockdraw;
               shift(0,-1);
               unlockmove;
               markup(field.cubearray);
               unlockdraw;
             end;
  end;
end;

function TTCube.getMaterial : TGLMaterial;

begin
  result := Material;
end;

procedure TTCube.setMaterial(material : TGLMaterial);

begin
  setallmaterial(material);      //Weitergeben
  unlockcheck;               //unlock alles
end;


procedure TTCube.setallmaterial(material : TGLMaterial);

var i : rdir;

begin
  if checking=false then      //überprüft ob schon in arbeit da !!rekrusiv!!
  begin
    checking := true;                //look
    for i := Low(linked) to High(linked) do
    begin                 //duch alle verbungen
      if linked[i] <> nil then if linked[i].checking = false then
      begin
        linked[i].setallmaterial(material);  //weitergabe an verbundene
      end;
    end;
    self.material.Assign(material);   //setzen
   // checking := false;       //unlook
  end;
end;

end.
