├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── CLI.hs ├── Main.hs ├── Online.hs ├── Parse.hs └── Train.hs ├── bench └── BenchMain.hs ├── jstris-ai.cabal ├── package.yaml ├── src ├── AI.hs ├── Grenade │ ├── Exts.hs │ └── Exts │ │ ├── Adam.hs │ │ ├── Gradient.hs │ │ └── Layer.hs ├── MCTS.hs └── Tetris │ ├── Action.hs │ ├── Block.hs │ ├── Board.hs │ ├── Simulator.hs │ └── State.hs ├── stack.yaml └── stack.yaml.lock /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | tetris.cabal 3 | *~ 4 | *.prof 5 | population* 6 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for jstris-ai 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # jstris-ai 2 | 3 | Jstris-ai is a bot designed to play tetris on [Jstris](https://jstris.jezevec10.com/). 4 | The program works by controlling Chrome via [Selenium](https://selenium.dev/). 5 | The program requires Selenium version 2.53.1, which you can find [here](http://selenium-release.storage.googleapis.com/index.html). 6 | You also need to install the Selenium Chrome Driver, which you can find [here](https://chromedriver.chromium.org/downloads). 7 | I am testing the program against Chrome 78. 8 | 9 | Note that the program is very brittle. 10 | I've hard coded a lot of assumptions about the DOM of Jstris and how it renders. 11 | These assumptions hold on my computer when I'm writing this program, but there are no guarantees that they will continue to hold on another computer, or in the future. 12 | If you're trying to build this, good luck! 13 | 14 | # Attribution 15 | 16 | The AI right now is almost an exact clone of [Lee Yiyuan's AI](https://github.com/LeeYiyuan/tetrisai). 17 | 18 | # Building 19 | 20 | This program is built with [Stack](https://docs.haskellstack.org/en/stable/README/). 21 | Once you have stack installed, simply run `stack build` from the project root to build the program. 22 | 23 | # Running 24 | 25 | 1. First, start the Selenium server. 26 | You can probably do this by just double clicking the jar file you downloaded above. 27 | Alternatively, you can run it from the command line via `java -jar /path/to/selenium-server-standalone-2.53.1.jar`. 28 | Note that Selenium needs to be able to find the Chrome Driver. 29 | Make sure the Chrome Driver executable you downloaded is in your PATH. 30 | 1. Now, you should be ready to run the AI! Simply run `stack run` from the project root. 31 | And that's that! 32 | 33 | 34 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/CLI.hs: -------------------------------------------------------------------------------- 1 | module CLI where 2 | 3 | import AI 4 | import qualified Data.ByteString as B 5 | import Grenade (Gradients) 6 | import Grenade.Exts.Adam 7 | import Options.Applicative 8 | 9 | 10 | -- FilePath: Read AIState from file 11 | -- True: Read AIState from stdin 12 | -- False: Random AIState 13 | type AISpec = Either FilePath Bool 14 | 15 | parseAISpec :: AISpec -> IO AIState 16 | parseAISpec (Left f) = (either fail pure . parseAI) =<< B.readFile f 17 | parseAISpec (Right True) = (either fail pure . parseAI ) =<< B.getContents 18 | parseAISpec (Right False) = defaultState 19 | 20 | data Command = Run AISpec String | Simulate AISpec Bool | Train (Adam (Gradients NL)) AISpec Bool (Maybe FilePath) 21 | 22 | aiFileOpt :: Parser FilePath 23 | aiFileOpt = strOption $ opts 24 | where opts = short 'f' 25 | <> long "file" 26 | <> help "Load the AI from the specified file." 27 | <> metavar "FILE" 28 | 29 | aiStdFlag :: Parser Bool 30 | aiStdFlag = flag False True opts 31 | where opts = short 'i' 32 | <> long "stdin" 33 | <> help "Read the AI from stdin." 34 | 35 | aiSpecOpt :: Parser AISpec 36 | aiSpecOpt = fmap Left aiFileOpt <|> fmap Right aiStdFlag 37 | 38 | 39 | urlOpt :: Parser String 40 | urlOpt = fmap ("https://jstris.jezevec10.com/" <>) . strOption $ opts 41 | where opts = short 'g' 42 | <> long "game" 43 | <> help "The specific game on jstris to join, as a subdomain of https://jstris.jezevec10.com/. For instance, to play Cheese Race you would specify '?play=3&mode=1'" 44 | <> value "" 45 | <> metavar "PATH" 46 | 47 | verboseFlag :: Parser Bool 48 | verboseFlag = flag False True opts 49 | where opts = short 'v' 50 | <> long "verbose" 51 | <> help "Whether to print out the game state after each tick." 52 | 53 | alphaOpt :: Parser Double 54 | alphaOpt = option auto $ opts 55 | where opts = short 'a' 56 | <> long "alpha" 57 | <> help "Adam's learning rate" 58 | <> value 0.001 59 | <> metavar "LR" 60 | 61 | beta1Opt :: Parser Double 62 | beta1Opt = option auto $ opts 63 | where opts = short 'b' 64 | <> long "beta1" 65 | <> help "Adam's running average coefficient for the gradient" 66 | <> value 0.9 67 | <> metavar "C" 68 | beta2Opt :: Parser Double 69 | beta2Opt = option auto $ opts 70 | where opts = short 'B' 71 | <> long "beta2" 72 | <> help "Adam's running average coefficient for the gradient squared" 73 | <> value 0.999 74 | <> metavar "C" 75 | 76 | epsOpt :: Parser Double 77 | epsOpt = option auto $ opts 78 | where opts = short 'e' 79 | <> long "epsilon" 80 | <> help "Term added to increase numerical stability" 81 | <> value 1e-8 82 | <> metavar "C" 83 | 84 | adamP :: Parser (Adam (Gradients NL)) 85 | adamP = Adam <$> fmap rtf alphaOpt <*> fmap rtf beta1Opt <*> fmap rtf beta2Opt <*> fmap rtf epsOpt <*> pure (rtf 0) <*> pure (rtf 0) <*> pure 0 86 | where rtf = realToFrac 87 | 88 | aiOutFileOpt :: Parser (Maybe FilePath) 89 | aiOutFileOpt = optional . strOption $ opts 90 | where opts = short 'o' 91 | <> long "out" 92 | <> help "Which file to save the trained AI to" 93 | <> metavar "FILE" 94 | 95 | parserInfo :: ParserInfo Command 96 | parserInfo = info (helper <*> (parser <|> runP)) (progDesc "jstris-ai manages an AI that can play jstris, an online, multiplayer version of Tetris found at https://jstris.jezevec10.com/.") 97 | where parser = hsubparser . mconcat . fmap command' $ 98 | [ ("run", "Run the AI online.", runP) 99 | , ("simulate", "Run the AI locally.", simP) 100 | , ("train", "Train a new AI.", trainP) 101 | ] 102 | runP = Run <$> aiSpecOpt <*> urlOpt 103 | simP = Simulate <$> aiSpecOpt <*> verboseFlag 104 | trainP = Train <$> adamP <*> aiSpecOpt <*> verboseFlag <*> aiOutFileOpt 105 | command' (n,d,p) = command n . info p . progDesc $ d 106 | 107 | 108 | processCLI :: IO Command 109 | processCLI = execParser parserInfo 110 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Control.Monad.IO.Class 5 | import Control.Monad.Trans.State.Strict 6 | import System.Random 7 | 8 | import AI 9 | import CLI 10 | import Online 11 | import Tetris.Board 12 | import Tetris.Simulator 13 | import Tetris.State 14 | import Train 15 | 16 | main :: IO () 17 | main = do 18 | cmd <- processCLI 19 | case cmd of 20 | Run a u -> parseAISpec a >>= \a' -> runOnline a' u 21 | Simulate a v -> parseAISpec a >>= \a' -> runSimulation a' v 22 | Train ad a v o -> parseAISpec a >>= \a' -> runTraining ad a' v o 23 | 24 | ----------------------- 25 | ----------------------- 26 | -- | Simulate Code | -- 27 | ----------------------- 28 | ----------------------- 29 | 30 | runSimulation :: AIState -> Bool -> IO () 31 | runSimulation ai v = flip evalStateT ai . go 0 . startingState =<< getStdGen 32 | where go :: Int -> SimulatorState -> StateT AIState IO () 33 | go n st = do 34 | when v . liftIO . (>> putStrLn "") . printBoard . addActiveBlock (board . gs $ st) . active . gs $ st 35 | acts <- runAI 10 (gs st) 36 | let acts' :: [Maybe SimulatorState -> StateT AIState IO (Maybe SimulatorState)] 37 | acts' = fmap (\(a,_) -> fmap (fmap fst . join) . sequence . fmap (advance n a)) acts 38 | st' <- foldl (>=>) (pure . id) acts' (Just st) 39 | case st' of 40 | Just s -> go (n + 1) s 41 | Nothing -> pure () 42 | -------------------------------------------------------------------------------- /app/Online.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Online where 4 | 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans.Random.Strict 7 | import Control.Monad.Trans 8 | import Control.Monad.Trans.State.Strict 9 | import Data.Text (Text) 10 | import qualified Data.Vector as V 11 | import qualified Data.Vector.Sized as VS 12 | import Data.Map.Strict (Map) 13 | import qualified Data.Map.Strict as M 14 | import Data.Maybe (fromJust) 15 | import System.Random 16 | import Test.WebDriver 17 | import Test.WebDriver.Commands.Wait 18 | import Test.WebDriver.JSON (ignoreReturn) 19 | 20 | import AI 21 | import Parse 22 | import Tetris.Block 23 | import Tetris.Board 24 | import Tetris.State 25 | 26 | chromeConfig :: WDConfig 27 | chromeConfig = useBrowser chrome defaultConfig 28 | 29 | inGame :: WD Bool 30 | inGame = not <$> executeJS [] "return window.game == null || window.game.gameEnded" 31 | 32 | waitForGameStart :: WD () 33 | waitForGameStart = waitUntil' 10000 600 $ do 34 | expect =<< inGame 35 | 36 | -- Given a frame index, waits for a higher frame index and then retrieves the associated frame. 37 | nextState :: Int -> WD (Int, GameState, [[Int]]) 38 | nextState curr = waitUntil' 10000 600 $ do 39 | count <- executeJS [] "return window.fcount;" 40 | expect $ count > curr 41 | 42 | (matrix, act, hld, hldUsed, cbo, q, inc) <- executeJS [] "return [window.game.matrix, window.game.activeBlock, window.game.blockInHold, window.game.holdUsedAlready, window.game.comboCounter, window.game.queue, window.game.incomingGarbage]" 43 | let brd = fromSquares . fromJust . VS.toSized . V.map (fromJust . VS.toSized . V.map (colorsToSquare M.!)) $ matrix 44 | garbage = fmap head $ inc 45 | gs = GameState brd act (kind <$> hld) (not hldUsed) (cbo + 1) (kind <$> q) garbage 46 | pure (count, gs, inc) 47 | 48 | type Lines = Map Int Int 49 | type Histogram = Map Int Int 50 | 51 | mainLoop :: AIState -> WD (Lines, Int) 52 | mainLoop = fmap fst . evalRandTIO . runStateT (go (0, (M.empty, 0))) 53 | where go :: (Int, (Lines, Int)) -> StateT AIState (RandT StdGen WD) (Lines, Int) 54 | go = guardInGame $ \(curr, (h, pct)) -> do 55 | (curr', state, inc) <- lift . lift . nextState $ curr 56 | let h' = foldr id h . fmap (\[size, id] -> M.insertWith (flip const) id size) $ inc 57 | -- liftIO . printBoard . addActiveBlock (board state) . active $ state 58 | 59 | keys <- runAI 10 state 60 | -- liftIO . putStrLn $ "Keys: " <> show keys 61 | 62 | body <- lift . lift . findElem $ ByTag "body" 63 | lift . lift . sendKeys (mconcat . fmap (actionToText . fst) $ keys) $ body 64 | 65 | go (curr', (h', pct + 1)) 66 | guardInGame :: ((Int, (Lines, Int)) -> StateT AIState (RandT StdGen WD) (Lines, Int)) -> (Int, (Lines, Int)) -> StateT AIState (RandT StdGen WD) (Lines, Int) 67 | guardInGame act p = do 68 | running <- lift (lift inGame) 69 | if running 70 | then act p 71 | else pure . snd $ p 72 | 73 | updateHist :: Histogram -> Lines -> Histogram 74 | updateHist = M.foldr (\v -> M.insertWith (+) v 1) 75 | 76 | runOnline :: AIState -> String -> IO () 77 | runOnline ai url = runSession chromeConfig . finallyClose $ do 78 | openPage url 79 | ignoreReturn $ executeJS [] extractGameTrackFrameJS 80 | 81 | flip execStateT (M.empty, 0) . sequence . repeat $ do 82 | liftIO $ putStrLn "Waiting for game to start..." 83 | lift waitForGameStart 84 | liftIO $ putStrLn "Game starting!" 85 | (hist, pcs) <- get 86 | (lines, ct) <- lift (mainLoop ai) 87 | if not (null lines) then do 88 | let hist' = updateHist hist lines 89 | put (hist', pcs + ct) 90 | liftIO . print $ hist' 91 | liftIO . print $ pcs + ct 92 | else pure () 93 | liftIO $ putStrLn "Game complete!" 94 | pure () 95 | 96 | -- This function injects some code into the render loop which lets us keep track 97 | -- of frames. It also puts the Game instance in a global variable so we can directly 98 | -- read the state. 99 | extractGameTrackFrameJS :: Text 100 | extractGameTrackFrameJS = " window.fcount = 0; \ 101 | \ window.game = null; \ 102 | \ var rd = Game.prototype.redraw; \ 103 | \ Game.prototype.redraw = function() { \ 104 | \ rd.apply(this,arguments); \ 105 | \ window.game = this; \ 106 | \ window.fcount += 1; \ 107 | \ };" 108 | -------------------------------------------------------------------------------- /app/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Parse where 3 | 4 | import Control.Monad 5 | import Data.Aeson 6 | import Data.Map.Strict (Map) 7 | import qualified Data.Map.Strict as M 8 | import Data.Text (Text) 9 | import qualified Test.WebDriver.Common.Keys as K 10 | 11 | import Tetris.Action 12 | import Tetris.Block 13 | import Tetris.Board 14 | 15 | idsToBlock :: Map Int Block 16 | idsToBlock = M.fromList [ (0, I) 17 | , (1, O) 18 | , (2, T) 19 | , (3, L) 20 | , (4, J) 21 | , (5, S) 22 | , (6, Z) 23 | ] 24 | 25 | colorsToSquare :: Map Int Square 26 | colorsToSquare = M.fromList [ (0, Empty) 27 | , (1, Garbage) 28 | , (2, Garbage) 29 | , (3, Garbage) 30 | , (4, Garbage) 31 | , (5, Garbage) 32 | , (6, Garbage) 33 | , (7, Garbage) 34 | , (8, Garbage) 35 | , (9, HurryUp) 36 | ] 37 | 38 | instance FromJSON ActiveBlock where 39 | parseJSON (Object v) = ActiveBlock <$> fmap (idsToBlock M.!) (v .: "id") 40 | <*> (parsePos =<< v.: "pos") 41 | <*> v .: "rot" 42 | where parsePos (Object v) = (,) <$> v .: "y" <*> v .: "x" 43 | parsePos _ = mzero 44 | parseJSON _ = mzero 45 | 46 | actionToText :: Action -> Text 47 | actionToText MoveLeft = K.arrowLeft 48 | actionToText MoveRight = K.arrowRight 49 | actionToText SoftDrop = K.arrowDown 50 | actionToText HardDrop = " " 51 | actionToText RotateLeft = "z" 52 | actionToText RotateRight = K.arrowUp 53 | actionToText Hold = "c" 54 | -------------------------------------------------------------------------------- /app/Train.hs: -------------------------------------------------------------------------------- 1 | module Train where 2 | 3 | import Control.Monad 4 | import Control.Monad.Trans.State.Strict 5 | import qualified Data.ByteString as B 6 | import Data.Maybe (fromJust, isNothing) 7 | import Grenade 8 | import System.Random 9 | import Text.Printf 10 | 11 | import AI 12 | import Grenade.Exts 13 | import Tetris.Action 14 | import Tetris.Block 15 | import Tetris.Board 16 | import Tetris.Simulator 17 | import Tetris.State 18 | 19 | data TState = TState { ss :: SimulatorState 20 | , as :: AIState 21 | , stp :: Int 22 | , kp :: Int 23 | , rollout :: [(Float, Gradients NL)] 24 | , adam :: Adam (Gradients NL) 25 | , episode :: Int 26 | , avg :: Float 27 | } 28 | 29 | resetSim :: TState -> IO TState 30 | resetSim ts = fmap (\g -> ts{ss = startingState g, stp = 0, kp = 0}) getStdGen 31 | 32 | updateNet :: TState -> TState 33 | updateNet st = st{rollout = [], adam = ad', as = AIState Nothing} 34 | where gamma = 0.95 35 | (_,gtrl) = foldl (\(v,ls) (r,g) -> let nv = gamma * v + r in (nv, (nv,g):ls)) (0, []) (rollout st) 36 | average :: Fractional n => [n] -> n 37 | average = (/) <$> sum <*> (realToFrac . length) 38 | avg :: Float 39 | avg = average (fmap fst gtrl) 40 | stdev :: Float 41 | stdev = sqrt . average . fmap (\(x,_) -> (x - avg)^2) $ gtrl 42 | rtf = realToFrac 43 | upd = foldr (\(x,g) ag -> ag + ((negate . rtf $ (x - avg) / (stdev + 1e-9)) * g)) (rtf 0) gtrl 44 | (ad', nn') = runAdam (adam st) upd (nn . as $st) 45 | 46 | nextEp :: Maybe FilePath -> TState -> IO TState 47 | nextEp fp ts = when (ep `mod` 10 == 0) logStat >> (resetSim . updateNet) ts{episode = ep, avg = navg} 48 | where reward = sum . fmap fst . rollout $ ts 49 | ep = 1 + episode ts 50 | navg = 0.05 * reward + 0.95 * (avg ts) 51 | logStat = do 52 | printf "Episode: %d Last reward: %.02f Average: %.02f\n" ep reward navg 53 | void . sequence . fmap (\afp -> B.writeFile afp . saveAI . as $ ts) $ fp 54 | 55 | step :: Bool -> Maybe FilePath -> TState -> IO TState 56 | step v fp ts = do 57 | when v . (>> putStrLn "") . printBoard . addActiveBlock (board . gs . ss $ ts) . active . gs . ss $ ts 58 | ((act, grad), as') <- runStateT (stepAI (gs . ss $ ts)) (as ts) 59 | act <- if kp ts == 10 then pure HardDrop else pure act 60 | nxt <- advance (stp ts) act (ss ts) 61 | if isNothing nxt 62 | then nextEp fp ts{rollout = (0,grad):(rollout ts)} 63 | else let (ss', atk) = fromJust nxt 64 | hd = act == HardDrop 65 | stp' = stp ts + (if hd then 1 else 0) 66 | kp' = if hd then 0 else 1 + (kp ts) 67 | rwd = 10 * (realToFrac atk) + if hd then (score . board . gs . ss $ ts) else 0 68 | rl' = (rwd, grad):(rollout ts) 69 | in pure ts{ss=ss', as=as', stp=stp', kp=kp', rollout=rl'} 70 | 71 | 72 | runTraining :: Adam (Gradients NL) -> AIState -> Bool -> Maybe FilePath -> IO () 73 | runTraining ad a v f = go =<< TState <$> fmap startingState getStdGen <*> pure a <*> pure 0 <*> pure 0 <*> pure [] <*> pure ad <*> pure 0 <*> pure 0 74 | where go :: TState -> IO () 75 | go = step v f >=> go 76 | 77 | aggregateHeight :: Board -> Int 78 | aggregateHeight board = sum (height board <$> [0..9]) 79 | 80 | height :: Board -> Col -> Int 81 | height board c = (20 -) . head . (<> [20]) . filter (\r -> getSquare (r,c) board /= Empty) $ [0..19] 82 | 83 | completeLines :: Board -> Int 84 | completeLines board = length . filter (complete board) $ [0..19] 85 | 86 | holes :: Board -> Int 87 | holes board = sum (colHoles <$> [0..9]) 88 | where colHoles :: Col -> Int 89 | colHoles c = length . filter (\r -> r > (20 - height board c) && getSquare (r,c) board == Empty) $ [0..19] 90 | 91 | bumpiness :: Board -> Int 92 | bumpiness board = sum . fmap (\c -> abs (height board c - height board (c + 1))) $ [0..8] 93 | 94 | -- See https://codemyroad.wordpress.com/2013/04/14/tetris-ai-the-near-perfect-player/ 95 | score :: Board -> Float 96 | score board = (-0.510066 * itf (aggregateHeight board)) + (0.760666 * itf (completeLines board)) + (-0.35663 * itf (holes board)) + (-0.184483 * itf (bumpiness board)) 97 | where itf = fromInteger . toInteger 98 | -------------------------------------------------------------------------------- /bench/BenchMain.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.IO.Class 2 | import Control.Monad.Random 3 | import Criterion.Main 4 | 5 | import MCTS 6 | import Tetris.Action 7 | import Tetris.Simulator 8 | 9 | main = defaultMain [ 10 | bgroup "strip" [ bench "5 step sim" $ nfIO ((\g -> fmap fst $ runSimulation g 5) =<< getStdGen) 11 | , bench "10 step sim" $ nfIO ((\g -> fmap fst $ runSimulation g 10) =<< getStdGen) 12 | , bench "20 step sim" $ nfIO ((\g -> fmap fst $ runSimulation g 20) =<< getStdGen) 13 | , bench "5 step sim a" $ nfIO ((\g -> fmap fst $ runSimulation2 g 5) =<< getStdGen) 14 | , bench "10 step sim a" $ nfIO ((\g -> fmap fst $ runSimulation2 g 10) =<< getStdGen) 15 | , bench "20 step sim a" $ nfIO ((\g -> fmap fst $ runSimulation2 g 20) =<< getStdGen) 16 | ] 17 | ] 18 | 19 | runSimulation :: RandomGen g => MonadIO m => g -> Int -> m (Reward, g) 20 | runSimulation g mx = flip runRandT g . simulateU mct mx . gs . startingState $ g 21 | where mct = MCTS { linesToReward = fromInteger . toInteger 22 | , stateToReward = const 0 23 | , simulate = const (pure 0) 24 | , lossReward = 0 25 | , gamma = 1 26 | , cp = 1 / sqrt 2 27 | } 28 | 29 | runSimulation2 :: RandomGen g => MonadIO m => g -> Int -> m (Reward, g) 30 | runSimulation2 g mx = flip runRandT g . simulateA mct mx . gs . startingState $ g 31 | where mct = MCTS { linesToReward = fromInteger . toInteger 32 | , stateToReward = const 0 33 | , simulate = const (pure 0) 34 | , lossReward = 0 35 | , gamma = 1 36 | , cp = 1 / sqrt 2 37 | } 38 | -------------------------------------------------------------------------------- /jstris-ai.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 4799af0e580aa2c56290ec60b2656773352720be4055519a53087e55832ec4bc 8 | 9 | name: jstris-ai 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/jbrot/jstris-ai#readme 13 | bug-reports: https://github.com/jbrot/jstris-ai/issues 14 | author: Joshua Brot 15 | maintainer: jbrot@umich.edu 16 | copyright: 2019(c) Joshua Brot 17 | license: GPL-3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/jbrot/jstris-ai 27 | 28 | library 29 | exposed-modules: 30 | AI 31 | Grenade.Exts 32 | Grenade.Exts.Adam 33 | Grenade.Exts.Gradient 34 | Grenade.Exts.Layer 35 | MCTS 36 | Tetris.Action 37 | Tetris.Block 38 | Tetris.Board 39 | Tetris.Simulator 40 | Tetris.State 41 | other-modules: 42 | Paths_jstris_ai 43 | hs-source-dirs: 44 | src 45 | ghc-options: -W 46 | build-depends: 47 | MonadRandom 48 | , aeson 49 | , base >=4.7 && <5 50 | , bytestring 51 | , cereal 52 | , clock 53 | , containers 54 | , finitary 55 | , finitary-derive 56 | , finite-typelits 57 | , ghc-prim 58 | , grenade 59 | , hmatrix 60 | , logict 61 | , mtl 62 | , optparse-applicative 63 | , parallel 64 | , random 65 | , random-shuffle 66 | , singletons 67 | , text 68 | , time 69 | , transformers 70 | , vector 71 | , vector-sized 72 | , webdriver 73 | default-language: Haskell2010 74 | 75 | executable jstris-ai-exe 76 | main-is: Main.hs 77 | other-modules: 78 | CLI 79 | Online 80 | Parse 81 | Train 82 | Paths_jstris_ai 83 | hs-source-dirs: 84 | app 85 | ghc-options: -W -threaded -rtsopts -with-rtsopts=-N -W 86 | build-depends: 87 | MonadRandom 88 | , aeson 89 | , base >=4.7 && <5 90 | , bytestring 91 | , cereal 92 | , clock 93 | , containers 94 | , finitary 95 | , finitary-derive 96 | , finite-typelits 97 | , ghc-prim 98 | , grenade 99 | , hmatrix 100 | , jstris-ai 101 | , logict 102 | , mtl 103 | , optparse-applicative 104 | , parallel 105 | , random 106 | , random-shuffle 107 | , singletons 108 | , text 109 | , time 110 | , transformers 111 | , vector 112 | , vector-sized 113 | , webdriver 114 | default-language: Haskell2010 115 | 116 | benchmark jstris-ai-bench 117 | type: exitcode-stdio-1.0 118 | main-is: BenchMain.hs 119 | other-modules: 120 | Paths_jstris_ai 121 | hs-source-dirs: 122 | bench 123 | ghc-options: -W -threaded -rtsopts -with-rtsopts=-N -O2 124 | build-depends: 125 | MonadRandom 126 | , aeson 127 | , base >=4.7 && <5 128 | , bytestring 129 | , cereal 130 | , clock 131 | , containers 132 | , criterion 133 | , finitary 134 | , finitary-derive 135 | , finite-typelits 136 | , ghc-prim 137 | , grenade 138 | , hmatrix 139 | , jstris-ai 140 | , logict 141 | , mtl 142 | , optparse-applicative 143 | , parallel 144 | , random 145 | , random-shuffle 146 | , singletons 147 | , text 148 | , time 149 | , transformers 150 | , vector 151 | , vector-sized 152 | , webdriver 153 | default-language: Haskell2010 154 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: jstris-ai 2 | version: 0.1.0.0 3 | github: "jbrot/jstris-ai" 4 | license: GPL-3 5 | author: "Joshua Brot" 6 | maintainer: "jbrot@umich.edu" 7 | copyright: "2019(c) Joshua Brot" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | ghc-options: 23 | - -W 24 | 25 | dependencies: 26 | - aeson 27 | - base >= 4.7 && < 5 28 | - bytestring 29 | - cereal 30 | - clock 31 | - containers 32 | - finite-typelits 33 | - finitary 34 | - finitary-derive 35 | - ghc-prim 36 | - grenade 37 | - hmatrix 38 | - logict 39 | - MonadRandom 40 | - mtl 41 | - optparse-applicative 42 | - parallel 43 | - random 44 | - random-shuffle 45 | - singletons 46 | - text 47 | - time 48 | - transformers 49 | - vector 50 | - vector-sized 51 | - webdriver 52 | 53 | library: 54 | source-dirs: src 55 | 56 | executables: 57 | jstris-ai-exe: 58 | main: Main.hs 59 | source-dirs: app 60 | ghc-options: 61 | - -threaded 62 | - -rtsopts 63 | - -with-rtsopts=-N 64 | - -W 65 | dependencies: 66 | - jstris-ai 67 | 68 | benchmarks: 69 | jstris-ai-bench: 70 | main: BenchMain.hs 71 | source-dirs: bench 72 | ghc-options: 73 | - -threaded 74 | - -rtsopts 75 | - -with-rtsopts=-N 76 | - -O2 77 | dependencies: 78 | - jstris-ai 79 | - criterion 80 | -------------------------------------------------------------------------------- /src/AI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators #-} 2 | module AI (NL, NNet, AIState (AIState), nn, defaultState, parseAI, saveAI, stepAI, runAI) where 3 | 4 | import Control.Monad.Random 5 | import Control.Monad.Trans.State.Strict 6 | import Data.ByteString (ByteString) 7 | import Grenade 8 | import System.Clock 9 | 10 | import Tetris.Action 11 | import Tetris.Block 12 | import Tetris.Board 13 | import Tetris.State 14 | import MCTS 15 | 16 | -- Input: Board (200) + Queue (7 * 5 = 35) + Active (7) + Active Position (2) + Active Rotation (1) + Combo (1) + Incoming (1) = 247 17 | -- Output: Left | Right | Rotate Left | Rotate Right | Drop (5) 18 | type NL = '[ FullyConnected 247 1024, Relu, FullyConnected 1024 5, Softmax ] 19 | type NNet = Network NL '[ 'D1 247, 'D1 1024, 'D1 1024, 'D1 5, 'D1 5 ] 20 | 21 | data AIState = AIState { tree :: Maybe (MCTree TransitionState) 22 | } 23 | 24 | params :: MCTS 25 | params = MCTS { linesToReward = fromInteger . toInteger 26 | , stateToReward = const 0 27 | , simulate = pure . (+ 1) . (/ 100) . realToFrac . score . board 28 | , lossReward = -10 29 | , gamma = 1 30 | , cp = 1 / sqrt 2 31 | } 32 | 33 | defaultState :: IO AIState 34 | defaultState = pure (AIState Nothing) 35 | 36 | nn :: AIState -> NNet 37 | nn = undefined 38 | 39 | parseAI :: ByteString -> Either String AIState 40 | parseAI = undefined 41 | 42 | saveAI :: AIState -> ByteString 43 | saveAI = undefined 44 | 45 | stepAI :: (MonadRandom m, MonadIO m) => GameState -> StateT AIState m (Action, Gradients NL) 46 | stepAI = undefined 47 | 48 | iterateM :: Monad m => Int -> (a -> m a) -> a -> m a 49 | iterateM 0 f = f 50 | iterateM n f = f >=> iterateM (n - 1) f 51 | 52 | iterateUntil :: MonadIO m => TimeSpec -> (a -> m a) -> a -> m a 53 | iterateUntil t f a = do 54 | a' <- iterateM 100 f a 55 | now <- liftIO $ getTime Monotonic 56 | if now > t 57 | then pure a' 58 | else iterateUntil t f a' 59 | 60 | runAI :: (MonadRandom m, MonadIO m) => Int -> GameState -> StateT AIState m [(Action, Maybe (Gradients NL))] 61 | runAI _ gs = do 62 | oldT <- fmap tree get 63 | time <- liftIO $ getTime Monotonic 64 | newT <- iterateUntil (time + (TimeSpec 0 $ 100 * 1000 * 1000)) (fmap snd . rollout params) (newRootNode oldT gs) 65 | (choice, leftover) <- decide newT 66 | put (AIState leftover) 67 | pure $ fmap (\a -> (a, Nothing)) choice 68 | 69 | aggregateHeight :: Board -> Int 70 | aggregateHeight board = sum (height board <$> [0..9]) 71 | 72 | height :: Board -> Col -> Int 73 | height board c = (20 -) . head . (<> [20]) . filter (\r -> getSquare (r,c) board /= Empty) $ [0..19] 74 | 75 | completeLines :: Board -> Int 76 | completeLines board = length . filter (complete board) $ [0..19] 77 | 78 | holes :: Board -> Int 79 | holes board = sum (colHoles <$> [0..9]) 80 | where colHoles :: Col -> Int 81 | colHoles c = length . filter (\r -> r > (20 - height board c) && getSquare (r,c) board == Empty) $ [0..19] 82 | 83 | bumpiness :: Board -> Int 84 | bumpiness board = sum . fmap (\c -> abs (height board c - height board (c + 1))) $ [0..8] 85 | 86 | -- See https://codemyroad.wordpress.com/2013/04/14/tetris-ai-the-near-perfect-player/ 87 | score :: Board -> Float 88 | score board = (-0.510066 * itf (aggregateHeight board)) + (0.760666 * itf (completeLines board)) + (-0.35663 * itf (holes board)) + (-0.184483 * itf (bumpiness board)) 89 | where itf = fromInteger . toInteger 90 | -------------------------------------------------------------------------------- /src/Grenade/Exts.hs: -------------------------------------------------------------------------------- 1 | module Grenade.Exts ( module Grenade.Exts.Layer 2 | , module Grenade.Exts.Adam 3 | ) where 4 | 5 | import Grenade.Exts.Gradient () 6 | import Grenade.Exts.Layer 7 | import Grenade.Exts.Adam 8 | -------------------------------------------------------------------------------- /src/Grenade/Exts/Adam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeFamilies #-} 2 | module Grenade.Exts.Adam where 3 | 4 | import Grenade 5 | import Grenade.Exts.Gradient () 6 | import Grenade.Exts.Layer 7 | 8 | data Adam t = Adam { alpha :: t 9 | , beta1 :: t 10 | , beta2 :: t 11 | , epsilon :: t 12 | , mom :: t 13 | , vel :: t 14 | , time :: Int 15 | } 16 | 17 | defAdam :: (Fractional t) => Adam t 18 | defAdam = Adam (rtf 0.01) (rtf 0.9) (rtf 0.999) (rtf 1e-8) (rtf 0) (rtf 0) 0 19 | where rtf :: Fractional t => Double -> t 20 | rtf = realToFrac 21 | 22 | runAdam :: (All UpdateLayerRaw layers, Floating (Gradients layers)) => Adam (Gradients layers) -> Gradients layers -> Network layers shapes -> (Adam (Gradients layers), Network layers shapes) 23 | runAdam a g n = (a{mom = m, vel = v, time = t}, applyRaw del n) 24 | where t = 1 + (time a) 25 | m = (beta1 a) * (mom a) + (1 - beta1 a) * g 26 | v = (beta2 a) * (vel a) + (1 - beta2 a) * g * g 27 | at = (alpha a) * sqrt (1 - (beta2 a)^t) / (1 - (beta1 a)^t) 28 | del = -at * m / (sqrt v + epsilon a) 29 | -------------------------------------------------------------------------------- /src/Grenade/Exts/Gradient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, TypeFamilies, TypeOperators, UndecidableInstances #-} 2 | module Grenade.Exts.Gradient where 3 | 4 | import Data.Singletons.TypeLits 5 | import Grenade 6 | 7 | instance (KnownNat i, KnownNat o) => Num (FullyConnected' i o) where 8 | (FullyConnected' a b) + (FullyConnected' a2 b2) = FullyConnected' (a + a2) (b + b2) 9 | (FullyConnected' a b) * (FullyConnected' a2 b2) = FullyConnected' (a * a2) (b * b2) 10 | abs (FullyConnected' a b) = FullyConnected' (abs a) (abs b) 11 | signum (FullyConnected' a b) = FullyConnected' (signum a) (signum b) 12 | fromInteger n = FullyConnected' (fromInteger n) (fromInteger n) 13 | negate (FullyConnected' a b) = FullyConnected' (negate a) (negate b) 14 | instance (KnownNat i, KnownNat o) => Fractional (FullyConnected' i o) where 15 | recip (FullyConnected' a b) = FullyConnected' (recip a) (recip b) 16 | fromRational r = FullyConnected' (fromRational r) (fromRational r) 17 | instance (KnownNat i, KnownNat o) => Floating (FullyConnected' i o) where 18 | pi = FullyConnected' pi pi 19 | exp (FullyConnected' a b) = FullyConnected' (exp a) (exp b) 20 | log (FullyConnected' a b) = FullyConnected' (log a) (log b) 21 | sin (FullyConnected' a b) = FullyConnected' (sin a) (sin b) 22 | cos (FullyConnected' a b) = FullyConnected' (cos a) (cos b) 23 | asin (FullyConnected' a b) = FullyConnected' (asin a) (asin b) 24 | acos (FullyConnected' a b) = FullyConnected' (acos a) (acos b) 25 | atan (FullyConnected' a b) = FullyConnected' (atan a) (atan b) 26 | sinh (FullyConnected' a b) = FullyConnected' (sinh a) (sinh b) 27 | cosh (FullyConnected' a b) = FullyConnected' (cosh a) (cosh b) 28 | asinh (FullyConnected' a b) = FullyConnected' (asinh a) (asinh b) 29 | acosh (FullyConnected' a b) = FullyConnected' (acosh a) (acosh b) 30 | atanh (FullyConnected' a b) = FullyConnected' (atanh a) (atanh b) 31 | 32 | instance Num (Gradients '[]) where 33 | GNil + GNil = GNil 34 | GNil * GNil = GNil 35 | abs GNil = GNil 36 | signum GNil = GNil 37 | fromInteger _ = GNil 38 | negate GNil = GNil 39 | instance Fractional (Gradients '[]) where 40 | fromRational _ = GNil 41 | recip GNil = GNil 42 | instance Floating (Gradients '[]) where 43 | pi = GNil 44 | exp GNil = GNil 45 | log GNil = GNil 46 | sin GNil = GNil 47 | cos GNil = GNil 48 | asin GNil = GNil 49 | acos GNil = GNil 50 | atan GNil = GNil 51 | sinh GNil = GNil 52 | cosh GNil = GNil 53 | asinh GNil = GNil 54 | acosh GNil = GNil 55 | atanh GNil = GNil 56 | 57 | instance (Num (Gradients as), Num (Gradient a), UpdateLayer a) => Num (Gradients (a ': as)) where 58 | (a :/> b) + (a2 :/> b2) = (a + a2) :/> (b + b2) 59 | (a :/> b) * (a2 :/> b2) = (a * a2) :/> (b * b2) 60 | abs (a :/> b) = (abs a) :/> (abs b) 61 | signum (a :/> b) = (signum a) :/> (signum b) 62 | fromInteger n = (fromInteger n) :/> (fromInteger n) 63 | negate (a :/> b) = (negate a) :/> (negate b) 64 | instance (Fractional (Gradients as), Fractional (Gradient a), UpdateLayer a) => Fractional (Gradients (a ': as)) where 65 | fromRational r = (fromRational r) :/> (fromRational r) 66 | recip (a :/> b) = (recip a) :/> (recip b) 67 | instance (Floating (Gradients as), Floating (Gradient a), UpdateLayer a) => Floating (Gradients (a ': as)) where 68 | pi = pi :/> pi 69 | exp (a :/> b) = (exp a) :/> (exp b) 70 | log (a :/> b) = (log a) :/> (log b) 71 | sin (a :/> b) = (sin a) :/> (sin b) 72 | cos (a :/> b) = (cos a) :/> (cos b) 73 | asin (a :/> b) = (asin a) :/> (asin b) 74 | acos (a :/> b) = (acos a) :/> (acos b) 75 | atan (a :/> b) = (atan a) :/> (atan b) 76 | sinh (a :/> b) = (sinh a) :/> (sinh b) 77 | cosh (a :/> b) = (cosh a) :/> (cosh b) 78 | asinh (a :/> b) = (asinh a) :/> (asinh b) 79 | acosh (a :/> b) = (acosh a) :/> (acosh b) 80 | atanh (a :/> b) = (atanh a) :/> (atanh b) 81 | 82 | instance Num () where 83 | () + () = () 84 | () * () = () 85 | abs () = () 86 | signum () = () 87 | fromInteger _ = () 88 | negate () = () 89 | instance Fractional () where 90 | fromRational _ = () 91 | recip () = () 92 | instance Floating () where 93 | pi = () 94 | exp () = () 95 | log () = () 96 | sin () = () 97 | cos () = () 98 | asin () = () 99 | acos () = () 100 | atan () = () 101 | sinh () = () 102 | cosh () = () 103 | asinh () = () 104 | acosh () = () 105 | atanh () = () 106 | -------------------------------------------------------------------------------- /src/Grenade/Exts/Layer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, DataKinds, KindSignatures, TypeFamilies, TypeOperators #-} 2 | module Grenade.Exts.Layer where 3 | 4 | import Data.Singletons.TypeLits 5 | import GHC.Types (Constraint) 6 | import Grenade 7 | import Grenade.Exts.Gradient () 8 | 9 | class UpdateLayer x => UpdateLayerRaw x where 10 | runUpdateRaw :: Gradient x -> x -> x 11 | 12 | instance (KnownNat i, KnownNat o) => UpdateLayerRaw (FullyConnected i o) where 13 | runUpdateRaw d (FullyConnected a b) = FullyConnected (d + a) b 14 | instance UpdateLayerRaw (Relu) where 15 | runUpdateRaw _ _ = Relu 16 | instance UpdateLayerRaw (Softmax) where 17 | runUpdateRaw _ _ = Softmax 18 | 19 | type family All (c :: * -> Constraint) (as :: [*]) :: Constraint where 20 | All c '[] = () 21 | All c (a ': as) = (c a, All c as) 22 | 23 | applyRaw :: All UpdateLayerRaw layers => Gradients layers -> Network layers shapes -> Network layers shapes 24 | applyRaw GNil NNil = NNil 25 | applyRaw (g :/> gs) (n :~> ns) = (runUpdateRaw g n :~> applyRaw gs ns) 26 | -------------------------------------------------------------------------------- /src/MCTS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables #-} 2 | module MCTS ( Choice, Reward 3 | , MCTS (..), NodeInfo (..), MCTree (..) 4 | , rollout, rootNode, decide, newRootNode 5 | , simulateU, simulateA 6 | ) where 7 | 8 | 9 | import Control.Applicative 10 | import Control.Monad.Logic 11 | import Control.Monad.Random 12 | import Control.Monad.Trans.State.Strict 13 | import Control.Monad.Trans.Writer.CPS 14 | import Data.List (maximumBy) 15 | import Data.Map.Strict (Map) 16 | import qualified Data.Map.Strict as M 17 | import Data.Maybe (fromMaybe) 18 | import Data.Monoid (Sum (..)) 19 | import Data.Vector (Vector) 20 | import qualified Data.Vector as V 21 | import qualified Data.Vector.Unboxed.Sized as U 22 | 23 | import Tetris.Action 24 | import Tetris.Block 25 | import Tetris.Board 26 | import Tetris.Simulator 27 | import Tetris.State 28 | 29 | type Choice = [Action] 30 | type Reward = Double 31 | 32 | -- Parameters for configuring the MCTS search. 33 | data MCTS = MCTS { linesToReward :: AttackLines -> Reward 34 | , stateToReward :: GameState -> Reward 35 | , simulate :: (forall m. MonadRandom m => GameState -> m Reward) -- Estimate reward at a given position 36 | , lossReward :: Reward 37 | , gamma :: Double 38 | , cp :: Double -- Exploration/exploitation factor (usually 1 / sqrt(2)) 39 | } 40 | 41 | data NodeInfo = NodeInfo { q :: Reward -- Total child reward from rollouts 42 | , r :: Reward -- Reward at this node 43 | , n :: Double -- Number of visits 44 | , best :: Reward 45 | } 46 | 47 | addReward :: Reward -> NodeInfo -> NodeInfo 48 | addReward rwd (NodeInfo q r n b) = NodeInfo (q + rwd) r (n + 1) (max rwd b) 49 | 50 | data MCTree a where 51 | StateNode :: NodeInfo -> GameState -> Vector (Choice, Maybe (MCTree TransitionState)) -> MCTree GameState 52 | TransitionNode :: NodeInfo -> TransitionState -> Map GameState (MCTree GameState) -> MCTree TransitionState 53 | 54 | -- Start a new MCTree 55 | rootNode :: GameState -> MCTree GameState 56 | rootNode gs = StateNode (NodeInfo 0 0 0 (-1 / 0)) gs (moves gs) 57 | 58 | -- Pick the best option currently in the MCTree, and get the portion of the tree below it. 59 | decide :: MonadRandom m => MCTree GameState -> m (Choice, Maybe (MCTree TransitionState)) 60 | decide (StateNode _ _ opts) = fmap (opts V.!) (bestMoveIndex (choiceScore . snd) opts) 61 | 62 | -- Given a portion of the tree from `decide`, and the resulting new GameState after taking 63 | -- the provided action, reduce the tree again to the appropriate branch, which can then 64 | -- be passed to rollout to begin searching again. 65 | newRootNode :: Maybe (MCTree TransitionState) -> GameState -> MCTree GameState 66 | newRootNode Nothing gs = rootNode gs 67 | newRootNode (Just (TransitionNode _ _ map)) gs = M.findWithDefault (rootNode gs) gs map 68 | 69 | -- Perform one step of UCT Monte Carlo Tree Search. 70 | -- That is, we keep picking the best move available until we reach an unexplored node. 71 | -- Then, we add that node to the tree and do a uniform roll out from it to give it a default value. 72 | rollout :: MonadRandom m => MCTS -> MCTree GameState -> m (Reward, MCTree GameState) 73 | rollout params (StateNode info gs opts) = do 74 | index <- bestMoveIndex (uctScore params (n info) . snd) opts 75 | (rwd, entry) <- descendState params gs (opts V.! index) 76 | pure $ (r info + (gamma params) * rwd, StateNode (addReward rwd info) gs (opts V.// [(index, entry)])) 77 | 78 | bestMoveIndex :: MonadRandom m => (a -> Double) -> Vector a -> m Int 79 | bestMoveIndex score opts = fmap (bestIndices V.!) $ getRandomR (0, length bestIndices - 1) 80 | where scores = fmap score opts 81 | best = V.maximum scores 82 | bestIndices = V.findIndices (== best) scores 83 | 84 | -- Parent Total -> Child -> Score 85 | uctScore :: MCTS -> Double -> Maybe (MCTree TransitionState) -> Double 86 | uctScore params total (Just (TransitionNode info _ _)) = r info + (q info) / (n info) + (cp params) * sqrt ((log total) / (n info)) 87 | uctScore _ _ _ = 1 / 0 -- Infinity 88 | 89 | choiceScore :: Maybe (MCTree TransitionState) -> Double 90 | choiceScore (Just (TransitionNode info _ _)) = r info + best info 91 | choiceScore _ = -1 / 0 92 | 93 | descendState :: MonadRandom m => MCTS -> GameState -> (Choice, Maybe (MCTree TransitionState)) -> m (Reward, (Choice, Maybe (MCTree TransitionState))) 94 | descendState params st (c, mts) = fmap (fmap $ \s -> (c, Just s)) . descendTransition params . fromMaybe (applyActions params c st 0) $ mts 95 | 96 | applyActions :: MCTS -> [Action] -> GameState -> AttackLines -> MCTree TransitionState 97 | applyActions _ [] _ _ = undefined 98 | applyActions params (a:as) gs c = case applyAction a gs of 99 | (c2, Right gs2) -> applyActions params as gs2 (c + c2) 100 | (c2, Left ts) -> TransitionNode (NodeInfo 0 (linesToReward params $ c + c2) 0 (-1 / 0)) ts M.empty 101 | 102 | descendTransition :: MonadRandom m => MCTS -> MCTree TransitionState -> m (Reward, MCTree TransitionState) 103 | descendTransition params (TransitionNode info ts children) = monteCarloTransition ts >>= \mgs -> 104 | case mgs of 105 | Nothing -> pure (r info + lossReward params, TransitionNode (addReward (lossReward params) info) ts children) -- We lose 106 | Just gs -> do 107 | (children', Sum result) <- runWriterT $ M.alterF (rolloutTransition params gs) gs children 108 | pure (r info + result, TransitionNode (addReward result info) ts children') 109 | 110 | rolloutTransition :: MonadRandom m => MCTS -> GameState -> Maybe (MCTree GameState) -> WriterT (Sum Reward) m (Maybe (MCTree GameState)) 111 | rolloutTransition params gs (Just (StateNode i _ m)) = do 112 | -- We're not at a leaf, so we keep descending 113 | (rwd, node') <- lift (rollout params (StateNode i gs m)) 114 | tell (Sum rwd) 115 | pure (Just node') 116 | rolloutTransition params gs Nothing = do 117 | -- We're at a leaf, create a new node. 118 | rwd <- lift $ simulate params gs 119 | tell . Sum $ stateToReward params gs + (gamma params) * rwd 120 | pure . Just $ StateNode (NodeInfo rwd (stateToReward params gs) 1 rwd) gs (moves gs) 121 | 122 | -- Play out n moves uniformly randomly from this state 123 | simulateU :: (MonadRandom m) => MCTS -> Int -> GameState -> m Reward 124 | simulateU _ 0 _ = pure 0 125 | simulateU params n gs = do 126 | let poss = moves gs 127 | choice <- fmap (fst . (poss V.!)) $ getRandomR (0, length poss - 1) 128 | let (TransitionNode (NodeInfo _ rwd _ _) ts _) = applyActions params choice gs 0 129 | mgs <- monteCarloTransition ts 130 | case mgs of 131 | Nothing -> pure (rwd + lossReward params) 132 | Just gs' -> fmap (\r -> rwd + stateToReward params gs' + (gamma params) * r) (simulateU params (n - 1) gs') 133 | 134 | -- Play out according to the old AI. 135 | simulateA :: (MonadRandom m) => MCTS -> Int -> GameState -> m Reward 136 | simulateA _ 0 _ = pure 0 137 | simulateA params n gs = do 138 | let poss = runComputation gs (possible >> act HardDrop >> score') 139 | (_, choice) = maximumBy (\(s1,_) (s2,_) -> compare s1 s2) poss 140 | let (TransitionNode (NodeInfo _ rwd _ _) ts _) = applyActions params choice gs 0 141 | mgs <- monteCarloTransition ts 142 | case mgs of 143 | Nothing -> pure (rwd + lossReward params) 144 | Just gs' -> fmap (\r -> rwd + stateToReward params gs' + (gamma params) * r) (simulateA params (n - 1) gs') 145 | 146 | moves :: GameState -> Vector (Choice, Maybe (MCTree TransitionState)) 147 | moves = V.fromList . fmap (\(_,c) -> (c <> [HardDrop], Nothing)) . flip runComputation possible 148 | 149 | newtype Computation a = Computation { unComp :: StateT GameState (WriterT [Action] Logic) a} 150 | deriving (Functor, Applicative, Monad, Alternative, MonadPlus) 151 | 152 | runComputation :: GameState -> Computation a -> [(a, [Action])] 153 | runComputation gs c = observeAll . runWriterT . flip evalStateT gs . unComp $ c 154 | 155 | getState :: Computation GameState 156 | getState = Computation get 157 | putState :: GameState -> Computation () 158 | putState = Computation . put 159 | tellAction :: Action -> Computation () 160 | tellAction = Computation . lift . tell . (:[]) 161 | 162 | liftMaybe :: MonadPlus m => Maybe a -> m a 163 | liftMaybe = maybe mzero pure 164 | 165 | act :: Action -> Computation AttackLines 166 | act HardDrop = do 167 | state <- getState 168 | let (lines, res) = applyAction HardDrop state 169 | state' <- case res of 170 | Left trans -> liftMaybe . deterministicTransition $ trans 171 | Right _ -> undefined 172 | tellAction HardDrop 173 | putState state' 174 | pure lines 175 | act a = do 176 | state <- getState 177 | state' <- liftMaybe . moveActive a $ state 178 | tellAction a 179 | putState state' 180 | pure 0 181 | 182 | rotations :: Computation () 183 | rotations = go 3 184 | where go 0 = pure () 185 | go n = pure () `mplus` (act RotateRight >> go (n - 1)) 186 | 187 | translations :: Computation () 188 | translations = pure() `mplus` go MoveLeft `mplus` go MoveRight 189 | where go a = act a >> (pure () `mplus` go a) 190 | 191 | possible :: Computation () 192 | possible = rotations >> translations 193 | 194 | aggregateHeight :: Board -> Int 195 | aggregateHeight board = sum (height board <$> [0..9]) 196 | 197 | height :: Board -> Col -> Int 198 | height board = fromInteger . toInteger . U.unsafeIndex (colHeights board) 199 | 200 | completeLines :: Board -> Int 201 | completeLines board = length . filter (complete board) $ [0..19] 202 | 203 | holes :: Board -> Int 204 | holes board = sum (colHoles <$> [0..9]) 205 | where colHoles :: Col -> Int 206 | colHoles c = length . filter (\r -> r > (20 - height board c) && getSquare (r,c) board == Empty) $ [0..19] 207 | 208 | bumpiness :: Board -> Int 209 | bumpiness board = sum . fmap (\c -> abs (height board c - height board (c + 1))) $ [0..8] 210 | 211 | -- See https://codemyroad.wordpress.com/2013/04/14/tetris-ai-the-near-perfect-player/ 212 | score :: Board -> Float 213 | score board = (-0.510066 * itf (aggregateHeight board)) + (0.760666 * itf (completeLines board)) + (-0.35663 * itf (holes board)) + (-0.184483 * itf (bumpiness board)) 214 | where itf = fromInteger . toInteger 215 | 216 | score' :: Computation Float 217 | score' = fmap (score . board) getState 218 | -------------------------------------------------------------------------------- /src/Tetris/Action.hs: -------------------------------------------------------------------------------- 1 | module Tetris.Action (Action (..), dropBlock, moveBlock, moveBlock') where 2 | 3 | import Data.Map.Strict (Map) 4 | import qualified Data.Map.Strict as M 5 | import Data.Maybe 6 | import qualified Data.Vector.Unboxed.Sized as U 7 | 8 | import Tetris.Block 9 | import Tetris.Board 10 | 11 | data Action = MoveLeft | MoveRight | SoftDrop | HardDrop | RotateLeft | RotateRight | Hold 12 | deriving (Eq, Show) 13 | 14 | -- Given an ActiveBlock, returns a new ActiveBlock in the position the current block will drop to. 15 | -- Will only return Nothing if the current position is invalid. 16 | dropPosition :: Board -> ActiveBlock -> Maybe ActiveBlock 17 | dropPosition b a = dropPosition_ b a{pos = (r',c)} 18 | where (_,c) = pos a 19 | maxHeight :: Int 20 | maxHeight = fromInteger . toInteger . maximum . fmap (U.unsafeIndex (colHeights b)) $ [max 0 c..min 9 (c + 3)] 21 | r' = maxHeight - 24 22 | 23 | dropPosition_ :: Board -> ActiveBlock -> Maybe ActiveBlock 24 | dropPosition_ board = fmap (\a@ActiveBlock{ pos = (r,c) } -> fromMaybe a . dropPosition_ board $ a{ pos = (r + 1, c) }) . validateAB board 25 | 26 | dropBlock :: Board -> ActiveBlock -> Board 27 | dropBlock board ab = addActiveBlock board . fromMaybe ab . dropPosition board $ ab 28 | 29 | -- True: rotates the block right, False: rotates left. 30 | -- This is actually reasonably complicated as it will resolve kicks. 31 | -- Returns Nothing if no rotation position is valid. 32 | rotateBlock :: Board -> Bool -> ActiveBlock -> Maybe ActiveBlock 33 | rotateBlock board dir (ActiveBlock k (r,c) rot) = listToMaybe . catMaybes . fmap (validateAB board) $ candidates 34 | where nrot = if dir then (rot + 1) `mod` 4 35 | else (rot + 3) `mod` 4 36 | kicks = if k == I then kickMap M.! (I, rot, dir) 37 | else kickMap M.! (J, rot, dir) 38 | candidates = fmap (\(ro,co) -> ActiveBlock k (r + ro, c + co) nrot) kicks 39 | 40 | -- Applies an action to a block. 41 | -- Does nothing if the specified Action is Hold. 42 | -- Returns Nothing if the Action fails. 43 | moveBlock :: Board -> Action -> ActiveBlock -> Maybe ActiveBlock 44 | moveBlock _ Hold a = Just a 45 | moveBlock b MoveLeft a@ActiveBlock{pos = (r,c)} = validateAB b a{pos = (r, c - 1) } 46 | moveBlock b MoveRight a@ActiveBlock{pos = (r,c)} = validateAB b a{pos = (r, c + 1) } 47 | moveBlock b SoftDrop a@ActiveBlock{pos = (r,c)} = validateAB b a{pos = (r + 1, c) } 48 | moveBlock b HardDrop a = dropPosition b a 49 | moveBlock b RotateLeft a = rotateBlock b False a 50 | moveBlock b RotateRight a = rotateBlock b True a 51 | 52 | -- Same as moveBlock, but returns the given ActiveBlock if the Action fails. 53 | moveBlock' :: Board -> Action -> ActiveBlock -> ActiveBlock 54 | moveBlock' b a ab = fromMaybe ab (moveBlock b a ab) 55 | 56 | -- True: right; False: left 57 | kickMap :: Map (Block, Rot, Bool) [Pos] 58 | kickMap = M.fromList [ ((I, 0, True), [ (0,0), (-2,0), ( 1,0), (-2,-1), ( 1, 2) ]) 59 | , ((I, 0, False), [ (0,0), (-1,0), ( 2,0), (-1, 2), ( 2,-1) ]) 60 | , ((I, 1, True), [ (0,0), (-1,0), ( 2,0), (-1, 2), ( 2,-1) ]) 61 | , ((I, 1, False), [ (0,0), ( 2,0), (-1,0), ( 2, 1), (-1,-2) ]) 62 | , ((I, 2, True), [ (0,0), ( 2,0), (-1,0), ( 2, 1), (-1,-2) ]) 63 | , ((I, 2, False), [ (0,0), ( 1,0), (-2,0), ( 1,-2), (-2, 1) ]) 64 | , ((I, 3, True), [ (0,0), ( 1,0), (-2,0), ( 1,-2), (-2, 1) ]) 65 | , ((I, 3, False), [ (0,0), (-2,0), ( 1,0), (-2,-1), ( 1, 2) ]) 66 | 67 | , ((J, 0, True), [ (0,0), (-1,0), (-1, 1), (0,-2), (-1,-2) ]) 68 | , ((J, 0, False), [ (0,0), ( 1,0), ( 1, 1), (0,-2), ( 1,-2) ]) 69 | , ((J, 1, True), [ (0,0), ( 1,0), ( 1,-1), (0, 2), ( 1, 2) ]) 70 | , ((J, 1, False), [ (0,0), ( 1,0), ( 1,-1), (0, 2), ( 1, 2) ]) 71 | , ((J, 2, True), [ (0,0), ( 1,0), ( 1, 1), (0,-2), ( 1,-2) ]) 72 | , ((J, 2, False), [ (0,0), (-1,0), (-1, 1), (0,-2), (-1,-2) ]) 73 | , ((J, 3, True), [ (0,0), (-1,0), (-1,-1), (0, 2), (-1, 2) ]) 74 | , ((J, 3, False), [ (0,0), (-1,0), (-1,-1), (0, 2), (-1, 2) ]) 75 | ] 76 | -------------------------------------------------------------------------------- /src/Tetris/Block.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} 2 | module Tetris.Block where 3 | 4 | data Block = I | J | L | O | S | T | Z 5 | deriving (Eq, Show, Ord, Enum) 6 | 7 | type Row = Int 8 | type Col = Int 9 | type Pos = (Row, Col) 10 | 11 | type Rot = Int 12 | 13 | data ActiveBlock = ActiveBlock { kind :: Block 14 | , pos :: Pos 15 | , rot :: Rot 16 | } deriving (Eq, Ord, Show) 17 | 18 | startingPosition :: Block -> ActiveBlock 19 | startingPosition b = ActiveBlock b (height b, 3) 0 20 | where height I = -1 21 | height _ = -2 22 | -------------------------------------------------------------------------------- /src/Tetris/Board.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, DeriveGeneric, DeriveAnyClass, DerivingVia, PatternSynonyms #-} 2 | module Tetris.Board ( Square (..) 3 | , Board (..), emptyBoard, fromSquares, toSquares, getSquare, isEmpty, printBoard 4 | , canAddActiveBlock, validateAB, addActiveBlock 5 | , complete, clearLines, addGarbageLines, hurryUp 6 | ) where 7 | 8 | import Data.Bits 9 | import Data.Finite 10 | import Data.Functor.Identity 11 | import Data.Vector.Unboxed.Sized (Vector) 12 | import qualified Data.Vector.Unboxed.Sized as U 13 | import qualified Data.Vector.Sized as V 14 | import Data.Word 15 | import Text.Printf 16 | 17 | import Tetris.Block 18 | 19 | data Square = Empty | Garbage | HurryUp 20 | deriving (Eq, Ord, Show) 21 | 22 | data Board = Board { rows :: (Vector 20 Word32) 23 | , hurry :: (Vector 20 Bool) 24 | , colHeights :: (Vector 10 Word8) 25 | } deriving (Eq, Ord, Show) 26 | 27 | emptyRow :: Word32 28 | emptyRow = (maxBound `shiftL` 18) .|. 255 29 | 30 | fullRow :: Word32 31 | fullRow = maxBound 32 | 33 | rowMask :: Int -> Board -> Word32 34 | rowMask r b 35 | | r >= 20 = fullRow 36 | | r < 0 = emptyRow 37 | | otherwise = (rows b) `U.unsafeIndex` r 38 | 39 | emptyBoard :: Board 40 | emptyBoard = Board (U.replicate emptyRow) (U.replicate False) (U.replicate 0) 41 | 42 | updateHeight :: Board -> Col -> Board 43 | updateHeight board c = board{colHeights = (colHeights board) U.// [((fromInteger . toInteger) c, 20 - hind)]} 44 | where hind = U.foldr (\r i -> if (r `shiftR` (8 + c)) .&. 1 == 0 then 1 + i else 0) 0 (rows board) 45 | 46 | fromSquares :: V.Vector 20 (V.Vector 10 Square) -> Board 47 | fromSquares v = foldl updateHeight rawBoard [0..9] 48 | where encodeRow :: V.Vector 10 Square -> Word32 49 | encodeRow = (.|. 255) . (`shiftL` 8) . foldr (\s v -> (v `shiftL` 1) .|. (if s == Empty then 0 else 1)) maxBound 50 | rawBoard = Board (U.generate (\n -> encodeRow (v `V.index` n))) 51 | (U.generate (\n -> (v `V.index` n) `V.index` 0 == HurryUp)) 52 | (U.replicate 0) 53 | 54 | toSquares :: Board -> V.Vector 20 (V.Vector 10 Square) 55 | toSquares board = V.generate genRow 56 | where genRow r = if (hurry board) `U.index` r 57 | then V.replicate HurryUp 58 | else V.unfoldrN (\b -> (if (b .&. 1) == 0 then Empty else Garbage, b `shiftR` 1)) (((rows board) `U.index` r) `shiftR` 8) 59 | 60 | getSquare :: Pos -> Board -> Square 61 | getSquare (r,c) board 62 | | r >= 0 && r < 20 && (hurry board) `U.unsafeIndex` r = HurryUp 63 | | ((rowMask r board) `shiftR` (8 + c)) .&. 1 == 0 = Empty 64 | | otherwise = Garbage 65 | 66 | isEmpty :: Board -> Pos -> Bool 67 | isEmpty b p = getSquare p b == Empty 68 | 69 | -- Are all the spaces occupied by the ActiveBlock empty? 70 | canAddActiveBlock :: Board -> ActiveBlock -> Bool 71 | canAddActiveBlock board ab = U.ifoldr chk True mask 72 | where (r,c) = pos ab 73 | mask = rotMaskMap (kind ab) (rot ab) 74 | chk i m b = if (m `shiftL` (8 + c)) .&. (rowMask (r + (fromInteger . getFinite $ i)) board) == 0 then b else False 75 | 76 | validateAB :: Board -> ActiveBlock -> Maybe ActiveBlock 77 | validateAB b a = if canAddActiveBlock b a then Just a else Nothing 78 | 79 | -- Replaces the squares in the board the ActiveBlock occupies with the appropriate remnants. 80 | -- Does not check if spaces are overwritten. 81 | addActiveBlock :: Board -> ActiveBlock -> Board 82 | addActiveBlock board ab = foldl updateHeight rawBoard [max 0 c..min 9 (c + 3)] 83 | where (r,c) = pos ab 84 | mask = U.map (`shiftL` (8 + c)) (rotMaskMap (kind ab) (rot ab)) 85 | upd i m vc = if i' < 0 || i' >= 20 then vc else U.unsafeUpd vc [(i', (vc `U.unsafeIndex` i') .|. m)] 86 | where i' = r + (fromInteger . getFinite $ i) 87 | rawBoard = board{rows = U.ifoldr upd (rows board) mask} 88 | 89 | 90 | complete :: Board -> Finite 20 -> Bool 91 | complete board r = ((rows board) `U.index` r) + 1 == 0 && not ((hurry board) `U.index` r) 92 | 93 | clearLines :: Board -> (Int, Board) 94 | clearLines board = foldr remove (0, board) . filter (complete board) . reverse $ [0..19] 95 | where remove :: Finite 20 -> (Int, Board) -> (Int, Board) 96 | remove r (c, brd) = (c + 1, brd{rows = rws' U.// [(0, emptyRow)]}) 97 | where nind 0 = 0 98 | nind i = fromInteger . getFinite $ if i <= r then i - 1 else i 99 | upd = (U.generate nind) :: Vector 20 Int 100 | rws' = U.backpermute (rows brd) upd 101 | 102 | addGarbageLines :: Int -> Col -> Board -> Board 103 | addGarbageLines n col board = if 20 > col && col >= 0 then updateHeight board' col else board' 104 | where endI = U.foldr (\b i -> if b then 0 else 1 + i) 0 (hurry board) 105 | nind i = let i' = fromInteger . getFinite $ i in if i' > (endI - 1 - n) then i' else i' + n 106 | rws1 = U.backpermute (rows board) ((U.generate nind) :: Vector 20 Int) 107 | rws2 = rws1 `U.unsafeUpd` [(x, grb_row) | x <- [endI - n .. endI - 1]] 108 | grb_row = complement (1 `shiftL` (col + 8)) 109 | board' = board{rows = rws2, colHeights = U.map (+ (fromInteger . toInteger) n) (colHeights board)} 110 | 111 | -- Add `n` hurry up lines to the board. 112 | hurryUp :: Int -> Board -> Board 113 | hurryUp n = markHU . addGarbageLines n 32 114 | where markHU brd = brd{hurry = (hurry brd) `U.unsafeUpd` [(x, True) | x <- [endI - n .. endI - 1]]} 115 | where endI = U.foldr (\b i -> if b then 0 else 1 + i) 0 (hurry brd) 116 | 117 | printBoard :: Board -> IO () 118 | printBoard board = (>> return ()) . sequence . fmap (printRow board) $ [0..19] 119 | where printSquare :: Square -> IO () 120 | printSquare s = let (r,g,b) = sqColor s in printf "\x1b[48;2;%d;%d;%dm%c" r g b (sqChar s) 121 | printRow :: Board -> Row -> IO () 122 | printRow b r = (>> printf "\x1b[0m\n") . sequence . fmap (printSquare . (\c -> getSquare (r, c) b)) $ [0..9] 123 | sqColor :: Square -> (Int, Int, Int) 124 | sqColor Empty = (0,0,0) 125 | sqColor Garbage = (115,115,115) 126 | sqColor HurryUp = (106,106,106) 127 | sqChar :: Square -> Char 128 | sqChar Empty = ' ' 129 | sqChar Garbage = 'X' 130 | sqChar HurryUp = 'X' 131 | 132 | {- These are the default colors on JStris. Now that the board no longer records remnant type, 133 | these no longer really have a use. I'm keeping them here, though, for posterity. 134 | colorMap :: Map Block (Int, Int, Int) 135 | colorMap = M.fromList [ (I, ( 15,155,215)) 136 | , (J, ( 33, 65,198)) 137 | , (L, (227, 91, 2)) 138 | , (O, (227,159, 2)) 139 | , (S, ( 89,177, 1)) 140 | , (T, (175, 41,138)) 141 | , (Z, (215, 15, 55)) 142 | ] 143 | -} 144 | 145 | rotMaskMap :: Block -> Rot -> Vector 4 Word32 146 | rotMaskMap b r = posToMask (rotMap b r) 147 | 148 | posToMask :: [Pos] -> Vector 4 Word32 149 | posToMask [] = U.replicate 0 150 | posToMask ((r,c):ps) = runIdentity $ U.ix (finite . toInteger $ r) (\v -> pure $ v .|. (1 `shiftL` c)) $ posToMask ps 151 | 152 | rotMap :: Block -> Rot -> [Pos] 153 | rotMap I 0 = [ (1,0), (1,1), (1,2), (1,3) ] 154 | rotMap I 1 = [ (0,2), (1,2), (2,2), (3,2) ] 155 | rotMap I 2 = [ (2,0), (2,1), (2,2), (2,3) ] 156 | rotMap I 3 = [ (0,1), (1,1), (2,1), (3,1) ] 157 | 158 | rotMap J 0 = [ (1,0), (2,0), (2,1), (2,2) ] 159 | rotMap J 1 = [ (1,1), (1,2), (2,1), (3,1) ] 160 | rotMap J 2 = [ (2,0), (2,1), (2,2), (3,2) ] 161 | rotMap J 3 = [ (3,0), (3,1), (2,1), (1,1) ] 162 | 163 | rotMap L 0 = [ (1,2), (2,0), (2,1), (2,2) ] 164 | rotMap L 1 = [ (1,1), (3,2), (2,1), (3,1) ] 165 | rotMap L 2 = [ (2,0), (2,1), (2,2), (3,0) ] 166 | rotMap L 3 = [ (1,0), (3,1), (2,1), (1,1) ] 167 | 168 | rotMap O 0 = [ (1,1), (1,2), (2,1), (2,2) ] 169 | rotMap O 1 = [ (1,1), (1,2), (2,1), (2,2) ] 170 | rotMap O 2 = [ (1,1), (1,2), (2,1), (2,2) ] 171 | rotMap O 3 = [ (1,1), (1,2), (2,1), (2,2) ] 172 | 173 | rotMap S 0 = [ (2,0), (2,1), (1,1), (1,2) ] 174 | rotMap S 1 = [ (1,1), (2,1), (2,2), (3,2) ] 175 | rotMap S 2 = [ (3,0), (3,1), (2,1), (2,2) ] 176 | rotMap S 3 = [ (1,0), (2,0), (2,1), (3,1) ] 177 | 178 | rotMap T 0 = [ (2,0), (2,1), (2,2), (1,1) ] 179 | rotMap T 1 = [ (1,1), (2,1), (3,1), (2,2) ] 180 | rotMap T 2 = [ (2,0), (2,1), (2,2), (3,1) ] 181 | rotMap T 3 = [ (2,0), (1,1), (2,1), (3,1) ] 182 | 183 | rotMap Z 0 = [ (1,0), (1,1), (2,1), (2,2) ] 184 | rotMap Z 1 = [ (3,1), (2,1), (2,2), (1,2) ] 185 | rotMap Z 2 = [ (3,2), (3,1), (2,1), (2,0) ] 186 | rotMap Z 3 = [ (3,0), (2,0), (2,1), (1,1) ] 187 | 188 | rotMap _ _ = undefined -- Invalid rotation 189 | -------------------------------------------------------------------------------- /src/Tetris/Simulator.hs: -------------------------------------------------------------------------------- 1 | module Tetris.Simulator ( AttackLines, applyAction, monteCarloTransition, deterministicTransition 2 | , SimulatorState(..), startingState, advance 3 | ) where 4 | 5 | import Control.Monad.Identity 6 | import Control.Monad.Random 7 | import Data.Bits 8 | import Data.Maybe (fromJust) 9 | import qualified Data.Vector.Unboxed.Sized as U 10 | import System.Random.Shuffle 11 | 12 | import Tetris.Action 13 | import Tetris.Block 14 | import Tetris.Board 15 | import Tetris.State 16 | 17 | type AttackLines = Int 18 | 19 | -- Board -> Combo -> Cleared -> LinesSent 20 | -- Combo counts consecutive clears, so if cleared > 0, then combo >= 1. 21 | attackLines :: Board -> Int -> Int -> AttackLines 22 | attackLines board combo cleared = cboLines + clearedLines 23 | where cboLines = case (combo - 1) of 24 | -1 -> 0 25 | 0 -> 0 26 | 1 -> 0 27 | 2 -> 1 28 | 3 -> 1 29 | 4 -> 1 30 | 5 -> 2 31 | 6 -> 2 32 | 7 -> 3 33 | 8 -> 3 34 | 9 -> 4 35 | 10 -> 4 36 | 11 -> 4 37 | _ -> 5 38 | mask = 1023 `shiftL` 8 39 | clearedLines = if U.all (\r -> r .&. mask == 0) (rows board) 40 | then 10 41 | else case cleared of 42 | 0 -> 0 43 | 1 -> 0 44 | 2 -> 1 45 | 3 -> 2 46 | 4 -> 4 47 | _ -> undefined 48 | 49 | cycleActive :: GameState -> GameState 50 | cycleActive gs@GameState{queue = q:qs} = gs{active = startingPosition q, queue = qs} 51 | cycleActive g = g 52 | 53 | garbageHistogram = [(1,517),(2,111),(3,27),(4,52),(5,16),(7,1),(10,3)] 54 | garbageTime = 10081 55 | 56 | sampleHistogram :: MonadRandom m => [(a, Int)] -> m a 57 | sampleHistogram h = fmap (\v -> fromJust . snd . foldl (flip iterate) (v, Nothing) $ h) $ getRandomR (0, len - 1) 58 | where len = sum . fmap snd $ h 59 | iterate :: (a, Int) -> (Int, Maybe a) -> (Int, Maybe a) 60 | iterate _ (_, Just a) = (0, Just a) 61 | iterate (a, c) (r, Nothing) = if c >= r then (0, Just a) 62 | else (r - c, Nothing) 63 | 64 | queueGarbage :: MonadRandom m => GameState -> m GameState 65 | queueGarbage s = getRandomR (0, garbageTime) >>= \r -> 66 | if r > (sum . fmap snd $ garbageHistogram) 67 | then pure s 68 | else do 69 | ct <- sampleHistogram garbageHistogram 70 | queueGarbage s{garbage = garbage s <> [ct]} 71 | 72 | -- Compute the GameState after the specified action is applied. If computing the new 73 | -- state is entirely deterministic, this returns Right GameState with the new state. 74 | -- If the new state is probablistic, this returns Left TransitionState, where the 75 | -- TransitionState contains the deterministic updates. You can then apply the 76 | -- probabilistic update via other functions. 77 | -- 78 | -- Things that need to be done for a TransitionState: 79 | -- 1) Add a new Block to the end of the queue 80 | -- 2) If the first component is True, spawn queued garbage 81 | -- 3) Possibly queue new garbage 82 | -- 83 | -- Note that a TransitionState is reached either when a HardDrop occurs or on the 84 | -- first Hold. This means that we will get one additional garbage spawn on the first 85 | -- Hold which I find acceptable. 86 | applyAction :: Action -> GameState -> (AttackLines, Either TransitionState GameState) 87 | applyAction Hold gs = (,) 0 $ if canHold gs 88 | then case held gs of 89 | Nothing -> Left . TransitionState $ (False, cycleActive gs{held = Just . kind . active $ gs}) 90 | Just k -> Right gs{held = Just . kind . active $ gs, active = startingPosition k} 91 | else Right gs 92 | applyAction HardDrop gs = (atk, Left . TransitionState $ (cl == 0, reduceGarbage cl gs1)) 93 | where (cl, gs1) = clearLines' . cycleActive . addActive . moveActive' HardDrop $ gs 94 | combo' = if cl > 0 then 1 + combo gs1 else 0 95 | atk = attackLines (board gs1) combo' cl 96 | applyAction act gs = ((,) 0) . Right . moveActive' act $ gs 97 | 98 | 99 | transitionWithBlockHU :: MonadRandom m => TransitionState -> Int -> Block -> m (Maybe GameState) 100 | transitionWithBlockHU (TransitionState (grb, gs0)) _ b = do 101 | gs1 <- if grb then addGarbage gs0 else pure gs0 102 | gs2 <- queueGarbage gs1 103 | let gs3 = gs2{board = hurryUp 0 (board gs2), queue = (queue gs2) <> [b]} 104 | if canAddActiveBlock (board gs3) (active gs3) 105 | then pure (Just gs3) 106 | else pure Nothing 107 | 108 | -- Transition with randomly dealt garbage and next piece. 109 | -- Returns Nothing if the game is over. 110 | monteCarloTransition :: MonadRandom m => TransitionState -> m (Maybe GameState) 111 | monteCarloTransition st = transitionWithBlockHU st 0 =<< fmap toEnum (getRandomR (0,6)) 112 | 113 | -- Transition without looking at garbage or queueing a new block. Use with caution 114 | deterministicTransition :: TransitionState -> Maybe GameState 115 | deterministicTransition (TransitionState (_,gs)) = guard (canAddActiveBlock (board gs) (active gs)) >> pure gs 116 | 117 | data SimulatorState = SimulatorState { gs :: GameState 118 | , squeue :: [Block] 119 | } 120 | 121 | pieceQueue :: RandomGen g => g -> [Block] 122 | pieceQueue = runIdentity . evalRandT (fmap mconcat . sequence . repeat . shuffleM $ [ I, J, L, O, S, T, Z ]) 123 | 124 | startingState :: RandomGen g => g -> SimulatorState 125 | startingState g = SimulatorState (GameState emptyBoard (startingPosition active) Nothing True 0 queue []) leftOver 126 | where (active:queue, leftOver) = splitAt 6 . pieceQueue $ g 127 | 128 | hurryUpCount :: Int -> Int 129 | hurryUpCount n 130 | | n < 900 = 0 131 | | n `mod` 20 == 0 = 1 132 | | otherwise = 0 133 | 134 | -- Transition according to the extra information in the SimulatorState. 135 | simulatorStateTransition :: MonadRandom m => TransitionState -> Int -> SimulatorState -> m (Maybe SimulatorState) 136 | simulatorStateTransition ts step ss@SimulatorState{ squeue = q} = fmap (fmap newState) $ transitionWithBlockHU ts (hurryUpCount step) (head q) 137 | where newState gs = ss{gs = gs, squeue = tail q} 138 | 139 | advance :: MonadRandom m => Int -> Action -> SimulatorState -> m (Maybe (SimulatorState, AttackLines)) 140 | advance step act ss = case res of 141 | Right gs -> pure . Just $ (ss{gs = gs}, atk) 142 | Left ts -> fmap (fmap (\ss -> (ss, atk))) $ simulatorStateTransition ts step ss 143 | where (atk, res) = applyAction act (gs ss) 144 | -------------------------------------------------------------------------------- /src/Tetris/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, DeriveGeneric, DeriveAnyClass, DerivingVia, PatternSynonyms, RankNTypes, ScopedTypeVariables #-} 2 | module Tetris.State ( GameState (..) 3 | , TransitionState (..) 4 | , moveActive, moveActive', addActive, clearLines' 5 | , addGarbage, reduceGarbage 6 | ) where 7 | 8 | import Control.Monad.Random 9 | import Data.Maybe 10 | 11 | import Tetris.Action 12 | import Tetris.Block 13 | import Tetris.Board 14 | 15 | data GameState = GameState { board :: Board 16 | , active :: ActiveBlock 17 | , held :: (Maybe Block) 18 | , canHold :: Bool 19 | , combo :: Int 20 | , queue :: [Block] 21 | , garbage :: [Int] 22 | } deriving (Show) 23 | 24 | data GSRecord = GSR { equal :: GameState -> GameState -> Bool 25 | , comp :: GameState -> GameState -> Ordering } 26 | wrap :: (Eq a, Ord a) => (GameState -> a) -> GSRecord 27 | wrap f = GSR (\g1 g2 -> f g1 == f g2) (\g1 g2 -> compare (f g1) (f g2)) 28 | compareList = [wrap board, wrap active, wrap held, wrap canHold, wrap combo, wrap garbage] 29 | 30 | instance Eq GameState where 31 | g1 == g2 = and . fmap (\r -> equal r g1 g2) $ compareList 32 | instance Ord GameState where 33 | compare g1 g2 = foldr cmp EQ compareList 34 | where cmp :: GSRecord -> Ordering -> Ordering 35 | cmp f b = let c = comp f g1 g2 in if c == EQ then b else c 36 | 37 | newtype TransitionState = TransitionState (Bool, GameState) 38 | 39 | moveActive :: Action -> GameState -> Maybe GameState 40 | moveActive act gs = fmap (\a -> gs{active = a}) $ moveBlock (board gs) act (active gs) 41 | 42 | moveActive' :: Action -> GameState -> GameState 43 | moveActive' a s = fromMaybe s (moveActive a s) 44 | 45 | addActive :: GameState -> GameState 46 | addActive g = g{board = addActiveBlock (board g) (active g)} 47 | 48 | clearLines' :: GameState -> (Int, GameState) 49 | clearLines' gs = fmap (\b -> gs{board = b}) . clearLines . board $ gs 50 | 51 | addGarbage :: MonadRandom m => GameState -> m GameState 52 | addGarbage g = fmap (\b -> g{board = b, garbage = []}) $ foldl update (pure $ board g) (garbage g) 53 | where update :: MonadRandom m => m Board -> Int -> m Board 54 | update b' ct = do 55 | cl <- getRandomR (0,9) 56 | pure . addGarbageLines ct cl =<< b' 57 | 58 | reduceGarbage :: Int -> GameState -> GameState 59 | reduceGarbage _ g@GameState{garbage = [] } = g 60 | reduceGarbage c g@GameState{garbage = ct:gbs} 61 | | c >= ct = reduceGarbage (c - ct) g{garbage = gbs} 62 | | otherwise = g{garbage = (ct - c):gbs} 63 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: nightly-2019-11-24 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | extra-deps: 43 | - finitary-derive-2.1.0.0@sha256:d1703269280319a5d53c8586b84bfb7bad29ce661594c07f2a60fa4411fca8e5,3025 44 | - coercible-utils-0.0.0@sha256:8d447373536021684dd3edcfd073a0046570c7010b2938f18f9538eccc9e76f5,1871 45 | - finitary-1.2.0.0@sha256:84edde7135d274b213e73f072b1b8326ef76e4f9f18c84524bcff2e01695d5e4,2715 46 | - typelits-witnesses-0.4.0.0@sha256:1d7092ba98fdc33f4b413e04144eb3ead7b105f74b2998e3c74a8a0feee685a9,1985 47 | - dependent-sum-0.6.2.0@sha256:bff37c85b38e768b942f9d81c2465b63a96076f1ba006e35612aa357770807b6,1856 48 | - constraints-extras-0.3.0.2@sha256:bf6884be65958e9188ae3c9e5547abfd6d201df021bff8a4704c2c4fe1e1ae5b,1784 49 | - git: https://github.com/jbrot/grenade.git 50 | commit: 4b5a6ee64184611c8558f87c41cd4424ce3a4cbe 51 | 52 | # Override default flag values for local packages and extra-deps 53 | # flags: {} 54 | 55 | # Extra package databases containing global packages 56 | # extra-package-dbs: [] 57 | 58 | # Control whether we use the GHC we find on the path 59 | # system-ghc: true 60 | # 61 | # Require a specific version of stack, using version ranges 62 | # require-stack-version: -any # Default 63 | # require-stack-version: ">=2.1" 64 | # 65 | # Override the architecture used by stack, especially useful on Windows 66 | # arch: i386 67 | # arch: x86_64 68 | # 69 | # Extra directories used by stack for building 70 | # extra-include-dirs: [/path/to/dir] 71 | # extra-lib-dirs: [/path/to/dir] 72 | # 73 | # Allow a newer minor version of GHC than the snapshot specifies 74 | # compiler-check: newer-minor 75 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: finitary-derive-2.1.0.0@sha256:d1703269280319a5d53c8586b84bfb7bad29ce661594c07f2a60fa4411fca8e5,3025 9 | pantry-tree: 10 | size: 750 11 | sha256: dde13b926593239369c00d31522a8cc0d9d6792f7caa79351bf7a3f8ccb6a949 12 | original: 13 | hackage: finitary-derive-2.1.0.0@sha256:d1703269280319a5d53c8586b84bfb7bad29ce661594c07f2a60fa4411fca8e5,3025 14 | - completed: 15 | hackage: coercible-utils-0.0.0@sha256:8d447373536021684dd3edcfd073a0046570c7010b2938f18f9538eccc9e76f5,1871 16 | pantry-tree: 17 | size: 382 18 | sha256: 0168b16d3bad18c1c5137441e33022bde170e4b58dd0282f493df86606559e2e 19 | original: 20 | hackage: coercible-utils-0.0.0@sha256:8d447373536021684dd3edcfd073a0046570c7010b2938f18f9538eccc9e76f5,1871 21 | - completed: 22 | hackage: finitary-1.2.0.0@sha256:84edde7135d274b213e73f072b1b8326ef76e4f9f18c84524bcff2e01695d5e4,2715 23 | pantry-tree: 24 | size: 438 25 | sha256: 0ef496caa99aa525363b84d2ddac5b8f19fd3cd02d5bd79544a8ad6c96b70e43 26 | original: 27 | hackage: finitary-1.2.0.0@sha256:84edde7135d274b213e73f072b1b8326ef76e4f9f18c84524bcff2e01695d5e4,2715 28 | - completed: 29 | hackage: typelits-witnesses-0.4.0.0@sha256:1d7092ba98fdc33f4b413e04144eb3ead7b105f74b2998e3c74a8a0feee685a9,1985 30 | pantry-tree: 31 | size: 403 32 | sha256: 2ee741f6bb4dba710e6449da335fdcf8940adb767798b29fdb8ae2606d22e0cb 33 | original: 34 | hackage: typelits-witnesses-0.4.0.0@sha256:1d7092ba98fdc33f4b413e04144eb3ead7b105f74b2998e3c74a8a0feee685a9,1985 35 | - completed: 36 | hackage: dependent-sum-0.6.2.0@sha256:bff37c85b38e768b942f9d81c2465b63a96076f1ba006e35612aa357770807b6,1856 37 | pantry-tree: 38 | size: 474 39 | sha256: ad3fbed5104f9ee9c8082c9dcc8ade847674e3053572533e8d26ad1a866f1107 40 | original: 41 | hackage: dependent-sum-0.6.2.0@sha256:bff37c85b38e768b942f9d81c2465b63a96076f1ba006e35612aa357770807b6,1856 42 | - completed: 43 | hackage: constraints-extras-0.3.0.2@sha256:bf6884be65958e9188ae3c9e5547abfd6d201df021bff8a4704c2c4fe1e1ae5b,1784 44 | pantry-tree: 45 | size: 594 46 | sha256: b0bcc96d375ee11b1972a2e9e8e42039b3f420b0e1c46e9c70652470445a6505 47 | original: 48 | hackage: constraints-extras-0.3.0.2@sha256:bf6884be65958e9188ae3c9e5547abfd6d201df021bff8a4704c2c4fe1e1ae5b,1784 49 | - completed: 50 | cabal-file: 51 | size: 7305 52 | sha256: 12ad21ee33ddfeebbe0a9d04e5fc09c00f70275eeed956c8cfd39e0fb184b3b7 53 | name: grenade 54 | version: 0.1.0 55 | git: https://github.com/jbrot/grenade.git 56 | pantry-tree: 57 | size: 5500 58 | sha256: 3b1a8a7c52c62a87d1fbd240da879c8e0c48d8b0419e62df86f107418f462ab8 59 | commit: 4b5a6ee64184611c8558f87c41cd4424ce3a4cbe 60 | original: 61 | git: https://github.com/jbrot/grenade.git 62 | commit: 4b5a6ee64184611c8558f87c41cd4424ce3a4cbe 63 | snapshots: 64 | - completed: 65 | size: 426679 66 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2019/11/24.yaml 67 | sha256: 249cba060354fd4e8ed95894f33f922c28f3276e2de629250c9d16aa1cf586e1 68 | original: nightly-2019-11-24 69 | --------------------------------------------------------------------------------