├── Life.wl ├── README.md └── Screenshot.png /Life.wl: -------------------------------------------------------------------------------- 1 | (* ::Package:: *) 2 | 3 | BeginPackage["Life`"]; 4 | 5 | $Rule::usage = "The default rule."; 6 | RuleNumber::usage = "Convert a rule string to a rule number."; 7 | ToRuleString::usage = 8 | "Merge a list of neighborhood strings (e.g., {\"B3a\",\"S2e\"}) \ 9 | into a rule string."; 10 | ToRLE::usage = "Convert a 2d 0-1 array to a string of RLE format."; 11 | FromRLE::usage = "Convert a string of RLE format to an array."; 12 | FromAPGCode::usage = "Convert an apgcode to an array."; 13 | PlotAndPrintRLE::usage = 14 | "Plot the pattern, and print the RLE of its first generation."; 15 | SearchPattern::usage = 16 | "SearchPattern[x, y, p, dx, dy] searches for a pattern with \ 17 | bounding box (x, y), period p, and translating (dx, dy) for each \ 18 | period. It returns a 0-1 array."; 19 | LifeFind::usage = 20 | "LifeFind[x, y, p, dx, dy] searches for a pattern with bounding box \ 21 | (x, y), period p, and translating (dx, dy) for each period. It \ 22 | returns a list of plots, and prints the RLE of the first generation."; 23 | Predecessor::usage = 24 | "Predecessor[pattern, n] tries to find a predecessor of the pattern \ 25 | of n generations."; 26 | CA::usage = 27 | "CA[pattern, n, \"Rule\" -> rule] gives \ 28 | CellularAutomaton[{RuleNumber[rule], 2, {1, 1}}, {pattern, 0}, gen]."; 29 | ExportGIF::usage = 30 | "ExportGIF[file, pattern, n] plots the pattern for n generations \ 31 | and export it to a GIF file."; 32 | ExportSpaceshipGIF::usage = 33 | "ExportSpaceshipGIF[file, pattern, p, dx, dy, s] plots a spaceship \ 34 | of period p, translating (dx, dy) for each period, and export it to a \ 35 | GIF file. Each cell has size (s, s) in the output GIF."; 36 | PatternRules::usage = 37 | "Give all possible rules of a pattern. The result is given in an \ 38 | Association, where True (resp. False) means this term should (resp. \ 39 | should not) appear in the rule."; 40 | 41 | Begin["`Private`"]; 42 | 43 | $Rule = "B3/S23"; 44 | 45 | NbhdNumber = <|"B0" -> {0}, 46 | "B1c" -> {1, 4, 64, 256}, 47 | "B1e" -> {2, 8, 32, 128}, 48 | "B2a" -> {3, 6, 9, 36, 72, 192, 288, 384}, 49 | "B2c" -> {5, 65, 260, 320}, 50 | "B2e" -> {10, 34, 136, 160}, 51 | "B2i" -> {40, 130}, 52 | "B2k" -> {12, 33, 66, 96, 129, 132, 258, 264}, 53 | "B2n" -> {68, 257}, 54 | "B3a" -> {11, 38, 200, 416}, 55 | "B3c" -> {69, 261, 321, 324}, 56 | "B3e" -> {42, 138, 162, 168}, 57 | "B3i" -> {7, 73, 292, 448}, 58 | "B3j" -> {14, 35, 74, 137, 164, 224, 290, 392}, 59 | "B3k" -> {98, 140, 161, 266}, 60 | "B3n" -> {13, 37, 67, 193, 262, 328, 352, 388}, 61 | "B3q" -> {70, 76, 100, 196, 259, 265, 289, 385}, 62 | "B3r" -> {41, 44, 104, 131, 134, 194, 296, 386}, 63 | "B3y" -> {97, 133, 268, 322}, 64 | "B4a" -> {15, 39, 75, 201, 294, 420, 456, 480}, 65 | "B4c" -> {325}, 66 | "B4e" -> {170}, 67 | "B4i" -> {45, 195, 360, 390}, 68 | "B4j" -> {106, 142, 163, 169, 172, 226, 298, 394}, 69 | "B4k" -> {99, 141, 165, 225, 270, 330, 354, 396}, 70 | "B4n" -> {71, 77, 263, 293, 329, 356, 449, 452}, 71 | "B4q" -> {102, 204, 267, 417}, 72 | "B4r" -> {43, 46, 139, 166, 202, 232, 418, 424}, 73 | "B4t" -> {105, 135, 300, 450}, 74 | "B4w" -> {78, 228, 291, 393}, 75 | "B4y" -> {101, 197, 269, 323, 326, 332, 353, 389}, 76 | "B4z" -> {108, 198, 297, 387}, 77 | "B5a" -> {79, 295, 457, 484}, 78 | "B5c" -> {171, 174, 234, 426}, 79 | "B5e" -> {327, 333, 357, 453}, 80 | "B5i" -> {47, 203, 422, 488}, 81 | "B5j" -> {103, 205, 271, 331, 358, 421, 460, 481}, 82 | "B5k" -> {229, 334, 355, 397}, 83 | "B5n" -> {107, 143, 167, 233, 302, 428, 458, 482}, 84 | "B5q" -> {110, 206, 230, 236, 299, 395, 419, 425}, 85 | "B5r" -> {109, 199, 301, 361, 364, 391, 451, 454}, 86 | "B5y" -> {173, 227, 362, 398}, 87 | "B6a" -> {111, 207, 303, 423, 459, 486, 489, 492}, 88 | "B6c" -> {175, 235, 430, 490}, 89 | "B6e" -> {335, 359, 461, 485}, 90 | "B6i" -> {365, 455}, 91 | "B6k" -> {231, 237, 363, 366, 399, 429, 462, 483}, 92 | "B6n" -> {238, 427}, 93 | "B7c" -> {239, 431, 491, 494}, 94 | "B7e" -> {367, 463, 487, 493}, 95 | "B8" -> {495}, 96 | "S0" -> {16}, 97 | "S1c" -> {17, 20, 80, 272}, 98 | "S1e" -> {18, 24, 48, 144}, 99 | "S2a" -> {19, 22, 25, 52, 88, 208, 304, 400}, 100 | "S2c" -> {21, 81, 276, 336}, 101 | "S2e" -> {26, 50, 152, 176}, 102 | "S2i" -> {56, 146}, 103 | "S2k" -> {28, 49, 82, 112, 145, 148, 274, 280}, 104 | "S2n" -> {84, 273}, 105 | "S3a" -> {27, 54, 216, 432}, 106 | "S3c" -> {85, 277, 337, 340}, 107 | "S3e" -> {58, 154, 178, 184}, 108 | "S3i" -> {23, 89, 308, 464}, 109 | "S3j" -> {30, 51, 90, 153, 180, 240, 306, 408}, 110 | "S3k" -> {114, 156, 177, 282}, 111 | "S3n" -> {29, 53, 83, 209, 278, 344, 368, 404}, 112 | "S3q" -> {86, 92, 116, 212, 275, 281, 305, 401}, 113 | "S3r" -> {57, 60, 120, 147, 150, 210, 312, 402}, 114 | "S3y" -> {113, 149, 284, 338}, 115 | "S4a" -> {31, 55, 91, 217, 310, 436, 472, 496}, 116 | "S4c" -> {341}, 117 | "S4e" -> {186}, 118 | "S4i" -> {61, 211, 376, 406}, 119 | "S4j" -> {122, 158, 179, 185, 188, 242, 314, 410}, 120 | "S4k" -> {115, 157, 181, 241, 286, 346, 370, 412}, 121 | "S4n" -> {87, 93, 279, 309, 345, 372, 465, 468}, 122 | "S4q" -> {118, 220, 283, 433}, 123 | "S4r" -> {59, 62, 155, 182, 218, 248, 434, 440}, 124 | "S4t" -> {121, 151, 316, 466}, 125 | "S4w" -> {94, 244, 307, 409}, 126 | "S4y" -> {117, 213, 285, 339, 342, 348, 369, 405}, 127 | "S4z" -> {124, 214, 313, 403}, 128 | "S5a" -> {95, 311, 473, 500}, 129 | "S5c" -> {187, 190, 250, 442}, 130 | "S5e" -> {343, 349, 373, 469}, 131 | "S5i" -> {63, 219, 438, 504}, 132 | "S5j" -> {119, 221, 287, 347, 374, 437, 476, 497}, 133 | "S5k" -> {245, 350, 371, 413}, 134 | "S5n" -> {123, 159, 183, 249, 318, 444, 474, 498}, 135 | "S5q" -> {126, 222, 246, 252, 315, 411, 435, 441}, 136 | "S5r" -> {125, 215, 317, 377, 380, 407, 467, 470}, 137 | "S5y" -> {189, 243, 378, 414}, 138 | "S6a" -> {127, 223, 319, 439, 475, 502, 505, 508}, 139 | "S6c" -> {191, 251, 446, 506}, 140 | "S6e" -> {351, 375, 477, 501}, 141 | "S6i" -> {381, 471}, 142 | "S6k" -> {247, 253, 379, 382, 415, 445, 478, 499}, 143 | "S6n" -> {254, 443}, 144 | "S7c" -> {255, 447, 507, 510}, 145 | "S7e" -> {383, 479, 503, 509}, 146 | "S8" -> {511}|>; 147 | 148 | NbhdNumberT = 149 | KeySort@Merge[ 150 | Table[{"B", "S"}[[#[[5]] + 1]] <> ToString@Tr@Delete[#, 5] &@ 151 | IntegerDigits[i, 2, 9] -> i, {i, 0, 511}], # &]; 152 | 153 | NbhdNumberV = 154 | KeySort@Merge[ 155 | Table[{"B", "S"}[[#[[5]] + 1]] <> ToString@Tr@#[[{2, 4, 6, 8}]] &@ 156 | IntegerDigits[i, 2, 9] -> i, {i, 0, 511}], # &]; 157 | 158 | NbhdNumberH = <|"B0" -> {0, 4, 64, 68}, 159 | "B1" -> {1, 2, 5, 6, 8, 12, 32, 36, 65, 66, 69, 70, 72, 76, 96, 160 | 100, 128, 132, 192, 196, 256, 260, 320, 324}, 161 | "B2o" -> {3, 7, 9, 13, 34, 38, 67, 71, 73, 77, 98, 102, 136, 140, 162 | 200, 204, 288, 292, 352, 356, 384, 388, 448, 452}, 163 | "B2m" -> {10, 14, 33, 37, 74, 78, 97, 101, 129, 133, 160, 164, 193, 164 | 197, 224, 228, 258, 262, 264, 268, 322, 326, 328, 332}, 165 | "B2p" -> {40, 44, 104, 108, 130, 134, 194, 198, 257, 261, 321, 325}, 166 | "B3o" -> {11, 15, 35, 39, 75, 79, 99, 103, 137, 141, 201, 205, 290, 167 | 294, 354, 358, 392, 396, 416, 420, 456, 460, 480, 484}, 168 | "B3m" -> {41, 42, 45, 46, 105, 106, 109, 110, 131, 135, 138, 142, 169 | 162, 166, 168, 172, 195, 199, 202, 206, 226, 230, 232, 236, 259, 170 | 263, 265, 269, 289, 293, 296, 300, 323, 327, 329, 333, 353, 357, 171 | 360, 364, 385, 386, 389, 390, 449, 450, 453, 454}, 172 | "B3p" -> {161, 165, 225, 229, 266, 270, 330, 334}, 173 | "B4o" -> {43, 47, 107, 111, 139, 143, 203, 207, 291, 295, 355, 359, 174 | 393, 397, 418, 422, 424, 428, 457, 461, 482, 486, 488, 492}, 175 | "B4m" -> {163, 167, 169, 173, 227, 231, 233, 237, 267, 271, 298, 176 | 302, 331, 335, 362, 366, 394, 398, 417, 421, 458, 462, 481, 177 | 485}, 178 | "B4p" -> {170, 174, 234, 238, 297, 301, 361, 365, 387, 391, 451, 179 | 455}, 180 | "B5" -> {171, 175, 235, 239, 299, 303, 363, 367, 395, 399, 419, 181 | 423, 425, 426, 429, 430, 459, 463, 483, 487, 489, 490, 493, 182 | 494}, 183 | "B6" -> {427, 431, 491, 495}, 184 | "S0" -> {16, 20, 80, 84}, 185 | "S1" -> {17, 18, 21, 22, 24, 28, 48, 52, 81, 82, 85, 86, 88, 92, 186 | 112, 116, 144, 148, 208, 212, 272, 276, 336, 340}, 187 | "S2o" -> {19, 23, 25, 29, 50, 54, 83, 87, 89, 93, 114, 118, 152, 188 | 156, 216, 220, 304, 308, 368, 372, 400, 404, 464, 468}, 189 | "S2m" -> {26, 30, 49, 53, 90, 94, 113, 117, 145, 149, 176, 180, 190 | 209, 213, 240, 244, 274, 278, 280, 284, 338, 342, 344, 348}, 191 | "S2p" -> {56, 60, 120, 124, 146, 150, 210, 214, 273, 277, 337, 341}, 192 | "S3o" -> {27, 31, 51, 55, 91, 95, 115, 119, 153, 157, 217, 221, 193 | 306, 310, 370, 374, 408, 412, 432, 436, 472, 476, 496, 500}, 194 | "S3m" -> {57, 58, 61, 62, 121, 122, 125, 126, 147, 151, 154, 158, 195 | 178, 182, 184, 188, 211, 215, 218, 222, 242, 246, 248, 252, 275, 196 | 279, 281, 285, 305, 309, 312, 316, 339, 343, 345, 349, 369, 373, 197 | 376, 380, 401, 402, 405, 406, 465, 466, 469, 470}, 198 | "S3p" -> {177, 181, 241, 245, 282, 286, 346, 350}, 199 | "S4o" -> {59, 63, 123, 127, 155, 159, 219, 223, 307, 311, 371, 375, 200 | 409, 413, 434, 438, 440, 444, 473, 477, 498, 502, 504, 508}, 201 | "S4m" -> {179, 183, 185, 189, 243, 247, 249, 253, 283, 287, 314, 202 | 318, 347, 351, 378, 382, 410, 414, 433, 437, 474, 478, 497, 203 | 501}, 204 | "S4p" -> {186, 190, 250, 254, 313, 317, 377, 381, 403, 407, 467, 205 | 471}, 206 | "S5" -> {187, 191, 251, 255, 315, 319, 379, 383, 411, 415, 435, 207 | 439, 441, 442, 445, 446, 475, 479, 499, 503, 505, 506, 509, 208 | 510}, 209 | "S6" -> {443, 447, 507, 511}|>; 210 | 211 | NbhdNumberHT = 212 | KeySort@Merge[ 213 | Table[{"B", "S"}[[#[[5]] + 1]] <> 214 | ToString@Tr@#[[{1, 2, 4, 6, 8, 9}]] &@ 215 | IntegerDigits[i, 2, 9] -> i, {i, 0, 511}], # &]; 216 | 217 | RuleNumber::nrule = "Invalid rule. Uses " <> $Rule <> " instead."; 218 | RuleNumber[n_Integer] := n; 219 | RuleNumber[rule_String] := 220 | Block[{parseNbhd, parseNbhdH, parseNbhdV, patNbhd, patNbhdH, 221 | patNbhdV, toNum, sb}, 222 | {parseNbhd, parseNbhdH, parseNbhdV} = 223 | KeyValueMap[ 224 | n : #1 ~~ h : ("-" | "") ~~ s : (Alternatives @@ #2) ... :> 225 | Sequence @@ 226 | Table[n <> c, {c, 227 | Which[#2 == {}, {""}, s == "" || h == "-", 228 | Complement[#2, Characters@s], True, 229 | Characters@s]}] &] /@ 230 | {<|"0" | "8" -> {}, 231 | "1" | "7" -> {"c", "e"}, 232 | "2" | "6" -> {"a", "c", "e", "i", "k", "n"}, 233 | "3" | "5" -> {"a", "c", "e", "i", "j", "k", "n", "q", "r", "y"}, 234 | "4" -> {"a", "c", "e", "i", "j", "k", "n", "q", "r", "t", "w", 235 | "y", "z"}|>, 236 | <|"0" | "1" | "5" | "6" -> {}, 237 | "2" | "3" | "4" -> {"o", "m", "p"}|>, 238 | <|"0" | "1" | "2" | "3" | "4" -> {}|>}; 239 | {patNbhd, patNbhdH, patNbhdV} = 240 | Alternatives @@ 241 | Keys[# /. 242 | Verbatim[Pattern][_, p_] :> p] ... & /@ 243 | {parseNbhd, 244 | parseNbhdH, parseNbhdV}; 245 | toNum[{s_, b_, n_}] := 246 | With[{nbhd = 247 | Switch[n, "v", NbhdNumberV, "h", NbhdNumberH, _, NbhdNumber], 248 | parse = 249 | Switch[n, "v", parseNbhdV, "h", parseNbhdH, _, parseNbhd]}, 250 | BitOr @@ 251 | Lookup[Tr /@ (2^nbhd), 252 | Join["B" <> # & /@ StringCases[b, parse, IgnoreCase -> True], 253 | "S" <> # & /@ StringCases[s, parse, IgnoreCase -> True]]]]; 254 | sb = StringCases[rule, 255 | Catenate[{StartOfString ~~ ("g" ~~ DigitCharacter ..) | "" ~~ 256 | "b" ~~ b : # ~~ "/" | "/s" | "s" ~~ 257 | s : # ~~ ("/" ~~ DigitCharacter ..) | "" ~~ #2 ~~ 258 | ":" | EndOfString :> {s, b, #2}, 259 | StartOfString ~~ s : # ~~ "/" ~~ 260 | b : # ~~ ("/" ~~ DigitCharacter ..) | "" ~~ #2 ~~ 261 | ":" | EndOfString :> {s, b, #2}} & @@@ {{patNbhd, 262 | ""}, {patNbhdV, "v"}, {patNbhdH, "h"}}], 263 | IgnoreCase -> True]; 264 | If[sb == {}, Message[RuleNumber::nrule]; 265 | RuleNumber[$Rule], toNum[sb[[1]]]]]; 266 | 267 | GenerationsNumber[rule_] := 268 | If[# == {}, 2, #[[1]]] &@ 269 | StringCases[ 270 | rule, {StartOfString ~~ "g" ~~ g : DigitCharacter .. ~~ 271 | "/" | "b" :> FromDigits[g], 272 | ___ ~~ "/" | "s" ~~ ___ ~~ "/" ~~ g : DigitCharacter .. ~~ 273 | "" | "v" | "h" ~~ ":" | EndOfString :> FromDigits[g]}, 274 | IgnoreCase -> True]; 275 | 276 | Options[ToRuleString] := {"Hexagonal" -> False, "Generations" -> 2}; 277 | ToRuleString[nbhds_, OptionsPattern[]] := 278 | If[OptionValue["Generations"] <= 2, 279 | "B" <> #1 <> "/S" <> #2, #2 <> "/" <> #1 <> "/" <> 280 | ToString@OptionValue["Generations"]] <> 281 | If[OptionValue["Hexagonal"], "H", ""] & @@ 282 | Table[KeyValueMap[StringJoin]@ 283 | Merge[Cases[Characters@Union@nbhds, {sb, i_, n___} :> i -> {n}], 284 | Catenate], {sb, {"B", "S"}}]; 285 | 286 | Options[ToRLE] = {"Rule" :> $Rule}; 287 | ToRLE[array_List, OptionsPattern[]] := 288 | "x = " <> #2 <> ", y = " <> #1 <> ", rule = " <> 289 | OptionValue["Rule"] <> "\n" & @@ ToString /@ Dimensions@array <> 290 | StringRiffle[ 291 | StringCases[ 292 | StringReplace[ 293 | StringReplace[ 294 | StringReplace[ 295 | Riffle[If[Max@array < 2, array /. {1 -> "o", 0 -> "b"}, 296 | array /. {0 -> ".", 297 | n_ /; n < 25 :> FromCharacterCode[n + 64], 298 | n_ /; n > 24 :> 299 | FromCharacterCode[Quotient[n, 24, 1] + 111] <> 300 | FromCharacterCode[Mod[n, 24, 1] + 64]}], "$"] <> "!", 301 | ("." | "b") .. ~~ s : "$" | "!" :> s], "$" .. ~~ "!" :> "!"], 302 | r : (x : 303 | "$" | "." | "b" | "o" | 304 | "*" | ("" | Alternatives @@ CharacterRange["p", "y"] ~~ 305 | Alternatives @@ CharacterRange["A", "X"])) .. :> 306 | (If[# == 1, "", ToString@#] &[StringLength@r/StringLength@x]) <> 307 | x], l : (___ ~~ 308 | "$" | "!" | "." | "b" | "o" | "*" | 309 | Alternatives @@ CharacterRange["A", "X"]) /; 310 | StringLength@l <= 70], "\n"]; 311 | 312 | FromRLE[rle_String] := 313 | PadRight[StringCases[{"." | "b" -> 0, "o" | "*" -> 1, 314 | a : Alternatives @@ CharacterRange["p", "y"] ~~ 315 | b : Alternatives @@ CharacterRange["A", "X"] :> 316 | Tr[24 (ToCharacterCode@a - 111) + ToCharacterCode@b - 64], 317 | b : Alternatives @@ CharacterRange["A", "X"] :> 318 | Tr[ToCharacterCode@b - 64]}] /@ 319 | StringSplit[ 320 | StringReplace[ 321 | StringDelete[ 322 | rle, (StartOfLine ~~ ("x" | "#") ~~ Shortest@___ ~~ 323 | EndOfLine) | "\n" | ("!" ~~ ___)], 324 | n : DigitCharacter .. ~~ 325 | a : ("$" | "." | "b" | "o" | 326 | "*" | ("" | Alternatives @@ CharacterRange["p", "y"] ~~ 327 | Alternatives @@ CharacterRange["A", "X"])) :> 328 | StringRepeat[a, FromDigits@n]], "$", All]]; 329 | 330 | FromAPGCode::napg = "Invalid apgcode."; 331 | FromAPGCode[apgcode_String] := 332 | If[# == {}, Message[FromAPGCode::napg]; {}, 333 | Total@MapIndexed[#1* 334 | Tr@#2 &, #[[1]]] /. {a___, {0 ...} ...} :> {a}] &[ 335 | StringCases[apgcode, 336 | StartOfString ~~ "x" ~~ Shortest[___] ~~ 337 | codes : ("_" ~~ WordCharacter ...) .. :> 338 | PadRight[ 339 | Transpose[ 340 | Join @@ Reverse /@ IntegerDigits[#, 2, 5] & /@ 341 | Thread@PadRight@ 342 | StringCases[ 343 | StringSplit[ 344 | StringReplace[#, {"y" ~~ d_ :> 345 | StringRepeat["0", 4 + FromDigits@d], "w" -> "00", 346 | "x" -> "000"}], "z"], d_ :> FromDigits@d]] & /@ 347 | StringSplit[codes, "_"]]]]; 348 | 349 | Options[PlotAndPrintRLE] = 350 | Join[Options[ToRLE], 351 | Options[ArrayPlot] /. (Mesh -> False) -> (Mesh -> 352 | All), {"Generations" -> Automatic}]; 353 | PlotAndPrintRLE[pattern_, opts : OptionsPattern[]] := 354 | Block[{gen = 355 | If[OptionValue["Generations"] === Automatic, 356 | GenerationsNumber[OptionValue["Rule"]], 357 | OptionValue["Generations"]]}, 358 | ArrayPlot[# /. i_ /; i > 0 :> (gen - i)/(gen - 1), 359 | FilterRules[{opts}, Options[ArrayPlot]], Mesh -> All, 360 | ColorFunctionScaling -> False] & /@ 361 | Echo[If[ArrayDepth@pattern == 2, {pattern}, pattern], "RLE: ", 362 | ToRLE[#[[1]], "Rule" -> OptionValue["Rule"]] &]]; 363 | 364 | SearchPattern::nsat = "No such pattern."; 365 | SearchPattern::nsym = "Invalid symmetry. Uses \"C1\" instead."; 366 | SearchPattern::genper = 367 | "Nonperiodic patterns are not supported for Generations rules."; 368 | Options[SearchPattern] = {"Rule" :> $Rule, "Hexagonal" -> False, 369 | "Totalistic" -> False, "Generations" -> 2, "Symmetry" -> "C1", 370 | "Periodic" -> True, "Agar" -> False, "Changing" -> False, 371 | "RandomArray" -> 0.5, "KnownCells" -> {}, "KnownRules" -> <||>, 372 | "OtherConditions" -> True}; 373 | SearchPattern[x_, y_, opts : OptionsPattern[]] := 374 | SearchPattern[x, y, 1, 0, 0, opts]; 375 | SearchPattern[x_, y_, p_, opts : OptionsPattern[]] := 376 | SearchPattern[x, y, p, 0, 0, opts]; 377 | SearchPattern[x_, y_, p_, dx_, opts : OptionsPattern[]] := 378 | SearchPattern[x, y, p, dx, 0, opts]; 379 | SearchPattern[x_, y_, p_, dx_, dy_, OptionsPattern[]] := 380 | Block[{rulenum, nbhd, gen, random, c, i, j, t, vcell, vchange, 381 | vrule, agarx, agary, cellcond, cond, change, knownc, knownr, 382 | cellsym, sym, other, result}, 383 | If[OptionValue["Rule"] == "", 384 | nbhd = Tr /@ (2^ 385 | If[OptionValue["Hexagonal"], 386 | If[OptionValue["Totalistic"], NbhdNumberHT, NbhdNumberH], 387 | If[OptionValue["Totalistic"], NbhdNumberT, NbhdNumber]]); 388 | gen = OptionValue["Generations"], 389 | rulenum = 390 | FromDigits[ 391 | IntegerDigits[RuleNumber[OptionValue["Rule"]], 2, 512] + 1, 4]; 392 | gen = GenerationsNumber[OptionValue["Rule"]]]; 393 | If[! OptionValue["Periodic"] && gen > 2, 394 | Message[SearchPattern::genper]]; 395 | cellcond[i_, j_, t_] = 396 | If[OptionValue["Rule"] == "", 397 | And @@ Table[ 398 | BooleanConvert[((c[i, j, t] || ! 399 | Array[c, {1, 1, gen - 1}, {i, j, t - gen + 2}, 400 | Or]) && (BooleanFunction[nbhd[k], 401 | Flatten@ 402 | Array[c, {3, 3, 1}, {i - 1, j - 1, 403 | t}]] \[Implies] (vrule[k] \[Equivalent] 404 | c[i, j, t + 1]))) || (! c[i, j, t] && 405 | Array[c, {1, 1, gen - 1}, {i, j, t - gen + 2}, Or] && ! 406 | c[i, j, t + 1]), "CNF"], {k, Keys@nbhd}], 407 | BooleanConvert[((c[i, j, t] || ! 408 | Array[c, {1, 1, gen - 1}, {i, j, t - gen + 2}, Or]) && 409 | BooleanFunction[rulenum, 410 | Flatten@{Array[c, {3, 3, 1}, {i - 1, j - 1, t}], 411 | c[i, j, t + 1]}]) || (! c[i, j, t] && 412 | Array[c, {1, 1, gen - 1}, {i, j, t - gen + 2}, Or] && ! 413 | c[i, j, t + 1]), "CNF"]]; 414 | cellsym[i_, j_, t_] = 415 | BooleanConvert[ 416 | Switch[OptionValue["Symmetry"], "C1", True, "C2", 417 | c[i, j, t] \[Equivalent] c[x + 1 - i, y + 1 - j, t], "C4", 418 | c[i, j, t] \[Equivalent] c[j, x + 1 - i, t], "D2-", 419 | c[i, j, t] \[Equivalent] c[x + 1 - i, j, t], "D2\\", 420 | c[i, j, t] \[Equivalent] c[j, i, t], "D2|", 421 | c[i, j, t] \[Equivalent] c[i, y + 1 - j, t], "D2/", 422 | c[i, j, t] \[Equivalent] c[y + 1 - j, x + 1 - i, t], "D4+", 423 | c[i, j, t] \[Equivalent] c[x + 1 - i, j, t] \[Equivalent] 424 | c[i, y + 1 - j, t], "D4X", 425 | c[i, j, t] \[Equivalent] c[j, i, t] \[Equivalent] 426 | c[y + 1 - j, x + 1 - i, t], "D8", 427 | c[i, j, t] \[Equivalent] c[j, x + 1 - i, t] \[Equivalent] 428 | c[j, i, t], _, Message[SearchPattern::nsym]; True], "CNF"]; 429 | agarx[{a_, _}] := agarx[a]; 430 | agarx[True] = agarx[0]; 431 | agarx[a_Integer] := 432 | c[Mod[#1, x, 1], Mod[#2 + Quotient[#1, x, 1] a, y, 1], #3] &; 433 | agarx[_] = 434 | If[If[OptionValue["Rule"] == "", 435 | Lookup[OptionValue["KnownRules"], "B0", False], EvenQ@rulenum], 436 | EvenQ@#3, False] &; 437 | agary[{_, a_}] := agary[a]; 438 | agary[True] = agary[0]; 439 | agary[a_Integer] := 440 | c[Mod[#1 + Quotient[#2, y, 1] a, x, 1], Mod[#2, y, 1], #3] &; 441 | agary[_] = 442 | If[If[OptionValue["Rule"] == "", 443 | Lookup[OptionValue["KnownRules"], "B0", False], EvenQ@rulenum], 444 | EvenQ@#3, False] &; 445 | random = 446 | RandomChoice[{OptionValue["RandomArray"], 447 | 1 - OptionValue["RandomArray"]} -> {1, 0}, {x, y, p}]; 448 | c[i_, j_, t_] /; t < 1 || t > p := 449 | c[i, j, t] = 450 | c[i - Quotient[t, p, 1] dx, j - Quotient[t, p, 1] dy, 451 | Mod[t, p, 1]]; 452 | c[i_, j_, t_] /; i < 1 || i > x := 453 | c[i, j, t] = agarx[OptionValue["Agar"]][i, j, t]; 454 | c[i_, j_, t_] /; j < 1 || j > y := 455 | c[i, j, t] = agary[OptionValue["Agar"]][i, j, t]; 456 | c[i_, j_, t_] := 457 | c[i, j, t] = 458 | If[random[[i, j, t]] == 1, ! vcell[i, j, t], vcell[i, j, t]]; 459 | change[True] = change[{1, 2}]; 460 | change[{t1_, t2_}] := 461 | Array[BooleanConvert[ 462 | c[##, t1] \[Xor] 463 | c[# + Round[(t2 - t1) dx/p], #2 + Round[(t2 - t1) dy/p], 464 | t2] \[Equivalent] vchange[##], "CNF"] &, {x, y}, 1, And] && 465 | Array[vchange, {x, y}, 1, Or]; 466 | change[_] := True; 467 | knownc = 468 | MapIndexed[Switch[#, 1, c @@ #2, 0, ! c @@ #2, _, True] &, 469 | Transpose[ 470 | Switch[ArrayDepth@#, 3, #, 2, {#}, 1, {{#}}, _, {{{}}}] &[ 471 | PadRight[1 + OptionValue["KnownCells"]] - 1], {3, 1, 472 | 2}], {3}] /. List -> And; 473 | If[OptionValue["Rule"] == "", 474 | knownr = 475 | And @@ KeyValueMap[vrule[#] \[Equivalent] #2 &, 476 | First@KeyIntersection[{OptionValue["KnownRules"], nbhd}]]]; 477 | sym = Array[cellsym, {x, y, p}, 1, And]; 478 | other = 479 | BooleanConvert[OptionValue["OtherConditions"] /. C -> c, "CNF"]; 480 | cond = 481 | Array[cellcond, {x + 2, y + 2, 482 | If[OptionValue["Periodic"], p, p - 1]}, {0, 0, 1}, And] && 483 | If[TrueQ[! OptionValue["Agar"]], 484 | Array[If[0 <= # + dx <= x + 1 && 0 <= #2 + dy <= y + 1, 485 | True, ! c[##, 1]] &, {x, y}, 1, And], True]; 486 | result = 487 | If[OptionValue["Rule"] == "", 488 | SatisfiabilityInstances[ 489 | knownc && knownr && sym && other && cond && 490 | change[OptionValue["Changing"]], 491 | Flatten@{Array[vcell, {x, y, p}], vrule /@ Keys@nbhd, 492 | Array[vchange, {x, y}]}, Method -> "SAT"], 493 | SatisfiabilityInstances[ 494 | knownc && sym && other && cond && 495 | change[OptionValue["Changing"]], 496 | Flatten@{Array[vcell, {x, y, p}], Array[vchange, {x, y}]}, 497 | Method -> "SAT"]]; 498 | If[result == {}, Message[SearchPattern::nsat]; {}, 499 | If[OptionValue["Rule"] == "", {#, 500 | Cases[Thread[ 501 | Keys@nbhd -> 502 | result[[1, x*y*p + 1 ;; x*y*p + Length@nbhd]]], (k_ -> 503 | True) :> k]}, #] &@ 504 | Nest[BlockMap[ 505 | Flatten@# /. {{0 | gen - 1, 0} -> 0, {i_, 0} /; i < gen - 1 :> 506 | i + 1, {_, i_} /; i > 0 :> i} &, 507 | Prepend[#, 508 | Drop[ArrayPad[ 509 | Last@#, {If[dx > 0, {0, dx}, {-dx, 0}], 510 | If[dy > 0, {0, dy}, {-dy, 0}]}], dx, dy]], {2, 1, 1}, 511 | 1] &, Transpose[ 512 | Mod[random + ArrayReshape[Boole@result[[1]], {x, y, p}], 513 | 2], {2, 3, 1}], gen - 2]]]; 514 | 515 | Options[LifeFind] = 516 | Union[Options[SearchPattern], Options[PlotAndPrintRLE]]; 517 | LifeFind[x_, y_, args___, opts : OptionsPattern[]] := 518 | Block[{rule, result, bounded}, {rule, result} = 519 | If[OptionValue["Rule"] == "", 520 | If[# == {}, {$Rule, {}}, {ToRuleString[#[[2]], 521 | "Hexagonal" -> OptionValue["Hexagonal"], 522 | "Generations" -> OptionValue["Generations"]], #[[1]]}] &@ 523 | SearchPattern[x, y, args, 524 | FilterRules[{opts}, Options[SearchPattern]]], {ToString@ 525 | OptionValue["Rule"], 526 | SearchPattern[x, y, args, 527 | FilterRules[{opts}, Options[SearchPattern]]]}]; 528 | bounded[a_?AtomQ] := bounded[{a, a}]; 529 | bounded[{0 | True, 0 | True}] := 530 | ":T" <> ToString@y <> "," <> ToString@x; 531 | bounded[{0 | True, a_Integer}] := 532 | ":T" <> ToString@y <> "," <> ToString@x <> If[a > 0, "+", ""] <> 533 | ToString@a; 534 | bounded[{a_Integer, 0 | True}] := 535 | ":T" <> ToString@y <> If[a > 0, "+", ""] <> ToString@a <> "," <> 536 | ToString@x; 537 | bounded[__] = ""; 538 | If[result != {}, 539 | PlotAndPrintRLE[result, 540 | "Rule" -> rule <> bounded[OptionValue["Agar"]]]]]; 541 | 542 | Options[Predecessor] = 543 | FilterRules[Options[SearchPattern], Except["Periodic"]]; 544 | Predecessor[pattern_, opt : OptionsPattern[]] := 545 | Predecessor[pattern, 1, opt]; 546 | Predecessor[pattern_, n_, opt : OptionsPattern[]] := 547 | SearchPattern[Dimensions[pattern][[1]], Dimensions[pattern][[2]], 548 | n + 1, "Periodic" -> False, opt, 549 | "KnownCells" -> Append[ConstantArray[{}, n], pattern]]; 550 | 551 | Options[CA] = {"Rule" :> $Rule}; 552 | CA[pattern_, gen_, opts : OptionsPattern[]] := 553 | CellularAutomaton[{RuleNumber@OptionValue["Rule"], 554 | 2, {1, 1}}, {pattern, 0}, gen]; 555 | 556 | Options[ExportGIF] = 557 | Join[{"DisplayDurations" -> 0.5}, Options[CA], 558 | Options[ArrayPlot] /. (Mesh -> False) -> (Mesh -> All)]; 559 | ExportGIF[file_, pattern_, gen_, opts : OptionsPattern[]] := 560 | Export[file, 561 | ArrayPlot[#, Mesh -> All, 562 | FilterRules[{opts}, Options[ArrayPlot]]] & /@ 563 | CA[pattern, gen - 1, FilterRules[{opts}, Options[CA]]], 564 | "DisplayDurations" -> OptionValue["DisplayDurations"], 565 | "AnimationRepetitions" -> Infinity]; 566 | 567 | Options[ExportSpaceshipGIF] = 568 | Join[{"DisplayDurations" -> 0.1, "Padding" -> 2}, Options[CA]]; 569 | ExportSpaceshipGIF[file_, pattern_, p_, dx_, dy_, s_, 570 | opts : OptionsPattern[]] := 571 | With[{g = GCD[dx, dy], u = s GCD[dx, dy]/p}, 572 | Export[file, 573 | Catenate@ 574 | MapIndexed[ 575 | Table[Image@ 576 | RotateLeft[ 577 | ArrayFlatten[ 578 | Map[ArrayPad[Table[1 - #, s - 2, s - 2], 1, 0.6] &, 579 | ArrayPad[#, OptionValue["Padding"]], {2}]], 580 | {dx, dy}/g Tr[u (#2 - 1) + i]], {i, u}] &, 581 | CA[pattern, p - 1, FilterRules[{opts}, Options[CA]]]], 582 | "DisplayDurations" -> OptionValue["DisplayDurations"], 583 | "AnimationRepetitions" -> Infinity]]; 584 | 585 | PatternRules::nrule = "No such rule."; 586 | Options[PatternRules] := {"B0" -> False, "Hexagonal" -> False, 587 | "Totalistic" -> False}; 588 | PatternRules[pattern_, OptionsPattern[]] := 589 | Block[{nbhd = 590 | If[OptionValue["Hexagonal"], 591 | If[OptionValue["Totalistic"], NbhdNumberHT, NbhdNumberH], 592 | If[OptionValue["Totalistic"], NbhdNumberT, NbhdNumber]]}, 593 | Catch[KeySort@ 594 | Merge[Flatten@ 595 | BlockMap[ 596 | Position[nbhd, FromDigits[Flatten@#[[1]], 2]][[1, 1, 1]] -> 597 | #[[2, 2, 2]] &, 598 | MapIndexed[ 599 | ArrayPad[#, 2, 600 | If[OptionValue["B0"], 1/2 + (-1)^Tr@#2/2, 0]] &, 601 | pattern], {2, 3, 3}, 1], 602 | Switch[Union@#, {0}, False, {1}, True, _, 603 | Throw[Message[PatternRules::nrule]]] &]]]; 604 | 605 | End[]; 606 | 607 | EndPackage[]; 608 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [LifeFind](https://github.com/AlephAlpha/LifeFind) 2 | 3 | A simple and naïve Game of Life pattern searcher written in Wolfram Language. 4 | 5 | ![Screenshot](Screenshot.png) 6 | 7 | 这是个用来搜索生命游戏（以及别的 Life-like 的元胞自动机）里的图样的 Mathematica 包。搜索方式是把图样要满足的条件看成一个 [SAT 问题](https://en.wikipedia.org/wiki/Boolean_satisfiability_problem)，然后用 Mathematica 自带的 [`SatisfiabilityInstances`](http://reference.wolfram.com/language/ref/SatisfiabilityInstances.html) 函数求解。灵感来自 Oscar Cunningham 写的 [Logic Life Search](https://github.com/OscarCunningham/logic-life-search)。 8 | 9 | 这个包就是写着玩的，搜索速度慢得离谱，完全无法搜索周期稍大的图样。如果需要实用一点的搜索工具，推荐使用 [Logic Life Search](https://github.com/OscarCunningham/logic-life-search)（可搜各种图样），或者 [ntzfind](https://github.com/rokicki/ntzfind)（专搜飞船）。更多搜索工具见[《生命游戏搜索程序汇总》](https://alephalpha.github.io/posts/96f4eb3/)。 10 | 11 | 我不怎么懂编程，代码肯定有很多 bug。遇到问题欢迎来提 [issue](https://github.com/AlephAlpha/LifeFind/issues)。 12 | 13 | 以下是简短的英文说明。详细的用法见[维基](https://github.com/AlephAlpha/LifeFind/wiki)（仅中文），或者[使用范例](https://alephalpha.github.io/posts/18a3d91c/)。 14 | 15 | --- 16 | 17 | This is a Mathematica package for finding patterns in life-like cellular automata. Inspired by Oscar Cunningham's [Logic Life Search](https://github.com/OscarCunningham/logic-life-search), it converts the problem to a [SAT problem](https://en.wikipedia.org/wiki/Boolean_satisfiability_problem), and solves it with the built-in function [`SatisfiabilityInstances`](http://reference.wolfram.com/language/ref/SatisfiabilityInstances.html). 18 | 19 | ## Usage 20 | 21 | This is a Mathematica package, so you need [_Wolfram Mathematica_](http://www.wolfram.com/mathematica/). [Here](http://support.wolfram.com/kb/5648) is a installation guide for any Mathemaica packages. 22 | 23 | After the installation, you can load the package with 24 | 25 | ``` mathematica 26 | << Life` 27 | ``` 28 | 29 | The main function in the package is `LifeFind`. `LifeFind[x, y, p, dx, dy]` will try to find a pattern with size `(x,y)`, period `p` (default = `1`), and translating `(dx,dy)` (default = `(0,0)`) during a period. 30 | 31 | For example, this may find [25P3H1V0.1](http://conwaylife.com/wiki/25P3H1V0.1): 32 | 33 | ``` mathematica 34 | LifeFind[5, 16, 3, 1, 0] 35 | ``` 36 | 37 | You can specify the rule and the [symmetry](http://www.conwaylife.com/wiki/Symmetry) with options `"Rule"` and `"Symmetry"` (see the screenshot above). The default rule is `"B3/S23"` (Conway's Game of Life). The supported symmetries are the same as Logic Life Search. 38 | 39 | If you can read Chinese, please read the [Wiki](https://github.com/AlephAlpha/LifeFind/wiki) or these [usage examples](https://alephalpha.github.io/posts/18a3d91c/). 40 | 41 | ## Supported rules 42 | 43 | * [Totalistic](http://conwaylife.com/wiki/Outer-totalistic_Life-like_cellular_automata) and [non-totalistic](http://conwaylife.com/wiki/Non-totalistic_Life-like_cellular_automaton) life-like rules 44 | * Totalistic and non-totalistic [hexagonal](http://www.conwaylife.com/wiki/Hexagonal_neighbourhood) rules (hexagonal symmetries are _not_ supported) 45 | * The corresponding [Generations](http://www.conwaylife.com/wiki/Generations) rules. 46 | 47 | The output for Generations rules might be incomplete: there might be "dying" cells outside the bounding box. I will _not_ fix this. 48 | 49 | If `"Rule"` is set to `""`, it will search in an unspecified rule, and return both the rule and the pattern. This is extremely slow, and the rule string is _not_ simplified. 50 | -------------------------------------------------------------------------------- /Screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AlephAlpha/LifeFind/dba99e58492026c2813b0695fcd4aa84dbced57a/Screenshot.png --------------------------------------------------------------------------------