[其他行业算法] 24点计算程序V2.0（面向对象版）

program main
    use point24
    use dislin
    implicit none

    integer,parameter::COUNT_OF_NUMBER=4 !4张牌
    !牌的数值最大限制 4张牌数值 6个输入文本框
    integer::Number_Scale=13,N(COUNT_OF_NUMBER),itxt(-1:COUNT_OF_NUMBER)
    !不可编辑文本框编号itotal 计算按钮控件编号ical 主界面编号ip
    integer::itotal,ical,ip
    character(64)::temptext !临时变量
    real::temp !随机数 单精度浮点数
    integer::i

    open(10,file="答案.txt") !打开输出文件
    open(11,file="题目.txt") !打开输出文件
    call random_seed() !随机种子
    call swgwth(50) !正数为绝对宽度  负数为相对宽度
    call swgfnt("Courier New",20) !Windows默认等宽字体
    call swgopt('INTEGER', 'VERIFY') !enables a check of input characters in text and table cells. 限定文本框输入只能是整数 可以为负数
    !DIGITS 0-9; INTEGER 0-9,'+','-'
    call swgopt('OK','CLOSE') !将界面右上角关闭窗口设置为OK(退出界面,程序继续执行) 默认为Quit(退出程序)
    call swgpop('NOQUIT') !Exit菜单无Quit子菜单 仅有OK子菜单 避免直接退出程序
    call swgtit("24 Points(Author: Wei Xing)") !界面标题
    call swghlp("Program For Calculating 24 Points|Author: Wei Xing|Email: [email]282844965@qq.com[/email]|Language: Fortran+Dislin11.5|Complier: SimplyFortran3.31") !帮助菜单显示信息
    call wgini('VERT', ip) !界面初始化 垂直布局
    !显示输入的最大限制值
    call wgltxt(ip,"Maximum of Card:","13",30,itxt(-1)) !带标签的文本框 初值13
    !显示运算目标值
    call wgltxt(ip,"Target Number:","24",30,itxt(0)) !带标签的文本框 初值为24 可以设置为负整数
    !显示每张牌
    do i=1,COUNT_OF_NUMBER
        write(temptext,"('No.',i0,' Card:')")i !标签
        call wgltxt(ip,trim(temptext),"",30,itxt(i)) !带标签的文本框 初值为空字符
    end do

    call wgpbut(ip,"Calculate",ical) !按钮控件
    call wgstxt(ip,2,99,itotal) !不可编辑文本框  2代表文本框显示高度占2行 99代表最多保存最近的99行 若超出则删除头部
    call wgok(ip,i) !OK按钮控件 同Exit->OK 退出界面 程序继续运行wgfin之后代码
    !第1次出题依次输入4张牌
    call CardRandom() !随机出牌 Number_Scale为默认值13
    !Number_Scale文本框数值改变后回车执行一次子程序change
    call swgcbk(itxt(-1),change) !文本框驱动子程序
    !单击一次Calculate按钮执行一次子程序calculate
    call swgcbk(ical, calculate) !文本框驱动子程序
    call wgfin !界面结束
    write(10,*)"end" !文件结尾标志 Exit->OK能运行到这里 Exit->Quit和关闭窗口('Quit','CLOSE')均不能运行到这里
    write(11,*)"end"
    close(10) !关闭文件
    close(11)
contains
subroutine calculate(id)
    integer,intent(in)::id !已单击的按钮控件编号
    integer::i,goal
    integer,save::num=1 !静态变量 有解题目序号
    character(64)::ans !题目答案
    type(T_game24Point)::g24

    call gwgint(itxt(-1),Number_Scale) !获取文本框输入整数  用户修改数据  限制牌的范围[1,Number_Scale]

    if(Number_Scale<10)then
        call msgbox("Warning:Maximum of Card must > 9.|Reset it within the correct range.") !弹出错误提示
        call swgfoc(itxt(-1)) !键盘焦点放在出错的文本框上 便于用户重新输入
        return !提前返回 等待用户重新输入 g24对象尚未分配内存
    end if

    write(ans,"(i0)")Number_Scale !整数转换为字符串
    !牌的数据处理顺序为N(i)-->swgint-->文本框字符串(用户可更改)-->gwgint-->N(i)
    !判断当前题目出牌数据是否在限定范围内[1,Number_Scale]
    do i=1,COUNT_OF_NUMBER
        !用户可手动更改文本框数值
        call gwgint(itxt(i),N(i)) !获取文本框输入整数  用户修改数据 牌的数据

        if(N(i)>Number_Scale .or. N(i)<1)then !输入范围限定
            write(temptext,"(i0)")i !出错牌的序号
            call msgbox("Warning:Input Integer must between [1,"//trim(ans)//"] in No."//trim(temptext)//" Card.|Reset it within the correct range.") !弹出错误提示 只会提示第1个错误
            call swgfoc(itxt(i)) !键盘焦点放在出错的文本框上 便于用户重新输入
            return !提前返回 等待用户重新输入 g24对象尚未分配内存
        end if
    end do

    call gwgint(itxt(0),goal) !获取文本框输入整数  用户修改数据 运算目标值Targer Number
    call g24%setNum(N,goal) !对象初始化 分配内存
    write(ans,"(i0)")num !整数转换为字符串 题目序号
    write(temptext,"(i0)")g24%getGoal() !整数转换为字符串 运算目标值
    !当前题目计算答案
    If(g24%Search())Then !有解
        write(11,*)"No."//trim(ans)//" Question:(Target->"//trim(temptext)//")" !题目文件输出题目编号
        write(11,*)"    "//g24%getCard() !题目文件输出题目内容 剔除无解题目
        ans="No."//trim(ans)//" Answer:"//trim(temptext)//"="//g24%getExpression() !屏幕显示答案
        write(10,*)ans !答案文件输出结果 剔除无解题目
        num=num+1 !有解的情况下题目序号才递增
    Else !无解
        ans="No."//trim(ans)//" Answer:None("//trim(temptext)//"/="//g24%getCard()//")" !屏幕显示无解
    End If
    !更新下一题出牌
    call CardRandom() !随机出牌
    !更新当前题目答案
    call swgtxt(itotal, trim(ans)) !文本框改变显示答案  wgstxt不是覆盖而是尾部另起一行增加
    call g24%free() !释放对象内存
end subroutine calculate
!牌的最大值文本框中重新设置数值Number_Scale后按回车  相应更新随机出牌
subroutine change(id)
    integer,intent(in)::id !数据改变的文本框编号

    call gwgint(itxt(-1),Number_Scale) !获取文本框输入整数  用户修改数据  限制牌的范围[1,Number_Scale]

    if(Number_Scale<10)then
        call msgbox("Warning:Maximum of Card must > 9.|Reset it within the correct range.") !弹出错误提示
        call swgfoc(itxt(-1)) !键盘焦点放在出错的文本框上 便于用户重新输入
        return !提前返回 等待用户重新输入 g24对象尚未分配内存
    end if

    call CardRandom() !随机出牌
end subroutine change
!随机出牌并在文本框显示 共3处调用：1主程序第1次出牌、2calculate子程序、3change子程序
subroutine CardRandom()
    integer::i

    do i=1,COUNT_OF_NUMBER
        call random_number(temp) !生成随机数[0,1) 单精度浮点数
        N(i)=int(temp*Number_Scale)+1 !下一题随机出牌[1,Number_Scale]
        !对象初始化发生在单击Calculate按钮后  没有必要在这里确定
        call swgint(itxt(i), N(i)) !文本框更新显示整数 程序修改数据 牌的数值
    end do
end subroutine CardRandom
end program

module point24
    implicit none
    private

    integer,parameter,public::DP=selected_real_kind(13) !精度控制
    real(DP),parameter::EPS = 0.000001_DP  !实数相等判断精度
    !处理递延字符串数组
    type::string
        private
        character(len=:),allocatable::str !递延字符串 无须用trim处理尾部空格问题
    end type string
    !类
    type,public::T_game24Point
        private !私有实例变量
        integer::number_to_be_cal=24 !运算目标值 默认为24
        integer::count_of_number !数组长度 参与运算的数字个数 由主程序中数组N的长度确定
        real(DP),allocatable::Number(:)   !运算数字数组 必须为浮点数 否则除法运算得不到精确结果
        type(string),allocatable::Expression(:) !运算表达式
        character(len=:),allocatable::cardArray !所有牌数据的字符串 4个空格间隔
    contains
        !公开实例方法
        procedure::setNum !构造方法 传入数组N(:)和运算目标值goal
        procedure::getExpression !返回答案表达式
        procedure::getGoal !返回运算目标值
        procedure::getCard !返回所有牌数据字符串
        procedure::search !搜索答案 true有解 false无解
        procedure::free !释放内存
    end type T_game24Point
contains
!24点递归算法。
!思路如下：
!采用遍历的方式，先从数组的N个元素中取出两个数，分别进行四则运算，其结果保存在数组中。该数组变换为N-1个元素
!再以新数组(N-1)个元素重复上述步骤的将上述两数运算结果与剩余数字组成的数组进行上述运算
!直至所有数组元素参与计算，即到最后仅剩1个元素时判断是否有计算结果
!Expression(i)中存放运算表达式，由于最终要计算到1个元素，所以最终表达式总是存放在Expression(1)中
!Number(i)中存放两两运算后的结果，由于最终要计算到1个元素，所以最终结果总是存放在Number(1)中
pure 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

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

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

pure function getGoal(this) result(res) !实例方法 返回运算目标值
    class(T_game24Point),intent(in)::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,this%cardArray)
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
    !整数数组转换为字符串
    write(strTemp,"(i0,*(4x,i0))")num !*自动匹配个数 4个空格间隔
    this%cardArray=trim(strTemp) !递延字符串分配内存
end subroutine setNum

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

    res=this%cardArray !全部牌数据字符串 4个空格间隔
end function getCard

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
            !若N-1个元素有解则结束递归
            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
            !若N-1个元素有解则结束递归
            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
            !若N-1个元素有解则结束递归
            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
            !若N-1个元素有解则结束递归
            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 !必须为浮点数 否则除法运算得不到精确结果
                !若N-1个元素有解则结束递归
                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 !必须为浮点数 否则除法运算得不到精确结果
                !若N-1个元素有解则结束递归
                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.  !若上述所有组合(N个数随机抽取2个数)的6种运算都均无解，则该数组无解
    deallocate(Expa,Expb) !释放递延字符串内存
end function Search
end module point24