path: root/raetselunit.pas

unit raetselunit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Spin, Controls, StdCtrls, ExtCtrls, LCLType,
  lowlevelunit;

type
  tAlphabetFunktion = function(i: longint): string;

  tFelderRaetsel = class;

  tFelderLoesMeta = class
  private
    _inh:  boolean;
    _perm: tLongintArray;
    _mgl:  tInt64Array;
    _posi: longint;
  public
    constructor create(ib: boolean; fr: tFelderRaetsel);
    destructor destroy;
    function posi: longint;
    function fwd: boolean;
    procedure rev;
    property inhaltBehalten: boolean read _inh;
    procedure aktualisiereInhalt(p: longint);
    procedure aktualisiereRand(p: longint);
  end;

  tRaetsel = class
  private
    besitzer:       tForm;
    zeichenflaeche: tImage;
    erzeugeBtn:     tButton;
    function besitzerHoehe: longint; dynamic;
    function besitzerBreite: longint; dynamic;
    procedure zeichenFlaecheNeuKreieren;
    procedure onKeyDown(sender: tObject; var key: word; shiftState: tShiftState); dynamic; abstract;
    procedure onMouseDown(sender: tObject; button: tMouseButton; shiftState: tShiftState; x,y: longint); dynamic; abstract;
    procedure erzeugeOnClick(sender: tObject);
    procedure loeschen; dynamic; abstract;
    function loesen(inhaltBehalten: boolean): longint; dynamic; abstract;
    function _loesen(lm: tFelderLoesMeta): longint; dynamic; abstract;
    procedure leeren; dynamic; abstract;
  public
    constructor create(aOwner: tForm);
    destructor destroy; override;
    procedure zeichnen; dynamic; abstract;
  end;

  tFelderRaetsel = class(tRaetsel)
    spinEdits:                         array of tSpinEdit;
    diagonalenCB:                      tCheckBox;
    groeszen,inhalt,rand:              array of longint;
    moeglich:                          array of int64;
    dim,schriftGroesze,cursorPosition: longint;
    zellGroesze:                       extended;
    uebersetze:                        tAlphabetFunktion;
    procedure anzSEsOnChange(sender: tObject);
    procedure onKeyDown(sender: tObject; var key: word; shiftState: tShiftState); override;
    procedure onMouseDown(sender: tObject; button: tMouseButton; shiftState: tShiftState; x,y: longint); override;
    procedure aktualisiereGroesze;
    procedure loeschen; override;
    function loesen(inhaltBehalten: boolean): longint; override;
    procedure leeren; override;
    procedure aktualisiereZeichenflaechenGroesze;
    function besitzerHoehe: longint; override;
    function besitzerBreite: longint; override;
    procedure schreibeZentriert(x,y,i: longint);
    procedure relativeInhaltsAenderung(diff: longint); dynamic; abstract;
    function absoluteInhaltsAenderung(key: word): boolean; dynamic; abstract;
  public
    constructor create(aOwner: tForm; anzInhTypen: longint; alphabetFunktion: tAlphabetFunktion);
    destructor destroy; override;
    procedure zeichnen; override;
  end;

  tBuchstabenRaetsel = class(tFelderRaetsel)
  private
    procedure relativeInhaltsAenderung(diff: longint); override;
    function absoluteInhaltsAenderung(key: word): boolean; override;
    function _loesen(lm: tFelderLoesMeta): longint; override;
  public
    constructor create(aOwner: tForm);
    destructor destroy; override;
  end;

  tHochhausRaetsel = class(tFelderRaetsel)
  private
    procedure relativeInhaltsAenderung(diff: longint); override;
    function absoluteInhaltsAenderung(key: word): boolean; override;
    function _loesen(lm: tFelderLoesMeta): longint; override;
  public
    constructor create(aOwner: tForm);
    destructor destroy; override;
  end;

const
  spacing = 2;

function buchstabenAlphabetFunktion(i: longint): string;
function zahlenAlphabetFunktion(i: longint): string;

implementation

uses
  math;

// tFelderLoesMeta *************************************************************

constructor tFelderLoesMeta.create(ib: boolean; fr: tFelderRaetsel);
var
  i: longint;
begin
  inherited create;
  _inh:=ib;
  _perm:=permutation(length(fr.inhalt));
  setlength(_perm,length(_perm)+1);
  for i:=length(_perm)-1 downto 1 do
    _perm[i]:=_perm[i-1];
  _perm[0]:=-1;
  setlength(_mgl,length(fr.inhalt));
  _posi:=0;
end;

destructor tFelderLoesMeta.destroy;
begin
  setlength(_perm,0);
  setlength(_mgl,0);
  inherited destroy;
end;

function tFelderLoesMeta.posi: longint;
begin
  result:=_perm[_posi];
end;

function tFelderLoesMeta.fwd: boolean;
begin
  result:=_posi<length(_perm);
  if result then
    inc(_posi);
end;

procedure tFelderLoesMeta.rev;
begin
  dec(_posi);
end;

procedure tFelderLoesMeta.aktualisiereInhalt(p: longint);
begin

end;

procedure tFelderLoesMeta.aktualisiereRand(p: longint);
begin

end;

// tRaetsel ********************************************************************

constructor tRaetsel.create(aOwner: tForm);
begin
  inherited create;
  besitzer:=aOwner;
  zeichenflaeche:=tImage.create(besitzer);
  zeichenflaeche.parent:=besitzer;
  zeichenflaeche.onMouseDown:=@onMouseDown;
  erzeugeBtn:=tButton.create(besitzer);
  erzeugeBtn.parent:=besitzer;
  erzeugeBtn.left:=spacing;;
  erzeugeBtn.top:=spacing;;
  erzeugeBtn.caption:='Erzeugen!';
  erzeugeBtn.onClick:=@erzeugeOnClick;
  erzeugeBtn.onKeyDown:=@onKeyDown;
end;

destructor tRaetsel.destroy;
begin
  zeichenflaeche.free;
  inherited destroy;
end;

function tRaetsel.besitzerHoehe: longint;
begin
  result:=zeichenflaeche.height+zeichenflaeche.top+spacing;
end;

function tRaetsel.besitzerBreite: longint;
begin
  result:=zeichenflaeche.width+zeichenflaeche.left+spacing;
end;

procedure tRaetsel.zeichenFlaecheNeuKreieren;
var
  i: tImage;
begin
  i:=tImage.create(besitzer);
  i.parent:=zeichenflaeche.parent;
  i.left:=zeichenflaeche.left;
  i.top:=zeichenflaeche.top;
  i.width:=zeichenflaeche.width;
  i.height:=zeichenflaeche.height;
  i.canvas.font.size:=zeichenflaeche.canvas.font.size;
  i.onMouseDown:=zeichenflaeche.onMouseDown;
  zeichenflaeche.free;
  zeichenflaeche:=i;
end;

procedure tRaetsel.erzeugeOnClick(sender: tObject);
begin
  loeschen;
  loesen(true);
  leeren;
end;

// tFelderRaetsel **************************************************************

constructor tFelderRaetsel.create(aOwner: tForm; anzInhTypen: longint; alphabetFunktion: tAlphabetFunktion);
var
  i: longint;
begin
  inherited create(aOwner);
  uebersetze:=alphabetFunktion;
  cursorPosition:=-1;
  setlength(spinEdits,anzInhTypen+1);
  setlength(groeszen,length(spinEdits)-1);
  for i:=0 to length(spinEdits)-1 do begin
    spinEdits[i]:=tSpinEdit.create(besitzer);
    if i=1 then
      groeszen[i-1]:=5
    else if i>1 then
      groeszen[i-1]:=1;
    with spinEdits[i] do begin
      parent:=besitzer;
      top:=erzeugeBtn.top+erzeugeBtn.height+spacing;
      if i>0 then begin
        left:=spinEdits[i-1].left + spinEdits[i-1].width;
        value:=groeszen[i-1];
      end;
      left:=left+spacing;
      onChange:=@anzSEsOnChange;
      onKeyDown:=@self.onKeyDown;
      tag:=i;
    end;
  end;
  spinEdits[0].showHint:=true;
  spinEdits[0].hint:='Schriftgröße';
  spinEdits[0].value:=14;
  diagonalenCB:=tCheckBox.create(besitzer);
  diagonalenCB.parent:=besitzer;
  diagonalenCB.caption:='Diagonalen';
  diagonalenCB.top:=erzeugeBtn.top+erzeugeBtn.height+spacing;
  diagonalenCB.left:=spinEdits[length(spinEdits)-1].left+spinEdits[length(spinEdits)-1].width+spacing;
  zeichenflaeche.left:=spacing;
  zeichenflaeche.top:=diagonalenCB.top+diagonalenCB.height+spacing;
  aktualisiereGroesze;
end;

destructor tFelderRaetsel.destroy;
begin
  inherited destroy;
end;

procedure tFelderRaetsel.anzSEsOnChange(sender: tObject);
begin
  if ((sender as tSpinEdit).tag = 0) and
     ((sender as tSpinEdit).value <> schriftGroesze) then begin
    schriftGroesze:=(sender as tSpinEdit).value;
    aktualisiereZeichenflaechenGroesze
  end
  else if (sender as tSpinEdit).value <> groeszen[(sender as tSpinEdit).tag-1] then
    aktualisiereGroesze;
end;

procedure tFelderRaetsel.onKeyDown(sender: tObject; var key: word; shiftState: tShiftState);
begin
  if not absoluteInhaltsAenderung(key) then
    case key of
      VK_DOWN:
        cursorPosition:=
          (cursorPosition mod dim) +
          dim*min(dim-1,cursorPosition div dim + 1);
      VK_UP:
        cursorPosition:=
          (cursorPosition mod dim) +
          dim*max(0,cursorPosition div dim - 1);
      VK_LEFT:
        cursorPosition:=
          max(0,cursorPosition mod dim - 1) +
          dim*(cursorPosition div dim);
      VK_RIGHT:
        cursorPosition:=
          min(dim-1,cursorPosition mod dim + 1) +
          dim*(cursorPosition div dim);
      33,107,187:
        if (cursorPosition>=0) and (cursorPosition<dim*dim) then
          relativeInhaltsAenderung(1);
      34,109,189:
        if (cursorPosition>=0) and (cursorPosition<dim*dim) then
          relativeInhaltsAenderung(-1);
      else
        exit;
    end{of case};
  key:=0;
  zeichnen;
end;

procedure tFelderRaetsel.onMouseDown(sender: tObject; button: tMouseButton; shiftState: tShiftState; x,y: longint);
begin
  x:=floor(x/zellGroesze-1);
  y:=floor(y/zellGroesze-1);
  if (x<0) or (x>=dim) or (y<0) or (y>=dim) then exit;
  cursorPosition:=x+y*dim;
  zeichnen;
end;

procedure tFelderRaetsel.aktualisiereGroesze;
var
  i: longint;
begin
  dim:=0;
  schriftGroesze:=spinEdits[0].value;
  for i:=0 to length(groeszen)-1 do begin
    groeszen[i]:=spinEdits[i+1].value;
    dim:=dim+groeszen[i];
  end;
  setlength(inhalt,dim*dim);
  setlength(rand,4*(dim+1));
  loeschen;
  cursorPosition:=0;
  aktualisiereZeichenflaechenGroesze;
end;

procedure tFelderRaetsel.loeschen;
var
  i: longint;
begin
  for i:=0 to length(inhalt)-1 do
    inhalt[i]:=-1;
  for i:=0 to length(rand)-1 do
    rand[i]:=-1;
end;

function tFelderRaetsel.loesen(inhaltBehalten: boolean): longint;
var
  lm: tFelderLoesMeta;
begin
  lm:=tFelderLoesMeta.create(inhaltBehalten,self);
  result:=_loesen(lm);
  lm.free;
end;

procedure tFelderRaetsel.leeren;
var
  p:   tLongintArray;
  i,w: longint;
var
  lm: tFelderLoesMeta;
begin
  lm:=tFelderLoesMeta.create(false,self);

  p:=permutation(dim*dim);
  for i:=0 to length(p)-1 do begin
    if inhalt[p[i]]<0 then continue;
    w:=inhalt[p[i]];
    inhalt[p[i]]:=-1;
    lm.aktualisiereInhalt(p[i]);
    if _loesen(lm)<>1 then begin
      inhalt[p[i]]:=w;
      lm.aktualisiereInhalt(p[i]);
    end;
  end;

  p:=permutation((dim+1)*4);
  for i:=0 to length(p)-1 do begin
    if rand[p[i]]<0 then continue;
    w:=rand[p[i]];
    rand[p[i]]:=-1;
    lm.aktualisiereRand(p[i]);
    if _loesen(lm)<>1 then begin
      rand[p[i]]:=w;
      lm.aktualisiereRand(p[i]);
    end;
  end;
end;

procedure tFelderRaetsel.aktualisiereZeichenflaechenGroesze;
begin
  zeichenflaeche.canvas.font.size:=schriftGroesze;
  zellGroesze:=
    2*spacing + zeichenflaeche.canvas.pen.width +
    max(
      zeichenflaeche.canvas.textWidth(uebersetze(dim)),
      zeichenflaeche.canvas.textHeight(uebersetze(dim))
    );
  zeichenflaeche.height:=round((dim+2)*zellGroesze);
  zeichenflaeche.width:=zeichenflaeche.height;
  zeichenFlaecheNeuKreieren;
  besitzer.height:=besitzerHoehe;
  besitzer.width:=besitzerBreite;
  zeichnen;
end;

function tFelderRaetsel.besitzerHoehe: longint;
var
  i: longint;
begin
  result:=max(inherited besitzerHoehe,diagonalenCB.top+diagonalenCB.height+spacing);
  for i:=0 to length(spinEdits)-1 do
    result:=max(result,spinEdits[i].top+spinEdits[i].height+spacing);
end;

function tFelderRaetsel.besitzerBreite: longint;
var
  i: longint;
begin
  result:=max(inherited besitzerBreite,diagonalenCB.left+diagonalenCB.width+spacing);;
  for i:=0 to length(spinEdits)-1 do
    result:=max(result,spinEdits[i].left+spinEdits[i].width+spacing);
end;

procedure tFelderRaetsel.schreibeZentriert(x,y,i: longint);
var
  br,ho: longint;
  s:     string;
begin
  s:=uebersetze(i);
  with zeichenflaeche.canvas do begin
    br:=textWidth(s);
    ho:=textHeight(s);
    textOut(
      round((x+1.5)*zellGroesze-br/2),
      round((y+1.5)*zellGroesze-ho/2),
      s
    );
  end;
end;

procedure tFelderRaetsel.zeichnen;
var
  i: longint;
begin
  zeichenflaeche.canvas.brush.color:=$ffffff;
  zeichenflaeche.canvas.rectangle(-10,-10,zeichenflaeche.width+10,zeichenflaeche.height+10);
  zeichenflaeche.canvas.pen.width:=3;
  zeichenflaeche.canvas.pen.color:=$000000;
  for i:=0 to dim do
    with zeichenflaeche.canvas do begin
      moveTo(round((i+1)*zellGroesze),round(zellGroesze));
      lineTo(round((i+1)*zellGroesze),round((dim+1)*zellGroesze));
      moveTo(round(zellGroesze),round((i+1)*zellGroesze));
      lineTo(round((dim+1)*zellGroesze),round((i+1)*zellGroesze));
    end;
  zeichenflaeche.canvas.pen.color:=$8080ff;
  if (cursorPosition>=0) and (dim>0) then
    zeichenflaeche.canvas.rectangle(
      round(((cursorPosition mod dim)+1)*zellGroesze),
      round(((cursorPosition div dim)+1)*zellGroesze),
      round(((cursorPosition mod dim)+2)*zellGroesze+1),
      round(((cursorPosition div dim)+2)*zellGroesze+1)
      );
  for i:=0 to dim-1 do begin
    schreibeZentriert(i,-1,rand[i]);
    schreibeZentriert(dim,i,rand[dim+i]);
    schreibeZentriert(i,dim,rand[2*dim+i]);
    schreibeZentriert(-1,i,rand[3*dim+i]);
  end;
  for i:=0 to length(inhalt)-1 do
    schreibeZentriert(i mod dim,i div dim,inhalt[i]);
end;

// tBuchstabenRaetsel **********************************************************

constructor tBuchstabenRaetsel.create(aOwner: tForm);
begin
  inherited create(aOwner,2,@buchstabenAlphabetFunktion);
  spinEdits[1].showHint:=true;
  spinEdits[1].hint:='Anzahl Buchstaben';
  spinEdits[1].value:=5;
  spinEdits[2].showHint:=true;
  spinEdits[2].hint:='Anzahl Leerfelder';
  spinEdits[2].value:=1;
  aktualisiereGroesze;
end;

destructor tBuchstabenRaetsel.destroy;
begin
  inherited destroy;
end;

procedure tBuchstabenRaetsel.relativeInhaltsAenderung(diff: longint);
begin
  if (cursorPosition<0) or (cursorPosition>=dim*dim) then exit;
  inhalt[cursorPosition]:=min(max(-1,inhalt[cursorPosition]+diff),groeszen[0]);
end;

function tBuchstabenRaetsel.absoluteInhaltsAenderung(key: word): boolean;
begin
  result:=true;
  if (key>=ord('A')) and (key<=min(ord('A')+groeszen[0]-1,ord('Z'))) then begin
    inhalt[cursorPosition]:=key-ord('A')+1;
    exit;
  end;
  if (key=ord(' ')) or (key=46) or (key=8) then begin
    inhalt[cursorPosition]:=-1;
    exit;
  end;
  if (key=189) then begin
    inhalt[cursorPosition]:=0;
    exit;
  end;
  result:=false;
end;

function tBuchstabenRaetsel._loesen(lm: tFelderLoesMeta): longint;
begin
  if not lm.fwd then begin
    result:=1;
    exit;
  end;
  if inhalt[lm.posi]>=0 then begin
    result:=_loesen(lm);
    exit;
  end;

  result:=0;
  //for

  if not lm.inhaltBehalten then begin
    inhalt[lm.posi]:=-1;
    lm.aktualisiereInhalt(lm.posi);
  end;
end;

// tHochhausRaetsel ************************************************************

constructor tHochhausRaetsel.create(aOwner: tForm);
begin
  inherited create(aOwner,1,@zahlenAlphabetFunktion);
  spinEdits[1].showHint:=true;
  spinEdits[1].hint:='Anzahl Spalten';
  spinEdits[1].value:=5;
  aktualisiereGroesze;
end;

destructor tHochhausRaetsel.destroy;
begin
  inherited destroy;
end;

procedure tHochhausRaetsel.relativeInhaltsAenderung(diff: longint);
begin
  if (cursorPosition<0) or (cursorPosition>=dim*dim) then exit;
  if inhalt[cursorPosition]=-1 then inhalt[cursorPosition]:=0;
  inhalt[cursorPosition]:=min(max(0,inhalt[cursorPosition]+diff),groeszen[0]);
  if inhalt[cursorPosition]=0 then inhalt[cursorPosition]:=-1;
end;

function tHochhausRaetsel.absoluteInhaltsAenderung(key: word): boolean;
begin
  result:=true;
  if (key>=ord('1')) and (key<=min(ord('1')+groeszen[0]-1,ord('9'))) then begin
    inhalt[cursorPosition]:=key-ord('1')+1;
    exit;
  end;
  if (key=ord(' ')) or (key=46) or (key=8) then begin
    inhalt[cursorPosition]:=-1;
    exit;
  end;
  result:=false;
end;

function tHochhausRaetsel._loesen(lm: tFelderLoesMeta): longint;
begin

end;

// allgemeine Funktionen *******************************************************

function buchstabenAlphabetFunktion(i: longint): string;
begin
  if i<0 then
    result:=''
  else if i=0 then
    result:='-'
  else begin
    result:='';
    while i>0 do begin
      dec(i);
      result:=char(ord('A')+(i mod 26))+result;
      i:=i div 26;
    end;
  end;
end;

function zahlenAlphabetFunktion(i: longint): string;
begin
  if i<0 then
    result:=''
  else if i=0 then
    result:='-'
  else
    result:=inttostr(i);
end;

end.