' Gesucht werden Polyominoes, die das Wohnungsproblem (Flatpuzzle) lösen.
' Benötigt werden Polyomino-Listen.
' Walter Trump
' 11.08.98
$ABIG Temp|(),p&(),l&(),b&()
GOSUB Start
GOSUB Eingabe
GOSUB Liste_laden
GOSUB Felder
GOSUB Bildschirm
GOSUB Polyomino
GOSUB fertig
GOSUB Ende
> PROCEDURE Eingabe
  CLS
  ?
  ? " Ein Polyomino heißt kontaktiv, wenn sich vier"
  ? " dazu kongruente Polyominoes so anordnen lassen,"
  ? " dass sie sich paarweise berühren."
  ?
  ? " 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%
  ?
  ?
  ? " Welche Liste soll durchsucht werden?"
  INPUT " --> ",ord%
  ord% = MAX(2,MIN(ord%,20))
  IF Liste!(ord%) = FALSE
    ?
    ? " Die Liste für die Ordnung " + DEC$(ord%,2)
    ? " wurde noch nicht erstellt oder befindet"
    ? " sich nicht im aktuellen Arbeitsverzeichnis."
    GOSUB Ende
  ENDIF
  ' Falls die Suche zuvor abgebrochen wurde, steht die Startnummer in der Datei Stop-num.txt.
  startnum% = 2      //Start bei 2 !! num%=1 liefert nie eine Lösung, da Figur konvex
  datei$ = "Poly-" + DEC$(ord%,2) + "\Stop-num.txt"
  IF EXIST(datei$)
    OPEN "I",#2,datei$
    LINE INPUT #2,a$
    INPUT #2,startnum%
    CLOSE #2
  ENDIF
  IF startnum% = -1
    CLS
    TEXT 20,30,"Alle kontaktiven Polyominoes der Ordnung " + STR$(ord%)
    TEXT 20,60,"wurden bereits im Ordner Poly-" + DEC$(ord%,2) + " gespeichert."
    GOSUB Ende
  ENDIF
RETURN
> PROCEDURE Liste_laden
  ' Die Liste der Polyominoes mit der Ordnung ord% wird geladen
  OPEN "I",#1,"poly-" + DEC$(ord%,2) + ".dat"
  LINE INPUT #1,Text$
  INPUT #1,anz%
  DIM l&(anz%),b&(anz%),P&(anz%,6)
  FOR i% = 1 TO anz%
    INPUT #1,b&(i%)
    INPUT #1,l&(i%)
    k% = 0
    DO
      INPUT #1,p&
      EXIT IF p& = 0
      P&(i%,k%) = p&
      INC k%
    LOOP
  NEXT i%
  CLOSE #1
RETURN
> PROCEDURE Polyomino
  ' Alle Figuren aus ord% Zellen werden untersucht.
  FOR num% = startnum% TO anz%
    ' Für schnelle Testläufe num% = 110 to ... wählen - bei ord%=8!!
    TEXT 50,70,DEC$(num%,6)
    '
    ' Daten eines Polyominos mit ord% Zellen in ein temporäres Integerfeld laden.
    sl& = SUCC(l&(num%))
    l& = PRED(l&(num%))  // Länge - 1
    b& = PRED(b&(num%))  // Breite - 1
    FOR j% = 0 TO b&
      z&(j%) = P&(num%,j%)
      v&(j%) = z&(j%)
    NEXT j%
    v&(SUCC(b&)) = 0
    v&(b& + 2) = 0
    nl& = l&, nb& = b&  //wird bei Spiegelungen und Drehungen verwendet
    '
    ' Mögliche Positionen und Ränder des Polyominoes speichern
    ' waagrechte Lage
    GOSUB Positionen(0)
    GOSUB vertikal_spiegeln
    GOSUB Positionen(2 * sl&)
    GOSUB horizontal_spiegeln
    GOSUB Positionen(1 * sl&)
    GOSUB vertikal_spiegeln
    GOSUB Positionen(3 * sl&)
    ' senkrechte Lage
    GOSUB drehen
    SWAP nl&,nb&
    GOSUB Positionen(4 * sl&)
    GOSUB vertikal_spiegeln
    GOSUB Positionen(6 * sl&)
    GOSUB horizontal_spiegeln
    GOSUB Positionen(5 * sl&)
    GOSUB vertikal_spiegeln
    GOSUB Positionen(7 * sl&)
    '
    ' Alle Ränder speichern
    GOSUB Poly1
  NEXT num%
RETURN
> PROCEDURE Poly1
  ' Vier Polyominoes sollen so gelegt werden,
  ' dass sie sich nicht überlagern und sich paarweise berühren.
  ' Das erste Polyomino wird an den oberen Rand auf die niederwertige Seite gelegt.
  ' (Dies ist möglich weil die Gesamtfigur in ein Rechteck einbeschrieben werden kann.
  ' Die Ränder dieses Rechtecks werden jeweils von mindestens einem Polyomino berührt.
  ' Da ein Poly von den anderen umschlossen, wird kann es keinen Rechteckrand berühren.
  ' Von den übrigen drei Polys muss also mindestens eines zwei Ränder berühren.
  ' Das ertse Poly soll diese Eigenschaft haben, und braucht deshalb nicht verschoben zu werden.)
  y1% = 1      // y-Position des 1. Polyomino (Start bei 1)
  yv1% = 0     // Zeile vor dem Poly 1
  x1% = 0      // x-Position des 1. Polyomino  (Start bei 0)
  FOR r1% = 0 TO 7   //Orientierung von Poly 1
    IF r1% < 4
      b1& = b&            //Breite des 1. Polyomino
      l1& = l&            //Länge des 1. Polyomino
    ELSE
      b1& = l&
      l1& = b&
    ENDIF
    ye1% = y1% + b1&        // letzte Zeile des Poly 1
    yn1% = SUCC(ye1%)       // Zeile nach Poly 1
    xe1% = l1&
    k1% = r1% * sl& + x1%
    GOSUB Poly2
    PEEKEVENT
    key$ = INKEY$
    IF key$ > " " THEN GOSUB Taste
  NEXT r1%
RETURN
> PROCEDURE Poly2
  ' Dieses Poly bildet normalerweise das mittlere, umschlossene Poly,
  ' es darf weder den oberen noch den niederwertigen Rand berühren,
  ' d.h. x>0 und y>1.
  FOR r2% = 0 TO 7
    IF r2% < 4
      b2& = b&            //Breite des 2. Poly
      l2& = l&
    ELSE
      b2& = l&
      l2& = b&
    ENDIF
    FOR x2% = 1 TO SUCC(xe1%)
      k2% = r2% * sl& + x2%
      xe2% = x2% + l2&
      FOR y2% = 2 TO yn1%       //y-Position höchstens eine Zeile unter dem 1. Poly
        yv2% = PRED(y2%)
        ye2% = y2% + b2&
        yn2% = SUCC(ye2%)
        ' Prüfen ob 1. Poly und 2. Poly sich überschneiden
        US! = FALSE
        FOR i% = y2% TO MIN(ye2%,ye1%)
          IF M%(k1%,i%) AND M%(k2%,i% - yv2%)
            US! = TRUE
            EXIT IF TRUE
          ENDIF
        NEXT i%
        IF NOT US!
          ' Prüfen, ob sich 1. Poly und 2. Poly berühren
          BR! = FALSE
          FOR i% = y2% TO MIN(ye2%,yn1%)
            IF R%(k1%,i%) AND M%(k2%,i% - yv2%)
              BR! = TRUE
              EXIT IF TRUE
            ENDIF
          NEXT i%
          IF BR!
            ' Poly 1 und Poly 2 liegen korrekt
            ' Nächstes Polyomino anlegen
            GOSUB Poly3
          ENDIF
        ENDIF
      NEXT y2%
    NEXT x2%
  NEXT r2%
RETURN
> PROCEDURE Poly3
  ' Poly 3 soll weiter am höherwertigen Rand liegen als Poly 2.
  FOR r3% = 0 TO 7
    IF r3% < 4
      b3& = b&            //Breite des 3. Poly
      l3& = l&
    ELSE
      b3& = l&
      l3& = b&
    ENDIF
    FOR x3% = x2% TO SUCC(MIN(xe1%,xe2%)) //x-Position höchstens eine Spalte hinter Poly 2 (bzw. Poly 1)
      k3% = r3% * sl& + x3%
      xe3% = x3% + l3&
      FOR y3% = 1 TO MIN(yn1%,yn2%)  //y-Position höchstens eine Zeile unter Poly 1 und 2
        yv3% = PRED(y3%)
        ye3% = y3% + b3&
        yn3% = SUCC(ye3%)
        ' Prüfen ob 1. Poly und 3. Poly sich überschneiden
        US! = FALSE
        FOR i% = y3% TO MIN(ye3%,ye1%)
          IF M%(k1%,i%) AND M%(k3%,i% - yv3%)
            US! = TRUE
            EXIT IF TRUE
          ENDIF
        NEXT i%
        IF NOT US!
          ' Prüfen ob 2. Poly und 3. Poly sich überschneiden
          US! = FALSE
          FOR i% = MAX(y3%,y2%) TO MIN(ye3%,ye2%)
            IF M%(k2%,i% - yv2%) AND M%(k3%,i% - yv3%)
              US! = TRUE
              EXIT IF TRUE
            ENDIF
          NEXT i%
          IF NOT US!
            ' Prüfen, ob sich 1. Poly und 3. Poly berühren
            BR! = FALSE
            FOR i% = y3% TO MIN(ye3%,yn1%)
              IF R%(k1%,i%) AND M%(k3%,i% - yv3%)
                BR! = TRUE
                EXIT IF TRUE
              ENDIF
            NEXT i%
            IF BR!
              ' Prüfen, ob sich 2. Poly und 3. Poly berühren
              BR! = FALSE
              FOR i% = MAX(y3%,yv2%) TO MIN(ye3%,yn2%)
                IF R%(k2%,i% - yv2%) AND M%(k3%,i% - yv3%)
                  BR! = TRUE
                  EXIT IF TRUE
                ENDIF
              NEXT i%
              IF BR!
                ' Poly 3 liegt korrekt
                ' Nächstes Polyomino anlegen
                GOSUB Poly4
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      NEXT y3%
    NEXT x3%
  NEXT r3%
RETURN
> PROCEDURE Poly4
  ' Poly 4 soll unterhalb von Poly 2 liegen
  FOR r4% = 0 TO 7
    IF r4% < 4
      b4& = b&            //Breite des 4. Poly
      l4& = l&
    ELSE
      b4& = l&
      l4& = b&
    ENDIF
    FOR x4% = 0 TO SUCC(MIN(xe1%,xe2%,xe3%))     //x-Position höchstens eine Spalte hinter Poly 1,2,3
      k4% = r4% * sl& + x4%
      xe4% = x4% + l4&
      FOR y4% = y2% TO MIN(yn1%,yn2%,yn3%)     //y-Position höchstens eine Zeile unter Poly 1,2,3
        yv4% = PRED(y4%)
        ye4% = y4% + b4&
        ' yn4% wird nicht gebraucht!
        ' Prüfen ob 1. Poly und 4. Poly sich überschneiden
        US! = FALSE
        FOR i% = y4% TO MIN(ye4%,ye1%)
          IF M%(k1%,i%) AND M%(k4%,i% - yv4%)
            US! = TRUE
            EXIT IF TRUE
          ENDIF
        NEXT i%
        IF NOT US!
          ' Prüfen ob 2. Poly und 4. Poly sich überschneiden
          FOR i% = MAX(y4%,y2%) TO MIN(ye4%,ye2%)
            IF M%(k2%,i% - yv2%) AND M%(k4%,i% - yv4%)
              US! = TRUE
              EXIT IF TRUE
            ENDIF
          NEXT i%
          IF NOT US!
            ' Prüfen ob 3. Poly und 4. Poly sich überschneiden
            FOR i% = MAX(y4%,y3%) TO MIN(ye4%,ye3%)
              IF M%(k3%,i% - yv3%) AND M%(k4%,i% - yv4%)
                US! = TRUE
                EXIT IF TRUE
              ENDIF
            NEXT i%
            IF NOT US!
              ' Prüfen, ob sich 1. Poly und 4. Poly berühren
              BR! = FALSE
              FOR i% = y4% TO MIN(ye4%,yn1%)
                IF R%(k1%,i%) AND M%(k4%,i% - yv4%)
                  BR! = TRUE
                  EXIT IF TRUE
                ENDIF
              NEXT i%
              IF BR!
                ' Prüfen, ob sich 2. Poly und 4. Poly berühren
                BR! = FALSE
                FOR i% = MAX(y4%,yv2%) TO MIN(ye4%,yn2%)
                  IF R%(k2%,i% - yv2%) AND M%(k4%,i% - yv4%)
                    BR! = TRUE
                    EXIT IF TRUE
                  ENDIF
                NEXT i%
                IF BR!
                  ' Prüfen, ob sich 3. Poly und 4. Poly berühren
                  BR! = FALSE
                  FOR i% = MAX(y4%,yv3%) TO MIN(ye4%,yn3%)
                    IF R%(k3%,i% - yv3%) AND M%(k4%,i% - yv4%)
                      BR! = TRUE
                      EXIT IF TRUE
                    ENDIF
                  NEXT i%
                  IF BR!
                    ' Eine Lösung wurde gefunden
                    GOSUB Ausgabe
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      NEXT y4%
    NEXT x4%
  NEXT r4%
RETURN
> PROCEDURE Start
  ' Fenster einrichten
  OPENW #31,0,0,640,400,0
  SETWINDOWSTYLE 31,WS_CAPTION OR WS_THICKFRAME OR WS_VISIBLE
  TITLEW #31," Suche nach kontaktiven Polyominoes "
  ' 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
  IF Ende! = FALSE
    DIM V_m$(200)
    Ende! = TRUE
  ENDIF
  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 Taste
  IF UPPER$(key$) = "E"
    DEC num%
    OPEN "O",#2,"Poly-" + DEC$(ord%,2) + "\" + "Stop-num.txt"
    PRINT #2,"Die Polyominosuche " + STR$(ord%) + " wurde bei folgender Nummer abgebrochen:"
    PRINT #2,num%
    CLOSE #2
    GOSUB Ende
  ENDIF
RETURN
> PROCEDURE fertig
  OPEN "O",#2,"Poly-" + DEC$(ord%,2) + "\" + "Stop-num.txt"
  PRINT #2,"Die Polyominosuche " + STR$(ord%) + " wurde vollständig durchgeführt."
  PRINT #2,-1
  CLOSE #2
RETURN
> PROCEDURE Felder
  ' Temporäre Integerfelder
  DIM z&(ord% + 2),v&(ord% + 2)
  ' Mogliche Positionen eines einzelnen Polyominoes
  DIM M%(8 * ord%,ord% + 1)
  ARRAYFILL M%(),0
  ' Ränder der Polyominoes
  DIM R%(8 * ord%,ord% + 1)
  ARRAYFILL R%(),0
  ' Untersuchung der Gesamtfigur
  DIM v%(32),t%(32)
  ' Zum Vergleich der Löcher bei unterschiedlichen Anordnungen
  DIM Lochzellen!(99),Loecherzahl!(50)
  ' Temporäres Feld zum Speichern der Bitmaps
  DIM temp|(54 + 8 * 8 * (ord% + 5) * (ord% + 5) * 3 + 1000)
  ' Variablen initialisieren
  a_num% = 0
  a_Loch% = 1000
RETURN
> PROCEDURE Bildschirm
  CLS
  GET 0,0,_X - 1,_Y - 1,leer&
  TEXT 20,10,"Polyominoes der Ordnung " + STR$(ord%) + " *** Abbruch mit der Taste E"
  TEXT 20,35,"Im Arbeitsverzeichnis muss der Ordner Poly-" + DEC$(ord%,2) + " angelegt sein!"
  TEXT 120,70,"von " + STR$(anz%)
RETURN
> PROCEDURE Positionen(z%)
  ' Die Figur muss in v&() gespeichert sein.
  ' Zwei Zeilen über die Breite b& hinaus müssen null sein.
  LOCAL k%,j%, m%, n%
  ' Bitmuster der Figur für alle x-Positionen von 0 bis (Länge der Figur) speichern.
  ' Die y-Position beginnt im Gegensatz zur x-Position nicht bei 0 sondern bei 1,
  ' damit der darüberliegende Randbereich auch gespeichert werden kann.
  FOR k% = 0 TO PRED(sl&)
    m% = 0
    n% = 0
    FOR j% = 0 TO nb& + 2
      v% = m%                 // Vorgänger
      m% = n%                 // aktuelle Zeile
      n% = SHL(v&(j%),k%)     // Nachfolger - Achtung v&() beginnt bei 0 !!
      M%(z% + k%,j%) = m%
      R%(z% + k%,j%) = SHL(m%,1) OR SHR(m%,1) OR v% OR n%
    NEXT j%
  NEXT k%
  ' Alle Bits, welche die Figur berühren werden in R%() gespeichert.
  ' Die Bits der Figur selbst werden mitgespeichert, weil sie beim Berührtest nicht stören.
  ' (Es wird stets vorher ausgeschlossen, dass sich die Figuren überlagern.)
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 z&() gedreht !!!
  ' Es wird eine 90°-Drehung im Uhrzeigersinn (ohne Spiegelung) durchgeführt.
  FOR v% = 0 TO nl&
    v& = 0
    FOR h% = 0 TO nb&
      IF BTST(z&(h%),v%)
        v& = BSET(v&,nb& - h%)
      ENDIF
    NEXT h%
    v&(v%) = v&
  NEXT v%
  v&(SUCC(nl&)) = 0
  v&(nl& + 2) = 0
RETURN
> PROCEDURE Ausgabe
  GOSUB Untersuchung
  IF a_num% = num%
    IF Lochzellen!(Loch%)=FALSE OR Loecherzahl!(Loecherzahl%)=FALSE
      Lochzellen!(Loch%) = TRUE
      Loecherzahl!(Loecherzahl%) = TRUE
      GOSUB Zeichnen
    ENDIF
  ELSE
    INC Zaehler%
    a_num% = num%
    ARRAYFILL Loecherzahl!(),0
    ARRAYFILL Lochzellen!(),0
    Lochzellen!(Loch%) = TRUE
    Loecherzahl!(Loecherzahl%) = TRUE
    GOSUB Zeichnen
  ENDIF
RETURN
PROCEDURE Zeichnen
  b% = 6
  x0% = 50
  y0% = 150
  PUT x0%,y0%,leer&
  RGBCOLOR RGB(0,0,0)
  ' 1. Polyomino
  FOR h% = y1% TO ye1%
    m% = M%(k1%,h% - yv1%)
    FOR v% = 0 TO 31
      IF m% AND BSET(0,v%)
        BOX x0% + v% * b%,y0% + h% * b%,x0% + SUCC(v%) * b%,y0% + SUCC(h%) * b%
        RGBCOLOR RGB(100,100,255)
        PBOX x0% + v% * b% + 1,y0% + h% * b% + 1,x0% + SUCC(v%) * b% - 1,y0% + SUCC(h%) * b% - 1
        RGBCOLOR RGB(0,0,0)
      ENDIF
    NEXT v%
  NEXT h%
  ' 2. Polyomino
  FOR h% = y2% TO ye2%
    m% = M%(k2%,h% - yv2%)
    FOR v% = 0 TO 31
      IF m% AND BSET(0,v%)
        BOX x0% + v% * b%,y0% + h% * b%,x0% + SUCC(v%) * b%,y0% + SUCC(h%) * b%
        RGBCOLOR RGB(230,230,0)
        PBOX x0% + v% * b% + 1,y0% + h% * b% + 1,x0% + SUCC(v%) * b% - 1,y0% + SUCC(h%) * b% - 1
        RGBCOLOR RGB(0,0,0)
      ENDIF
    NEXT v%
  NEXT h%
  ' 3. Polyomino
  FOR h% = y3% TO ye3%
    m% = M%(k3%,h% - yv3%)
    FOR v% = 0 TO 31
      IF m% AND BSET(0,v%)
        BOX x0% + v% * b%,y0% + h% * b%,x0% + SUCC(v%) * b%,y0% + SUCC(h%) * b%
        RGBCOLOR RGB(0,220,0)
        PBOX x0% + v% * b% + 1,y0% + h% * b% + 1,x0% + SUCC(v%) * b% - 1,y0% + SUCC(h%) * b% - 1
        RGBCOLOR RGB(0,0,0)
      ENDIF
    NEXT v%
  NEXT h%
  ' 4. Polyomino
  FOR h% = y4% TO ye4%
    m% = M%(k4%,h% - yv4%)
    FOR v% = 0 TO 31
      IF m% AND BSET(0,v%)
        BOX x0% + v% * b%,y0% + h% * b%,x0% + SUCC(v%) * b%,y0% + SUCC(h%) * b%
        RGBCOLOR RGB(255,50,50)
        PBOX x0% + v% * b% + 1,y0% + h% * b% + 1,x0% + SUCC(v%) * b% - 1,y0% + SUCC(h%) * b% - 1
        RGBCOLOR RGB(0,0,0)
      ENDIF
    NEXT v%
  NEXT h%
  '
  '
  bmb& = (ord% + 4) * 6  //b% * 2 * ord% + 21
  bmh& = (ord% + 4) * 6  //SUCC(MAX(ye1%,ye2%,ye3%,ye4%)) * b% + 21
  'bmp& = CREATEBMP(bmb&,bmh&)
  '~SelectObject(hnddc&,bmp&)
  'BITBLT _DC(31),x0% - 10,y0% - 10,bmb&,bmh&,hnddc&,0,0,SRCCOPY
  GET x0% - 8,y0%,x0% + bmb& - 9,y0% + bmh& - 1,bmp&

  GOSUB BitmapSpeichern("Poly-" + DEC$(ord%,2) + "\" + CHR$(65+Loecherzahl%) + DEC$(Loch%,2)+"-" + DEC$(Zaehler%,4) + ".bmp",bmp&,bmb&,bmh&)
  FREEBMP bmp&
  '  REPEAT
  '  PEEKEVENT
  '  key$ = UPPER$(INKEY$)
  '  IF key$ = "E" THEN GOSUB Ende
  '  UNTIL key$ = " "
RETURN
> PROCEDURE BitmapSpeichern(datei$,bmp&,b&,h&)
  ' datei$ enthält den gewünschten Pfad und File-Namen des Bildes
  ' bmp& ist das Handle des Bit-Map-Bildes
  ' Es wird nur im TRUE-COLOUR-Format ohne Komprimierung gespeichert.
  LOCAL head$,by%,a%,d%,e%,i%
  head$ = "BM" + MKL$(b& * h& * 3 + 54) + MKI$(0) + MKI$(0) + MKL$(54)
  head$ = head$ + MKL$(40) + MKL$(b&) + MKL$(h&) + MKI$(1)
  head$ = head$ + MKI$(24) + MKL$(0) + MKL$(0) + MKL$(3000) + MKL$(3000) + MKL$(0) + MKL$(8)
  BMOVE V:head$,V:temp|(0),30
  by% = GetBitmapBits(bmp&,b& * h& * 3,V:temp|(54))
  OPEN "O",#1,datei$
  BPUT #1,V:temp|(0), 54
  d% = 3 * b&
  e% = 54 + PRED(h&) * d%
  ' Die Reihenfolge der Zeilen muss umgekehrt werden.
  FOR a% = e% TO 54 STEP -d%
    BPUT #1,V: temp|(a%),d%
  NEXT a%
  CLOSE #1
RETURN
> PROCEDURE Untersuchung
  ARRAYFILL v%(),0
  Loch% = 0
  FOR v% = y1% TO ye1%
    v%(v%) = M%(k1%,v% - yv1%)
  NEXT v%
  FOR v% = y2% TO ye2%
    v%(v%) = v%(v%) OR M%(k2%,v% - yv2%)
  NEXT v%
  FOR v% = y3% TO ye3%
    v%(v%) = v%(v%) OR M%(k3%,v% - yv3%)
  NEXT v%
  FOR v% = y4% TO ye4%
    v%(v%) = v%(v%) OR M%(k4%,v% - yv4%)
  NEXT v%
  DELETE v%(0)
  fl& = MAX(xe1%,xe2%,xe3%,xe4%)
  fb& = PRED(MAX(ye1%,ye2%,ye3%,ye4%))
  GOSUB Einschluss
RETURN
> PROCEDURE Einschluss
  LOCAL h%,v%,j%
  ' Das Polyomino muss in v%() gespeichert sein.
  ' fl& und fb& geben die Grenzen des umbeschriebenen Rechtecks an.
  ' Wenn Leerfelder eingeschlossen, werden diese gezählt.
  Loecherzahl% = 0   // Anzahl der gefundenen Löcher
  Loch% = 0          // Gesamtzahl der Zellen in Löchern
  IF fb& < 2 OR fl& < 2 THEN EXPROC   // Polyomino zu klein
  FOR j% = 0 TO fb&     // Figur in t%() übernehmen
    t%(j%) = v%(j%)
  NEXT j%
  FOR h% = 1 TO PRED(fb&)
    FOR v% = 1 TO PRED(fl&)
      IF BTST(v%(h%),v%) = FALSE AND BTST(v%(h%),PRED(v%)) = TRUE AND BTST(v%(PRED(h%)),v%) = TRUE
        Einschluss! = TRUE
        Zellen% = 0
        GOSUB Ausweg(v%,h%)
        IF Einschluss!
          INC Loecherzahl%
          ADD Loch%,Zellen%
          FOR j% = 0 TO fb&     // t%() in v%() übernehmen, damit Loch gefüllt ist
            v%(j%) = t%(j%)
          NEXT j%
        ELSE
          FOR j% = 0 TO fb&     // t%() wieder herstellen, damit keine Ausgänge verstopft werden
            t%(j%) = v%(j%)
          NEXT j%
        ENDIF
      ENDIF
    NEXT v%
  NEXT h%
RETURN
> PROCEDURE Ausweg(lsx%,lsy%)
  ' Dies ist eine rekursive Prozedur
  ' von der Leerstelle lsx%,lsy% wird ein Weg zum Rand des umbeschriebenen Rechtecks gesucht.
  ' t%() wird von dieser Prozedur verändert !!!
  IF lsx% = 0 OR lsx% = fl& OR  lsy% = 0 OR lsy% = fb&
    ' Der Rand wurde erreicht.
    Einschluss! = FALSE
  ELSE
    ' Aktuelles Feld belegen, damit dieses Feld nicht nocheinmal betreten wird.
    t%(lsy%) = BSET(t%(lsy%),lsx%)
    ' Zellen eines eventuellen Loches zählen. Alle Zellen werden automatisch betreten.
    INC Zellen%
    ' Nach rechts
    IF BTST(t%(lsy%),SUCC(lsx%)) = FALSE THEN GOSUB Ausweg(SUCC(lsx%),lsy%)
    IF Einschluss!
      ' Nach links
      IF BTST(t%(lsy%),PRED(lsx%)) = FALSE THEN GOSUB Ausweg(PRED(lsx%),lsy%)
      IF Einschluss!
        ' Nach unten
        IF BTST(t%(SUCC(lsy%)),lsx%) = FALSE THEN GOSUB Ausweg(lsx%,SUCC(lsy%))
        IF Einschluss!
          ' Nach oben
          IF BTST(t%(PRED(lsy%)),lsx%) = FALSE THEN GOSUB Ausweg(lsx%,PRED(lsy%))
        ENDIF
      ENDIF
    ENDIF
  ENDIF
RETURN