hill fuer tsp

Bilder: Startbild Endbild

;;; 
; benötigt [Graph fuer tsp.scm]
(load "Graph fuer tsp.scm")
;;; hill climbing - Verfahren nach mathematik lehren Heft 81  
;;; lokale Verbesserung durch Zweiwegetausch:
;>>> t(0) t(1) ... t(k) t(k+1)      ...    t(m) t(m+1) ...   t(n)
;;; wird getauscht zu:
;>>> t(0) t(1) ... t(k) t(m) t(m-1) ...  t(k+1) t(m+1) ...   t(n)
;;; das Teilstück wird also in umgekehrter Reihenfolge
;;; durchlaufen.( n Knoten, t(n)= t(0) )
;;; ===== tausche-Knoten =====================================
; tauscht die Knoten nach dem o.a. Verfahren aus.
; Die Prozedur verhindert einen Tausch, wenn k<0, m>=n-2
; und m<k+2
(define
  (tausche-Knoten k m tour)
  (let
      ((n (sub1 (length tour))))
    (cond
      ((negative? k) tour)
      ((> m (- n 2)) tour)
      ((< m (+ k 2)) tour)
      (else
       (append
        (reverse (list-tail (reverse tour) (- n k)))
        (list-tail
         (reverse (list-tail tour (add1 k)))
         (- n m))
        (list-tail tour (add1 m)))))))

;;; ===== hill ===============================================
; Das Verfahren durchläuft eine Schleife, bei der alle möglichen
; Zweiwegetausche daraufhin untersucht werden, ob sie zu einer
; Verbesserung führen. Wenn ja, wird dieser weiter verfolgt,
; anderenfalls bricht das Verfahren ab.

(define
  (alle-tauschen tour bisheriges-minimum)
  (let
      k-Schleife
    ((k 0)
     (n (sub1 (length tour)))
     (neue-tour #f))
    (cond
      ((> k (sub1 n)) neue-tour)
      (else
       (let
           m-Schleife
         ((m (+ k 2))
          (neue-tour neue-tour))
         (cond
           ((>= m n)
            (k-Schleife
             (add1 k)
             n
             neue-tour))
           (else
            (let
                ((Versuch (tausche-knoten k m tour)))
              (cond
                ((kuerzer? Versuch tour)
                 (if
                  neue-tour
                  (if
                   (kuerzer? Versuch neue-tour)
                   (m-Schleife (add1 m) Versuch)
                   (m-Schleife (add1 m) neue-tour))
                  (m-Schleife (add1 m) Versuch)))
                (else
                 (m-Schleife (add1 m) neue-tour)))))))))))
;;; ===== hill ===============================================
(define
  (hill tour)
  (let
      loop
    ((neu (alle-tauschen tour (Tourlaenge tour))))
    (if
     neu
     (hill neu)
     (begin
       (display "keine weitere Verbesserung möglich")(newline)
       (display tour)(newline)
       (display (Tourlaenge tour))(newline)
       (alle-Kanten-und-Punkte-zeichnen tour)
       (void)))))


;;; ===== kuerzer? ===========================================
; Vergleicht die Länge von zwei Touren.
(define
  (kuerzer? tour-1 tour-2)
  (< (Tourlaenge tour-1) (Tourlaenge tour-2)))

;;; ===== Tourlaenge =========================================
(define
  (Tourlaenge tour)
  (let
      loop
    ((Punkt (car tour))
     (liste (cdr tour))
     (laenge 0))
    (cond
      ((null? liste) laenge)
      (else
       (loop
        (car liste)
        (cdr liste)
        (+ laenge (abstand Punkt (car liste))))))))

;;; ===== Test : ====================================================
(define Mustertour (cons (car (reverse alle-Knoten)) alle-Knoten))
(Tourlaenge Mustertour)
(alle-Kanten-und-Punkte-zeichnen Mustertour)
(hill Mustertour)

Startbild:

Endbild: