minimal spanning tree
;;; Algorithmus von Kruskal [minimal nach Kruskal.scm]
; Bestimmt einen minimal spanning tree nach dem Algorithmus von Kruskal
(require-library "breakpoint.scm")
;;; ===== Suchraum ==================================================
; definiert den Suchraum mit bei Anzahl gesetzt vielen zufällig
; gewählten Punkten.
(define
Suchraum
(let loop
((Anzahl 50)
(akku ()))
(cond
((zero? Anzahl) akku)
(else
(loop
(sub1 Anzahl)
(cons
(list
(random 400)
(random 400))
akku))))))
;;; ===== Suchraum-liste ============================================
; Formt aus der Liste Suchraum eine Liste von Listen, bei der jede
; genau den Index des Punktes enthält.
(define
(Suchraum-liste)
(let loop
((Anzahl (length Suchraum))
(akku ()))
(cond
((zero? Anzahl) akku)
(else (loop (sub1 Anzahl) (cons (list Anzahl) akku))))))
;;; ===== Koordinaten ============================================
; Formt aus der Liste Suchraum eine Liste von Listen, bei der jede
; genau den Index des Punktes enthält.
(define
(Koordinaten)
(let loop
((Suchraum (reverse Suchraum))
(Anzahl (length Suchraum))
(akku ()))
(cond
((zero? Anzahl) akku)
(else (loop (cdr Suchraum) (sub1 Anzahl) (cons (list Anzahl (car Suchraum)) akku))))))
;;; ===== Abstand-q =================================================
(define (sqr a) (* a a))
(define
(Abstand-q p q)
(+ (sqr (- (car p) (car q))) (sqr (- (cadr p) (cadr q)))))
;;; ===== fuege-ein =================================================
(define
(fuege-ein Kante Prio)
(cond
((null? Prio) (list Kante))
((> (caddr Kante) (caddar Prio))
(cons (car Prio) (fuege-ein Kante (cdr Prio))))
(else (cons Kante Prio))))
;;; ===== alle-Abstaende ============================================
; berechnet eine Prioritätswarteschlange für alle möglichen Kanten
(define
(berechne-Prioritätswarteschlange Anzahl)
(let loop
((z-1 Anzahl)
(z-2 (sub1 Anzahl))
(akku ()))
(cond
((zero? (sub1 z-1)) akku)
((zero? z-2)
(loop
(sub1 z-1)
(sub1 (sub1 z-1))
akku))
(else
(loop
z-1
(sub1 z-2)
(fuege-ein
(list
z-1
z-2
(Abstand-q (list-ref suchraum (sub1 z-1)) (list-ref suchraum (sub1 z-2))))
akku))))))
(define
Prio
(berechne-Prioritätswarteschlange (length Suchraum)))
;;; ===== teste =====================================================
; Liefert #f zurueck, wenn Anfang und Ende zum selben Teilbaum
; gehören.
(define
(teste Kante Teilbaeume)
(cond
((and
(member (car Kante) (car Teilbaeume))
(member (cadr Kante) (car Teilbaeume)))
#f)
((member (car Kante) (car Teilbaeume)) #t)
(else (teste Kante (cdr Teilbaeume)))))
;(teste '(1 3 234567) '((4 7 9) (1 3) (2 5) (6)))
;(teste '(1 3 234567) '((4 7 9) (1 2) (3 5) (6)))
;;; ===== nimm-auf ==================================================
(define
(nimm-auf Kante Teilbaeume)
(let loop
((erster #f)
(zweiter #f)
(Teilbaeume Teilbaeume)
(akku ()))
(cond
((and erster zweiter) ; beide Teilbaeume verbinden
(append akku (list (append erster zweiter)) Teilbaeume))
((member (car Kante) (car Teilbaeume))
(loop
(car Teilbaeume)
zweiter
(cdr Teilbaeume)
akku))
((member (cadr Kante) (car Teilbaeume))
(loop
erster
(car Teilbaeume)
(cdr Teilbaeume)
akku))
(else
(loop
erster
zweiter
(cdr Teilbaeume)
(cons (car Teilbaeume) akku))))))
;(nimm-auf '(1 3 234567) '((4 7 9) (1 2) (3 5) (6)))
;(nimm-auf '(1 6 23567) '((4 7 9) (1 3) (2 5) (6)))
;(nimm-auf '(4 6 123567) '((4 7 9) (1 3) (2 5) (6)))
;;; ===== minimal ===================================================
(define
(minimal-spanning-tree)
; (writeln Prio)
(let loop
((Teilbaeume (Suchraum-liste))
(gewaehlte-Kanten ())
(Prio Prio))
(cond
((null? Prio) #f) ; kann eigentlich nicht sein.
((null? (cdr Teilbaeume)) ; fertig
gewaehlte-Kanten)
((teste (car Prio) Teilbaeume) ; kein Zyklus?
(loop
(nimm-auf (car Prio) Teilbaeume)
(cons (car Prio) gewaehlte-Kanten)
(cdr Prio)))
(else
(loop Teilbaeume gewaehlte-Kanten (cdr Prio))))))
;;; ===== Aufruf ====================================================
(define
tree
(minimal-spanning-tree))
;;; ===== Test: ==============================================
(display "Grafik ?")
(cond
((equal? (read) #t)
(load "minimal mit greedy Grafik.scm")
(zeichne tree (Koordinaten)))
(else
(greedy 1 Graph)))