[Fortran] 纯文本查看 复制代码

查看代码

打印?

001	module point24

002	implicit none

003

private

004

005	integer,parameter,public::DP=selected_real_kind(13) !精度控制

006	real(DP),parameter::EPS = 0.000001_DP  !实数相等判断精度

007	!处理递延字符串数组

008	type::string

009

private

010	character(len=:),allocatable::str !递延字符串 无须用trim处理尾部空格问题

011	end type string

012

!类

013	type,public::T_game24Point

014	private !私有实例变量

015	integer::number_to_be_cal=24 !运算目标值 默认为24

016	integer::count_of_number !数组长度 参与运算的数字个数 由主程序中数组N的长度确定

017	real(DP),allocatable::Number(:)   !运算数字数组 必须为浮点数 否则除法运算得不到精确结果

018	type(string),allocatable::Expression(:) !运算表达式

019	character(len=:),allocatable::cardArray !所有牌数据的字符串 4个空格间隔

020

contains

021

!公开实例方法

022	procedure::setNum !构造方法 传入数组N(:)和运算目标值goal

023	procedure::getExpression !返回答案表达式

024	procedure::getGoal !返回运算目标值

025	procedure::getCard !返回所有牌数据字符串

026	procedure::search !搜索答案 true有解 false无解

027	procedure::free !释放内存

028	end type T_game24Point

029

contains

030

!24点递归算法。

031

!思路如下：

032	!采用遍历的方式，先从数组的N个元素中取出两个数，分别进行四则运算，其结果保存在数组中。该数组变换为N-1个元素

033	!再以新数组(N-1)个元素重复上述步骤的将上述两数运算结果与剩余数字组成的数组进行上述运算

034	!直至所有数组元素参与计算，即到最后仅剩1个元素时判断是否有计算结果

035	!Expression(i)中存放运算表达式，由于最终要计算到1个元素，所以最终表达式总是存放在Expression(1)中

036	!Number(i)中存放两两运算后的结果，由于最终要计算到1个元素，所以最终结果总是存放在Number(1)中

037	pure function AandB(A,sb,B) result(res) !模块方法

038	character(*),intent(in)::A,sb,B

039	character(len=:),allocatable::res !递延字符串 FTN95暂不支持

040

041	res="(" // A // sb // B // ")"

042	end function AandB

043

044	pure function getExpression(this) result(res) !实例方法

045	class(T_game24Point),intent(in)::this

046	character(len=:),allocatable::res !递延字符串 FTN95暂不支持

047

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

049	end function getExpression

050

051	pure function getGoal(this) result(res) !实例方法 返回运算目标值

052	class(T_game24Point),intent(in)::this

053	integer::res

054

055	res=this%number_to_be_cal

056	end function getGoal

057

058	subroutine free(this) !实例方法 释放递延字符串及动态数组内存

059	class(T_game24Point)::this

060	integer::i

061	!释放递延字符串内存

062	do i=1,this%count_of_number

063	deallocate(this%Expression(i)%str)

064

end do

065

!释放动态数组内存

066	deallocate(this%Expression,this%Number,this%cardArray)

067	end subroutine free

068

069	subroutine setNum(this,num,goal) !实例方法 用于初始化

070	class(T_game24Point)::this

071	integer,intent(in)::num(:) !参与运算数组

072	integer,intent(in),optional::goal !运算目标值

073	character(len=64)::strTemp

074	integer::i

075

076	if(present(goal))this%number_to_be_cal=goal !更改运算目标值

077	this%count_of_number=size(num) !一维数组长度

078

!分配动态数组内存

079	allocate(this%Number(this%count_of_number))

080	allocate(this%Expression(this%count_of_number))

081

082	do i=1,this%count_of_number

083	this%Number(i)=real(num(i),DP) !整数转换为浮点数 便于除法运算

084	write(strTemp,"(i0)")num(i) !整数转换为字符串

085	!strTemp必须为定长字符串 F202X标准才支持递延字符串

086	this%Expression(i)%str=trim(strTemp) !删除尾部空格 递延字符串分配内存

087

end do

088	!整数数组转换为字符串

089	write(strTemp,"(i0,*(4x,i0))")num !*自动匹配个数 4个空格间隔

090	this%cardArray=trim(strTemp) !递延字符串分配内存

091	end subroutine setNum

092

093	pure function getCard(this) result(res) !实例方法

094	class(T_game24Point),intent(in)::this

095	character(len=:),allocatable::res !递延字符串 FTN95暂不支持

096

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

098	end function getCard

099

100	recursive function Search(this,ns) result(res) !实例方法 返回是否有解

101	class(T_game24Point)::this

102	integer,intent(in),optional::ns !数组元素个数

103	logical::res !是否有解

104	real(DP)::a,b !数组元素临时变量 必须为浮点数 否则除法运算得不到精确结果

105	character(len=:),allocatable::Expa,Expb !递延字符串 表达式临时变量

106	integer::i,j,n

107

108	if(present(ns))then

109	n=ns !递归时使用

110

else

111	n=this%count_of_number !主程序使用 默认为牌张数

112

end if

113	!以下会报错 merge必须计算正反两面 而三元操作符present(ns)?ns:this%count_of_number只需计算一面

114	!n=merge(ns,this%count_of_number,present(ns))

115	If (n == 1) Then !递归出口

116	!.true.有解 .false.无解

117	res = Abs(this%Number(1) - this%number_to_be_cal) < EPS

118

119	If (res) Then !有解

120	i = len(this%Expression(1)%str) - 1 !删除答案最外围左右括号后尾部字符的位置

121	this%Expression(1)%str=this%Expression(1)%str(2:i)

122

End If

123

124

return

125

End If

126

127	res = .true. !假定有解

128	!类似于冒泡法排序 共计C(n,2)种组合 从n个数抽取2个数

129	do i = 1, n

130	do j = i + 1 , n

131	!存放参与计算的两个数至临时变量

132	Expa = this%Expression(i)%str !存放表达式

133	Expb = this%Expression(j)%str

134	a = this%Number(i) !存放数值

135	b = this%Number(j)

136	!由于每次进行更深入递归都不再生成新数组，而是以数组N-1个元素进行运算，故将最后一个元素放到j位置

137	this%Expression(j)%str = this%Expression(n)%str

138	this%Number(j) = this%Number(n)

139	!表达式赋值，运算结果赋值，进行递归运算

140	!运算1 a+b 同b+a

141	!i位置存放i和j位置的两个数的运算结果

142	this%Expression(i)%str = AandB(Expa , "+" , Expb)

143	this%Number(i) = a + b

144	!若N-1个元素有解则结束递归

145	If (this%Search(n - 1)) Then   !递归在这里

146	deallocate(Expa,Expb) !释放递延字符串内存

147

return

148

End If

149

!以下请参考上面

150

!运算2 a-b

151	!i位置存放i和j位置的两个数的运算结果

152	this%Expression(i)%str = AandB(Expa , "-" , Expb)

153	this%Number(i) = a - b

154	!若N-1个元素有解则结束递归

155	If (this%Search(n - 1)) Then

156	deallocate(Expa,Expb) !释放递延字符串内存

157

return

158

End If

159

!运算3 b-a

160	!i位置存放i和j位置的两个数的运算结果

161	this%Expression(i)%str = AandB(Expb , "-" , Expa)

162	this%Number(i) = b - a

163	!若N-1个元素有解则结束递归

164	If (this%Search(n - 1)) Then

165	deallocate(Expa,Expb) !释放递延字符串内存

166

return

167

End If

168	!运算4 a*b 同b*a

169	!i位置存放i和j位置的两个数的运算结果

170	this%Expression(i)%str = AandB(Expa , "*" , Expb)

171	this%Number(i) = a * b

172	!若N-1个元素有解则结束递归

173	If (this%Search(n - 1)) Then

174	deallocate(Expa,Expb) !释放递延字符串内存

175

return

176

End If

177

!运算5 a/b

178	!i位置存放i和j位置的两个数的运算结果

179	If (Abs(b) > EPS) Then !分母不为0

180	this%Expression(i)%str = AandB(Expa , "/" , Expb)

181	this%Number(i) = a / b !必须为浮点数 否则除法运算得不到精确结果

182	!若N-1个元素有解则结束递归

183	If (this%Search(n - 1)) Then

184	deallocate(Expa,Expb) !释放递延字符串内存

185

return

186

End If

187

End If

188

!运算6 b/a

189	!i位置存放i和j位置的两个数的运算结果

190	If (Abs(a) > EPS) Then !分母不为0

191	this%Expression(i)%str = AandB(Expb , "/" , Expa)

192	this%Number(i) = b / a !必须为浮点数 否则除法运算得不到精确结果

193	!若N-1个元素有解则结束递归

194	If (this%Search(n - 1)) Then

195	deallocate(Expa,Expb) !释放递延字符串内存

196

return

197

End If

198

End If

199	!若数组取出2个元素的6种运算均无解,则将数组复原，继续进行循环遍历

200	this%Expression(i)%str = Expa

201	this%Expression(j)%str = Expb

202	this%Number(i) = a

203	this%Number(j) = b

204

end do

205

end do

206

207	res = .false.  !若上述所有组合(N个数随机抽取2个数)的6种运算都均无解，则该数组无解

208	deallocate(Expa,Expb) !释放递延字符串内存

209	end function Search

210	end module point24

[Fortran] 纯文本查看 复制代码

查看代码

打印?

001	program main

002	use point24

003	use dislin

004	implicit none

005

006	integer,parameter::COUNT_OF_NUMBER=4 !4张牌

007	!牌的数值最大限制 4张牌数值 6个输入文本框

008	integer::Number_Scale=13,N(COUNT_OF_NUMBER),itxt(-1:COUNT_OF_NUMBER)

009	!不可编辑文本框编号itotal 计算按钮控件编号ical 主界面编号ip

010	integer::itotal,ical,ip

011	character(64)::temptext !临时变量

012	real::temp !随机数 单精度浮点数

013	integer::i

014

015	open(10,file="答案.txt") !打开输出文件

016	open(11,file="题目.txt") !打开输出文件

017	call random_seed() !随机种子

018	call swgwth(50) !正数为绝对宽度  负数为相对宽度

019	call swgfnt("Courier New",20) !Windows默认等宽字体

020	call swgopt('INTEGER', 'VERIFY') !enables a check of input characters in text and table cells. 限定文本框输入只能是整数 可以为负数

021	!DIGITS 0-9; INTEGER 0-9,'+','-'

022	call swgopt('OK','CLOSE') !将界面右上角关闭窗口设置为OK(退出界面,程序继续执行) 默认为Quit(退出程序)

023	call swgpop('NOQUIT') !Exit菜单无Quit子菜单 仅有OK子菜单 避免直接退出程序

024	call swgtit("24 Points(Author: Wei Xing)") !界面标题

025	call swghlp("Program For Calculating 24 Points|Author: Wei Xing|Email: [email]282844965@qq.com[/email]|Language: Fortran+Dislin11.5|Complier: SimplyFortran3.31") !帮助菜单显示信息

026	call wgini('VERT', ip) !界面初始化 垂直布局

027	!显示输入的最大限制值

028	call wgltxt(ip,"Maximum of Card:","13",30,itxt(-1)) !带标签的文本框 初值13

029

!显示运算目标值

030	call wgltxt(ip,"Target Number:","24",30,itxt(0)) !带标签的文本框 初值为24 可以设置为负整数

031

!显示每张牌

032	do i=1,COUNT_OF_NUMBER

033	write(temptext,"('No.',i0,' Card:')")i !标签

034	call wgltxt(ip,trim(temptext),"",30,itxt(i)) !带标签的文本框 初值为空字符

035

end do

036

037	call wgpbut(ip,"Calculate",ical) !按钮控件

038	call wgstxt(ip,2,99,itotal) !不可编辑文本框  2代表文本框显示高度占2行 99代表最多保存最近的99行 若超出则删除头部

039	call wgok(ip,i) !OK按钮控件 同Exit->OK 退出界面 程序继续运行wgfin之后代码

040	!第1次出题依次输入4张牌

041	call CardRandom() !随机出牌 Number_Scale为默认值13

042	!Number_Scale文本框数值改变后回车执行一次子程序change

043	call swgcbk(itxt(-1),change) !文本框驱动子程序

044	!单击一次Calculate按钮执行一次子程序calculate

045	call swgcbk(ical, calculate) !文本框驱动子程序

046	call wgfin !界面结束

047	write(10,*)"end" !文件结尾标志 Exit->OK能运行到这里 Exit->Quit和关闭窗口('Quit','CLOSE')均不能运行到这里

048	write(11,*)"end"

049	close(10) !关闭文件

050

close(11)

051

contains

052	subroutine calculate(id)

053	integer,intent(in)::id !已单击的按钮控件编号

054	integer::i,goal

055	integer,save::num=1 !静态变量 有解题目序号

056	character(64)::ans !题目答案

057	type(T_game24Point)::g24

058

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

060

061	if(Number_Scale<10)then

062	call msgbox("Warning:Maximum of Card must > 9.|Reset it within the correct range.") !弹出错误提示

063	call swgfoc(itxt(-1)) !键盘焦点放在出错的文本框上 便于用户重新输入

064	return !提前返回 等待用户重新输入 g24对象尚未分配内存

065

end if

066

067	write(ans,"(i0)")Number_Scale !整数转换为字符串

068	!牌的数据处理顺序为N(i)-->swgint-->文本框字符串(用户可更改)-->gwgint-->N(i)

069	!判断当前题目出牌数据是否在限定范围内[1,Number_Scale]

070	do i=1,COUNT_OF_NUMBER

071	!用户可手动更改文本框数值

072	call gwgint(itxt(i),N(i)) !获取文本框输入整数  用户修改数据 牌的数据

073

074	if(N(i)>Number_Scale .or. N(i)<1)then !输入范围限定

075	write(temptext,"(i0)")i !出错牌的序号

076	call msgbox("Warning:Input Integer must between [1,"//trim(ans)//"] in No."//trim(temptext)//" Card.|Reset it within the correct range.") !弹出错误提示 只会提示第1个错误

077	call swgfoc(itxt(i)) !键盘焦点放在出错的文本框上 便于用户重新输入

078	return !提前返回 等待用户重新输入 g24对象尚未分配内存

079

end if

080

end do

081

082	call gwgint(itxt(0),goal) !获取文本框输入整数  用户修改数据 运算目标值Targer Number

083	call g24%setNum(N,goal) !对象初始化 分配内存

084	write(ans,"(i0)")num !整数转换为字符串 题目序号

085	write(temptext,"(i0)")g24%getGoal() !整数转换为字符串 运算目标值

086

!当前题目计算答案

087	If(g24%Search())Then !有解

088	write(11,*)"No."//trim(ans)//" Question:(Target->"//trim(temptext)//")" !题目文件输出题目编号

089	write(11,*)"    "//g24%getCard() !题目文件输出题目内容 剔除无解题目

090	ans="No."//trim(ans)//" Answer:"//trim(temptext)//"="//g24%getExpression() !屏幕显示答案

091	write(10,*)ans !答案文件输出结果 剔除无解题目

092	num=num+1 !有解的情况下题目序号才递增

093

Else !无解

094	ans="No."//trim(ans)//" Answer:None("//trim(temptext)//"/="//g24%getCard()//")" !屏幕显示无解

095

End If

096

!更新下一题出牌

097	call CardRandom() !随机出牌

098

!更新当前题目答案

099	call swgtxt(itotal, trim(ans)) !文本框改变显示答案  wgstxt不是覆盖而是尾部另起一行增加

100	call g24%free() !释放对象内存

101	end subroutine calculate

102	!牌的最大值文本框中重新设置数值Number_Scale后按回车  相应更新随机出牌

103	subroutine change(id)

104	integer,intent(in)::id !数据改变的文本框编号

105

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

107

108	if(Number_Scale<10)then

109	call msgbox("Warning:Maximum of Card must > 9.|Reset it within the correct range.") !弹出错误提示

110	call swgfoc(itxt(-1)) !键盘焦点放在出错的文本框上 便于用户重新输入

111	return !提前返回 等待用户重新输入 g24对象尚未分配内存

112

end if

113

114	call CardRandom() !随机出牌

115	end subroutine change

116	!随机出牌并在文本框显示 共3处调用：1主程序第1次出牌、2calculate子程序、3change子程序

117	subroutine CardRandom()

118	integer::i

119

120	do i=1,COUNT_OF_NUMBER

121	call random_number(temp) !生成随机数[0,1) 单精度浮点数

122	N(i)=int(temp*Number_Scale)+1 !下一题随机出牌[1,Number_Scale]

123	!对象初始化发生在单击Calculate按钮后  没有必要在这里确定

124	call swgint(itxt(i), N(i)) !文本框更新显示整数 程序修改数据 牌的数值

125

end do

126	end subroutine CardRandom

127	end program