玩转f#的一个实例——拼图游戏
起因
起因是这样的：前一阵逛抖音，买了个预售的拼图游戏。据说是国内团队开发的，非常有趣。大概长这样：
拼图设计上故意空出三个空位，拼图的格子上印有1-12月的月份，1-31号的日期，以及周一到周日的星期。空出的三个空位，可以正好用来匹配月份-日期-星期的组合。这个可以使得你每天都可以有一道新的谜题可玩，好几年都不带重样的。
可是呢，这是个预售商品，大概研发团队找的生产厂商生产力不足吧。下单后要一个半月才发货。实属令人抓腮。
正好最近在折腾F#，干脆我来验证下是不是每种情况都有解吧。
于是，开工。
思路
暂时不需要太复杂的算法，就用最简单的DFS就可以了。
我们从左到右，从上到下搜索棋盘格，只要这个格子应放但未放入积木，我们就尝试放一个形状进去，然后继续搜索。如果无法放入我们就继续试其他形状。如果所有积木的所有形状都试过了我们就回溯。这样可以保证了搜索到某个点时，它之前的所有行、它同一行左侧的所有点都已经填满了积木。只需要搜完整个地图，说明全部积木都放进去了。
因为是函数式编程，上述的过程也被转换成了递归。
具体步骤：
- 将积木保存为大小仅为长*宽的点阵，有木头的为1，空白的为0。并把积木编上从0到10的号。
- 针对每个积木，通过旋转、翻转，产生出它的所有的变形形状，并且剔除重复的形状，作为该积木应该尝试的所有形状列表。每个形状记录左上角那块积木的位置（相对于当前积木区域的坐标），上比左优先。后面的搜索要用到。
- 地图抽象为7行6列的矩阵。不可达的区域定义为-100，需要空出来的月份、日期、星期三个格子定义为100，未放置任何积木的定义为-1，放置了积木的格子记录为这个积木的编号（0-10）
- 针对棋盘开始搜索，从（0，0）处依次向右、向下搜索。注意这里的坐标采取(x,y)形式，也就是列在前，行在后。
- 遇到已经放入积木、不可达区域、需要空出来的格子则直接跳过，递归搜索下一个点。
- 遇到空白格子（为-1的格子）则针对该点遍历所有积木的所有形状。将该形状的左上角点放置于此格子，并判断是否能放进该形状。如果形状能放入则放入，并继续递归，在尝试下一个形状之前删除该形状。如果无法放入，则不进行递归。
- 当搜索到达（3，6）格子时，意味着找到了一个解。此时可以选择继续搜索找出所有解，或者退出搜索完成任务。（两种我都试了，解法真的很多很多，本文只讲取一种解的情况）
那么，开工
准备工作
定义形状、积木
这里采用记录：
//积木变形形状
type Shape =
{
X: int //最大x坐标，而非length
Y: int //最大y坐标，而非length
TopLeft: int * int
Map: int[,]
}
//积木单元
type Piece =
{
Shapes: list
}
生成积木
做一个积木的形状生成器，这样可以方便积木形状的生成：
- 单个积木根据有木头的点坐标自动生成积木的基本形状的map。
- 进行旋转获取4个形状，然后翻转后再旋转获取4个形状
- 对8种形状做去重
- 针对所有积木执行上述步骤，生成所有积木
//根据提供的占位坐标点序列，生成所有积木单元，并计算全部不重复的形状
let genPieces (piecesDesc: seq>) =
//生成一个积木单元
let genPiece (arr: seq) =
//根据基础形状，生成所有不重复形状
let genAvailabeShapes shape =
//变形，f为目的地元素函数
let transShape shape f =
let cur = Array2D.create (shape.Y + 1) (shape.X + 1) 0 //(x,y)格式，先列后行
let mutable minX = -1
let mutable minY = -1
for y in 0 .. shape.X do //行列互换
for x in 0 .. shape.Y do
cur[x, y] <- f shape x y
if minX = -1 && cur[x, y] = 1 then minX <- x; minY <- y
{
Map = cur
X = shape.Y
Y = shape.X
TopLeft = (minX, minY)
}
//旋转变形（顺时针）
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个形状
//筛选有效形状（不重复）
let searchAvailableShapes (allshapes: List) =
//判断形状相同，用于剔除旋转后重复的形状
let shapeEqual shape1 shape2 =
if shape1.X <> shape2.X then false
elif shape1.Y <> shape2.Y then false
else
seq { 0 .. shape1.Y }
|> Seq.exists (fun y ->
seq { 0 .. shape1.X }
|> Seq.exists (fun x ->
shape1.Map[x, y] <> shape2.Map[x, y]
))
|> not
//递归筛选有效形状（不重复）
let rec searchAvailableShapesLoop (allshapes: List) n = //此处不是序号，是数量，8到1
match n with
| 0 -> []
| _ ->
let next = searchAvailableShapesLoop allshapes (n - 1)
let hasEqual =
seq { 0 .. next.Length - 1 }
|> Seq.exists(fun i -> shapeEqual next.[i] allshapes.[n - 1])
if hasEqual then next else allshapes[n - 1] :: next
searchAvailableShapesLoop allshapes allshapes.Length
//生成最终积木作为结果
searchAvailableShapes allShapes
//初始化
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 mutable minX = -1
let mutable minY = -1
seq { 0 .. maxY }
|> Seq.exists (fun y ->
seq { 0 .. maxX }
|> Seq.exists (fun x ->
if minX = -1 && cur[x, y] = 1 then
minX <- x; minY <- y; true
else false
))
|> ignore
//基础形状
let shape =
{
X = maxX
Y = maxY
TopLeft = (minX, minY) //用于判断
Map = cur
}
//计算本积木的所有可用变形并返回为一个Piece
{
Shapes = genAvailabeShapes shape
}
//根据参数生成所有积木
Seq.map (fun pieceDesc -> genPiece pieceDesc) piecesDesc |> Array.ofSeq
然后利用生成器生成全部积木：
//根据实际情况，生成积木
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 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 solve m d w =
//搜索时用的map
let map = Array2D.create 8 7 -1 //(x,y)格式，先列后行
//赋初值
//map[0, 0] <- -100 //这里不对……
seq { 3 .. 7 } |> Seq.iter (fun i -> map[i, 6] <- -100) //-100为地图黑域
map[fst m, snd m] <- 100 //100为空出位置
map[fst d, snd d] <- 100
map[fst w, snd w] <- 100
//搜索时记录积木是否已经使用的map
let pieceUsed = Array.create pieces.Length false
//打印解
let printMap () =
let showChar d =
match d with
| -100 -> ' '
| -1 -> '_'
| 100 -> ' '
| 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 =
let xOffset, yOffset = shape.TopLeft
//排除出界情况
if x - xOffset < 0 then false
elif x - xOffset + shape.X > 7 then false
elif y - yOffset < 0 then false
elif y - yOffset + 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 - xOffset + xLoop, y + yOffset + 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 =
let xOffset, yOffset = shape.TopLeft
for yLoop in 0 .. shape.Y do
for xLoop in 0 .. shape.X do
if shape.Map[xLoop, yLoop] = 1 then
map[x - xOffset + xLoop, y - yOffset + yLoop] <- -1
pieceUsed[i] <- false
//主过程，逐级递归
let rec solveLoop x y =
match (x, y) with
| (3, 6) ->
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
执行
考虑两种模式：
- 根据用户输入的月份、日期、星期求出这种情况的解。
- 自动计算所有月份、日期、星期组合的所有情况，验证每种情况的解。
以上两种我也都做了。但是下面代码只演示了第一种。
首先我们Nuget安装一个包，用于scanf
Install-Package FSharp.Scanf
然后open它
open FSharp.Scanf
然后根据输入转换成坐标：
let m, d, w = scanfn "%d %d %d"
let (month, day, weekday) = blankPos (m, d, w)
接下来就是根据输入求解了：
printfn "=== %2d.%2d-%d ===" m d w
//解决问题
let solved = solve month day weekday
if not solved then printfn "%2d.%2d-%d 此题无解" m d w
printfn "==============="
代码码完了。
随便测试一个：
- 月份：8
- 日期：16
- 星期：三
再测试一个：
- 月份：12
- 日期：31
- 星期：日
随后测试了下速度，在编译为Release的情况下：
- 针对特定月份、日期、星期，算出所有解的数量，大约需要3秒
- 针对所有的月份、日期、星期的组合，验证每一种至少有一个解的情况，总用时大约需要3秒。
发现效率还可以，就不考虑继续优化算法了。
OK。等玩具到了，想不出来解的时候，至少有个工具能用了。