' Erstellung kompletter Polyomino-Listen
' Walter Trump
' 03.08.98
$ABIG p$(),ap&(),al&(),ab&()
'
GOSUB Start
GOSUB Eingabe
IF ord% = 2
  GOSUB erste_Liste
ELSE
  GOSUB BasisListe
ENDIF
GOSUB Felder
GOSUB Bildschirm
GOSUB Polyomino
GOSUB Liste_speichern
GOSUB Ende
> PROCEDURE Eingabe
  CLS
  ?
  ? " Erstellung von Polyominolisten"
  ?
  ? " Vorhande Listen (poly-xx.dat):"
  ?
  ? " 01";
  DIM Liste!(20)
  ARRAYFILL Liste!() = 0
  Liste!(1) = TRUE
  FOR i% = 2 TO 20
    IF EXIST("poly-" + DEC$(i%,2) + ".dat")
      ? " - " + DEC$(i%,2);
      Liste!(i%) = TRUE
    ENDIF
  NEXT i%
  ?
  ?
  ? " Eine Liste für Polyominoes der Ordnung n"
  ? " kann nur dann erstellt werden,"
  ? " wenn die Liste der Ordnung n-1 vorhanden ist."
  ?
  ? " Geben Sie die Ordnung der gewünschten Polyominoes ein:"
  INPUT " --> ",ord%
  ord% = MAX(2,MIN(ord%,20))
  IF Liste!(ord% - 1) = FALSE
    ?
    ? " Die Liste kann nicht erstellt werden,"
    ? " weil die Liste für die Ordnung " + DEC$(ord% - 1,2)
    ? " noch nicht erstellt wurde oder sich"
    ? " nicht im aktuellen Arbeitsverzeichnis befindet."
    GOSUB Ende
  ENDIF
RETURN
> PROCEDURE BasisListe
  ' Die Liste der Polyominoes mit der Ordnung ord%-1 wird geladen
  OPEN "I",#1,"poly-" + DEC$(ord% - 1,2) + ".dat"
  LINE INPUT #1,Text$
  INPUT #1,Bn%
  DIM al&(Bn%),ab&(Bn%),ap&(Bn%,6)
  FOR i% = 1 TO Bn%
    INPUT #1,ab&(i%)
    INPUT #1,al&(i%)
    k% = 0
    DO
      INPUT #1,p&
      EXIT IF p& = 0
      ap&(i%,k%) = p&
      INC k%
    LOOP
  NEXT i%
  CLOSE #1
RETURN
> PROCEDURE erste_Liste
  Bn% = 1
  DIM al&(Bn%),ab&(Bn%),ap&(Bn%,6)
  al&(1) = 1
  ab&(1) = 1
  ap&(1,0) = 1  //Das Bit 0 wird auf 1 gesetzt
  ap&(1,1) = 0
  ap&(1,2) = 0
  ap&(1,3) = 0
  ap&(1,4) = 0
  ap&(1,5) = 0
  ap&(1,6) = 0
RETURN
> PROCEDURE Polyomino
  ' Alle Figuren aus ord% Feldern (Quadraten) werden gesucht.
  LOCAL i%, j%, k%
  ' Zähler für neue Polyominos: num%
  num% = 0
  FOR i% = 1 TO Bn%
    '
    ' Daten eines Polyominos mit ord%-1 Quadraten in ein temporäres Integerfeld laden.
    l& = PRED(al&(i%))  // Länge - 1
    b& = PRED(ab&(i%))  // Breite - 1
    FOR j% = 0 TO b&
      z&(j%) = ap&(i%,j%)
    NEXT j%
    '
    ' Bilden einer neuen Figur mit ord% Feldern
    ' Ein Bit wird auf der niederwertigen Seite hinzugefügt
    nl& = SUCC(l&)
    nb& = b&
    FOR j% = 0 TO b&
      t&(j%) = 2 * z&(j%)     //um ein Bit verschieben
    NEXT j%
    FOR k% = 0 TO b&
      IF BTST(t&(k%),1)
        t&(k%) = BSET(t&(k%),0)
        GOSUB Normierung
        t&(k%) = BCLR(t&(k%),0)
      ENDIF
    NEXT k%
    ' Ein Bit wird links hinzugefügt
    FOR j% = 0 TO b&
      t&(j%) = z&(j%)
    NEXT j%
    FOR k% = 0 TO b&
      IF BTST(t&(k%),l&)
        t&(k%) = BSET(t&(k%),nl&)
        GOSUB Normierung
        t&(k%) = z&(k%)
      ENDIF
    NEXT k%
    ' Ein Bit wird oben hinzugefügt
    nl& = l&
    nb& = SUCC(b&)
    m& = z&(0)
    FOR j% = 0 TO b&
      t&(SUCC(j%)) = z&(j%)
    NEXT j%
    FOR k% = 0 TO l&
      IF BTST(m&,k%)
        t&(0) = BSET(0,k%)
        GOSUB Normierung
      ENDIF
    NEXT k%
    ' Ein Bit wird unten hinzugefügt
    m& = z&(b&)
    FOR j% = 0 TO b&
      t&(j%) = z&(j%)
    NEXT j%
    FOR k% = 0 TO l&
      IF BTST(m&,k%)
        t&(nb&) = BSET(0,k%)
        GOSUB Normierung
      ENDIF
    NEXT k%
    ' Es wird im Inneren ein Bit hinzugefügt
    ' ( t&() ist noch richtig belegt)
    nb& = b&
    t&(SUCC(b&)) = 0
    ' Erste Zeile
    ' Mögliche Positionen für ein zusätzliches Quadrat ermitteln
    ' Ein Feld kann belegt werden, wenn das darüber oder darunter liegende Feld belegt ist,
    ' Oder wenn das rechts oder links liegende Feld belegt ist,
    ' aber natürlich darf das Feld selbst noch nicht belegt sein.
    m& = (t&(1) OR (2 * t&(0)) OR (t&(0) DIV 2)) AND (NOT t&(0))
    FOR k% = 0 TO l&
      IF BTST(m&,k%)
        t&(0) = BSET(z&(0),k%)
        GOSUB Normierung
      ENDIF
    NEXT k%
    t&(0) = z&(0)
    t&(SUCC(b&)) = 0
    ' Weitere Zeilen
    FOR j% = 1 TO b&
      m& = (t&(PRED(j%)) OR t&(SUCC(j%)) OR SHL&(t&(j%),1) OR SHR&(t&(j%),1)) AND (NOT t&(j%))
      FOR k% = 0 TO l&
        IF BTST(m&,k%)
          t&(j%) = BSET(z&(j%),k%)
          GOSUB Normierung
        ENDIF
      NEXT k%
      t&(j%) = z&(j%)
    NEXT j%
  NEXT i%
RETURN
> PROCEDURE Start
  ' Fenster einrichten
  OPENW #31,0,0,640,400,0
  SETWINDOWSTYLE 31,WS_CAPTION OR WS_THICKFRAME OR WS_VISIBLE
  TITLEW #31," Polyominos "
  ' Graphik einstellung
  DEFMOUSE 0
  GRAPHMODE R2_COPYPEN,OPAQUE
  DEFLINE 0,1
  COLOR 0
  DEFFILL 0
  ' Zeichensatz festgelegen
  FONT "COURIER NEW"
  FONT WIDTH 10, HEIGHT 20
  FONT ITALIC 0,UNDERLINE 0,STRIKEOUT 0,WEIGHT 700
  FONT TO V_font&
  SETFONT V_font&
  ON BREAK GOSUB Ende
  CLS
  ' Systemmeldungen abwarten
  DO
    PEEKEVENT
  LOOP UNTIL MENU(1) = 0
RETURN
> PROCEDURE Ende
  DIM V_m$(200)
  FOR V_i& = 0 TO _Y DIV 8
    GET 0,V_i& * 8,_X,V_i& * 8 + 8,V_m$(V_i&)
  NEXT V_i&
  SETWINDOWSTYLE 31,WS_CAPTION OR WS_SYSMENU OR WS_THICKFRAME OR WS_VISIBLE
  TITLEW #31, "Programm beendet. Esc --> Fenster schließen"
  DO
    PEEKEVENT
    IF MENU(1) = 21
      FOR V_i& = 0 TO _Y DIV 8
        PUT 0,V_i& * 8,V_m$(V_i&)
      NEXT V_i&
    ELSE IF MENU(1) = 1
      V_key| = MENU(5)
    ENDIF
  LOOP UNTIL V_key| = 32 OR V_key| = 27 OR MENU(1) = 4
  CLOSEW #31
  IF V_key| = 32 THEN RUN
  EDIT
RETURN
> PROCEDURE Felder
  ' Maximale Zahl der speicherbaren Polyominoes
  maxnum% = 5 * Bn%
  ' Jedes Polyomino wird in eine Normlage gebracht.
  ' Dabei soll die längere Seite des umbeschriebenen Rechtecks waagrecht liegen.
  ' Die Figur wird durch ein Bitmuster beschrieben, das in Normlage
  ' einer möglichst kleinen Zahl entspricht.
  ' Die x-Richtung beträgt immer 16 Bit (word)
  ' Die Anzahl der 16-Bit-Integer richtet sich nach der Breite (Höhe) des umbeschriebenen
  ' Rechtecks.
  ' Die Polyominoes werden als Strings gespeichert
  DIM p$(maxnum%)
  ' Anzahl der Teilquadrate des Polyominoes
  '  DIM l&(maxnum%),b&(maxnum%)
  ' Bit_Codierung der Polyominoes:
  '  DIM P&(maxnum%,6)
  ' Temporäre Integerfelder
  DIM t&(10),z&(10),v&(10),w&(10)
RETURN
> PROCEDURE Bildschirm
  CLS
  GET 0,0,200,100,leer&
  TEXT 20,10,"Gesucht werden Polyominos der Ordnung " + STR$(ord%)
RETURN
> PROCEDURE Normierung
  ' Notwendige Daten: nl&, nb&, t&()
  ' Es werden h% und v% lokal verwendet
  ' w&() soll das normierte Polyomino enthalten.
  ' v&() enthält jeweils das Polyomino in einer veränderten Lage
  FOR h% = 0 TO nb&
    v&(h%) = t&(h%)
    w&(h%) = t&(h%)
  NEXT h%
  IF nl& > nb&    // Es ist keine Drehung notwendig
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB horizontal_spiegeln
    GOSUB Vergleich
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB einsortieren
  ELSE IF nl& = nb&    // Es sind Drehungen möglich
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB horizontal_spiegeln
    GOSUB Vergleich
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB drehen
    GOSUB Vergleich
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB horizontal_spiegeln
    GOSUB Vergleich
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB einsortieren
  ELSE   // Es ist eine Drehung notwendig, da die Breite größer als die Länge ist
    GOSUB drehen
    SWAP nl&,nb&
    FOR h% = 0 TO nb&
      w&(h%) = v&(h%)
    NEXT h%
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB horizontal_spiegeln
    GOSUB Vergleich
    GOSUB vertikal_spiegeln
    GOSUB Vergleich
    GOSUB einsortieren
    SWAP nl&,nb&
  ENDIF
RETURN
> PROCEDURE vertikal_spiegeln
  FOR h% = 0 TO PRED(nb&) DIV 2
    SWAP v&(h%),v&(nb& - h%)
  NEXT h%
RETURN
> PROCEDURE horizontal_spiegeln
  FOR h% = 0 TO nb&
    v& = 0
    FOR v% = 0 TO nl&
      IF BTST(v&(h%),v%)
        v& = BSET(v&,nl& - v%)
      ENDIF
    NEXT v%
    v&(h%) = v&
  NEXT h%
RETURN
> PROCEDURE drehen
  ' Achtung es wird immer das Polyomino in t&() gedreht !!!
  FOR v% = 0 TO nl&
    v& = 0
    FOR h% = 0 TO nb&
      IF BTST(t&(h%),v%)
        v& = BSET(v&,h%)
      ENDIF
    NEXT h%
    v&(v%) = v&
  NEXT v%
RETURN
> PROCEDURE Vergleich
  FOR h% = 0 TO nb&
    EXIT IF w&(h%) <> v&(h%)
  NEXT h%
  IF v&(h%) < w&(h%)
    FOR h% = 0 TO nb&
      w&(h%) = v&(h%)
    NEXT h%
  ENDIF
RETURN
> PROCEDURE einsortieren
  p$ = CHR$(SUCC(nb&)) + CHR$(SUCC(nl&))
  FOR h% = 0 TO nb&
    p$ = p$ + MKI$(w&(h%))
  NEXT h%
  IF num% > 2
    min% = 1
    max% = num%
    IF p$ =< p$(1)
      IF p$ < p$(1)
        GOSUB platzieren(1)
      ENDIF
    ELSE IF p$ >= p$(num%)
      IF p$ > p$(num%)
        GOSUB platzieren(SUCC(num%))
      ENDIF
    ELSE
      DO WHILE min% < PRED(max%)
        mid% = (max% + min%) DIV 2
        q$ = p$(mid%)
        EXIT IF p$ = q$
        IF p$ < q$
          max% = mid%
        ELSE
          min% = mid%
        ENDIF
      LOOP
      IF p$ <> q$
        GOSUB platzieren(max%)
      ENDIF
    ENDIF
  ELSE IF num% = 2
    IF p$ < p$(1)
      GOSUB platzieren(1)
    ELSE IF p$ > p$(2)
      GOSUB platzieren(3)
    ELSE IF p$ > p$(1) AND p$ < p$(2)
      GOSUB platzieren(2)
    ENDIF
  ELSE IF num% = 1
    IF p$ < p$(1)
      GOSUB platzieren(1)
    ELSE IF p$ > p$(1)
      GOSUB platzieren(2)
    ENDIF
  ELSE
    GOSUB platzieren(1)
  ENDIF
RETURN
> PROCEDURE platzieren(p%)
  ' INSERT p$(p%) = p$
  IF num% >= p%
    FOR pl% = num% DOWNTO p%
      p$(SUCC(pl%)) = p$(pl%)
    NEXT pl%
  ENDIF
  p$(p%) = p$
  INC num%
  TEXT 10,50,STR$(num%,8)
  '  GOSUB Ausgabe
RETURN
> PROCEDURE Ausgabe
  b% = 16
  x0% = 50
  y0% = 100
  PUT x0%,y0%,leer&
  FOR h% = 0 TO nb&
    FOR v% = 0 TO nl&
      IF BTST(w&(h%),v%)
        BOX x0% + v% * b%,y0% + h% * b%,x0% + SUCC(v%) * b%,y0% + SUCC(h%) * b%
      ENDIF
    NEXT v%
  NEXT h%
  '  REPEAT
  '    PEEKEVENT
  '  UNTIL INKEY$ = " "
RETURN
> PROCEDURE Liste_speichern
  CLS
  ? "Die Liste ";STR$(ord%);" wird gespeichert."
  ? "Es wurden ";STR$(num%);" Polyominoes gefunden."
  ' Sicherheitstest
  FOR n% = 1 TO num% - 1
    IF p$(n%) >= p$(SUCC(n%))
      ? " Die Reihenfolge ist nicht korrekt!!"
      ? " Fehler bei ";n%,n% + 1
    ENDIF
  NEXT n%
  OPEN "O",#1,"poly-" + DEC$(ord%,2) + ".dat"
  PRINT #1,"Polyominoes der Ordnung " + STR$(ord%)
  PRINT #1,num%
  FOR i% = 1 TO num%
    p$ = p$(i%)
    PRINT #1,ASC(MID$(p$,1,1))
    PRINT #1,ASC(MID$(p$,2,1))
    k% = LEN(p$) DIV 2 - 1
    FOR j% = 1 TO k%
      PRINT #1,CVI(MID$(p$,j% * 2 + 1,2))
    NEXT j%
    PRINT #1, 0
  NEXT i%
  CLOSE #1
  ?
  ? "Fertig!"
RETURN