{****************************************************************
*                                                               *
*  Programm zur Loesung des Pentomino-Problems ( Hoppe/Meyer ). *
*                                                               *
*****************************************************************
*                                                               *
*  Programm : Penta                                             *
*                                                               *
*  Datum    : 30. 3.85                                          *
*                                                               *
****************************************************************}

program penta(input, output, datei) ;

  const
    dimension = 4 ;

    d1 = 20 ; d2 = 9 ; d3 = 5 ; d4 = 2 ;

    maxsteinzahl   =   5 ;
    maxfigurenzahl =  12 ;
    maxlagenzahl   = 196 ;

  type
    achsen = array[1..dimension] of integer ;
    ntupel = record
               koordinate : achsen ;
             end ;

    raum = array[1..d1, 1..d2, 1..d3, 1..d4] of boolean ;

    einzelfigur  = record
                     einzelstein : array[1..maxsteinzahl] of ntupel ;
                     passt       : raum ;
                   end ;
    figurenblock = record
                     kennung     : char ;
                     steinanzahl : integer ;
                     grundfigur  : einzelfigur ;
                     drehanzahl  : integer ;
                     drehfigur   : array[1..maxlagenzahl] of einzelfigur ;
                   end ;
    datenblock   = record
                     anzahl : integer ;
                     daten  : array[1..maxfigurenzahl] of figurenblock ;
                   end ;

    zielfigur = record
                  maximum    : ntupel ;
                  ausdehnung : ntupel ;
                  kubus      : raum ;
                end ;

    moeglichelage = record
                      tausch   : achsen ;
                      ungerade : boolean ;
                    end ;

    vorzeichenkombination = array[1..dimension] of boolean ;

    string = packed array[1..20] of char ;

  var
    figuren : datenblock ;
    quader : zielfigur ;
    figurenname, quadername : string ;
    datei : text ;
    moeglich : boolean ;

  procedure figurenlesen ;

    var
      i, j, k, x1, x2, x3, x4 : integer ;

    begin
      writeln ;
      write('Gib den Filenamen an, der die Figuren enthaelt   : ') ;
      readln(figurenname) ;
      writeln ;
      if figurenname = '                    '
        then
          figurenname := 'PENTO.FIG           ' ;
      open(datei, figurenname, history := old) ;
        reset(datei) ;
        with figuren do
          begin
            readln(datei, anzahl) ;
            if anzahl > maxfigurenzahl
              then
                begin
                  writeln ;
                  writeln('Kerl ! Das sind mir zu viele Pentominos !') ;
                  moeglich := false ;
                end
              else
                for i := 1 to anzahl do
                  if moeglich
                    then
                      with daten[i], grundfigur do
                        begin
                          readln(datei) ;
                          readln(datei, kennung, steinanzahl) ;
                          readln(datei) ;
                          if steinanzahl > maxsteinzahl
                            then
                              begin
                                writeln ;
                                writeln('Zu viele Steine, du Depp !') ;
                                moeglich := false ;
                              end
                            else
                              for j := 1 to steinanzahl do
                                with einzelstein[j] do
                                  begin
                                    for k := 1 to dimension do
                                      read(datei, koordinate[k]) ;
                                    readln(datei) ;
                                  end ;
                          for x1 := 1 to d1 do
                            for x2 := 1 to d2 do
                              for x3 := 1 to d3 do
                                for x4 := 1 to d4 do
                                  passt[x1, x2, x3, x4] := false ;
                          drehanzahl := 0 ;
                        end ;
          end ;
      close(datei) ;
    end ;

  procedure quaderlesen ;

    var
      i, x1, x2, x3, x4 : integer ;
      zeichen : char ;

    begin
      writeln ;
      write('Gib den Filenamen an, der die Zielfigur enthaelt : ') ;
      readln(quadername) ;
      writeln ;
      if quadername = '                    '
        then
          quadername := '3X4X5.              ' ;
      open(datei, quadername, history := old) ;
        reset(datei) ;
        with quader do
          begin
            with maximum do
              begin
                koordinate[1] := d1 ;
                koordinate[2] := d2 ;
                koordinate[3] := d3 ;
                koordinate[4] := d4 ;
              end ;
            with ausdehnung do
              begin
                for i := 1 to dimension do
                  if moeglich
                    then
                      begin
                        read(datei, koordinate[i]) ;
                        if koordinate[i] > maximum.koordinate[i]
                          then
                            begin
                              writeln ;
                              writeln('Mann ! Der Quader ist zu gross !') ;
                              moeglich := false ;
                            end ;
                      end ;
                readln(datei) ;
                if moeglich
                  then
                    for x4 := 1 to koordinate[4] do
                      begin
                        readln(datei) ;
                        for x3 := 1 to koordinate[3] do
                          begin
                            readln(datei) ;
                            for x2 := koordinate[2] downto 1 do
                              begin
                                for x1 := 1 to koordinate[1] do
                                  begin
                                    read(datei, zeichen) ;
                                    kubus[x1, x2, x3, x4] := ( zeichen = '.' ) ;
                                  end ;
                                readln(datei) ;
                              end ;
                          end ;
                      end ;
              end ;
          end ;
      close(datei) ;
    end ;

  procedure raumlagen ;

    var
      i : integer ;

    procedure allelagen(var daten : figurenblock) ;

      var
        figur : einzelfigur ;
        lage : moeglichelage ;
        vorzeichen : vorzeichenkombination ;

      procedure erstelage ;

        var
          i : integer ;

        begin
          with lage do
            begin
              for i := 1 to dimension do
                tausch[i] := i ;
              ungerade := false ;
            end ;
        end ;

      procedure erstesvorzeichen ;

        var
          i : integer ;

        begin
          for i := 1 to dimension do
            vorzeichen[i] := false ;
        end ;

      procedure figurerzeugen ;

        var
          i, j, k : integer ;

        begin
          with daten do
            begin
              figur := grundfigur ;
              with figur, lage do
                for i := 1 to steinanzahl do
                  with einzelstein[i] do
                    begin
                      for j := 1 to dimension do
                        begin
                          k                     := koordinate[j] ;
                          koordinate[j]         := koordinate[tausch[j]] ;
                          koordinate[tausch[j]] := k ;
                        end ;
                      for j := 1 to dimension do
                        if vorzeichen[j]
                          then
                            koordinate[j] := - koordinate[j] ;
                    end ;
            end ;
        end ;

      procedure sortieren ;

        var
          stein : ntupel ;
          i, j, k, l : integer ;
          raus : boolean ;

        begin
          with daten, figur do
            for i := 1 to ( steinanzahl - 1 ) do
              for j := ( i + 1 ) to steinanzahl  do
                begin
                  raus := false ;
                  k := 1 ;
                  repeat
                    if einzelstein[i].koordinate[k] >
                      einzelstein[j].koordinate[k]
                      then
                        begin
                          stein          := einzelstein[i] ;
                          einzelstein[i] := einzelstein[j] ;
                          einzelstein[j] := stein ;
                          raus := true ;
                        end
                      else
                        if einzelstein[i].koordinate[k] =
                          einzelstein[j].koordinate[k]
                          then
                            k := k + 1
                          else
                            raus := true ;
                  until raus or ( k > dimension ) ;
                  if k > dimension
                    then
                      begin
                        writeln ;
                        writeln('Ha ! Da sind zwei Steine gleich !') ;
                        moeglich := false ;
                      end ;
                end ;
        end ;

      procedure zurechtruecken ;

        var
          i, j : integer ;

        begin
          with daten, figur do
            for i := steinanzahl downto 1 do
              with einzelstein[i] do
                for j := 1 to dimension do
                  koordinate[j] := koordinate[j] -
                    einzelstein[1].koordinate[j] ;
        end ;

      function nochnichtda : boolean ;

        var
          i, j, k : integer ;
          nichtda, verschieden : boolean ;

        begin
          nichtda := true ;
          with daten do
            for i := 1 to drehanzahl do
              with drehfigur[i] do
                begin
                  verschieden := false ;
                  for j := 1 to steinanzahl do
                    with einzelstein[j] do
                      for k := 1 to dimension do
                        if koordinate[k] <> figur.einzelstein[j].koordinate[k]
                          then
                            verschieden := true ;
                  nichtda := nichtda and verschieden ;
                end ;
          nochnichtda := nichtda ;
        end ;

      function figurpasstinquader : boolean ;

        var
          xmin, xmax : achsen ;
          i, j, x1, x2, x3, x4 : integer ;
          gehtrein : boolean ;

        begin
          with daten, quader, figur do
            begin
              xmin := einzelstein[1].koordinate ;
              xmax := xmin ;
              for i := 1 to dimension do
                begin
                  for j := 2 to steinanzahl do
                    with einzelstein[j] do
                      begin
                        if xmin[i] > koordinate[i]
                          then
                            xmin[i] := koordinate[i] ;
                        if xmax[i] < koordinate[i]
                          then
                            xmax[i] := koordinate[i] ;
                      end ;
                  xmin[i] := 1 - xmin[i] ;
                  xmax[i] := ausdehnung.koordinate[i] - xmax[i] ;
                end ;
              gehtrein := false ;
              for x1 := xmin[1] to xmax[1] do
                for x2 := xmin[2] to xmax[2] do
                  for x3 := xmin[3] to xmax[3] do
                    for x4 := xmin[4] to xmax[4] do
                      begin
                        passt[x1, x2, x3, x4] := true ;
                        for i := 1 to steinanzahl do
                          with einzelstein[i] do
                            passt[x1, x2, x3, x4] := passt[x1, x2, x3, x4] and
                              not kubus[( koordinate[1] + x1 ),
                              ( koordinate[2] + x2 ), ( koordinate[3] + x3 ),
                              ( koordinate[4] + x4 )] ;
                        gehtrein := gehtrein or passt[x1, x2, x3, x4] ;
                      end ;
            end ;
          figurpasstinquader := gehtrein ;
        end ;

      function letztesvorzeichen : boolean ;

        var
          i : integer ;
          fertig, sammel : boolean ;

        begin
          repeat
            i := 0 ;
            repeat
              i := i + 1 ;
              vorzeichen[i] := not vorzeichen[i] ;
            until vorzeichen[i] or ( i = dimension ) ;
            fertig := not vorzeichen[i] and ( i = dimension ) ;
            sammel := false ;
            for i := 1 to dimension do
              if vorzeichen[i]
                then
                  sammel := not sammel ;
          until fertig or ( sammel = lage.ungerade ) ;
          letztesvorzeichen := fertig ;
        end ;

      function letztelage : boolean ;

        var
          i : integer ;
          raus : boolean ;

        begin
          i := 0 ;
          raus := false ;
          with lage do
            begin
              repeat
                i := i + 1 ;
                tausch[i] := tausch[i] + 1 ;
                if tausch[i] > dimension
                  then
                    tausch[i] := i
                  else
                    raus := true ;
              until raus or ( i = dimension ) ;
              ungerade := false ;
              for i := 1 to dimension do
                if tausch[i] <> i
                  then ungerade := not ungerade ;
            end ;
          letztelage := not raus ;
        end ;

      begin
        erstelage ;
        repeat
          erstesvorzeichen ;
          repeat
            figurerzeugen ;
            sortieren ;
            zurechtruecken ;
            if nochnichtda
              then
                if figurpasstinquader
                  then
                    with daten do
                      begin
                        drehanzahl := drehanzahl + 1 ;
                        drehfigur[drehanzahl] := figur ;
                      end ;
          until letztesvorzeichen or not moeglich ;
        until letztelage or not moeglich ;
      end ;

    begin
      with figuren do
        for i := 1 to anzahl do
          if moeglich
            then
              with daten[i] do
                begin
                  allelagen(daten[i]) ;
                  writeln ;
                  write('Figur "', kennung, '" ') ;
                  if drehanzahl = 0
                    then
                      begin
                        writeln('passt nicht rein !') ;
                        moeglich := false ;
                      end
                    else
                      if drehanzahl = 1
                        then
                          writeln('hat 1 Lage im Raum.')
                        else
                          writeln('hat ', drehanzahl: 1, ' Lagen im Raum.') ;
                end ;
    end ;

  procedure speicherschreiben ;

    var
      i, j, k, l, x1, x2, x3, x4 : integer ;

    begin
      open(datei, 'PENTO.DAT', history := new) ;
        rewrite(datei) ;
        writeln(datei, figurenname) ;
        writeln(datei, quadername) ;
        with figuren do
          begin
            write(datei, anzahl: 1) ;
            with quader.ausdehnung do
              for i := 1 to dimension do
                write(datei, koordinate[i]: 3) ;
            writeln(datei) ;
            for i := 1 to anzahl do
              with daten[i] do
                begin
                  writeln(datei) ;
                  writeln(datei, kennung, steinanzahl: 3, drehanzahl: 4) ;
                  for j := 1 to drehanzahl do
                    with drehfigur[j] do
                      begin
                        for k := 1 to steinanzahl do
                          with einzelstein[k] do
                            begin
                              for l := 1 to dimension do
                                write(datei, koordinate[l]: 4) ;
                              writeln(datei) ;
                            end ;
                        with quader.ausdehnung do
                          for x4 := 1 to koordinate[4] do
                            begin
                              for x2 := koordinate[2] downto 1 do
                                begin
                                  for x3 := 1 to koordinate[3] do
                                    begin
                                      for x1 := 1 to koordinate[1] do
                                        if passt[x1, x2, x3, x4]
                                          then
                                            write(datei, '*')
                                              else
                                            write(datei, '.') ;
                                      write(datei, ' ') ;
                                    end ;
                                  writeln(datei) ;
                                end ;
                              writeln(datei) ;
                            end ;
                      end ;
                end ;
          end ;
      close(datei) ;
    end ;

  begin
    writeln ;
    write('**********************************') ;
    writeln('*******************************') ;
    writeln('*', ' ': 63, '*') ;
    write('*  Hier ist der Pentomino-Loesungsalgorithmus ( Teil A ).') ;
    writeln('       *') ;
    writeln('*', ' ': 63, '*') ;
    write('**********************************') ;
    writeln('*******************************') ;
    writeln('*', ' ': 63, '*') ;
    write('*  Ich berechne die Drehfiguren und ihre Lagemoeglichkeiten.') ;
    writeln('    *') ;
    writeln('*  Die Ergebnisse speichere ich in "PENTO.DAT".', ' ': 17, '*') ;
    writeln('*', ' ': 63, '*') ;
    write('*  Quadergroesse dieser Pentomino-Version : ') ;
    writeln(d1: 2, ' * ', d2: 2, ' * ', d3: 2, ' * ', d4: 2, '.  *') ;
    writeln('*', ' ': 63, '*') ;
    write('**********************************') ;
    writeln('*******************************') ;
    moeglich := true ;
    figurenlesen ;
    if moeglich
      then
        quaderlesen ;
    if moeglich
      then
        raumlagen ;
    if moeglich
      then
        speicherschreiben ;
  end .