zurück Grafik

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