玩转f#的一个实例——解拼图游戏

起因

起因是这样的：前一阵逛抖音，买了个预售的拼图游戏。据说是国内团队开发的，非常有趣。大概长这样：

拼图设计上故意空出三个空位，拼图的格子上印有1-12月的月份，1-31号的日期，以及周一到周日的星期。空出的三个空位，可以正好用来匹配月份-日期-星期的组合。这个可以使得你每天都可以有一道新的谜题可玩，好几年都不带重样的。

可是呢，这是个预售商品，大概研发团队找的生产厂商生产力不足吧。下单后要一个半月才发货。实属令人抓腮。

正好最近在折腾F#，干脆我来验证下是不是每种情况都有解吧。

于是，开工。

思路

暂时不需要太复杂的算法，就用最简单的DFS就可以了。

我们从左到右，从上到下搜索棋盘格，只要这个格子应放但未放入积木，我们就尝试放一个形状进去，然后继续搜索。如果无法放入我们就继续试其他形状。如果所有积木的所有形状都试过了我们就回溯。这样可以保证了搜索到某个点时，它之前的所有行、它同一行左侧的所有点都已经填满了积木。只需要搜完整个地图，说明全部积木都放进去了。

因为是函数式编程，上述的过程也被转换成了递归。

具体步骤：

将积木保存为大小仅为长*宽的点阵，有木头的为1，空白的为0。并把积木编上从0到10的号。
针对每个积木，通过旋转、翻转，产生出它的所有的变形形状，并且剔除重复的形状，作为该积木应该尝试的所有形状列表。每个形状记录第一行最左侧那块积木的位置（相对当前积木区域的x坐标）。后面的搜索要用到。
地图抽象为7行6列的矩阵。不可达的区域定义为-100，需要空出来的月份、日期、星期三个格子定义为100，未放置任何积木的定义为-1，放置了积木的格子记录为这个积木的编号（0-10）
针对棋盘开始搜索，从（0，0）处依次向右、向下搜索。注意这里的坐标采取(x,y)形式，也就是列在前，行在后。
1. 遇到已经放入积木、不可达区域、需要空出来的格子则直接跳过，递归搜索下一个点。
2. 遇到空白格子（为-1的格子）则针对该点遍历所有积木的所有形状。将该形状的第一行的最左侧积木块放置于此格子，并判断是否能放进该形状。如果形状能放入则放入，并继续递归，在尝试下一个形状之前删除该形状。如果无法放入，则不进行递归。
3. 当搜索到达（3，6）格子时，意味着找到了一个解。此时可以选择继续搜索找出所有解，或者退出搜索完成任务。（两种我都试了，解法真的很多很多，本文只讲取一种解的情况）

那么，开工

准备工作

定义形状、积木

这里采用记录：

//积木变形形状
type Shape = { X: int //最大x坐标，而非lengthY: int //最大y坐标，而非lengthOffset: intMap: 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 docur[x, y] <- f shape x y //注意，行列互换了//取第一行的偏移let offset =seq { 0 .. shape.Y }  //注意，列长变成了原来的行长度|> Seq.pick (fun x ->if cur[x, 0] = 1 then Some xelseNone){ Map = curX = shape.YY = shape.XOffset = 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个形状//判断形状相同，用于剔除旋转后重复的形状let shapeEqual shape1 shape2 =if shape1.X <> shape2.X then falseelif shape1.Y <> shape2.Y then falseelseseq { 0 .. shape1.Y }|> Seq.exists (fun y ->seq { 0 .. shape1.X }|> Seq.exists (fun x ->shape1.Map[x, y] <> shape2.Map[x, y]))|> not//去重作为结果，顺序会反过来，无所谓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.maxlet maxY = Seq.map (fun (_, y) -> y) arr |> Seq.maxlet 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 xelse None)//基础形状let shape = { X = maxXY = maxYOffset = 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 dofor 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 doprintfn ""for shape in piece.Shapes dofor y in 0 .. shape.Y dofor x in 0 .. shape.X doif 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, 0else 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) / 8monthPos (month - 1), dayPos (day - 1), weekdayPos (weekday - 1)let monthPos, dayPos, weekdayPos = blankPos (month, day, weekday)//搜索时用的maplet 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] <- 100map[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 dofor x in 0..7 doprintf "%c " (showChar map.[x, y])printfn ""printfn ""//尝试填充shape，若失败撤销填充，若成功标记used为truelet tryShape i shape x y =//排除出界情况if x - shape.Offset < 0 then falseelif x - shape.Offset + shape.X > 7 then falseelif y + shape.Y > 6 then falseelselet 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 + yLoopif shape.Map[xLoop, yLoop] <> 1 then tryShapeRec i shape (xLoop - 1) yLoopelif map[xIndex, yIndex] <> -1 then falseelsemap[xIndex, yIndex] <- ilet rsl = tryShapeRec i shape (xLoop - 1) yLoopif not rsl then map[xIndex, yIndex] <- -1rsllet rsl = tryShapeRec i shape shape.X shape.Yif rsl then pieceUsed[i] <- truersl//回滚填充的shapelet eraseShape i shape x y =for yLoop in 0 .. shape.Y dofor xLoop in 0 .. shape.X doif shape.Map[xLoop, yLoop] = 1 thenmap[x - shape.Offset + xLoop, y + yLoop] <- -1pieceUsed[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] thenpieces[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 trueelse eraseShape i shape x y; falseelse false)else false)//printMap () //测试用，打印初始map//调用solveLoop 0 0

执行

考虑两种模式：

根据用户输入的月份、日期、星期求出这种情况的解。
自动计算所有月份、日期、星期组合的所有情况，验证每种情况的解。

以上两种我们都实现一下，通过用户输入选择不同模式。并且加入容错机制：

open System
open System.Linqprintfn "模式："
printfn "1) 根据输入求解"
printfn "2) 验证所有组合有解"
printf "请选择："let choose = Console.ReadLine().Trim()printfn ""match choose with
| "1" -> while true do    //反复求解printf "输入 月份、日期、星期："trylet month, day, weekday = Console.ReadLine().Trim().Split([| ' '; '\t' |]).Where(fun x -> not (String.IsNullOrEmpty(x)))|> (fun x ->if x.Count() = 3 thenint (Seq.item 0 x), int (Seq.item 1 x), int (Seq.item 2 x)elsefailwith "")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 trueif 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 Noneelse 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上。