program logiktrainer;{arbeitet in reiner Textform, zeigt aber ein Computer kann auch logisch Denken}
{Weitere Beschreibung im Hauptprogramm am Ende}
{Wenn man Prozedur Denken ver„ndert, kann man selber gegen Computer spielen(Zufallsvorgaben in Prozedur Vorgabe)}
{$M  32000, 0, 655360}
uses crt;

type str4 = string[4];
     f12typ = array[1..1000] of string[12];
     ergeb = array [1..7] of record
                                 tip, erg: str4;
                               end;

     sortier = array[1..6, 1..6, 1..6, 1..6] of boolean;

const farben : array [1..9] of byte = (14, 3, 4, 2, 1, 6, 8, 15, 5);
      namef  : array[1..6] of string[5] =
                 ('gelb', 'cyan', 'rot', 'grn', 'blau', 'braun');

function vorgabe2: str4;

  var i : byte;
      fstr : string;
      z1, z2, z3, z4 : string[1];
      nofehler : boolean;
      code, zahl : integer;

  begin
    writeln;
    writeln('*** Programm Logiktrainer ***; Ohne Reihenfolge: ');
    textcolor(15); write(chr(219));
    textcolor(7); write(' weiá : vorhanden, ');
    textcolor(5); write(chr(219));
    textcolor(7); write(' magenta: Ort richtig, ');
    textcolor(8); write(chr(219));
    textcolor(7); write(' dunkelgrau : nicht vorhanden');
    writeln;
    for i:=1 to 6 do
      begin
        write(i, ': ', namef[i], ' ');
        textcolor(farben[i]);
        write(chr(219), '   ');
        textcolor(7);
      end;
    writeln;
    repeat
      nofehler:=true;
      writeln('Bitte die Farben der 4 K„stchen eingeben !');
      write('(z.B. 3424 fr rot-grn-cyan-grn) : '); readln(fstr);
      for i:=1 to 4 do
        if ( ord(fstr[i]) < ord('1') ) or ( ord(fstr[i]) > ord('6') )
          then nofehler:=false;
      if length(fstr)<>4 then nofehler:=false;
      writeln;
    until nofehler=true;
    vorgabe2:=fstr;
  end;

function vorgabe(j, k, l, m : byte): str4;

  var i : byte;
      fstr : string;
      z1, z2, z3, z4 : string[1];
      nofehler : boolean;
      code, zahl : integer;

  begin
    {randomize;          (Computer gibt vor, Mensch spielt *)
    str(random(6)+1, z1);
    str(random(6)+1, z2);
    str(random(6)+1, z3);
    str(random(6)+1, z4);}
    str(j, z1);          (* Mensch gibt vor in vorgabe2, Computer spielt *)
    str(k, z2);
    str(l, z3);
    str(m, z4);
    fstr:=z1+z2+z3+z4;
    vorgabe:=fstr;
  end;

procedure denken(ergfeld: ergeb; sortfeld: sortier; durch: byte;
                 var tip1 : str4);

  var i, j, k, l, anz, v1tip, v2tip, n1tip, n2tip : byte;
      istr, jstr, kstr, lstr : string[1];
      bool : boolean;
      moeglich : array[1..4] of
                   record
                       str: str4;
                     end;

  begin
    v1tip:=0; v2tip:=0; n1tip:=0; n2tip:=0;
    k:=0;
    for i:=1 to 2 do     {3. Tip 5665 weglassen, wenn schon 4 weisse und oder pinke  gesteckt}
      for j:=1 to 4 do
        if (ergfeld[i].erg[j]>'0') then k:=k+1;
    if (durch>=3) and (k=4) then
      begin
        durch:=durch+1;
        ergfeld[3].tip:='5665'; ergfeld[3].erg:='0000';
      end;
    i:=0; j:=0; k:=0; l:=0;

    {write('Tip: '); readln(tip1);      (* Eingabe durch Spieler *) }
    if durch=1 then tip1:='1122';
    if durch=2 then tip1:='3434';     {3434}
    if durch=3 then tip1:='5665';    {5665}

    if ((durch=4) or (durch=5)) and (bool=false)
      then for i:=1 to 3 do
             begin
               if ergfeld[i].erg[2]<>'0' then
                 if v1tip=0 then v1tip:=i
                            else v2tip:=i;
               if ergfeld[i].erg[1]='0' then
                 if n1tip=0 then n1tip:=i
                            else n2tip:=i;
             end
      else begin
             v1tip:=1;
             v2tip:=2;
           end;

    if durch=4 then
      begin
        if v1tip=1 then
          begin
            if v2tip=0 then
              begin
                if (n1tip=0) and (n2tip=0) then tip1:='1362';
                if (n1tip=2) and (n2tip=0) then tip1:='1562';
                if (n1tip=2) and (n2tip=3) then tip1:='2211';
                if (n1tip=3) and (n2tip=0) then tip1:='1342';
              end;
            if v2tip=2 then tip1:='1342';
            if v2tip=3 then tip1:='1562';
          end;
        if v1tip=2 then
          begin
            if v2tip=0 then
              begin
                if (n1tip=0) and (n2tip=0) then tip1:='3164';
                if (n1tip=1) and (n2tip=0) then tip1:='3564';
                if (n1tip=1) and (n2tip=3) then tip1:='4433';
                if (n1tip=3) and (n2tip=0) then tip1:='3124';
              end;
            if v2tip=3 then tip1:='3564';
          end;
        if v1tip=3 then
          begin
            if (n1tip=0) and (n2tip=0) then tip1:='5146';
            if (n1tip=1) and (n2tip=0) then tip1:='5346';
            if (n1tip=1) and (n2tip=2) then tip1:='6655';
            if (n1tip=2) and (n2tip=0) then tip1:='5126';
          end;
      end;

    if durch=5 then
      begin
        if v1tip=1 then
          begin
            if v2tip=0 then
              begin
                if (n1tip=0) and (n2tip=0) then tip1:='5124';
                if (n1tip=2) and (n2tip=0) then tip1:='5126';
                if (n1tip=2) and (n2tip=3) then tip1:='2121';
                if (n1tip=3) and (n2tip=0) then tip1:='3124';
              end;
            if v2tip=2 then tip1:='3124';
            if v2tip=3 then tip1:='5126';
          end;
        if v1tip=2 then
          begin
            if v2tip=0 then
              begin
                if (n1tip=0) and (n2tip=0) then tip1:='5342';
                if (n1tip=1) and (n2tip=0) then tip1:='5346';
                if (n1tip=1) and (n2tip=3) then tip1:='4343';
                if (n1tip=3) and (n2tip=0) then tip1:='1342';
              end;
            if v2tip=3 then tip1:='5346';
          end;
        if v1tip=3 then
          begin
            if (n1tip=0) and (n2tip=0) then tip1:='3562';
            if (n1tip=1) and (n2tip=0) then tip1:='3564';
            if (n1tip=1) and (n2tip=2) then tip1:='6565';
            if (n1tip=2) and (n2tip=0) then tip1:='1562';
          end;
      end;

    anz:=1;
    if (durch>5) then
      for i:=1 to 4 do moeglich[i].str:='0000';
    if (durch>5) then
      for i:=1 to 6 do
        for j:=1 to 6 do
          for k:=1 to 6 do
            for l:=1 to 6 do
              if sortfeld[i, j ,k ,l]=true then
                begin
                  str(i, istr); str(j, jstr); str(k, kstr); str(l, lstr);
                  moeglich[anz].str:=istr+jstr+kstr+lstr;
                  anz:=anz+1;
                end;

    if (durch=6) then
      if (moeglich[4].str='0000')
        then tip1:=moeglich[1].str
        else tip1:=moeglich[1].str;

    if (durch>=7) then tip1:=moeglich[1].str;

    writeln; writeln;
    write(durch, '. ');
    write('Tip: ', tip1);
    writeln; writeln;
  end;

procedure bewertung
  (vorgeg1, tip1 : str4; var erg2: str4; var ende1: boolean);

  var i, j, k    : byte;
      erg1       : str4;
      verglichentip, verglichengeg : array[1..4] of boolean;
      ende       : boolean;

  begin
    erg1:='0000';
    for i:=1 to 4 do verglichentip[i]:=false;
    for i:=1 to 4 do verglichengeg[i]:=false;
    j:=1;
    for i:=1 to 4 do
      if vorgeg1[i]=tip1[i]
        then begin
               erg1[j]:='2';
               j:=j+1;
               verglichentip[i]:=true;
               verglichengeg[i]:=true;
             end;
    for i:=1 to 4 do
      begin
        k:=1;
        ende:=false;
        repeat
          if ( tip1[i]=vorgeg1[k] ) and ( verglichengeg[k] = false )
            then ende:=true
            else k:=k+1;
          if k>=5 then ende:=true;
        until ende=true;
        if k>=5 then k:=0;
        if ( k > 0 ) and ( verglichentip[i] = false )
          then begin
                 erg1[j]:='1';
                 j:=j+1;
                 verglichentip[i]:=true;
                 verglichengeg[k]:=true;
               end;
      end;
    erg2:=erg1;
    if erg1='2222' then ende1:=true;
  end;

procedure ausgabe(tip3, erg3 : str4);

  var z, i : byte;
      code : integer;

  begin
    gotoxy(15, wherey-2);
    for i:=1 to 4 do
      begin
        val(tip3[i], z, code);
        textcolor(farben[z]);
        write(z);
        write('  ');
      end;
    write('     ');
    textcolor(7);
    for i:=1 to 4 do
      begin
        val(erg3[i], z, code);
        textcolor(farben[z+7]);
        write(chr(219), ' ');
      end;
    textcolor(7);
    write('     ');
  end;

procedure aussortieren(ergfeld: ergeb; durch: byte; var sortfeld: sortier);

  var i, j, k, l     : byte;
      sortstr, erg   : str4;
      is, js, ks, ls : string[1];
      ende           : boolean;

  begin
    for i:=1 to 6 do       {true: m”gliche L”sung}
      for j:=1 to 6 do
        for k:=1 to 6 do
          for l:=1 to 6 do
            if sortfeld[i, j, k, l]=true then
              begin
                str(i, is); str(j, js); str(k, ks); str(l, ls);
                sortstr:=is+ js+ ks+ ls;
                bewertung(ergfeld[durch].tip, sortstr, erg, ende);
                if pos(ergfeld[durch].erg, erg)=0
                  then sortfeld[i, j, k, l]:=false;
              end;
  end;
 
procedure eintragen(ergfeld: ergeb; var feld12erg: f12typ; var groesse: integer);


  var f12element: string[12];
      i         : integer;

  begin
    f12element:=ergfeld[1].erg+ergfeld[2].erg+ergfeld[3].erg;
    i:=0;
    repeat
      i:=i+1;
    until (i>groesse) or (f12element=feld12erg[i]);
    if (i>groesse) and ((copy(f12element, 1, 4)='2100') or (copy(f12element, 1, 8)='00002100'))
      then begin
             feld12erg[groesse+1]:=f12element;
             groesse:=groesse+1;
           end;
  end;

procedure haupt(vorgeg: str4);

  var tip, erg  : str4;
      ende      : boolean;
      durch, i, j, k, l : byte;
      ergfeld   : ergeb;
      feld12    : f12typ;
      sortfeld  : sortier;
      anz, groesse : integer;
      ch        : char;

  begin
    if vorgeg=('1111') then
      begin groesse:=0;
            for anz:=1 to 1000 do feld12[i]:='';
      end;
    anz:=0; durch:=1; ende:=false;
    for i:=1 to 6 do
      for j:=1 to 6 do
        for k:=1 to 6 do
          for l:=1 to 6 do
            sortfeld[i, j, k, l]:=true;
    repeat
      denken(ergfeld, sortfeld, durch, tip);
      bewertung(vorgeg, tip, erg, ende);
      ergfeld[durch].tip:=tip;
      ergfeld[durch].erg:=erg;
      if durch<7 then aussortieren(ergfeld, durch, sortfeld);
      {if durch>=7 then} ausgabe(tip, erg);
      textcolor(15+blink);
      if ende=true then write('Richtig !   ');
      textcolor(7);
      durch:=durch+1;
      if durch=8 then ende:=true;
    until ende=true;
    writeln; writeln; writeln; writeln;
    ausgabe(vorgeg, '2222');
    textcolor(15+blink);
    writeln('Spielende !');
    textcolor(15);
    for i:=1 to 6 do
      for j:=1 to 6 do
        for k:=1 to 6 do
          for l:=1 to 6 do
            if sortfeld[i, j, k, l]=true then
              begin
                {writeln(i, j, k, l);}
                inc(anz);
              end;
    {write(anz, ' ', (100*anz/1296):0:4);}
    while keypressed do
      ch:=readkey;
    if anz>1 then repeat until keypressed;
    eintragen(ergfeld, feld12, groesse);
    anz:=0;
    if tip='6666' then
      repeat
        write(feld12[anz+1], '  ', feld12[anz+2], '  ', feld12[anz+3], ' ');
        writeln(feld12[anz+4], '  ', feld12[anz+5]);
        anz:=anz+5;
      until feld12[anz+1]='';
  end;

var i, j, k, l : byte;
    ch : char;

begin
  textcolor(7);
  i:=1; j:=1; k:=1; l:=1;
  (*for i:=1 to 6 do                {Programmteil, der alle Kombinationen
                                  durchprft zur Feststellung, wieviele
                                  Kombinationen nicht geschafft werden,
                                  derzeit 5 von 6*6*6*6, Dauert auf langsameren Rechnern mehrere Minuten,
                                  Abbruch m”glich mit STRG-PAUSE}
    for j:=1 to 6 do
      for k:=1 to 6 do
        for l:=1 to 6 do
          begin
            haupt(vorgabe(i, j, k, l));
            while keypressed do
              ch:=readkey;
          end;*)
  haupt(vorgabe2);         {Programmteil, bei dem man selber Kombination eingibt, Computer versucht dann, sie zu knacken}
  while keypressed do
    ch:=readkey;
  textcolor(7);
end.