; example.scm
; 97-05-05

; Beispiel fuer den Dijkstra-Algorithmus aus der Vorlesung 
; Diskrete Strukturen, WS96
;                            6
;                  2-------------------4
;                 /                   . \
;               2/                 .     \1
;               /               .         \
;              0            4.             5
;               \         .               /
;               3\     .                 /2
;                 \ .                   /
;                  1-------------------3 
;                            2

(define nn 6)
(define maxdist 100)

(define WEIGHT-ARRAY
  '(((0 . 1) 3)
    ((0 . 2) 2)
    ((1 . 3) 2)
    ((1 . 4) 4)
    ((2 . 4) 6)
    ((3 . 5) 2)
    ((4 . 5) 1)))

(define (weight-ref i j)
  (cond ((= i j) 0)
	((< i j) (let ((info (assoc (cons i j) WEIGHT-ARRAY)))
		   (if info (cadr info) maxdist)))
  	((< j i) (let ((info (assoc (cons j i) WEIGHT-ARRAY)))
		   (if info (cadr info) maxdist)))))	

;(define two_natinf ((plus-natinf one_natinf) one_natinf))
;(define three_natinf ((plus-natinf two_natinf) one_natinf))
;(define four_natinf ((plus-natinf three_natinf) one_natinf))
;(define five_natinf ((plus-natinf four_natinf) one_natinf))
;(define six_natinf ((plus-natinf five_natinf) one_natinf))

;(define (w i)
;  (lambda (j)
;    (cond ((or (undef-nat? i) (undef-nat? j)) undef_natinf)
;	  ((and (synt-total? i) (equal? i j)) zero_natinf)
;	  ((and (integer? i) (<= 0 i) (integer? j) (<= 0 j))
;	   (cond ((= 0 i)
;		  (cond ((= 1 j) three_natinf)
;			((= 2 j) two_natinf)
;			(else inf_natinf)))
;		 ((= 1 i)
;		  (cond ((= 0 j) three_natinf)
;			((= 3 j) two_natinf)
;			((= 4 j) four_natinf)
;			(else inf_natinf)))
;		 ((= 2 i)
;		  (cond ((= 0 j) two_natinf)
;			((= 4 j) six_natinf)
;			(else inf_natinf)))
;		 ((= 3 i)
;		  (cond ((= 1 j) two_natinf)
;			((= 5 j) two_natinf)
;			(else inf_natinf)))
;		 ((= 4 i)
;		  (cond ((= 1 j) four_natinf)
;			((= 2 j) six_natinf)
;			((= 5 j) one_natinf)
;			(else inf_natinf)))
;		 ((= 5 i)
;		  (cond ((= 3 j) two_natinf)
;			((= 4 j) one_natinf)
;			(else inf_natinf)))
;		 (else inf_natinf)))
;	  ((and (zero? j) (not (zero? i))) (list (list 'w 0) i))
;	  (else (list (list 'w i) j)))))

; Optimierte Versionen von pick, comp, next, dist.

(define PICK-ARRAY '())
(define COMP-ARRAY '())
(define NEXT-ARRAY '())
(define DIST-ARRAY '())

; C_0={0} (gilt am Anfang als berechnet; durch seinen Rand will man
; suchen).  d_0 gibt fuer C_0 die richtigen Distanzen.  p_0(j)
; durchsucht den Rand von C_0.  p_0 sei der Knoten mit kleinstem
; d_0-Abstand.

; C_1=C_0 \cup {p_0}.  d_1 gibt fuer C_1 die richtigen Distanzen
; (Minimum des alten Abstandes und des Summenabstands ueber p_0).
; p_1(j) durchsucht den Rand von C_1.  p_1 sei der Knoten mit kleinstem
; d_1-Abstand.

; C_2=C_1 \cup {p_1}.  Usw. 

(define (comp-opt i j)
  (let ((info (assoc (cons i j) COMP-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? i) (= j 0))
			   ((and (< 0 i) (<= i nn))
			    (let* ((i-1 (- i 1)))
			      (or (comp-opt i-1 j)
				  (= j (pick-opt i-1 nn)))))
			   (else (error "comp-opt called with" i j)))))
	  (set! COMP-ARRAY (cons (list (cons i j) value) COMP-ARRAY))
	  value))))
    
(define (dist-opt i j)
  (let ((info (assoc (cons i j) DIST-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? i) (weight-ref 0 j))
			   ((and (< 0 i) (<= i nn))
			    (let* ((i-1 (- i 1))
				   (prev-dist (dist-opt i-1 j))
				   (p (pick-opt i-1 nn))
				   (dist-via-p (+ (dist-opt i-1 p)
						  (weight-ref p j))))
			      (if (<= prev-dist dist-via-p)		    
				  prev-dist
				  (min maxdist dist-via-p))))
			   (else (error "dist-opt called with" i j)))))
	  (set! DIST-ARRAY (cons (list (cons i j) value) DIST-ARRAY))
	  value))))

(define (pick-opt i j)
  (let ((info (assoc (cons i j) PICK-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? j) nn)
			   ((and (< 0 j) (<= j nn))
			    (let* ((j-1 (- j 1))
				   (prev-pick (pick-opt i j-1)))
			      (if (or (comp-opt i j-1)
				      (<= (if (= nn prev-pick)
					      maxdist
					      (dist-opt i prev-pick))
					  (dist-opt i j-1)))
				  prev-pick
				  j-1)))
			   (else (error "pick-opt called with" i j)))))
	  (set! PICK-ARRAY (cons (list (cons i j) value) PICK-ARRAY))
	  value))))
		  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Beispiel nach Rosen, S.404
;                            3
;                  2-------------------4
;                 /   .                 \
;               4/      .                \2
;               /         .               \
;              0            3              5
;               \              .          /
;               2\                .      /1
;                 \                  .  /
;                  1-------------------3 
;                            3

(define nn 6)
(define maxdist 100)

(define WEIGHT-ARRAY
  '(((0 . 1) 2)
    ((0 . 2) 4)
    ((1 . 3) 3)
    ((2 . 3) 3)
    ((2 . 4) 3)
    ((3 . 5) 1)
    ((4 . 5) 2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Beispiel nach Rosen, S.406
;                            5
;                  2-------------------4
;                 /|                  .|\
;               4/ |               .   | \6
;               /  |            .      |  \
;              0  1|        8.        2|   5
;               \  |      .            |  /
;               2\ |   .               | /3
;                 \|.                  |/
;                  1-------------------3 
;                            10
(define WEIGHT-ARRAY
  '(((0 . 1) 2)
    ((0 . 2) 4)
    ((1 . 2) 1)
    ((1 . 3) 10)
    ((1 . 4) 8)
    ((2 . 4) 5)
    ((3 . 4) 2)
    ((3 . 5) 3)
    ((4 . 5) 6)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Beispiel nach Rosen, S.408
;                          5
;                  2---------------4
;                 /  .             |\
;               2/     .           | \2
;               /        .         |  \
;              0           2      1|   5
;               \            .     |  /
;               3\             .   | /4
;                 \              . |/
;                  1---------------3 
;                          5

(define nn 6)
(define maxdist 100)

(define WEIGHT-ARRAY
  '(((0 . 1) 3)
    ((0 . 2) 2)
    ((1 . 3) 5)
    ((2 . 3) 2)
    ((2 . 4) 5)
    ((3 . 4) 1)
    ((3 . 5) 4)
    ((4 . 5) 2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Beispiel nach Rosen, S.408b
;                          5               5
;                  2---------------4---------------6
;                 /|             . |               |\
;               4/ |           .   |               | \7
;               /  |         .     |               |  \
;              0   |2      . 3     |1             2|   7
;               \  |     .         |               |  /
;               3\ |   .           |               | /4
;                 \| .             |               |/
;                  1---------------3---------------5
;                          6               5

(define nn 8)
(define maxdist 100)

(define WEIGHT-ARRAY
  '(((0 . 1) 3)
    ((0 . 2) 4)
    ((1 . 2) 2)
    ((1 . 3) 6)
    ((1 . 4) 3)
    ((2 . 4) 5)
    ((3 . 4) 1)
    ((3 . 5) 5)
    ((4 . 6) 5)
    ((5 . 6) 2)
    ((5 . 7) 4)
    ((6 . 7) 7)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 97-05-04

(define (next-opt i j)
  (let ((info (assoc (cons i j) NEXT-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? i)
			    (if (= maxdist (weight-ref 0 j))
				nn
				0))
			   ((and (< 0 i) (<= i nn))
			    (let* ((i-1 (- i 1))
				   (prev-dist (dist-opt i-1 j))
				   (p (pick-opt i-1 nn))
				   (dist-via-p (+ (dist-opt i-1 p)
						  (weight-ref p j))))
			      (if (<= prev-dist dist-via-p)		    
				  (next-opt i-1 j)
				  p)))
			   (else (error "next-opt called with" i j)))))
	  (set! NEXT-ARRAY (cons (list (cons i j) value) NEXT-ARRAY))
	  value))))

; Zur Anzeige:

(define (construct-path i j)
  (cond ((zero? j) (list j))
	((< j nn) (cons j (construct-path i (next-opt i j))))
	(else (display "construct-path called at non-node ") (display j))))

(define (next-path i j)
  (cond ((zero? j) (display "Already at root"))
	((< j nn)
	 (let ((value (next-opt i j)))
	   (if (= nn value)
	       (begin (display "At step ") (display i)
		      (display " no path from ") (display j)
		      (display " to 0 found."))
	       (let ((path (cons j (construct-path i value))))
		 (display "0")
		 (do ((l (cdr (reverse path))
			 (begin (display " <-- ") (display (car l)) (cdr l))))
		     ((null? l)
		      (let ((present-dist (dist-opt i j))
			    (final-dist (dist-opt nn j)))
			(if (< final-dist present-dist)
			    (begin (display " is a shortest path at step ")
				   (display i)
				   (display ", of length ")
				   (display present-dist) (display "."))
			    (begin (display " is a shortest path, of length ")
				   (display present-dist)
				   (display "."))))))))))
	(else (display "next-path called at non-node ") (display j))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Weiteres Beispiel
;                          5               5
;                  2---------------4---------------6
;                 /|             . | .           . |\
;               4/ |           .   |   .3     1.   | \7
;               /  |         .     |     .   .     |  \
;              0   |2      . 3     |1      8      2|   7
;               \  |     .         |       |       |  /
;               3\ |   .           |       |1      | /4
;                 \| .             |       |       |/
;                  1---------------3-------9-------5
;                          6           2       4

(define nn 10)
(define maxdist 100)

(define WEIGHT-ARRAY
  '(((0 . 1) 3)
    ((0 . 2) 4)
    ((1 . 2) 2)
    ((1 . 3) 6)
    ((1 . 4) 3)
    ((2 . 4) 5)
    ((3 . 4) 1)
    ((3 . 9) 2)
    ((4 . 6) 5)
    ((4 . 8) 3)
    ((5 . 6) 2)
    ((5 . 7) 4)
    ((5 . 9) 4)
    ((6 . 7) 7)
    ((6 . 8) 1)
    ((8 . 9) 1)))

; Tests:
; ==> (next-path 6 7)
; At step 6 no path from 7 to 0 found.

; ==> (next-path 7 7)
; 0 <-- 1 <-- 4 <-- 8 <-- 6 <-- 7 is a shortest path at step 7, of length 17.

; ==> (next-path 8 7)
; 0 <-- 1 <-- 4 <-- 8 <-- 6 <-- 5 <-- 7 is a shortest path, of length 16.

; ==> (next-path 1 3)
; 0 <-- 1 <-- 3 is a shortest path at step 1, of length 9.

; ==> (next-path 2 3)
; 0 <-- 1 <-- 3 is a shortest path at step 2, of length 9.

; ==> (next-path 3 3)
; 0 <-- 1 <-- 4 <-- 3 is a shortest path, of length 7.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 97-05-06
; Glattere Numerierung

; C_0=\emptyset.  d_0 ist 0 fuer 0 und unendlich sonst.  p_0(j)=p_0=0.

; C_1=C_0 \cup {p_0}.  d_1 gibt fuer C_1 die richtigen Distanzen
; (Minimum des alten Abstandes und des Summenabstands ueber p_0).
; p_1(j) durchsucht den Rand von C_1.  p_1 sei der Knoten mit kleinstem
; d_1-Abstand.

; C_2=C_1 \cup {p_1}.  Usw. C_nn={0=p_0,p_1,...,p_{nn-1}}.
; d_nn gibt fuer C_nn die richtigen Distanzen.

(define (comp0-opt i j)
  (let ((info (assoc (cons i j) COMP-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? i) #f)
			   ((and (< 0 i) (<= i nn))
			    (let* ((i-1 (- i 1)))
			      (or (comp0-opt i-1 j)
				  (= j (pick0-opt i-1 nn)))))
			   (else (error "comp0-opt called with" i j)))))
	  (set! COMP-ARRAY (cons (list (cons i j) value) COMP-ARRAY))
	  value))))

(define (dist0-opt i j)
  (let ((info (assoc (cons i j) DIST-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? i) (if (zero? j) 0 maxdist))
			   ((and (< 0 i) (<= i nn))
			    (let* ((i-1 (- i 1))
				   (prev-dist (dist0-opt i-1 j))
				   (p (pick0-opt i-1 nn))
				   (dist-via-p (+ (dist0-opt i-1 p)
						  (weight-ref p j))))
			      (if (<= prev-dist dist-via-p)		    
				  prev-dist
				  (min maxdist dist-via-p))))
			   (else (error "dist0-opt called with" i j)))))
	  (set! DIST-ARRAY (cons (list (cons i j) value) DIST-ARRAY))
	  value))))

(define (pick0-opt i j)
  (let ((info (assoc (cons i j) PICK-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? j) nn)
			   ((and (< 0 j) (<= j nn))
			    (let* ((j-1 (- j 1))
				   (prev-pick (pick0-opt i j-1)))
			      (if (or (comp0-opt i j-1)
				      (<= (if (= nn prev-pick)
					      maxdist
					      (dist0-opt i prev-pick))
					  (dist0-opt i j-1)))
				  prev-pick
				  j-1)))
			   (else (error "pick0-opt called with" i j)))))
	  (set! PICK-ARRAY (cons (list (cons i j) value) PICK-ARRAY))
	  value))))

(define (next0-opt i j)
  (let ((info (assoc (cons i j) NEXT-ARRAY)))
    (if info (cadr info)
	(let ((value (cond ((zero? i)
			    (if (zero? j) 0 nn))
			   ((and (< 0 i) (<= i nn))
			    (let* ((i-1 (- i 1))
				   (prev-dist (dist0-opt i-1 j))
				   (p (pick0-opt i-1 nn))
				   (dist-via-p (+ (dist0-opt i-1 p)
						  (weight-ref p j))))
			      (if (<= prev-dist dist-via-p)		    
				  (next0-opt i-1 j)
				  p)))
			   (else (error "next0-opt called with" i j)))))
	  (set! NEXT-ARRAY (cons (list (cons i j) value) NEXT-ARRAY))
	  value))))

; Zur Anzeige:

(define (construct0-path i j)
  (cond ((zero? j) (list j))
	((< j nn) (cons j (construct0-path i (next0-opt i j))))
	(else (display "construct0-path called at non-node ") (display j))))

(define (next0-path i j)
  (cond ((zero? j) (display "Already at root"))
	((< j nn)
	 (let ((value (next0-opt i j)))
	   (if (= nn value)
	       (begin (display "At step ") (display i)
		      (display " no path from ") (display j)
		      (display " to 0 found."))
	       (let ((path (cons j (construct0-path i value))))
		 (display "0")
		 (do ((l (cdr (reverse path))
			 (begin (display " <-- ") (display (car l)) (cdr l))))
		     ((null? l)
		      (let ((present-dist (dist0-opt i j))
			    (final-dist (dist0-opt nn j)))
			(if (< final-dist present-dist)
			    (begin (display " is a shortest path at step ")
				   (display i)
				   (display ", of length ")
				   (display present-dist) (display "."))
			    (begin (display " is a shortest path, of length ")
				   (display present-dist)
				   (display "."))))))))))
	(else (display "next0-path called at non-node ") (display j))))
