fixedpoint.jp


2007/02/24

Dijkstra's algorithm 再び

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)

© 2006-2023 fixedpoint.jp