zurück
;;;                                            (magische Quadrate.scm)
(require-library "breakpoint.scm")
;;;                                          Albowski , 3'2001
;;; Auf der Grundlage von 8 Damen
;;; -----------------------------------------------------------------
; Es wird zwar prinzipiell mit dem Programm zur Tiefensuche
; gearbeitet, bei jeder neuen Besetzung n/2n/usw. wird aber geprüft,
; ob die Bedingungen (constraints) verletzt werden. Ist das der
; Fall, wird der Ast nicht weiter verfolgt.

;;; ----- maxZahl ---------------------------------------------------
; Die Angabe der Zeilen und Spalten des Quadrates regelt maxZahl.
(define maxZahl 3)
;;; ----- Tiefensuche -----------------------------------------------
; Zeile x Spalte x Liste von Zahlen --> boolean
; In der Damenliste wird die Spaltenposition der Damen geführt
; für Zeile 1 .. aktuell besetzte Zeile.

;{4} Zunächst der Versuch, in die Tiefe zu gehen. Die Damen
; werden beginnend in der ersten Spalte nacheinander auf alle
; Spaltenpositionen gesetzt.
;{5} Zur nächsten Alternative.

(define
  (Tiefensuche maxZahl)
  (letrec
      ((Gesamtzahl (* maxZahl maxZahl))
       (Summe (/ (* maxZahl (add1 Gesamtzahl)) 2)))
    (let
        t-s
      ((Anzahl 0)
       (Quadrat ())
       (Versuch Gesamtzahl))
      (cond
        ((zero? Versuch) #f)              ; erfolglos

        ((and
          (not (zero? Anzahl))
          (member (car Quadrat) (cdr Quadrat))) ; war schon
         #f)

        ((and
          (not (zero? Anzahl))
          (zero? (modulo Anzahl maxZahl))  ; Zeile voll
          (Zeilenfehler Summe maxZahl Quadrat))
         #f)

        ((and                     ; in der letzten Zeile
          (>= (quotient (sub1 Anzahl) maxZahl) (sub1 maxZahl))
          (Spaltenfehler Summe maxZahl Quadrat))
         #f)

        ((= Anzahl Gesamtzahl)            ; Quadrat voll
         (if
          (Diagonalenfehler Summe maxZahl Quadrat)
          #f
          (Darstellung Quadrat maxZahl)))

        ;;; Versuch in die Tiefe :
        ((t-s (add1 Anzahl) (cons Versuch Quadrat) Gesamtzahl))

        (else
         ;;; Abbau der Alternativen :
         (t-s Anzahl Quadrat (sub1 Versuch)))))))

;;; ===== Zeilenfehler ==============================================
; Prüft die maxZahl ersten Elemente der Liste Quadrat.
(define
  (Zeilenfehler Summe maxZahl Quadrat)
  (not
   (= Summe
      (apply
       +
       (list-tail
        (reverse Quadrat)
        (- (length Quadrat) maxZahl))))))

;;; ===== Spaltenfehler =============================================
; Prüft die Elemente der Liste Quadrat an den Positionen 1, 1+maxZahl
; usw.
; Dazu wird jeweils die maxZahl-te Restliste gebildet.
(define
  (Spaltenfehler Summe maxZahl Quadrat)
  (not
   (= Summe
      (let loop
        ((Summe-ist 0)
         (Quadrat Quadrat))
         (cond
          ((< (length Quadrat) (add1 maxZahl))
           (+ Summe-ist (car Quadrat)))
          (else
           (loop
            (+ Summe-ist (car Quadrat))
            (list-tail Quadrat maxZahl))))))))

;;; ===== Diagonalenfehler =============================================
; Prüft die Elemente der beiden Diagonalen.
; usw.
;;; Dazu wird einmal jeweils die maxZahl+1-te Restliste gebildet:
(define
  (Hauptdiagonalenfehler Summe maxZahl Quadrat)
  (not
   (= Summe
      (let loop
        ((Summe-ist 0)
         (Quadrat Quadrat))
        (cond
          ((< (length Quadrat) (add1 maxZahl))
           (+ Summe-ist (car Quadrat)))
          (else
           (loop
            (+ Summe-ist (car Quadrat))
            (list-tail Quadrat (add1 maxZahl)))))))))
;;; Andererseits wird beginnend beim maxZahl-ten Element jeweils die
;;; maxZahl-1-te Restliste gebildet:
(define
  (Nebendiagonalenfehler Summe maxZahl Quadrat)
  (not
   (= Summe
      (let loop
        ((Summe-ist 0)
         (Quadrat (list-tail Quadrat (sub1 maxZahl))))
         (cond
          ((< (length Quadrat) (add1 maxZahl))
           (+ Summe-ist (car Quadrat)))
          (else
           (loop
            (+ Summe-ist (car Quadrat))
            (list-tail Quadrat (sub1 maxZahl)))))))))
;;; Und die Zusammenfassung:
(define
  (Diagonalenfehler Summe maxZahl Quadrat)
  (or
   (Hauptdiagonalenfehler Summe maxZahl Quadrat)
   (Nebendiagonalenfehler Summe maxZahl Quadrat)))

;;; ===== Darstellung ===============================================
(define
  (Darstellung Quadrat maxZahl)
  (let loop
    ((Quadrat Quadrat))
     (cond
      ((null? Quadrat) (newline))
      ((zero? (modulo (sub1 (length Quadrat)) maxZahl))
       (fuenf-Zeichen (car Quadrat))
       (newline)
       (loop (cdr Quadrat)))
      (else
       (fuenf-Zeichen (car Quadrat))
       (loop (cdr Quadrat))))))

;;; ===== fuenf-Zeichen ==========================================
(define
  (fuenf-Zeichen Zahl)
  (display
   (string-append
    (substring
     "     "
     0
     (- 5
        (string-length (number->string Zahl))))
    (number->string Zahl))))
;;;==================================================================
(define ist-eins '(6 7 2 1 5 9 8 3 4))
(Tiefensuche 3)