Traveling Salesman Problem using genetic algorithms

breed[citys a-city]
breed[persons a-person]

citys-own[

]
persons-own[
  chrome
  distance-total
  score
  fitness
  prob-max
  prob-min
  not-mutate?
]
globals[
  best-chrome
  max-score
  gen-num
  default-chrome
  step
  sort-persons-max-set
  sort-persons-max-list
  sort-persons-min-list
  consum-list
  min-distance-total
  mean-distance-total
  max-fitness
  distance-list
  ;;
  ;;
  parents-list
  num-of-child
]

to setup
clear-all
  init-model
  init-patches
reset-ticks
end 

to   init-model
set-default-shape citys "circle"
set-default-shape persons "person"
set default-chrome remove 0 range  citys-num
create-citys citys-num [
    setxy random-xcor  random-ycor
    set label who
    set color brown
    if who = 0 [set color yellow]
    set size 1.5
  ]
create-persons persons-num[
    init-agents
  ]
set step 0
set gen-num 0
set parents-list []
set  num-of-child 0
end 

to   init-patches
end 

to   init-agents
    setxy [ xcor ] of a-city 0 [ ycor ] of a-city 0
    let s-list  random-chrome
    set chrome sentence  [0] s-list
    set chrome lput 0 chrome
    set distance-total 0
    set score 0
    set fitness 0
    set prob-max 0
    set prob-min 0
    set not-mutate? 0
    set hidden? true
    pen-up
end 

to-report random-chrome
  report n-of (citys-num - 1 ) shuffle default-chrome
end 

to go
  clear-drawing
  active-model
  tick
end 

to active-model
  repeat count citys   [
    set step step + 1
    ask persons [move]
  ]
  set step 0
  set gen-num gen-num + 1
  cal-fitness
  create-next-gen
  output-print(word "gen-num : " gen-num )
end 

to move
let order item step chrome
set distance-total distance-total + distance a-city order
move-to a-city order
end 

to cal-fitness

  ask persons [set score 1 / distance-total ]


  ask persons [set fitness  score / sum [score] of persons]
  set distance-list [distance-total] of  persons

  set-current-plot "plot 1"
  set-current-plot-pen "pen-2"
  histogram distance-list

  set max-score max [score] of persons
  set min-distance-total min [distance-total] of persons
  set mean-distance-total  mean [distance-total] of persons
  set max-fitness max [fitness] of persons
end 

to create-next-gen
  ifelse t-select? = true [t-selection
  ][
    select-roulette
    roulette-selection]
end 

to t-selection

  let old-gen (turtle-set persons)

  let best-num count old-gen with [ score = max-score]

  ifelse best-num <= best-num-max [][set best-num  best-num-max]

  let best-turtle max-n-of best-num old-gen [score]

  set best-chrome [chrome] of max-one-of old-gen [score]
  output-print(word "strategy " best-chrome)

  let new-old-gen  n-of (select-new-gen-rate * persons-num ) old-gen

  let crossover-count persons-num / 2 - best-num

  ask best-turtle [
    hatch 1[
      init-agents
      set chrome [chrome] of myself
      pen-down
      set pen-size 2
      set not-mutate? 1

    ]
    hatch 1[
      init-agents
      set chrome [chrome] of myself
    ]
  ]

  repeat crossover-count [

  let parent1 max-one-of (n-of ( select-parent-rate * persons-num ) new-old-gen) [score]
  let parent2 max-one-of (n-of ( select-parent-rate * persons-num ) new-old-gen) [score]

  let childchrome crossover-chrome  [chrome] of parent1 [chrome] of parent2
    ask parent1 [
      hatch 1 [
        init-agents
        set chrome item 0 childchrome]
    ]
    ask parent2 [
      hatch 1 [
        init-agents
        set chrome item 1 childchrome]
    ]
  ]
  ask old-gen[die]
  ask n-of (persons-num * mutate-rate )  persons [
    if not-mutate? = 0 [mutate]
  ]
end 

to select-roulette
  set sort-persons-max-set  sort-by [[a b] -> [fitness] of a < [fitness] of b] persons
  set sort-persons-max-list sort-by [[a b] ->  a < b]  ([fitness] of persons )
  set consum-list partial-sums sort-persons-max-list
  set sort-persons-min-list ( map - consum-list sort-persons-max-list )
  ( foreach  sort-persons-max-set consum-list sort-persons-min-list  [ [ a b c ] -> ask a [set prob-max b set prob-min c] ] ) ;速度较慢
end 

to-report partial-sums [nums]
  report butfirst reverse reduce [ [ a b ] -> fput (b + first a) a] fput [0] nums
end 

to roulette-selection

  let old-gen (turtle-set persons)

  let best-num count old-gen with [fitness = max-fitness]

  ifelse best-num <= best-num-max [][set best-num  best-num-max]

  let best-turtle max-n-of best-num old-gen [fitness]
  output-print(word [chrome] of max-one-of old-gen [fitness])

  ask best-turtle [
    hatch 1[
      init-agents
      set chrome [chrome] of myself
      pen-down
      set pen-size 2
      set not-mutate? 1
      set color random 250
    ]
    hatch 1[
      init-agents
      set chrome [chrome] of myself
    ]
  ]

;;
;;  Method 4
;;
;;  let next-gen-num 2 * best-num
;;  while next-gen-num > length old-gen   [
;;
;;  set next-gen-num next-gen-num + 1
;;]
;;  set parents-list []
;;

;;
;;  Method 3
;;
  ask old-gen [
  let random-num1 random-float  max [prob-max] of old-gen
  let parent one-of old-gen with [prob-max > random-num1 and prob-min <= random-num1]
  set parents-list fput ( [who] of parent ) parents-list ]

;;  repeat 2 * best-num [
;;    set parents-list remove-item ( random length parents-list )  parents-list ]
;;
;;  output-print(word parents-list)
;;
  while [ num-of-child <= persons-num - 2 * best-num ] [
  let parent1-num one-of parents-list
  let parent1 turtle parent1-num
  ifelse random-float 1 < cross-rate [
    set num-of-child num-of-child + 2
    let parent2 turtle one-of parents-list
    let childchrome crossover-chrome  ( [chrome] of parent1 ) ([chrome] of parent2 )
    ask parent1 [
      hatch 1 [
        init-agents
        set chrome item 0 childchrome]
    ]
        ask parent2 [
      hatch 1 [
        init-agents
        set chrome item 1 childchrome]
    ]
  ][ask parent1 [set  num-of-child num-of-child + 1 hatch 1 [init-agents set chrome [chrome] of myself]]]]
  set num-of-child 2
  set parents-list []
  ask old-gen [die]

  set-current-plot "plot 2"
  set-current-plot-pen "pen5"
  plot count persons

;;  foreach parents-list [a -> ask turtle a [
;;    ifelse random-float 1 <= cross-rate [
;;      let parent2 turtle one-of parents-list
;;      let child-chromosomes crossover-chrome  ( chrome ) ([chrome] of parent2)
;;          hatch 1 [
;;              init-agents
;;              set chrome item 0 child-chromosomes
;;          ]
;;  ][hatch 1 [init-agents set chrome [chrome] of myself]]]
;;  ]
;;  set parents-list []


;;
;;  Method 1
;;
;;ask max-n-of ( persons-num - 2 * best-num ) old-gen [fitness] [
;;  ask old-gen [
;;    ifelse random-float 1 <= cross-rate [
;;     let random-num1 random-float  max [prob-max] of old-gen
;;      let parent2 one-of old-gen with [prob-max > random-num1 and prob-min <= random-num1]
;;      let child-chromosomes crossover-chrome  ( chrome ) ([chrome] of parent2)
;;          hatch 1 [
;;              init-agents
;;              set chrome item 0 child-chromosomes
;;           ]
;;  ][hatch 1 [init-agents set chrome [chrome] of myself]]]
;;  ask old-gen [die]
;;  ask n-of ( 2 * best-num )  persons with [not-mutate? = 0 ] [die]


;;
;;  Method 2
;;
;;  repeat ( count old-gen / 2 - best-num )  [
;;  let random-num1 random-float  max [prob-max] of old-gen
;;  let random-num2 random-float  max [prob-max] of old-gen
;;  let parent1 one-of old-gen with [prob-max > random-num1 and prob-min <= random-num1]
;;  let parent2 one-of old-gen with [prob-max > random-num2 and prob-min <= random-num2]
;;  let childchrome crossover-chrome  [chrome] of parent1 [chrome] of parent2
;;    ask parent1 [
;;      hatch 1 [
;;        init-agents
;;        set chrome item 0 childchrome]
;;    ]
;;    ask parent2 [
;;      hatch 1 [
;;        init-agents
;;        set chrome item 1 childchrome]
;;    ]
;;  ]
;;  ask old-gen[die]

  ask n-of (persons-num * mutate-rate)  persons [
    if not-mutate? = 0 [mutate]
  ]
end 

to-report crossover-chrome [chrome1 chrome2]

  let split-point1 1 + random  ( length chrome1 - 4 )
  let split-point2 3 + split-point1

  let chrome2-sublist ( sublist chrome2 split-point1 split-point2 )
  let chrome1-sublist ( sublist chrome1 split-point1 split-point2 )

  let newchrome1 list-sub chrome2-sublist chrome1
  let newchrome2 list-sub chrome1-sublist chrome2

  report list (sentence (sublist newchrome1 0 split-point1 )
                        (sublist chrome2 split-point1 split-point2)
                        (sublist newchrome1 split-point1 length newchrome1))
         (sentence (sublist newchrome2 0 split-point1 )
                   (sublist chrome1 split-point1 split-point2)
                   (sublist newchrome2 split-point1 length newchrome2))
end 

to-report list-sub [list-a list-b]
  let temp-list-b list-b
  foreach list-a [a -> if member? a temp-list-b [set temp-list-b remove a temp-list-b]]
  report temp-list-b
end 

to mutate
  repeat length default-chrome [
  ifelse  (random-float 1 < gen-mutate-rate )[
    let action one-of default-chrome
    set chrome change-action action chrome
  ][]]
end 

to-report  change-action [action my-chrome]

  let pos1 position action my-chrome
  let temp-action one-of remove action default-chrome
  let pos2 position temp-action my-chrome

  let temp-chrome replace-item pos1 my-chrome temp-action
  set temp-chrome replace-item pos2 temp-chrome action
  report temp-chrome
end