自动算24点

Module game24PointMod
  use,intrinsic :: iso_fortran_env, only: real64
  implicit none
  private  
  real(real64), parameter :: EPS              = 0.000001_real64  !实数相等判断精度
  integer     , parameter :: COUNT_OF_NUMBER  = 4      !参与运算的数字个数 4张牌
  integer     , parameter :: NUMBER_TO_BE_CAL = 24     !运算目标值 24
  
  Type , public :: T_game24Point
    real(real64)   , private :: Number(COUNT_OF_NUMBER)   !运算数字数组 必须为浮点数 否则除法运算得不到精确结果
    character(256) , private :: Expression(COUNT_OF_NUMBER) !运算表达式    
  contains
    Procedure :: setNum
    Procedure :: getExpression
    Procedure :: search
  End Type T_game24Point
  
contains
  !24点递归算法。
  !思路如下：
  !采用遍历的方式，先从数组的N个元素中取出两个数，分别进行四则运算，其结果保存在数组中。该数组变换为N-1个元素
  !再以新数组（N-1）个元素重复上述步骤的将上述两数运算结果与剩余数字组成的数组进行上述运算
  !直至所有数组元素参与计算，即到最后仅剩2个元素时判断是否有计算结果
  !Expression(i)中存放运算表达式，由于最终要计算到2个元素，所以最终表达式总是存放在Expression(1)中
  !Number(i)中存放两两运算后的结果，由于最终要计算到2个元素，所以最终结果总是存放在Number(1)中

  Character(len=256) Function getExp(a,b,oper)
    Character(len=*) , intent(IN) :: a , b , oper
    getExp = "(" // trim(adjustl(a)) // trim(oper) // trim(adjustl(b)) // ")"
  End Function getExp
  
  Character(len=256) Function getExpression(this,i)
    class(T_game24Point) :: this
    Integer , intent(IN) :: i
    getExpression = this%Expression(i)
  End Function getExpression
  
  Subroutine setNum(this,num)
    class(T_game24Point) :: this
    integer , Intent(IN) :: num(COUNT_OF_NUMBER)
    integer :: i
    do i = 1 , COUNT_OF_NUMBER
      this%Number(i)=real(num(i),real64)
      write(this%Expression(i),"(i0)") num(i) !整数转换为字符串
    end do
  End Subroutine setNum

  Recursive logical function Search(this,ns) result(res)
    class(T_game24Point) :: this
    integer,intent(in),optional::ns
    real(real64)      ::a,b
    character(256)    :: Expa, Expb
    integer::i, j , n
    n = merge( ns , COUNT_OF_NUMBER , present(ns) )
    If (n == 1) Then !递归出口
      res = Abs(this%Number(1) - NUMBER_TO_BE_CAL) < EPS
      If (res) Then   !当数字个数仅剩2个时，判断运算是否完成
        i = Len_trim(this%Expression(1)) - 1 !删除答案最外围左右括号后最后字符的位置 WX增加
        this%Expression(1) = this%Expression(1)(2:i) !删除最外围左右括号 WX增加
      End If
      return
    End If
    res = .true.
    !类似于冒泡法排序 共计C(n,2)种组合 从n个数抽取2个数
    Do i = 1, n
      Do j = i+1 , n
        !存放参与计算的两个数至临时变量
        a    = this%Number(i)
        b    = this%Number(j)
        Expa = this%Expression(i)
        Expb = this%Expression(j)
        !由于每次进行更深入递归都不再生成新数组，而是以数组N-1个元素进行运算，故将最后一个元素放到j位置
        this%Number(j) = this%Number(n)
        this%Expression(j) = this%Expression(n)
        !表达式赋值，运算结果赋值，进行递归运算
        !运算1 a+b
        !i位置存放i和j位置的两个数的运算结果
        this%Expression(i)  = getExp(Expa,Expb,'+')
        this%Number(i)      = a + b
        !若有运算结果则结束程序
        If (this%Search(n-1)) return
        !以下请参考上面
        !运算2 a-b
        !i位置存放i和j位置的两个数的运算结果
        this%Expression(i)  = getExp(Expa,Expb,'-')
        this%Number(i)      = a - b
        If (this%Search(n-1)) return
        !运算3 b-a
        !i位置存放i和j位置的两个数的运算结果
        this%Expression(i)  = getExp(Expb,Expa,'-')
        this%Number(i)      = b - a
        If (this%Search(n-1)) return
        !运算4 a*b
        !i位置存放i和j位置的两个数的运算结果
        this%Expression(i)  = getExp(Expa,Expb,'x')
        this%Number(i)      = a * b
        If (this%Search(n-1)) return
        !运算5 a/b
        !i位置存放i和j位置的两个数的运算结果
        If (Abs(b) > EPS) Then !分母不为0
          this%Expression(i)  = getExp(Expa,Expb,'/')
          this%Number(i)      = a / b !必须为浮点数 否则除法运算得不到精确结果
          If (this%Search(n-1)) return
        End If
        !运算6 b/a
        !i位置存放i和j位置的两个数的运算结果
        If (Abs(a) > EPS) Then !分母不为0
          this%Expression(i)  = getExp(Expb,Expa,'/')
          this%Number(i)      = b / a !必须为浮点数 否则除法运算得不到精确结果
          If (this%Search(n-1)) return
        End If
        !若6种运算均没有运算结果,则将数组复原，继续进行循环遍历
        this%Number(i)     = a
        this%Number(j)     = b
        this%Expression(i) = Expa
        this%Expression(j) = Expb
      End Do
    End Do
    res = .False.  !若上述所有组合的6种运算都没有结果，则该数组无法满足运算要求
  end function search

End Module game24PointMod

Program fcode_cn
  use game24PointMod
  implicit none
  type(T_game24Point) :: g24
  integer :: N(4) , k
  Do
    write(*,"('依次输入4张牌:')")
    read(*,*,ioStat=k) N
    if(k/=0) exit
    call g24%setNum(N)
    If (g24%search()) then !有解 会改变Number()及Expression()的数据
      write(*,"('Answer: 24=',a)") g24%getExpression(1) !若有多个答案 只会显示其中一个最快的答案
    Else !无解
      write(*,"('Answer: None')")
    End If
  End Do
End Program fcode_cn