Rucksack

;;; <Rucksack.scm>
; Löst das einfache Rucksackproblem mit GA
(require-library "breakpoint.scm")

;------------ Beschreibung der Modellierung -------------------------
; Individuen sind zulässige, also nicht zu "schwere", Listen von
; Einzelgewichten. Da diese unterschiedlich lang sein können und
; verschiedene Einzelgewichte enthalten können müssen, ist zu
; gewährleisten, dass bei den genetischen Prozessen keine Individuen
; auftreten, die sich nicht aus der Liste der Einzelgewichte
; erstellen lassen.
; Beim genetischen Prozess muss auch eine Veränderung der Länge
; möglich sein.
; Wenn zu schwere Listen ausgeschlossen werden, ist als Bewertung
; einfach das Gesamtgewicht zu verwenden.

;;; ===== erstelle-Einzelgewichte ===================================
; Erstellt eine Anzahl lange Liste von zufälligen Einzelgewichten
; zwischen 1 und Maximalwert.
(define
  (erstelle-Einzelgewichte Anzahl Maximalwert)
  (let loop
    ((Anzahl Anzahl)
     (akku ()))
    (cond
      ((zero? Anzahl) akku)
      (else
       (loop
        (sub1 Anzahl)
        (cons (add1 (random Maximalwert)) akku))))))

;;; ===== erstelle-pool =============================================
(define
  (erstelle-pool Anzahl-Individuen)
  (let loop
    ((n Anzahl-Individuen)
     (akku ()))
    (cond
      ((zero? n) akku)
      (else
       (loop
        (sub1 n)
        (cons (erstelle-Individuum) akku))))))

;;; ===== erstelle-Individuum =============================
; Erstellt durch zufällige Auswahl aus der Liste der Einzelgewichte
; ein "lebensfähiges" Individuum, also eines, das nicht zu groß ist.
; Greift auf globale Variable Einzelgewichte und Gesamtgewicht zu.
(define
  (erstelle-Individuum)
  (let loop
    ((Einzelgewichte Einzelgewichte)
     (Summe 0)
     (akku ()))
    (cond
      ((null? Einzelgewichte) akku)
      ((> Summe Gesamtgewicht) (cdr akku))
      (else
       (let
           ((Auswahl         ; Das Einzelgewicht
             (zufaellig-aus Einzelgewichte)))
       (loop
        (entferne Auswahl Einzelgewichte)
        (+ Summe Auswahl)
        (cons Auswahl akku)))))))

;   ----- zufaellig-aus -----------------------------------
; Hilfsfunktion, die zufällig ein Element aus einer Liste wählt.
(define
  (zufaellig-aus liste)
  (list-ref liste (random (length liste))))

;   ----- entferne ----------------------------------------
; Hilfsfunktion zum Entfernen des ausgewählten Elementes
; aus der Liste.
(define
  (entferne element liste)
  (cond
    ((null? liste) (error "Fehler bei der Auswahl von" element))
    ((= element (car liste)) (cdr liste))
    (else
     (cons (car liste) (entferne element (cdr liste))))))


;;; ===== Mutation ==================================================
; Steuert die Mutation insgesamt.
; Der Wert der Mutationswahrscheinlichkeit mut-% muss ein ganzzahliger
; Wert zwischen 1 und 100 sein.
(define
  (Mutation pool mut-%)
  (let loop
    ((pool pool)
     (akku ()))
    (cond
      ((null? pool) akku)
      ((> (add1 (random 100)) mut-%)
       (loop (cdr pool) (cons (car pool) akku)))
      (else
       (loop
        (cdr pool)
        (cons (mutiere (car pool)) (cons (car pool) akku)))))))

;  ----- mutiere ----------------------------------------------------
; Führt die Einzelmutation durch Entfernen, Austauschen oder Einfügen
; eines Einzelgewichtes aus.
; Es muss aber überprüft werden, ob das Individuum mit dem neuen noch
; aus den Einzelgewichten zu erstellen ist.
; Greift auf die globale Variable Einzelgewichte zu.

(define
  (mutiere Individuum)
  (case
      (random 3)
    ((0) (raus Individuum))
    ((1) (tausch Individuum))
    ((2) (rein Individuum))))

;;; ----- raus ------
(define
  (raus Individuum)
  (entferne (zufaellig-aus Individuum) Individuum))

;;; ----- tausch -------
(define
  (tausch Individuum)
  (rein
   (raus Individuum)))

;;; ----- rein -----
; Wählt solange ein zufälliges Element aus Einzelgewichte (globale
; Variable) aus, bis sie ein Element gefunden hat, das noch eingefuegt
; werden darf.
(define
  (rein Individuum)
  (if
   (< (length Individuum) (length Einzelgewichte))
   (let loop
     ((neu (zufaellig-aus Einzelgewichte)))
     (cond
       ((vorhanden? neu Individuum Einzelgewichte)
        (loop (zufaellig-aus Einzelgewichte)))
       (else (cons neu Individuum))))
   Individuum))

;;; ----- vorhanden? ---------
; Prüft, ob das einzufügende Element schon vorhanden ist.
(define
  (vorhanden? neu Individuum Einzelgewichte)
  (cond
    ((not (member neu Einzelgewichte)) #t)
    ((not (member neu Individuum)) #f)
    (else
     (vorhanden?       ; es kann mehrfach auftreten !
      neu
      (cdr (member neu Individuum))
      (cdr (member neu Einzelgewichte))))))

;;; ===== crossing-over =============================================
; Das crossing-over ist eigentlich am schwersten zu modellieren, da
; hier nicht die Länge der Individuen gleich bleiben muss.
; Eine Idee: Schneide aus dem ersten Individuum  von vorn und dem
; zweiten von  hinten so viel heraus, dass der Gesamtwert maximal so
; groß wird wie das Gesamtgewicht.
; Problem: Es muss darauf geachtet werden, dass alle hinzugefuegten
; zulässig sind!
; Die Funktion crossing-over selbst steuert nur den Ablauf abhängig
; von der crossing-over - Wahrscheinlichkeit cross-%.
; cross-% muss ein ganzzahliger Wert zwischen 1 und 100 sein.
(define
  (crossing-over pool cross-%)
  (let loop
    ((Anzahl (round (/ (* cross-% (length pool)) 100)))
     (akku ()))
    (cond
      ((zero? Anzahl) (append akku pool))
      (else
       (loop
        (sub1 Anzahl)
        (cons
         (cross (zufaellig-aus pool) (zufaellig-aus pool))
         akku))))))

;   ----- cross -----------------------------------------------------
; Führt das eigentliche crossing-over aus.
; Greift auf die globalen Variablen Gesamtgewicht und Einzelgewichte
; zu.
(define
  (cross Individuum-1 Individuum-2)
  (let loop
    ((L1 Individuum-1)
     (L2 (reverse Individuum-2))
     (akku ()))
    (cond
      ((> (apply + akku) Gesamtgewicht)
       (loop L1 L2 (cdr akku)))
      ((and (null? L1) (null? L2))    ; sollte nicht auftreten
       akku)
      ((and
        (null? L1)
        (vorhanden? (car L2) akku Einzelgewichte))
       (loop L1 (cdr L2) akku))
      ((null? L1)
       (loop L1 (cdr L2) (cons (car L2) akku)))
      ((and
        (null? L2)
        (vorhanden? (car L1) akku Einzelgewichte))
       (loop (cdr L1) L2 akku))
      ((null? L2)
       (loop (cdr L1) L2 (cons (car L1) akku)))
      ((vorhanden? (car L1) (cons (car L2) akku) Einzelgewichte)
       (loop (cdr L1) L2 akku))
      ((vorhanden? (car L2) akku Einzelgewichte)
       (loop L1 (cdr L2) akku))
      (else
       (loop (cdr L1) (cdr L2)
             (cons (car L1) (cons (car L2) akku)))))))

;;; ===== Selektion =================================================
; Führt die Selektion durch Kampf von je zwei zufällig ausgewählten
; Individuuen durch. Es überlebt stets das bessere von beiden, hier
; also das mit der größeren Summe.
; Die Selektion wird abgebrochen, wenn die vorgegebene zahl von
; Individuen erreicht wurde.
; Anm.: Die Selektion wird nicht mehr durchgeführt, wenn eines der
; Individuen den Gesamtwert erreicht hat.
(define
  (Selektion pool Gesamtzahl)
  (let loop
    ((akku ()))
    (cond
      ((= (length akku) Gesamtzahl)
       akku)
      (else
       (let
           ((erste (zufaellig-aus pool))
            (zweite (zufaellig-aus pool)))
         (loop
          (cons
           (if
            (> (apply + erste) (apply + zweite))
            erste
            zweite)
           akku)))))))

;;; ===== gefunden? =================================================
; Untersucht den pool, ob eine Lösung enthalten ist.
(define
  (gefunden? pool)
  (cond
    ((null? pool) #f)
    ((= (summe (car pool)) Gesamtgewicht)
     (car pool))
    (else
     (gefunden? (cdr pool)))))

;   ----- summe ----------------
; Hilfsfunktion
(define
  (summe l)
  (apply + l))

;;; ===== GA ========================================================
; Steuert den gesamten Ablauf.
; Muss zwischendurch prüfen, ob schon einer mit Geamtgewicht gefunden
; wurde.
(define
  (GA
   Anzahl-Generationen
   Pool-Groesse
   Mutationswahrscheinlichkeit
   crossing-over-Wahrscheinlichkeit)
  (let loop
    ((n Anzahl-Generationen)
     (pool
      (crossing-over
       (Mutation
        (erstelle-pool Pool-Groesse)
        Mutationswahrscheinlichkeit)
       crossing-over-Wahrscheinlichkeit)))
    (cond
      ((zero? n)
       (writeln "Einzelgewichte:" Einzelgewichte)
       (writeln "Keine Lösung" pool)
       (map summe pool))
      ((gefunden? pool)
       (writeln "Einzelgewichte:" Einzelgewichte)
       (writeln "Anzahl-Generationen:" (- Anzahl-Generationen n))
       (writeln "Pool:" pool)
       (writeln "Lösung:" (gefunden? pool)))
      (else
       (loop
        (sub1 n)
        (crossing-over
         (Mutation
          (Selektion pool Pool-Groesse)
          Mutationswahrscheinlichkeit)
         crossing-over-Wahrscheinlichkeit))))))

;;; ===== Globale Variable und Aufrufe ==============================
;;; Global sind:
(define    Maximalwert-der-Einzelgewichte 100)
(define    Anzahl-Gewichte 40)
(define    Einzelgewichte
  (erstelle-Einzelgewichte
   Anzahl-Gewichte
   Maximalwert-der-Einzelgewichte))
(define    Gesamtgewicht 2000)
(define    Anzahl-Generationen 100)
(define    Pool-Groesse 20)
(define    Mutationswahrscheinlichkeit 30)
(define    crossing-over-Wahrscheinlichkeit 50)

;;; Test:
Einzelgewichte
(GA
 Anzahl-Generationen
 Pool-Groesse
 Mutationswahrscheinlichkeit
 crossing-over-Wahrscheinlichkeit)