セールスマン問題をといてみた

core.clj

(ns traveling-salesman.core
  (:gen-class))

(def df-dna-set-am 100)

(def df-generation-am 1000)

(def df-max-cost 10000)

(def df-point-am 10)

(defn get-cost [a b n cost-list]
  (let [[a b] (if (> a b) [b a] [a b])]
    (nth cost-list (+ (- (*  n  a) (quot (* a (- a 1)) 2) ) (- b a) -1))))

(defn dna-eval [dna point-am cost-list]
  (loop [cost (get-cost (first dna) (last dna) point-am cost-list)
         uncheck-dna dna]
    (if (= (count uncheck-dna) 1) cost
      (recur (+ cost (get-cost (first uncheck-dna) (second uncheck-dna) point-am cost-list )) (next uncheck-dna))
    )))

(defn make-problem [n]
  (take (quot (* n (+ n 1)) 2) (repeatedly #(+ 1 (rand-int (- df-max-cost 1))))))

(defn make-dna [n]
  (shuffle (range n)))

(defn change-list [n t l]
  (let [mae (take n l)
        back (drop (+ n 1) l)]
    (concat mae (cons t back))
    ))

(defn choice-dna [sorted-dnas point-am cost-list dna-set-am ]
  (let [result-cost (pmap #(dna-eval % point-am cost-list) sorted-dnas)
        most-and-little-cost (+ (first result-cost) (last result-cost))
        eval-cost (pmap #(- most-and-little-cost % ) result-cost)
        all-cost (reduce + eval-cost)
        ]
    (loop [remain (rand-int all-cost)
           dnas sorted-dnas
           eval-cost eval-cost
           ]
      (let [remain (- remain (first eval-cost))]
        (if (<= remain 0) (first dnas)
          (recur remain (next dnas) (next eval-cost))))
    )))

(defn swap-dna [dna a b]
  (let [x (nth dna b)]
    (change-list a x (change-list b (nth dna a) dna))
  ))

(defn mutaion-dna [dna point-am]
  (let [a (rand-int point-am)
        b (rand-int point-am)]
    (swap-dna dna a b)
  ))

(defn cross-dna [a b point-am]
  (loop [i 0
         a a
         b b]
    (if (= i point-am) (list a b)
      (let [r (rand-int 2)]
        (if (= r 1) (recur (+ i 1) a b)
          (let [a-t (first (keep-indexed #(if (= %2 (nth b i)) %1) a))
                b-t (first (keep-indexed #(if (= %2 (nth a i)) %1) b))
                next-a (swap-dna a a-t i)
                next-b (swap-dna b b-t i)]
            (recur (+ i 1) next-a next-b)
            ))
    ))))

(def last-good (atom nil))

(defn first-mane [dna-set-am generation-am point-am]
  (let [cost-list (list 2138 1198 2667 8293 644 2644 9025 7551 2313 200 1176 501 1364 3016 525 4364 1576 6120 2672 4621 5656 6575 352 5682 6825 6858 1607 2881 3879 3760 424 2627 2055 7930 2642 97 4653 9971 2097 5441 4536 3917 710 195 405 7861 1482 5260 58 4534 5229 696 1711 1696 278 5341 4892 3356 9323 1288 4441 8054 9194 4144 4698 9673 7337 5133 6095 9610 3524 5142 3050 6517 6484 4033 319 1267 2949 751 4784 340 952 1083 1013 387 134 249 1874 368 9259 6963 9 5394 5200 4081 2004 8132 8228 8474 4734 9493 5628 9426 2566 197 9341 479 4821 8767 3667 4413 5249 9557 5846 4856 9110 6405 5826 848 8933 3772 1401 2623 6982 7329 1519 7881 1075 276 3602 7835 470 9977 414 1444 283 1931 8191 4425 6096 4485 589 6870 5281 8295 2284 9578 7887 9042 2033 4587 7949 623 7421 9818 5490 8671 2585 1229 640 1111 5785 8392 3857 3187 5869 1094 464 9391 5375 5128 3439 3601 3306 5301 5746 1784 2485 2367 2325 8722 4754 8540 2342 1308 2295 3124 4279 6214 4874 5791 6 8973 887 96 9121 4863 4767 3908 1518 9347 4525 6652 4397 7324 968 5432 9755 5909) #_(make-problem point-am)]
    (println "problem:" cost-list)
    (loop [i 0
           dnas (take dna-set-am (repeatedly #(make-dna point-am)))]
      (if (> i generation-am) (println "FINISH")
        (let [sorted-dnas (sort-by #(dna-eval % point-am cost-list) dnas)
              now-good (dna-eval (first sorted-dnas) point-am cost-list)]
          (when (or (nil? @last-good) (< now-good @last-good))
            (do 
              (reset! last-good now-good)
              (println "第" i "世代\nDNA: " (first sorted-dnas) "\nCost: " now-good "\n"))
          )
          (recur (+ i 1) 
            (letfn [(dice-dna [] (choice-dna sorted-dnas point-am cost-list dna-set-am))]
              (loop [next-dnas (list (first sorted-dnas))]
                (if (>= (count next-dnas) dna-set-am) (take generation-am next-dnas)
                  (let [prob (rand)]
                    (recur (cond
                             (< prob 0) (cons (make-dna point-am) next-dnas)
                             (< prob 0.01) (cons (mutaion-dna (dice-dna) point-am) next-dnas)
                             (< prob 0.3)  (concat (cross-dna (dice-dna) (dice-dna) point-am) next-dnas)
                             :else         (cons (dice-dna) next-dnas)
                           )))
                )))))))))

(defn -main [] 
  (first-mane df-dna-set-am df-generation-am 20))