PfG 1999 - Beispielprogramme

Die Türme von Hanoi

(define other-peg
  (lambda (peg-1 peg-2)
    (- (- 6 peg-1) peg-2)))

(define hanoi
  (lambda (n source-peg dest-peg)
    (if (= n 0)
	'()
	(append
	 (hanoi (- n 1)
		source-peg
		(other-peg source-peg dest-peg))
	 (cons (cons source-peg dest-peg)
	       (hanoi (- n 1)
		      (other-peg source-peg dest-peg)
		      dest-peg))))))

Nim

(define play-nim
  (lambda (game-state player)
    (begin
      (display-game-state game-state)
      (cond ((over? game-state) 
	     (announce-winner player))
	    ((equal? player 'human)  
	     (play-nim (human-move game-state) 'computer))
	    ((equal? player 'computer)  
	     (play-nim (computer-move game-state) 'human))
	    (else  
	     (error "player wasn't human or computer:" player))))))

(define computer-move
  (lambda (game-state)
    (let ((pile (if (> (size-of-pile game-state 1) 0)
                    1
                    2)))
      (begin
	(display "I take 1 coin from pile ")
	(display pile)
	(newline)
	(remove-coins-from-pile game-state 1 pile)))))

(define prompt
  (lambda (prompt-string)
    (begin
      (newline)
      (display prompt-string)
      (newline)
      (read))))

(define human-move
  (lambda (game-state)
    (let ((p (prompt "Which pile will you remove from?")))
      (let ((n (prompt "How many coins do you want to remove?")))
        (remove-coins-from-pile game-state n p)))))

(define over?
  (lambda (game-state)
    (= (total-size game-state) 0)))

(define announce-winner
  (lambda (player)
    (begin
      (if (equal? player 'human) 
	  (display "You lose. Better luck next time.")
	  (display "You win. Congratulations."))
      (newline))))
	
(define make-game-state
  (lambda (n m)
    (cons n m)))

(define size-of-pile
  (lambda (game-state pile-number)
    (if (= pile-number 1)
        (car game-state)
        (cdr game-state))))

(define remove-coins-from-pile
  (lambda (game-state num-coins pile-number)
    (if (= pile-number 1)
        (make-game-state (- (size-of-pile game-state 1)
                            num-coins) 
                         (size-of-pile game-state 2))
        (make-game-state (size-of-pile game-state 1)
                         (- (size-of-pile game-state 2)
                            num-coins)))))

(define display-game-state
  (lambda (game-state)
    (begin
      (newline)
      (display "    Pile 1: ")
      (display (size-of-pile game-state 1))
      (newline)
      (display "    Pile 2: ")
      (display (size-of-pile game-state 2))
      (newline))))

(define total-size
  (lambda (game-state)
    (+ (size-of-pile game-state 1)
       (size-of-pile game-state 2))))

(define error
  (lambda (message thing)
    (begin
      (display message) (display " ") (display thing) (newline)
      (/ 1 0))))

Sortierverfahren

;; Insertion sort

(define insertion-sort
  (lambda (list)
    (cond
     ((null? list) list)
     ((null? (cdr list)) list)
     (else
      (insert (car list) (insertion-sort (cdr list)))))))

(define insert
  (lambda (number list)
    (cond
     ((null? list) (cons number '()))
     ((< number (car list))
      (cons number list))
     (else
      (cons (car list) (insert number (cdr list)))))))


(define insertion-sort-2
  (lambda (list)
    (insertion-sort-help list '())))

(define insertion-sort-help
  (lambda (remaining sorted)
    (if (null? remaining)
	sorted
	(insertion-sort-help (cdr remaining)
			     (insert (car remaining) sorted)))))

(define insert-2
  (lambda (number list)
    (insert-2-help number list '())))

(define insert-2-help
  (lambda (number remaining reverse-result)
    (cond
     ((null? remaining)
      (reverse (cons number reverse-result)))
     ((< number (car remaining))
      (append (reverse reverse-result)
	      (cons number remaining)))
     (else
      (insert-2-help number
		     (cdr remaining)
		     (cons (car remaining) reverse-result))))))

;; Bubble sort

(define bubble-sort
  (lambda (list)
    (bubble-sort-help list '() #t)))

(define bubble-sort-help
  (lambda (remaining reverse-result sorted?)
    (if (or (null? remaining)
	    (null? (cdr remaining)))
	(let ((result (reverse (append remaining reverse-result))))
	  (if sorted?
	      result
	      (bubble-sort-help result '() #t)))
	(let ((first (car remaining))
	      (second (car (cdr remaining)))
	      (rest (cdr (cdr remaining))))
	  (if (< first second)
	      (bubble-sort-help (cons second rest)
				(cons first reverse-result)
				#t)
	      (bubble-sort-help (cons first rest)
				(cons second reverse-result)
				#f))))))


;; Merge sort

(define merge-sort 
  (lambda (list)
    (cond ((null? list)    
           '())
          ((null? (cdr list))
           list)
          (else
           (merge (merge-sort (one-part list))
                  (merge-sort (the-other-part list)))))))
                    
(define merge
  (lambda (list1 list2)
    (cond
     ((null? list1) list2)
     ((null? list2) list1)
     ((< (car list1) (car list2))
      (cons (car list1) (merge (cdr list1) list2)))
     ((= (car list1) (car list2))
      (cons (car list1) (merge (cdr list1) (cdr list2))))
     (else
      (cons (car list2) (merge  list1 (cdr list2)))))))
                                
(define odd-part
  (lambda (list)
    (if (null? list)    
        '()
        (cons (car list) (even-part (cdr list))))))
                  
(define even-part
  (lambda (list)
    (if (null? list)
        '()
        (odd-part (cdr list)))))

(define one-part odd-part)
(define the-other-part even-part)

;; Quicksort

(define (choose-pivot list)
  (cons (car list) (cdr list)))

(define (split-list-around-pivot-help pivot list before after)
  (cond
   ((null? list)
    (cons before after))
   ((< (car list) pivot)
    (split-list-around-pivot-help pivot (cdr list)
				  (cons (car list) before)
				  after))
   (else
    (split-list-around-pivot-help pivot (cdr list)
				  before
				  (cons (car list) after)))))

(define (split-list-around-pivot pivot list)
  (split-list-around-pivot-help pivot list '() '()))

(define (quicksort list)
  (if (or (null? list) (null? (cdr list)))
      list
      (let* ((p (choose-pivot list))
	     (pivot (car p))
	     (rest (cdr p)))
	(let* ((p (split-list-around-pivot pivot rest))
	       (before (car p))
	       (after (cdr p)))
	  (append (quicksort before)
		  (cons pivot '())
		  (quicksort after))))))


;; Radix exchange

;; POSITION is from the back ...

(define (extract-digit position number)
  (let ((truncate-head (remainder number (expt 10 (+ 1 position)))))
    (quotient truncate-head (expt 10 position))))

(define (radix-sort list number-of-digits)
  (if (= 0 number-of-digits)
      list
      (let ((digit-lists (make-vector 10 '())))
	(radix-sort-collect list (- number-of-digits 1) digit-lists)
	(radix-sort-digit-lists digit-lists (- number-of-digits 1))
	(radix-sort-collect-digit-lists digit-lists))))

(define (radix-sort-collect list position digit-lists)
   (if (null? list)
       #f
       (let ((digit (extract-digit position (car list))))
	 (vector-set! digit-lists digit
		      (cons (car list) (vector-ref digit-lists digit)))
	 (radix-sort-collect (cdr list) position digit-lists))))

(define (radix-sort-digit-lists digit-lists number-of-digits)
  (radix-sort-digit-lists-help digit-lists number-of-digits 0))

(define (radix-sort-digit-lists-help
	 digit-lists number-of-digits index)
  (if (= index 10)
      #f
      (begin
	(vector-set! digit-lists index
		     (radix-sort (vector-ref digit-lists index)
				 number-of-digits))
	(radix-sort-digit-lists-help digit-lists
				     number-of-digits
				     (+ 1 index)))))

(define (radix-sort-collect-digit-lists digit-lists)
  (radix-sort-collect-digits-lists-help digit-lists 9 '()))

(define (radix-sort-collect-digit-lists-help digit-lists index result)
  (if (< index 0)
      result
      (radix-sort-collect-digits-lists-help
       digit-lists (- index 1)
       (append (vector-ref digit-lists index) result))))