GAでも今日も一日がんばるぞい！ ref: http://qiita.com/make_now_just/items/6a0a729b00a81b5ec460

zoi.f90

program zoi
  implicit none

  character(len=8) :: zoizoi(7)
  integer :: gene_len = 0
  character(len=100) :: ansstr = ""

  integer :: genes(5)
  integer :: cnt
  logical :: finish = .false.

  ! srand, timeはgfortranの拡張
  call srand(time())
  call load_zoi(gene_len, ansstr, zoizoi)

  call ga_init(genes)
  cnt = 1
  do
    call ga_step(cnt, genes, finish)
    if (finish) exit
    cnt = cnt + 1
  end do
  print '("がんばるまで", I0, "ぞいでした")', cnt

contains

  ! 遺伝子から文字列に変換する
  function gene_to_str(gene) result(str)
    integer, intent(in) :: gene
    character(len=100) :: str

    character(len=8) :: z
    integer :: i, j = 1

    str = ""

    do i = 1, size(zoizoi)
      z = zoizoi(i)
      if (z(1:1) == "*") then
        str = trim(str) // z(2:)
      else
        if (btest(gene, j)) then
          str = trim(str) // z
        else
          str = trim(str) // "ぞい"
        end if
        j = j + 1
      end if
    end do
  end function gene_to_str

  ! 交叉（一様交叉）
  function ga_crossing(parents) result(child)
    integer, intent(in) :: parents(2)
    integer :: child

    integer :: i

    child = 0

    do i = 1, gene_len
      child = ior(child, iand(ishft(1, i), parents(mod(i, 2) + 1)))
    end do
  end function ga_crossing

  ! 突然変異
  function ga_mutation(gene) result(mu_gene)
    integer, intent(in) :: gene
    integer :: mu_gene

    integer :: i

    mu_gene = gene

    do i = 1, gene_len
      ! irandはgfortranの拡張
      if (mod(irand(), 2) == 0) then
        mu_gene = ibset(mu_gene, i)
      end if
    end do
  end function ga_mutation

  ! 評価関数
  function ga_score(str) result(score)
    character(len=*), intent(in) :: str
    real :: score

    integer :: i

    score = 0.0
    do i = 1, len_trim(ansstr)
      if (ansstr(i:i) == str(i:i)) score = score + 1.0
    end do

    score = score / real(len_trim(ansstr))
  end function ga_score

  ! 遺伝的アルゴリズムの1ステップ
  subroutine ga_step(cnt, genes, finish)
    integer, intent(in) :: cnt
    integer, intent(inout) :: genes(:)
    logical, intent(out) :: finish

    character(len=100), allocatable :: strs(:)
    real, allocatable :: scores(:), sorted(:)

    character(len=100) :: parents_str(2)
    integer :: parents(2)
    integer :: i, j, k

    allocate (strs(size(genes)))
    allocate (scores(size(genes)))

    do i = 1, size(genes)
      strs(i) = gene_to_str(genes(i))
      scores(i) = ga_score(strs(i))
    end do

    sorted = qsort(scores)
    sorted = sorted(size(sorted):1:-1)
    k = -1
    do i = 1, 2
      do j = 1, size(scores)
        if (sorted(i) == scores(j) .and. j /= k) then
          parents_str(i) = strs(j)
          parents(i) = genes(j)
          k = j
          exit
        end if
      end do
    end do

    print '(I0, " => ", A, " (", F0.3, ")")', cnt, trim(parents_str(1)), sorted(1)

    if (sorted(1) == 1.0) then
      finish = .true.
      return
    end if

    do i = 1, size(genes)
      if (i <= 2) then
        genes(i) = parents(i)
      else if (mod(irand(), 3) == 0) then
        genes(i) = ga_mutation(parents(mod(i, 2) + 1))
      else
        genes(i) = ga_crossing(parents)
      end if
    end do
  end subroutine ga_step

  ! 遺伝的アルゴリズムの初期値
  subroutine ga_init(genes)
    integer, intent(inout) :: genes(:)

    integer :: i

    do i = 1, size(genes)
      genes(i) = irand()
    end do
  end subroutine ga_init

  ! ファイルの読み込み
  subroutine load_zoi(gene_len, ansstr, zoizoi)
    integer, intent(out) :: gene_len
    character(len=*) :: ansstr
    character(len=8), intent(out) :: zoizoi(7)

    integer :: i, j
    integer :: funit

    ! ファイル名決め打ち
    open (newunit = funit, file = "zoi.txt", status = 'old')

    do i = 1, size(zoizoi)
      read (funit, *), zoizoi(i)
      if (zoizoi(i)(1:1) == "*") then
        ansstr = trim(ansstr) // zoizoi(i)(2:)
      else
        gene_len = gene_len + 1
        ansstr = trim(ansstr) // zoizoi(i)
      end if
    end do
  end subroutine load_zoi

  ! http://qiita.com/cure_honey/items/29944920e8aff5651e41
  recursive function qsort(arr) result(res)
    real, intent(in)  :: arr(:)
    real, allocatable :: res(:)
    real :: pivot
    if (size(arr) <= 1) then 
      res = arr
    else  
      pivot = arr(size(arr) / 2)
      res = [qsort(pack(arr, arr < pivot)), &
                   pack(arr, arr == pivot), &
             qsort(pack(arr, arr > pivot))]
    end if
  end function qsort  
end program zoi

zoi.txt

今日
*も
1
日
がん
ばる
*ぞい!