[其他行业算法] 24点计算程序

module hi
    !use,intrinsic :: iso_fortran_env, only: real64
    implicit none

    integer,parameter::real64=SELECTED_REAL_KIND(11)
    real(real64),parameter::EPS= 0.000001_real64  !实数相等判断精度
    integer,parameter::COUNT_OF_NUMBER=4    !参与运算的数字个数 4张牌
    integer,parameter::NUMBER_TO_BE_CAL=24  !运算目标值 24
    integer,parameter::Number_Scale=13      !运算数字的范围 13
    real(real64)::Number(COUNT_OF_NUMBER)   !运算数字数组 必须为浮点数 否则除法运算得不到精确结果
    character(256)::Expression(COUNT_OF_NUMBER) !运算表达式
contains
!24点递归算法。
!思路如下：
!采用遍历的方式，先从数组的N个元素中取出两个数，分别进行四则运算，其结果保存在数组中。该数组变换为N-1个元素
!再以新数组（N-1）个元素重复上述步骤的将上述两数运算结果与剩余数字组成的数组进行上述运算
!直至所有数组元素参与计算，即到最后仅剩2个元素时判断是否有计算结果
!Expression(i)中存放运算表达式，由于最终要计算到2个元素，所以最终表达式总是存放在Expression(1)中
!Number(i)中存放两两运算后的结果，由于最终要计算到2个元素，所以最终结果总是存放在Number(1)中
recursive function Search(n) result(res)
    integer,intent(in)::n
    logical::res
    real(real64)::a,b
    character(256)::Expa, Expb
    integer::i, j

    If (n == 1) Then !递归出口
        If (Abs(Number(1) - NUMBER_TO_BE_CAL) < EPS) Then   !当数字个数仅剩2个时，判断运算是否完成
            res = .True.
            i = Len_trim(Expression(1)) - 1 !删除答案最外围左右括号后最后字符的位置 WX增加
            Expression(1) = Expression(1)(2:i) !删除最外围左右括号 WX增加
        Else
            res = .False.
        End If

        return
    End If
    !类似于冒泡法排序 共计C(n,2)种组合 从n个数抽取2个数
    do i = 1, n
        do j = i + 1 , n
            !存放参与计算的两个数至临时变量
            a = Number(i)
            b = Number(j)
            Expa = Expression(i)
            Expb = Expression(j)
            !由于每次进行更深入递归都不再生成新数组，而是以数组N-1个元素进行运算，故将最后一个元素放到j位置
            Number(j) = Number(n)
            Expression(j) = Expression(n)
            !表达式赋值，运算结果赋值，进行递归运算
            !运算1 a+b
            !i位置存放i和j位置的两个数的运算结果
            Expression(i) = "(" // trim(adjustl(Expa)) // "+" // trim(adjustl(Expb)) // ")"
            Number(i) = a + b
            !若有运算结果则结束程序
            If (Search(n - 1)) Then   !递归在这里
                res = .True.
                return
            End If
            !以下请参考上面
            !运算2 a-b
            !i位置存放i和j位置的两个数的运算结果
            Expression(i) = "(" // trim(adjustl(Expa)) // "-" // trim(adjustl(Expb)) // ")"
            Number(i) = a - b

            If (Search(n - 1)) Then
                res = .True.
                return
            End If
            !运算3 b-a
            !i位置存放i和j位置的两个数的运算结果
            Expression(i) = "(" // trim(adjustl(Expb)) // "-" // trim(adjustl(Expa)) // ")"
            Number(i) = b - a

            If (Search(n - 1)) Then
                res = .True.
                return
            End If
            !运算4 a*b
            !i位置存放i和j位置的两个数的运算结果
            Expression(i) = "(" // trim(adjustl(Expa)) // "*" // trim(adjustl(Expb)) // ")"
            Number(i) = a * b

            If (Search(n - 1)) Then
                res = .True.
                return
            End If
            !运算5 a/b
            !i位置存放i和j位置的两个数的运算结果
            If (Abs(b) > EPS) Then !分母不为0
                Expression(i) = "(" // trim(adjustl(Expa)) // "/" // trim(adjustl(Expb)) // ")"
                Number(i) = a / b !必须为浮点数 否则除法运算得不到精确结果

                If (Search(n - 1)) Then
                    res = .True.
                    return
                End If
            End If
            !运算6 b/a
            !i位置存放i和j位置的两个数的运算结果
            If (Abs(a) > EPS) Then !分母不为0
                Expression(i) = "(" // trim(adjustl(Expb)) // "/" // trim(adjustl(Expa)) // ")"
                Number(i) = b / a !必须为浮点数 否则除法运算得不到精确结果

                If (Search(n - 1)) Then
                    res = .True.
                    return
                End If
            End If
            !若6种运算均没有运算结果,则将数组复原，继续进行循环遍历
            Number(i) = a
            Number(j) = b
            Expression(i) = Expa
            Expression(j) = Expb
        end do
    end do

    res = .False.  !若上述所有组合的6种运算都没有结果，则该数组无法满足运算要求
end function
end module

program main
    use hi
    implicit none

    integer::i,N
    write(*,*)"依次输入4张牌(每张范围为1-13):"

    do i = 1 , COUNT_OF_NUMBER
        do                        
            write(*,"(a,i0,a)",advance="NO")"输入第",i,"张牌:"
            read(*,*)N

            If (N <= Number_Scale .And. N >= 1) Then !输入正确
                exit !退出循环
            else
                write(*,"(a,i0,a)")"第",i, "张牌已超出范围，请重新输入!"
            End If
        end do
        !整数转换为浮点数
        Number(i)=real(N,real64)
        !整数转换为字符串
        write(Expression(i),"(i0)")N
    end do

    If (Search(COUNT_OF_NUMBER)) Then !有解 会改变Number()及Expression()的数据
        write(*,"(a,i0,a)")"Answer:",NUMBER_TO_BE_CAL,"="//Expression(1) !若有多个答案 只会显示其中一个最快的答案
    Else !无解
        write(*,*)"Answer:None"
    End If

    read(*,*)
end program

module hh
    use hi
    implicit none
    !全局变量
    integer::N(COUNT_OF_NUMBER)
    character(64)::str
contains
integer function test()
    implicit none

    integer::i
    integer,save::num=0 !静态变量
    real(real64)::temp
    
    num=num+1 !题目计数
    write(str,"(i0)")num
    !当前题目出牌
    do i=1,COUNT_OF_NUMBER
        !整数转换为浮点数
        Number(i)=real(N(i),real64)
        !整数转换为字符串
        write(Expression(i),"(i0)")N(i)
    end do
    !当前题目计算答案
    If (Search(COUNT_OF_NUMBER)) Then !有解 会改变Number()及Expression()的数据
        str="No."//trim(adjustl(str))//"-Previous Answer:"//Expression(1)
    Else !无解
        str="No."//trim(adjustl(str))//"-Previous Answer:None"
    End If
    !更新下一题出牌
    do i=1,COUNT_OF_NUMBER
        call random_number(temp) !生成随机数[0,1)
        N(i)=int(temp*Number_Scale)+1 !下一题随机出牌[1,Number_Scale]
        !整数转换为浮点数
        Number(i)=real(N(i),real64)
        !整数转换为字符串
        write(Expression(i),"(i0)")N(i)
    end do
    !更新当前题目答案
    CALL window_update@(str) !To check if a window should be updated or closed
    test=1
end function
end module

program main
    use hh
    implicit none

    integer::ans,i
    real(real64)::temp

    str=" "
    N=5 !数组初始值
    call random_seed() !随机种子
    ans=winio@('%ca[24 Points]&') !标题
    ans=winio@('%mn[&File[&Exit]]&','EXIT') !菜单
    ans=winio@('%il&',1,Number_Scale) !限定输入整数范围[1,Number_Scale]
    !第一次出题依次输入4张牌
    do i=1,COUNT_OF_NUMBER
        call random_number(temp) !生成随机数[0,1)
        N(i)=int(temp*Number_Scale)+1 !第一次出题随机出牌[1,Number_Scale]
        ans=winio@('%nl%wdth Card: %rd&',i,N(i)) !输入整数
    end do
    !每单击一次Calculate按钮执行一次子程序test
    ans=winio@('%nl%`^bt[&Calculate]&',test) !按钮
    ans=winio@('%nl%ob%42st%cb',str) !显示答案
end program

module point24
    implicit none
    private

    integer,parameter::DP=selected_real_kind(13) !精度控制
    real(DP),parameter::EPS = 0.000001_DP  !实数相等判断精度
    !递延字符串 无须用trim处理尾部空格问题
    type::string
        private
        character(len=:),allocatable::str
    end type string
    !类
    type,public::T_game24Point
        private
        integer::number_to_be_cal=24 !运算目标值 默认为24
        integer::count_of_number !数组长度 参与运算的数字个数
        real(DP),allocatable::Number(:)   !运算数字数组 必须为浮点数 否则除法运算得不到精确结果
        type(string),allocatable::Expression(:) !运算表达式
    contains
        !公开实例方法
        procedure::setNum !构造方法
        procedure::getExpression !返回答案表达式
        procedure::getGoal !返回运算目标值
        procedure::search !搜索答案
        procedure::free !释放内存
    end type T_game24Point
contains
!24点递归算法。
!思路如下：
!采用遍历的方式，先从数组的N个元素中取出两个数，分别进行四则运算，其结果保存在数组中。该数组变换为N-1个元素
!再以新数组（N-1）个元素重复上述步骤的将上述两数运算结果与剩余数字组成的数组进行上述运算
!直至所有数组元素参与计算，即到最后仅剩1个元素时判断是否有计算结果
!Expression(i)中存放运算表达式，由于最终要计算到1个元素，所以最终表达式总是存放在Expression(1)中
!Number(i)中存放两两运算后的结果，由于最终要计算到1个元素，所以最终结果总是存放在Number(1)中
function AandB(A,sb,B) result(res) !模块方法
    character(*),intent(in)::A,sb,B
    character(len=:),allocatable::res !递延字符串 FTN95暂不支持

    res="(" // A // sb // B // ")"
end function AandB

function getExpression(this) result(res) !实例方法
    class(T_game24Point)::this
    character(len=:),allocatable::res !递延字符串 FTN95暂不支持

    res=this%Expression(1)%str !最终答案的表达式
end function getExpression

function getGoal(this) result(res) !实例方法 返回运算目标值
    class(T_game24Point)::this
    integer::res

    res=this%number_to_be_cal
end function getGoal

subroutine free(this) !实例方法 释放递延字符串及动态数组内存
    class(T_game24Point)::this
    integer::i
    !释放递延字符串内存
    do i=1,this%count_of_number
        deallocate(this%Expression(i)%str)
    end do
    !释放动态数组内存
    deallocate(this%Expression,this%Number)
end subroutine free

subroutine setNum(this,num,goal) !实例方法 用于初始化
    class(T_game24Point)::this
    integer,intent(in)::num(:) !参与运算数组
    integer,intent(in),optional::goal !运算目标值
    character(len=64)::strTemp
    integer::i

    if(present(goal))this%number_to_be_cal=goal !更改运算目标值
    this%count_of_number=size(num) !数组长度
    !分配动态数组内存
    allocate(this%Number(this%count_of_number))
    allocate(this%Expression(this%count_of_number))

    do i=1,this%count_of_number
        this%Number(i)=real(num(i),DP) !整数转换为浮点数 便于除法运算
        write(strTemp,"(i0)")num(i) !整数转换为字符串
        !strTemp必须为定长字符串 F202X标准才支持递延字符串
        this%Expression(i)%str=trim(strTemp) !删除尾部空格
    end do
end subroutine setNum

recursive function Search(this,ns) result(res) !实例方法 返回是否找到答案
    class(T_game24Point)::this
    integer,intent(in),optional::ns !数组元素个数
    logical::res !是否找到答案
    real(DP)::a,b !数组元素临时变量 必须为浮点数 否则除法运算得不到精确结果
    character(len=:),allocatable::Expa,Expb !递延字符串 表达式临时变量
    integer::i,j,n

    if(present(ns))then
        n=ns
    else
        n=this%count_of_number
    end if
    !以下会报错 merge必须计算正反两面 而三元操作符present(ns)?ns:this%count_of_number只需计算一面
    !n=merge(ns,this%count_of_number,present(ns))
    If (n == 1) Then !递归出口
        !.true.找到答案 .false.没有找到答案
        res = Abs(this%Number(1) - this%number_to_be_cal) < EPS

        If (res) Then !找到答案
            i = len(this%Expression(1)%str) - 1 !删除答案最外围左右括号后尾部字符的位置
            this%Expression(1)%str=this%Expression(1)%str(2:i)
        End If

        return
    End If

    res = .true.
    !类似于冒泡法排序 共计C(n,2)种组合 从n个数抽取2个数
    do i = 1, n
        do j = i + 1 , n
            !存放参与计算的两个数至临时变量
            Expa = this%Expression(i)%str !存放表达式
            Expb = this%Expression(j)%str
            a = this%Number(i) !存放数值
            b = this%Number(j)
            !由于每次进行更深入递归都不再生成新数组，而是以数组N-1个元素进行运算，故将最后一个元素放到j位置
            this%Expression(j)%str = this%Expression(n)%str
            this%Number(j) = this%Number(n)
            !表达式赋值，运算结果赋值，进行递归运算
            !运算1 a+b 同b+a
            !i位置存放i和j位置的两个数的运算结果
            this%Expression(i)%str = AandB(Expa , "+" , Expb)
            this%Number(i) = a + b
            !若有运算结果则结束递归
            If (this%Search(n - 1)) Then   !递归在这里
                deallocate(Expa,Expb) !释放递延字符串内存
                return
            End If
            !以下请参考上面
            !运算2 a-b
            !i位置存放i和j位置的两个数的运算结果
            this%Expression(i)%str = AandB(Expa , "-" , Expb)
            this%Number(i) = a - b
            !若有运算结果则结束递归
            If (this%Search(n - 1)) Then
                deallocate(Expa,Expb) !释放递延字符串内存
                return
            End If
            !运算3 b-a
            !i位置存放i和j位置的两个数的运算结果
            this%Expression(i)%str = AandB(Expb , "-" , Expa)
            this%Number(i) = b - a
            !若有运算结果则结束递归
            If (this%Search(n - 1)) Then
                deallocate(Expa,Expb) !释放递延字符串内存
                return
            End If
            !运算4 a*b 同b*a
            !i位置存放i和j位置的两个数的运算结果
            this%Expression(i)%str = AandB(Expa , "*" , Expb)
            this%Number(i) = a * b
            !若有运算结果则结束递归
            If (this%Search(n - 1)) Then
                deallocate(Expa,Expb) !释放递延字符串内存
                return
            End If
            !运算5 a/b
            !i位置存放i和j位置的两个数的运算结果
            If (Abs(b) > EPS) Then !分母不为0
                this%Expression(i)%str = AandB(Expa , "/" , Expb)
                this%Number(i) = a / b !必须为浮点数 否则除法运算得不到精确结果
                !若有运算结果则结束递归
                If (this%Search(n - 1)) Then
                    deallocate(Expa,Expb) !释放递延字符串内存
                    return
                End If
            End If
            !运算6 b/a
            !i位置存放i和j位置的两个数的运算结果
            If (Abs(a) > EPS) Then !分母不为0
                this%Expression(i)%str = AandB(Expb , "/" , Expa)
                this%Number(i) = b / a !必须为浮点数 否则除法运算得不到精确结果
                !若有运算结果则结束递归
                If (this%Search(n - 1)) Then
                    deallocate(Expa,Expb) !释放递延字符串内存
                    return
                End If
            End If
            !若数组取出2个元素的6种运算均没有运算结果,则将数组复原，继续进行循环遍历
            this%Expression(i)%str = Expa
            this%Expression(j)%str = Expb
            this%Number(i) = a
            this%Number(j) = b
        end do
    end do

    res = .False.  !若上述所有组合的6种运算都没有结果，则该数组没有答案
    deallocate(Expa,Expb) !释放递延字符串内存
end function Search
end module point24

program main
    use point24
    implicit none

    integer::i,NN(4)
    type(T_game24Point)::g24

    do
        write(*,*)"依次输入每张牌："
        read(*,*,iostat=i)NN

        if(i/=0)then
            write(*,*)"输入整数数组错误，退出程序！"
            exit
        end if

        call g24%setNum(NN) !初始化

        if(g24%search())then !有解
            write(*,"('Answer:',i0,'=',a)")g24%getGoal(),g24%getExpression()
        else !无解
            write(*,*)"Answer:None"
        end if

        call g24%free() !释放内存
    end do
end program