2007/02/22に書いた Dijkstra's algorithm のコードにバグがあったため修正をしました。特にテスト用のコードとして、世界の28都市を結ぶ旅客ルートの距離(マイルで計算)をもとに最短コースを計算させてみました。
(use gauche.sequence)
(use srfi-1)
(use util.combinations)
(define (vertices-of graph)
(fold
(lambda (e temp)
(let ((u (car e))
(v (cdr e)))
(if (memq u temp)
(if (memq v temp)
temp
(cons v temp))
(if (memq v temp)
(cons u temp)
(cons* u v temp)))))
'()
graph))
(define (dijkstra graph weight s)
(let lp0 ((dst `((,s . 0)))
(prv '())
(vst '())
(ust (vertices-of graph)))
(let ((udst (filter (lambda (x) (memq (car x) ust)) dst)))
(if (null? udst)
(values dst prv)
(let ((u-and-d (car (sort udst (lambda (x y) (< (cdr x) (cdr y)))))))
(let ((u (car u-and-d))
(d (cdr u-and-d)))
(let lp1 ((out (map cdr (filter (lambda (e) (eq? u (car e))) graph)))
(dst dst)
(prv prv))
(if (null? out)
(lp0 dst prv (cons u vst) (delete u ust eq?))
(let* ((v (car out))
(d+w (+ d (weight u v))))
(let lp2 ((rest dst)
(temp '()))
(if (null? rest)
(lp1 (cdr out) (cons (cons v d+w) dst) (cons (cons v u) prv))
(let ((v-and-d (car rest)))
(if (eq? v (car v-and-d))
(if (< d+w (cdr v-and-d))
(lp1 (cdr out)
(cons (cons v d+w) (append (cdr rest) temp))
(cons (cons v u) (remove (lambda (e) (eq? v (car e))) prv)))
(lp1 (cdr out) dst prv))
(lp2 (cdr rest) (cons v-and-d temp)))))))))))))))
(define (shortest-path graph weight x y)
(receive (dst prv)
(dijkstra graph weight x)
(let lp ((u y)
(s '()))
(cond ((assq u prv) => (lambda (p) (lp (cdr p) (cons u s))))
(else s)))))
マイルによる距離は http://www.infoplease.com/ipa/A0759496.html にある表を利用しました。例えば、ロンドンからシドニーに行くには、直通ルートよりもモスクワ及びカルカッタ経由のルートの方がマイルが少ないということが分かります。また、
などの変更を加えると面白いです。
(define cities
'(berlin buenos-aires cairo calcutta cape-town caracas chicago
hong-kong honolulu istanbul lisbon london los-angeles manila
mexico-city montreal moscow new-york paris rio-de-janeiro rome
san-francisco shanghai stockholm sydney tokyo warsaw washington-dc))
(define-macro (define-statute-miles cities table)
`(define (statute-miles x y)
(case x
,@(map-with-index
(lambda (i c)
`((,c)
(case y
,@(map-with-index
(lambda (j d)
`((,d)
,(list-ref (list-ref table j) i)))
cities)
(else #f))))
cities)
(else #f)))
)
(define-statute-miles
(berlin buenos-aires cairo calcutta cape-town caracas chicago
hong-kong honolulu istanbul lisbon london los-angeles manila
mexico-city montreal moscow new-york paris rio-de-janeiro rome
san-francisco shanghai stockholm sydney tokyo warsaw washington-dc)
(
(#f 7402 1795 4368 5981 5247 4405 5440 7309 1078 1436 579 5724 6132 6047 3729 1004 3965 545 6220 734 5661 5218 504 10006 5540 320 4169)
(7402 #f 7345 10265 4269 3168 5598 11472 7561 7611 5956 6916 6170 11051 4592 5615 8376 5297 6870 1200 6929 6467 12201 7808 7330 11408 7662 5218)
(1795 7345 #f 3539 4500 6338 6129 5061 8838 768 2363 2181 7520 5704 7688 5414 1803 5602 1995 6146 1320 7364 5183 2111 8952 5935 1630 5800)
(4368 10265 3539 #f 6024 9605 7980 1648 7047 3638 5638 4947 8090 2203 9492 7607 3321 7918 4883 9377 4482 7814 2117 4195 5685 3194 4048 8084)
(5981 4269 4500 6024 #f 6365 8494 7375 11534 5154 5325 6012 9992 7486 8517 7931 6300 7764 5807 3773 5249 10247 8061 6444 6843 9156 5958 7901)
(5247 3168 6338 9605 6365 #f 2501 10167 6013 6048 4041 4660 3632 10620 2232 2449 6173 2132 4736 2810 5196 3904 9501 5420 9513 8799 5517 2059)
(4405 5598 6129 7980 8494 2501 #f 7793 4250 5477 3990 3950 1745 8143 1691 744 4974 713 4134 5296 4808 1858 7061 4278 9272 6299 4667 597)
(5440 11472 5061 1648 7375 10167 7793 #f 5549 4984 6853 5982 7195 693 8782 7729 4439 8054 5985 11021 5768 6897 764 5113 4584 1794 5144 8147)
(7309 7561 8838 7047 11534 6013 4250 5549 #f 8109 7820 7228 2574 5299 3779 4910 7037 4964 7438 8285 8022 2393 4941 6862 4943 3853 7355 4519)
(1078 7611 768 3638 5154 6048 5477 4984 8109 #f 2012 1552 6783 5664 7110 4789 1091 4975 1400 6389 843 6703 4962 1348 9294 5560 863 5215)
(1436 5956 2363 5638 5325 4041 3990 6853 7820 2012 #f 985 5621 7546 5390 3246 2427 3364 904 4796 1161 5666 6654 1856 11302 6915 1715 3562)
(579 6916 2181 4947 6012 4660 3950 5982 7228 1552 985 #f 5382 6672 5550 3282 1555 3458 213 5766 887 5357 5715 890 10564 5940 899 3663)
(5724 6170 7520 8090 9992 3632 1745 7195 2574 6783 5621 5382 #f 7261 1589 2427 6003 2451 5588 6331 6732 347 6438 5454 7530 5433 5922 2300)
(6132 11051 5704 2203 7486 10620 8143 693 5299 5664 7546 6672 7261 #f 8835 8186 5131 8498 6677 11259 6457 6967 1150 5797 3944 1866 5837 8562)
(6047 4592 7688 9492 8517 2232 1691 8782 3779 7110 5390 5550 1589 8835 #f 2318 6663 2094 5716 4771 6366 1887 8022 5959 8052 7021 6365 1887)
(3729 5615 5414 7607 7931 2449 744 7729 4910 4789 3246 3282 2427 8186 2318 #f 4386 320 3422 5097 4080 2539 7053 3667 9954 6383 4009 488)
(1004 8376 1803 3321 6300 6173 4974 4439 7037 1091 2427 1555 6003 5131 6663 4386 #f 4665 1544 7175 1474 5871 4235 762 9012 4647 715 4858)
(3965 5297 5602 7918 7764 2132 713 8054 4964 4975 3364 3458 2451 8498 2094 320 4665 #f 3624 4817 4281 2571 7371 3924 9933 6740 4344 205)
(545 6870 1995 4883 5807 4736 4134 5985 7438 1400 904 213 5588 6677 5716 3422 1544 3624 #f 5699 697 5558 5754 958 10544 6034 849 3829)
(6220 1200 6146 9377 3773 2810 5296 11021 8285 6389 4796 5766 6331 11259 4771 5097 7175 4817 5699 #f 5684 6621 11336 6651 8306 11533 6467 4796)
(734 6929 1320 4482 5249 5196 4808 5768 8022 843 1161 887 6732 6457 6366 4080 1474 4281 697 5684 #f 6240 5677 1234 10136 6135 817 4434)
(5661 6467 7364 7814 10247 3904 1858 6897 2393 6703 5666 5357 347 6967 1887 2539 5871 2571 5558 6621 6240 #f 6140 5361 7416 5135 5841 2442)
(5218 12201 5183 2117 8061 9501 7061 764 4941 4962 6654 5715 6438 1150 8022 7053 4235 7371 5754 11336 5677 6140 #f 4825 4899 1097 4951 7448)
(504 7808 2111 4195 6444 5420 4278 5113 6862 1348 1856 890 5454 5797 5959 3667 762 3924 958 6651 1234 5361 4825 #f 9696 5051 501 4123)
(10006 7330 8952 5685 6843 9513 9272 4584 4943 9294 11302 10564 7530 3944 8052 9954 9012 9933 10544 8306 10136 7416 4899 9696 #f 4866 9696 9758)
(5540 11408 5935 3194 9156 8799 6299 1794 3853 5560 6915 5940 5433 1866 7021 6383 4647 6740 6034 11533 6135 5135 1097 5051 4866 #f 5249 6772)
(320 7662 1630 4048 5958 5517 4667 5144 7355 863 1715 899 5922 5837 6365 4009 715 4344 849 6467 817 5841 4951 501 9696 5249 #f 4457)
(4169 5218 5800 8084 7901 2059 597 8147 4519 5215 3562 3663 2300 8562 1887 488 4858 205 3829 4796 4434 2442 7448 4123 9758 6772 4457 #f)
))
(define air-graph
(remove (lambda (pair) (eq? (car pair) (cdr pair)))
(map (lambda (x) (cons (car x) (cadr x)))
(cartesian-product (list cities cities)))))
(shortest-path air-graph statute-miles 'tokyo 'new-york)
(shortest-path (delete '(tokyo . london) air-graph equal?) statute-miles 'tokyo 'london)
(shortest-path air-graph statute-miles 'sydney 'london)