Murmeln gruppieren
Angenommen man hat eine gelbe, zwei blaue, sieben grüne und neun rote Murmeln. Wie viele Zweiergruppen aus Murmeln mit unterschiedlicher Farbe kann man bilden?
Die 9 Zweiergruppen liefert die Prozedur marble-sets, wenn sie mit den Argumenten
(list
(new color-count (quote rot) 9)
(new color-count (quote gelb) 1)
(new color-count (quote grün) 7)
(new color-count (quote blau) 2))
und 2 aufgerufen wird. Die Zweiergruppen sind in diesem Fall
((grün rot) (grün rot) (grün rot)
(grün rot) (grün rot) (blau rot)
(grün rot) (gelb rot) (grün blau))
Die Prozedur marble-sets löst das Problem für einen beliebigen Vorrat an Murmeln und eine wählbare Gruppengröße.
Der Vorrat wird dabei durch eine Liste von Instanzen der Datenstruktur color-count beschrieben. Diese fasst eine Farbe und eine Anzahl zusammen.
(defstruct color-count
(color count)
(and (symbol? color) (integer? count) (> count 0)))
Die Prozedur take-one-marble liefert das Argument remaining zurück, wenn das Argument count den Wert 1 hat. Anderenfalls wird eine neue Instanz der Datenstruktur color-count erzeugt, mit der angegebenen Farbe und dem um 1 verminderten count.
(defproc take-one-marble (color count remaining)
(cond
((< count 1)
(throw (quote error) (concatenate "count for " color " is " count)))
((= count 1)
remaining)
(t
(cons
(new color-count color (- count 1))
remaining))))
Die Prozedur take-marbles entnimmt aus den ersten size Elementen der Liste supply je eine Murmel. Diese wird der Liste marbles hinzugefügt. Die übrig gebliebenen Murmeln werden durch einen Aufruf von take-one-marble in die Liste remaining eingefügt. Sobald size den Wert 0 erreicht, liefert die Prozedur die entnommenen Murmeln und die verbleibenden Murmeln als Paar zurück.
(defproc take-marbles (supply size marbles remaining)
(cond
((zero? size)
(list marbles (append supply remaining)))
((null? supply)
nil)
(t
(with-slots (color count) (first supply)
(take-marbles
(rest supply)
(- size 1)
(cons color marbles)
(take-one-marble color count remaining))))))
Die Prozedur sort-bag sortiert die Murmeln so, dass die am häufigsten vorkommende Farbe am Anfang der Liste steht. Danach folgen die anderen Farben in absteigender Häufigkeit.
(defproc sort-bag (bag)
(sort
bag
(lambda (c d) (> (. c count) (. d count)))))
Schließlich kombiniert die Prozedur marble-sets die anderen Prozeduren so, dass das oben beschriebene Problem gelöst wird.
(defproc marble-sets (supply size)
(let
((taken (take-marbles (sort-bag supply) size nil nil)))
(if
(null? taken)
nil
(cons
(first taken)
(marble-sets (second taken) size)))))
Quelle
Sharon Curtis
"An Algorithm for Marble Mingling"
Department of Computing Science and Mathematics
University of Stirling Stirling, UK
Die 9 Zweiergruppen liefert die Prozedur marble-sets, wenn sie mit den Argumenten
(list
(new color-count (quote rot) 9)
(new color-count (quote gelb) 1)
(new color-count (quote grün) 7)
(new color-count (quote blau) 2))
und 2 aufgerufen wird. Die Zweiergruppen sind in diesem Fall
((grün rot) (grün rot) (grün rot)
(grün rot) (grün rot) (blau rot)
(grün rot) (gelb rot) (grün blau))
Die Prozedur marble-sets löst das Problem für einen beliebigen Vorrat an Murmeln und eine wählbare Gruppengröße.
Der Vorrat wird dabei durch eine Liste von Instanzen der Datenstruktur color-count beschrieben. Diese fasst eine Farbe und eine Anzahl zusammen.
(defstruct color-count
(color count)
(and (symbol? color) (integer? count) (> count 0)))
Die Prozedur take-one-marble liefert das Argument remaining zurück, wenn das Argument count den Wert 1 hat. Anderenfalls wird eine neue Instanz der Datenstruktur color-count erzeugt, mit der angegebenen Farbe und dem um 1 verminderten count.
(defproc take-one-marble (color count remaining)
(cond
((< count 1)
(throw (quote error) (concatenate "count for " color " is " count)))
((= count 1)
remaining)
(t
(cons
(new color-count color (- count 1))
remaining))))
Die Prozedur take-marbles entnimmt aus den ersten size Elementen der Liste supply je eine Murmel. Diese wird der Liste marbles hinzugefügt. Die übrig gebliebenen Murmeln werden durch einen Aufruf von take-one-marble in die Liste remaining eingefügt. Sobald size den Wert 0 erreicht, liefert die Prozedur die entnommenen Murmeln und die verbleibenden Murmeln als Paar zurück.
(defproc take-marbles (supply size marbles remaining)
(cond
((zero? size)
(list marbles (append supply remaining)))
((null? supply)
nil)
(t
(with-slots (color count) (first supply)
(take-marbles
(rest supply)
(- size 1)
(cons color marbles)
(take-one-marble color count remaining))))))
Die Prozedur sort-bag sortiert die Murmeln so, dass die am häufigsten vorkommende Farbe am Anfang der Liste steht. Danach folgen die anderen Farben in absteigender Häufigkeit.
(defproc sort-bag (bag)
(sort
bag
(lambda (c d) (> (. c count) (. d count)))))
Schließlich kombiniert die Prozedur marble-sets die anderen Prozeduren so, dass das oben beschriebene Problem gelöst wird.
(defproc marble-sets (supply size)
(let
((taken (take-marbles (sort-bag supply) size nil nil)))
(if
(null? taken)
nil
(cons
(first taken)
(marble-sets (second taken) size)))))
Quelle
Sharon Curtis
"An Algorithm for Marble Mingling"
Department of Computing Science and Mathematics
University of Stirling Stirling, UK