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

program pentb(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
                     verbraucht  : boolean ;
                     kennung     : char ;
                     steinanzahl : integer ;
                     drehanzahl  : integer ;
                     drehfigur   : array[1..maxlagenzahl] of einzelfigur ;
                   end ;
    datenblock   = record
                     anzahl : integer ;
                     daten  : array[1..maxfigurenzahl] of figurenblock ;
                   end ;

    zielfigur   = record
                    ausdehnung : ntupel ;
                    kubus      : raum ;
                    erstesfeld : ntupel ;
                  end ;
    zielfiguren = array[0..maxfigurenzahl] of zielfigur ;

    zaehleinheit = record
                     figur   : integer ;
                     drehung : integer ;
                     lage    : ntupel ;
                   end ;
    zaehlliste   = array[1..maxfigurenzahl] of zaehleinheit ;

    ausgabe = array[1..d1, 1..d2, 1..d3, 1..d4] of char ;

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

  var
    figuren : datenblock ;
    quader : zielfiguren ;
    figurenname, quadername : string ;
    datei : text ;

  procedure speicherlesen ;

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

    begin
      open(datei, 'PENTO.DAT', history := old) ;
        reset(datei) ;
        readln(datei, figurenname) ;
        readln(datei, quadername) ;
        writeln ;
        writeln('Die Figuren kommen aus  : ', figurenname) ;
        writeln('Die Zielfigur kommt aus : ', quadername) ;
        with figuren do
          begin
            read(datei, anzahl) ;
            with quader[0].ausdehnung do
              for i := 1 to dimension do
                read(datei, koordinate[i]) ;
            readln(datei) ;
            for i := 1 to anzahl do
              with daten[i] do
                begin
                  readln(datei) ;
                  readln(datei, kennung, steinanzahl, drehanzahl) ;
                  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
                                read(datei, koordinate[l]) ;
                              readln(datei) ;
                            end ;
                        with quader[0].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
                                        begin
                                          read(datei, zeichen) ;
                                          passt[x1, x2, x3, x4] :=
                                            ( zeichen = '*' ) ;
                                        end ;
                                      read(datei, zeichen) ;
                                    end ;
                                  readln(datei) ;
                                end ;
                              readln(datei) ;
                            end ;
                      end ;
                end ;
          end ;
      close(datei) ;
    end ;

  procedure quaderlesen ;

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

    begin
      open(datei, quadername, history := old) ;
        reset(datei) ;
        readln(datei) ;
        with quader[0], ausdehnung do
          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 ;
      close(datei) ;
    end ;

  procedure loesungsuchen ;

    var
      anfang : achsen ;
      zaehler : zaehlliste ;
      rechentiefe, ebene, i : integer ;
      rechenschritte, loesungen : integer ;
      moeglich, quadervoll : boolean ;

    procedure erstesfreiesfeld(var quader : zielfigur) ;

      var
        x1, x2, x3, x4 : integer ;

      begin
        x1 := anfang[1] ;
        x2 := anfang[2] ;
        x3 := anfang[3] ;
        x4 := anfang[4] ;
        quadervoll := true ;
        with quader do
          repeat
            repeat
              repeat
                repeat
                  if not kubus[x1, x2, x3, x4]
                    then
                      with erstesfeld do
                        begin
                          koordinate[1] := x1 ;
                          koordinate[2] := x2 ;
                          koordinate[3] := x3 ;
                          koordinate[4] := x4 ;
                          quadervoll := false ;
                        end ;
                  x4 := x4 + 1 ;
                until not quadervoll or ( x4 > ausdehnung.koordinate[4] ) ;
                x4 := 1 ;
                x3 := x3 + 1 ;
              until not quadervoll or ( x3 > ausdehnung.koordinate[3] ) ;
              x3 := 1 ;
              x2 := x2 + 1 ;
            until not quadervoll or ( x2 > ausdehnung.koordinate[2] ) ;
            x2 := 1 ;
            x1 := x1 + 1 ;
          until not quadervoll or ( x1 > ausdehnung.koordinate[1] ) ;
      end ;

    procedure naechstefigureinsetzen(var xpos : achsen) ;

      var
        x : achsen ;
        hilfsquader : zielfigur ;
        i, j : integer ;
        raus : boolean ;

      begin
        moeglich := false ;
        raus := false ;
        with figuren, zaehler[ebene] do
          repeat
            drehung := drehung + 1 ;
            if drehung > daten[figur].drehanzahl
              then
                begin
                  figur := figur + 1 ;
                  drehung := 1 ;
                  raus := ( figur > anzahl ) ;
                end ;
            if not raus
              then
                with daten[figur], drehfigur[drehung], hilfsquader do
                  if not verbraucht
                    then
                      if passt[xpos[1],xpos[2],xpos[3],xpos[4]]
                        then
                          begin
                            hilfsquader := quader[ebene] ;
                            moeglich := true ;
                            i := 0 ;
                            repeat
                              i := i + 1 ;
                              with einzelstein[i] do
                                begin
                                  for j := 1 to dimension do
                                    x[j] := xpos[j] + koordinate[j] ;
                                  if kubus[x[1], x[2], x[3], x[4]]
                                    then
                                      moeglich := false
                                    else
                                      kubus[x[1], x[2], x[3], x[4]] := true ;
                                end ;
                            until not moeglich or ( i = steinanzahl ) ;
                            if moeglich
                              then
                                begin
                                  quader[ebene] := hilfsquader ;
                                  raus := true ;
                                end ;
                          end ;
          until raus ;
      end ;

    procedure loesungausgeben ;

      var
        montage : ausgabe ;
        i, j, k, x1, x2, x3, x4 : integer ;
        x : achsen ;

      begin
        loesungen := loesungen + 1 ;
        writeln(datei) ;
        writeln(datei, 'Loesung ', loesungen: 1, ' :') ;
        writeln(datei, rechenschritte: 1, ' Rechenschritte.') ;
        with quader[0].ausdehnung do
          for x1 := 1 to koordinate[1] do
            for x2 := 1 to koordinate[2] do
              for x3 := 1 to koordinate[3] do
                for x4 := 1 to koordinate[4] do
                  montage[x1, x2, x3, x4] := '.' ;
        for i := 1 to rechentiefe do
          with figuren.daten[zaehler[i].figur], zaehler[i] do
            for j := 1 to steinanzahl do
              with drehfigur[drehung].einzelstein[j] do
                begin
                  for k := 1 to dimension do
                    x[k] := lage.koordinate[k] + koordinate[k] ;
                  montage[x[1], x[2], x[3], x[4]] := kennung ;
                end ;
        with quader[0].ausdehnung do
          for x4 := 1 to koordinate[4] do
            begin
              writeln(datei) ;
              for x2 := koordinate[2] downto 1 do
                begin
                  for x3 := 1 to koordinate[3] do
                    begin
                      for x1 := 1 to koordinate[1] do
                        write(datei, montage[x1, x2, x3, x4]) ;
                      write(datei, ' ') ;
                    end ;
                  writeln(datei) ;
                end ;
            end ;
      end ;

    begin
      open(datei, 'PENTO.INF', history := new) ;
        rewrite(datei) ;
        writeln(datei, figurenname) ;
        writeln(datei, quadername) ;
        writeln ;
        with figuren do
          for i := 1 to anzahl do
            with daten[i] do
              begin
                verbraucht := false ;
                write('Figur "', kennung, '" hat ', drehanzahl: 2, ' ') ;
                if drehanzahl = 1
                  then
                    writeln('Lage  im Raum.')
                  else
                    writeln('Lagen im Raum.') ;
              end ;
        repeat
          writeln ;
          write('Wieviele Figuren soll ich einsetzen ? ') ;
          readln(rechentiefe) ;
          writeln ;
        until ( 0 < rechentiefe ) and ( rechentiefe <= figuren.anzahl ) ;
        ebene := 1 ;
        rechenschritte := 0 ;
        loesungen := 0 ;
        for i := 1 to dimension do
          anfang[i] := 1 ;
        erstesfreiesfeld(quader[0]) ;
        with zaehler[1] do
          begin
            figur := 1 ;
            drehung := 0 ;
            lage := quader[0].erstesfeld ;
          end ;
        repeat
          rechenschritte := rechenschritte + 1 ;
          if ( rechenschritte mod 10000 ) = 0
            then
              begin
                writeln ;
                writeln('Bis jetzt ', rechenschritte: 1, ' Rechenschritte.') ;
                for i := 1 to ( ebene - 1 ) do
                  with figuren.daten[zaehler[i].figur], zaehler[i], lage do
                    writeln(kennung, ' in Drehlage ', drehung: 3, '. ',
                      koordinate[1]: 4, koordinate[2]: 4,
                      koordinate[3]: 4, koordinate[4]: 4) ;
              end ;
          quader[ebene] := quader[ebene - 1] ;
          naechstefigureinsetzen(quader[ebene].erstesfeld.koordinate) ;
          if not moeglich
            then
              begin
                ebene := ebene - 1 ;
                if ebene > 0
                  then
                    figuren.daten[zaehler[ebene].figur].verbraucht := false ;
              end
            else
              if ebene = rechentiefe
                then
                  loesungausgeben
                else
                  begin
                    anfang := zaehler[ebene].lage.koordinate ;
                    erstesfreiesfeld(quader[ebene]) ;
                    if quadervoll
                      then
                        loesungausgeben
                      else
                        begin
                          figuren.daten[zaehler[ebene].figur].verbraucht :=
                            true ;
                          ebene := ebene + 1 ;
                          with zaehler[ebene] do
                            begin
                              figur := 1 ;
                              drehung := 0 ;
                              lage := quader[ebene-1].erstesfeld ;
                            end ;
                        end ;
                  end ;
        until ( ebene = 0 ) or ( loesungen = 1 ) ;
      close(datei) ;
      writeln ;
      if loesungen = 0
        then
          writeln('Keine Loesung !')
        else
          writeln('Probieren beendet !') ;
      writeln ;
      writeln(rechenschritte: 1, ' Rechenschritte.') ;
      writeln ;
    end ;

  begin
    writeln ;
    write('**********************************') ;
    writeln('*******************************') ;
    writeln('*', ' ': 63, '*') ;
    write('*  Hier ist der Pentomino-Loesungsalgorithmus ( Teil B ).') ;
    writeln('       *') ;
    writeln('*', ' ': 63, '*') ;
    write('**********************************') ;
    writeln('*******************************') ;
    writeln('*', ' ': 63, '*') ;
    writeln('*  Ich bin das eigentliche Probierprogramm.', ' ': 21, '*') ;
    writeln('*  Die Ergebnisse speichere ich in "PENTO.INF".', ' ': 17, '*') ;
    writeln('*', ' ': 63, '*') ;
    write('*  Quadergroesse dieser Pentomino-Version : ') ;
    writeln(d1: 2, ' * ', d2: 2, ' * ', d3: 2, ' * ', d4: 2, '.  *') ;
    writeln('*', ' ': 63, '*') ;
    write('**********************************') ;
    writeln('*******************************') ;
    speicherlesen ;
    quaderlesen ;
    loesungsuchen ;
  end .