;;; (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)