玩转f#的一个实例——解拼图游戏
起因
起因是这样的:前一阵逛抖音,买了个预售的拼图游戏。据说是国内团队开发的,非常有趣。大概长这样:
拼图设计上故意空出三个空位,拼图的格子上印有1-12月的月份,1-31号的日期,以及周一到周日的星期。空出的三个空位,可以正好用来匹配月份-日期-星期的组合。这个可以使得你每天都可以有一道新的谜题可玩,好几年都不带重样的。
可是呢,这是个预售商品,大概研发团队找的生产厂商生产力不足吧。下单后要一个半月才发货。实属令人抓腮。
正好最近在折腾F#,干脆我来验证下是不是每种情况都有解吧。
于是,开工。
思路
暂时不需要太复杂的算法,就用最简单的DFS就可以了。
我们从左到右,从上到下搜索棋盘格,只要这个格子应放但未放入积木,我们就尝试放一个形状进去,然后继续搜索。如果无法放入我们就继续试其他形状。如果所有积木的所有形状都试过了我们就回溯。这样可以保证了搜索到某个点时,它之前的所有行、它同一行左侧的所有点都已经填满了积木。只需要搜完整个地图,说明全部积木都放进去了。
因为是函数式编程,上述的过程也被转换成了递归。
具体步骤:
- 将积木保存为大小仅为长*宽的点阵,有木头的为1,空白的为0。并把积木编上从0到10的号。
- 针对每个积木,通过旋转、翻转,产生出它的所有的变形形状,并且剔除重复的形状,作为该积木应该尝试的所有形状列表。每个形状记录第一行最左侧那块积木的位置(相对当前积木区域的x坐标)。后面的搜索要用到。
- 地图抽象为7行6列的矩阵。不可达的区域定义为-100,需要空出来的月份、日期、星期三个格子定义为100,未放置任何积木的定义为-1,放置了积木的格子记录为这个积木的编号(0-10)
- 针对棋盘开始搜索,从(0,0)处依次向右、向下搜索。注意这里的坐标采取(x,y)形式,也就是列在前,行在后。
- 遇到已经放入积木、不可达区域、需要空出来的格子则直接跳过,递归搜索下一个点。
- 遇到空白格子(为-1的格子)则针对该点遍历所有积木的所有形状。将该形状的第一行的最左侧积木块放置于此格子,并判断是否能放进该形状。如果形状能放入则放入,并继续递归,在尝试下一个形状之前删除该形状。如果无法放入,则不进行递归。
- 当搜索到达(3,6)格子时,意味着找到了一个解。此时可以选择继续搜索找出所有解,或者退出搜索完成任务。(两种我都试了,解法真的很多很多,本文只讲取一种解的情况)
那么,开工
准备工作
定义形状、积木
这里采用记录:
//积木变形形状
type Shape =
{ X: int //最大x坐标,而非length
Y: int //最大y坐标,而非length
Offset: int
Map: int[,] }
//积木单元
type Piece =
{ Shapes: list<Shape> }
生成积木
做一个积木的形状生成器,这样可以方便积木形状的生成:
- 单个积木根据有木头的点坐标自动生成积木的基本形状的map。
- 进行旋转获取4个形状,然后翻转后再旋转获取4个形状
- 对8种形状做去重
- 针对所有积木执行上述步骤,生成所有积木
//根据提供的占位坐标点序列,生成所有积木单元,并计算全部不重复的形状
let genPieces (piecesDesc: seq<seq<int * int>>) =
//生成一个积木单元
let genPiece (arr: seq<int * int>) =
//根据基础形状,生成所有不重复形状
let genAvailabeShapes shape =
//变形,f为目的地元素函数
let transShape shape f =
let cur = Array2D.create (shape.Y + 1) (shape.X + 1) 0 //(x,y)格式,先列后行
for y in 0 .. shape.X do //行列互换
for x in 0 .. shape.Y do
cur[x, y] <- f shape x y //注意,行列互换了
//取第一行的偏移
let offset =
seq { 0 .. shape.Y } //注意,列长变成了原来的行长度
|> Seq.pick (fun x ->
if cur[x, 0] = 1 then
Some x
else
None)
{ Map = cur
X = shape.Y
Y = shape.X
Offset = offset }
//旋转变形(顺时针,因此行列互换)
let rotateShape shape =
transShape shape (fun shape x y -> shape.Map[shape.X - y, x])
//翻转变形(左上、右下对角线,因此仍然是行列互换)
let turnOverShape shape =
transShape shape (fun shape x y -> shape.Map[y, x])
//重复旋转获取四种情况(含未旋转)
let getRotateShapes4 shape =
let rec rotateLoop shape n = //4、3、2、1,尾递归
match n with
| 0 -> []
| _ -> shape :: rotateLoop (rotateShape shape) (n - 1)
rotateLoop shape 4
//旋转、翻转获取变形列表
let rotatedShapes = getRotateShapes4 shape //旋转的4个形状
let turnedOverShape = turnOverShape shape //翻转形状
let turnedOverRotatedShapes = getRotateShapes4 turnedOverShape //基于翻转旋转的4个形状
let allShapes = List.append rotatedShapes turnedOverRotatedShapes //拼接全部8个形状
//去重作为结果,顺序会反过来,无所谓
allShapes
|> Seq.fold (fun next shape ->
let hasEqual =
next
|> Seq.exists(fun av -> shapeEqual av shape)
if hasEqual then next else shape :: next) []
//|> List.rev //如果不高兴,可以再正过来
//初始化
let maxX = Seq.map (fun (x, _) -> x) arr |> Seq.max
let maxY = Seq.map (fun (_, y) -> y) arr |> Seq.max
let cur = Array2D.create (maxX + 1) (maxY + 1) 0 //(x,y)格式,先列后行
//根据参数填充格子
Seq.iter (fun (x, y) -> cur[x, y] <- 1) arr
//取第一行的偏移
let offset =
seq { 0 .. maxX }
|> Seq.pick (fun x ->
if cur[x, 0] = 1 then Some x
else None)
//基础形状
let shape =
{ X = maxX
Y = maxY
Offset = offset //用于判断
Map = cur }
//计算本积木的所有可用变形并返回为一个Piece
{ Shapes = genAvailabeShapes shape }
//根据参数生成所有积木,块数越多的越早测试,有效剪枝
Seq.map (fun pieceDesc -> genPiece pieceDesc) piecesDesc
//先按照形状的多少预排(感觉用处不大)
|> Seq.sortByDescending (fun piece -> piece.Shapes.Length)
//再按照块的大小排序(后一次排序为主排序,因为sort是稳定排序,所以前一次排序会作为副排序)
|> Seq.sortByDescending (fun piece ->
seq {
for y in 0 .. piece.Shapes[0].Y do
for x in 0 .. piece.Shapes[0].X -> piece.Shapes[0].Map[x, y]
}
|> Seq.sum)
|> Array.ofSeq //采用数组,使得索引器效率变为O(1)
然后利用生成器生成全部积木:
//根据实际情况,生成积木
let pieces = genPieces [
[ (0, 0); (0, 1); (1, 1); (2, 1); (2, 0) ]
[ (0, 0); (0, 1); (1, 1) ]
[ (0, 0); (0, 1); (1, 0); (2, 0) ]
[ (0, 0); (0, 1); (0, 2); (1, 0); (1, 1) ]
[ (0, 0); (0, 1); (1, 0); (1, 1) ]
[ (0, 0); (0, 1); (0, 2); (0, 3); (1, 1) ]
[ (0, 0); (0, 1); (0, 2); (0, 3); ]
[ (0, 0); (0, 1); (0, 2); (0, 3); (1, 0) ]
[ (0, 0); (0, 1); (0, 2); (1, 0); (2, 0) ]
[ (0, 0); (1, 0); (1, 1); (2, 1) ]
[ (0, 0); (1, 0); (2, 0); (1, 1) ]
]
验证生成的积木
为了确保积木生成正确,我们简单打印一下所有积木的所有形状:
//测试函数,打印生成的积木形状
let printPieces () =
for piece in pieces do
printfn ""
for shape in piece.Shapes do
for y in 0 .. shape.Y do
for x in 0 .. shape.X do
if shape.Map[x, y] = 1 then printf "* "
else printf " "
printfn ""
printfn ""
printfn "==============="
printfn ""
printPieces ()
结果如下:
*
* *
* *
* *
* * *
* *
* *
*
* * *
* *
* *
* * *
*
* *
* *
* * *
* *
* *
* *
*
===============
*
*
* *
*
*
* * * *
*
* *
*
*
* * * *
*
*
* * * *
*
*
* *
*
* * * *
*
*
* *
*
*
===============
*
*
*
* *
*
* * * *
* *
*
*
*
* * * *
*
*
* * * *
*
*
*
* *
* * * *
*
* *
*
*
*
===============
* *
*
* *
* * *
* *
* *
*
* *
* *
* * *
===============
*
*
* * *
*
*
* * *
* * *
*
*
* * *
*
*
===============
*
* * *
*
*
* *
* * *
*
* *
*
*
*
*
* *
*
* * *
* *
*
*
* * *
*
===============
* *
* *
*
* *
*
*
* *
*
* *
* *
===============
*
* *
*
*
* * *
*
* *
*
* * *
*
===============
* * * *
*
*
*
*
===============
* *
* *
===============
*
* *
* *
*
* *
*
*
* *
===============
非常GOOD。
求解
求解函数
按照之前的算法,写出求解函数
let solve month day weekday print =
//计算位置坐标
let blankPos (month, day, weekday) =
//计算星期坐标
let weekdayPos weekdayZB =
if weekdayZB < 3 then 1 + weekdayZB, 0
else weekdayZB - 3, 1
//计算月份坐标
let monthPos monthZB =
4 + monthZB % 4, monthZB / 4
//计算日期坐标
let dayPos dayZB =
match dayZB with
| 0 | 1 | 2 | 3 -> dayZB, 2
| _ -> (dayZB - 4) % 8, 3 + (dayZB - 4) / 8
monthPos (month - 1), dayPos (day - 1), weekdayPos (weekday - 1)
let monthPos, dayPos, weekdayPos = blankPos (month, day, weekday)
//搜索时用的map
let map = Array2D.create 8 7 -1 //(x,y)格式,先列后行
//赋初值
seq { 3 .. 7 } |> Seq.iter (fun i -> map[i, 6] <- -100) //-100为地图黑域
map[fst monthPos, snd monthPos] <- 100 //100为空出位置
map[fst dayPos, snd dayPos] <- 100
map[fst weekdayPos, snd weekdayPos] <- 100
//搜索时记录积木是否已经使用的map,为了效率,元素作为变量参与算法
let pieceUsed = Array.create pieces.Length false
//打印解
let printMap () =
let showChar d =
match d with
| -100 | 100 -> ' '
| -1 -> '_' //打印中间过程时用于测试
| d -> "*#+&@$%08oD"[d] //积木打印字符集
printfn ""
for y in 0..6 do
for x in 0..7 do
printf "%c " (showChar map.[x, y])
printfn ""
printfn ""
//尝试填充shape,若失败撤销填充,若成功标记used为true
let tryShape i shape x y =
//排除出界情况
if x - shape.Offset < 0 then false
elif x - shape.Offset + shape.X > 7 then false
elif y + shape.Y > 6 then false
else
let rec tryShapeRec i shape xLoop yLoop =
match xLoop, yLoop with
| _, -1 -> true
| -1, _ -> tryShapeRec i shape shape.X (yLoop - 1)
| _ ->
//x为当前测试map位置,它减去offset是当前图形起始位置, loopx为循环遍历当前图形小坐标。 y同理
let xIndex, yIndex = x - shape.Offset + xLoop, y + yLoop
if shape.Map[xLoop, yLoop] <> 1 then tryShapeRec i shape (xLoop - 1) yLoop
elif map[xIndex, yIndex] <> -1 then false
else
map[xIndex, yIndex] <- i
let rsl = tryShapeRec i shape (xLoop - 1) yLoop
if not rsl then map[xIndex, yIndex] <- -1
rsl
let rsl = tryShapeRec i shape shape.X shape.Y
if rsl then pieceUsed[i] <- true
rsl
//回滚填充的shape
let eraseShape i shape x y =
for yLoop in 0 .. shape.Y do
for xLoop in 0 .. shape.X do
if shape.Map[xLoop, yLoop] = 1 then
map[x - shape.Offset + xLoop, y + yLoop] <- -1
pieceUsed[i] <- false
//主过程,逐级递归
let rec solveLoop x y =
match (x, y) with
| 3, 6 ->
if print then printMap ();
true
| _ ->
if map[x, y] <> -1 then //已经填充
solveLoop ((x + 1) % 8) (y + ((x + 1) / 8))
else //尝试填充
seq { 0..10 }
|> Seq.exists(fun i ->
if not pieceUsed[i] then
pieces[i].Shapes
|> List.exists (fun shape ->
if tryShape i shape x y then
//printMap () //测试,打印中间过程
let nextRsl = solveLoop ((x + 1) % 8) (y + ((x + 1) / 8))
if nextRsl then true
else eraseShape i shape x y; false
else false)
else false)
//printMap () //测试用,打印初始map
//调用
solveLoop 0 0
执行
考虑两种模式:
- 根据用户输入的月份、日期、星期求出这种情况的解。
- 自动计算所有月份、日期、星期组合的所有情况,验证每种情况的解。
以上两种我们都实现一下,通过用户输入选择不同模式。并且加入容错机制:
open System
open System.Linq
printfn "模式:"
printfn "1) 根据输入求解"
printfn "2) 验证所有组合有解"
printf "请选择:"
let choose = Console.ReadLine().Trim()
printfn ""
match choose with
| "1" ->
while true do //反复求解
printf "输入 月份、日期、星期:"
try
let month, day, weekday =
Console.ReadLine().Trim().Split([| ' '; '\t' |]).Where(fun x -> not (String.IsNullOrEmpty(x)))
|> (fun x ->
if x.Count() = 3 then
int (Seq.item 0 x), int (Seq.item 1 x), int (Seq.item 2 x)
else
failwith "")
if
month < 1 ||
month > 12 ||
day < 1 ||
day > 31 ||
weekday < 1 ||
weekday > 7 then failwith ""
printfn ""
printfn "=== %02d.%02d-%d ===" month day weekday
//解决问题
let solved = solve month day weekday true
if not solved then printfn "此题无解"
printfn "==============="
printfn ""
with ex -> //容错,输入有误
printfn "";
printfn "输入有误,请重新输入!";
printfn ""
| "2" ->
//会在遇到第一个无解情况后终止
let allAv =
seq { 1..12 }
|> Seq.tryPick (fun month ->
seq { 1..31 }
|> Seq.tryPick (fun day ->
seq { 1..7 }
|> Seq.tryPick(fun weekday ->
if solve month day weekday false then None
else Some (month, day, weekday))))
match allAv with
| Some (month, day, weekday) -> printfn "%02d.%02d-%d 无解!" month day weekday
| _ -> printfn "恭喜!测试通过,全部有解!"
| _ -> printfn "输入有误,退出程序!"
代码码完了。
随便测试一个:
- 月份:8
- 日期:16
- 星期:三
=== 08.16-3 ===
* * # + + o o
* # # 8 + o o
* * D 8 + & & &
$ D D 8 8 8 & &
$ $ D 0 0 0 0
$ @ @ % % % % 0
$ @ @
===============
再测试一个:
- 月份:12
- 日期:31
- 星期:日
=== 12.31-7 ===
* * # + + + & &
* # # $ + & &
* * $ $ $ $ &
% 0 0 0 0 @ @ 8
% D o o 0 @ @ 8
% D D o o 8 8 8
% D
===============
随后,我测试了下用不同的积木组合来求解,只需要修改genPieces
的参数即可。很是有趣。
最后看下效率,在编译为Release的情况下:
- 针对特定月份、日期、星期,算出一个解来,肉眼难以分辨延迟。
- 针对特定月份、日期、星期,算出所有解的数量,大约需要3秒。
- 针对所有的月份、日期、星期的组合,成功验证每一种至少有一个解的,总用时大约需要3秒。
- 针对所有的月份、日期、星期的组合,验证至少有一种组合不满足,大约也是3秒。(目前遇到的情况如此,不过这个可能有弹性)
OK。等玩具到了,想不出来解的时候,至少有个工具能用了。
PS: 完整代码已发布在Github上。
最新更新
代码已重写,现在支持自定义的map和piece。因此可以适用于大部分拼图场景。顺带实现了一个从命令行参数读取解析参数的模块,已上传Github。