;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package "CL-USER") #|| SOLUTION TO THE ILC 2003 PROGRAMMING CONTEST -------------------------------------------- Of course, I'd never write horrible code like this for a "real" program... :) HOW TO USE ---------- The program consists of one file "puzzle.lisp" and it is executed by compiling and loading this file. It will print all solutions to the puzzle described in the contest. The way I understand the rules of the contest I expect the timing to be measured more or less like this: (time (progn (compile-file "puzzle" :print nil :verbose nil) (load "puzzle" :print nil :verbose nil))) On my laptop (Pentium III 1.2 GHz, 768 MB RAM) with Linux and CMUCL 18e this whole process takes about 0.65 seconds. (AllegroCL, LispWorks, and SBCL all need between 1.5 and 2.0 seconds, CLISP is at about 5.5 seconds.) HOW IT WORKS ------------ The heart of the algorithm is classical backtracking, I couldn't conceive of any better way to do this. In order to find a fast solution I tried to avoid consing as much as possible. Here are my basic implementation strategies (see also comments in "puzzle.lisp" itself): 1. The board plus the pieces currently on it are represented by three integers. Actually, the board is represented by 64 bits where the first 22 bits are (BYTE 1 0) to (BYTE 1 21) of the first integer, the next 22 bits are (BYTE 1 0) to (BYTE 1 21) of the second integer and the remaining 20 bits are (BYTE 1 0) to (BYTE 1 19) of the third integer. (1 meaning that the corresponding square is occupied, 0 meaning that it's not.) These integers are called PART-0 through PART-2 throughout the program. This strategy was chosen because it can be assumed that 22 bits will fit into a FIXNUM in all current CL implementations. (But note that this isn't required for the program to work. It's just a reasonable assumption to make it fast.) Squares are counted from left to right and then from top to bottom, i.e. the upper left square (0,0) is 0, the next square to the right is 1, the square below (0,0) - i.e. (1,0) - is 8, and so on: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 2. Pieces (including their orientation and position on the board) are represented in the same way, thus allowing us to use, say, LOGAND for collision tests and LOGIOR to add a piece to the board). We call such a piece (if converted to its internal representation) a "move". 3. Before we start the backtracking we compute each possible move a piece can assume. 4. We have manually assembled 32 "forbidden" situations (see variable *CAGES*) which we don't need to try. For example it wouldn't make sense to place a piece such that square (0,0) (the upper left corner) was free and (0,1) and (1,0) were occupied. (This corresponds to the first pair in *CAGES*.) 5. Each move is associated with its first (if counting from 0 to 63) non-zero square through the *MOVES* array, i.e. each move occurs in *MOVES* only once. The backtracking function TRY will look for the next free square NEXT-SQUARE and then try each move from (AREF *MOVES* NEXT-SQUARE). If we can't succeed with this move here it won't make sense to try it again later (on another square). 6. For each move we also compute its "width" (see comments in the code) which will help us to skip squares when descending down into TRY. 7. The "chessboard" analogy (as suggested by the contest rules) is built into the program - see the variable INITIAL-NUDGE. A MORE GENERAL SOLUTION ----------------------- The internal representation of boards and moves is hand-tailored for the specific size of the board. My first attempt involved macrology to make the code work for arbitrary board sizes such that the "parts" would always fit into a FIXNUM and such that it would only use one or two parts for 64-bit Lisps. However, I dropped it when I read that macro expansion time and compilation time would be considered part of the total running time. The other significant part of the program specific to this particular puzzle is the list *CAGES* which relies on the shapes of the pieces. However, it turns out that getting rid of *CAGES* doesn't hamper the program too much - with *CAGES* set to NIL the SOLVE function needs about 0.6 (as opposed to 0.4) seconds in CMUCL. In other words: It'd be relatively easy to extend this program to a general solution for arbitrary boards, arbitrary initial fillings, and arbitrary pieces. Dr.Edmund Weitz Hamburg Germany 2003-06-20 ||# (defpackage "PUZZLE" (:use "CL") (:export "SOLVE" "*PIECES*" "*INITIAL-BOARD*")) (in-package "PUZZLE") (defconstant +board-size+ 8 "Height/width of the board") (defconstant +board-squares+ (* +board-size+ +board-size+) "Number of squares on the board") (defstruct piece "Structure to describe one piece" ;; the character which names the piece char ;; a list of all possible moves for this piece moves ;; whether this piece is currently in use (while in TRY) in-use-p) (defstruct move "Structure to describe one move" ;; the three parts of the move part-0 part-1 part-2 ;; a list of indices into *result-string* corresponding to this move markers ;; whether this move has already been put into *MOVES* seen-p ;; the width of the first row of ones of this move width ;; the piece this move belongs to piece ;; whether this move is currently in use (while in TRY) in-use-p) ;; the first two aren't actually used... (defvar *part-0* 0 "First part of initial board") (defvar *part-1* 0 "Second part of initial board") (defvar *part-2* 0 "Third part of initial board") (defvar *num-pieces* 0 "Holds the number of pieces") (defvar *moves* nil "An array which holds all moves, indexed by square") (defvar *result-string* (copy-seq "- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 3 - - - - - - - 3 3 ") "This string will be used to print the results. The triomino is already there.") (defun build-board (input v-offset h-offset) "Transforms the board INPUT (a list of lists of zeros and ones) into its internal representation, i.e. into three parts. INPUT can be a partial board in which case V-OFFSET and H-OFFSET denote its upper left square - otherwise both are 0." (let ((part-0 0) (part-1 0) (part-2 0)) (loop for 1st-square-in-1st-row from (+ (* +board-size+ v-offset) h-offset) by +board-size+ for row in input do (let ((square 1st-square-in-1st-row)) (dolist (content row) (when (= 1 content) ;; set the correct bit to 1 (cond ((<= 0 square 21) (setq part-0 (dpb 1 (byte 1 square) part-0))) ((<= 22 square 43) (setq part-1 (dpb 1 (byte 1 (- square 22)) part-1))) (t (setq part-2 (dpb 1 (byte 1 (- square 44)) part-2))))) (incf square)))) (values part-0 part-1 part-2))) (defvar *cages* (loop for (input-1 input-2) on '(((0 1) ;; one block, upper left corner (1 0)) ((0 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 1) ;; three blocks, upper left corner (the #\W piece...) (0 1 0) (1 0 0)) ((0 0 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 1) ;; two blocks, upper left corner, horizontal (1 1 0)) ((0 0 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 1) ;; three blocks, upper left corner, horizontal (1 1 1 0)) ((0 0 0 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0) ;; four blocks, upper left corner, horizontal (1 1 1 1)) ((0 0 0 0 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 1) ;; two blocks, upper left corner, vertical (0 1) (1 0)) ((0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 1) ;; three blocks, upper left corner, vertical (0 1) (0 1) (1 0)) ((0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 1) ;; four blocks, upper left corner, vertical (0 1) (0 1) (0 1)) ((0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 1 0) ;; one block, upper right corner (0 0 0 0 0 0 0 1)) ((1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 1 0 0) ;; two blocks, upper right corner, horizontal (0 0 0 0 0 0 1 1)) ((1 1 1 1 1 1 0 0) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0 1 0 0 0) ;; three blocks, upper right corner, horizontal (0 0 0 0 0 1 1 1)) ((1 1 1 1 1 0 0 0) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 0 0) ;; four blocks, upper right corner, horizontal (0 0 0 0 1 1 1 1)) ((1 1 1 1 0 0 0 0) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 1 0) ;; two blocks, upper right corner, vertical (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 0 1)) ((1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 1 0) ;; three blocks, upper right corner, vertical (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 0 1)) ((1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 1 0) ;; four blocks, upper right corner, vertical (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 1 0)) ((1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1)) ((0 0) ;; one block, lower left corner (0 0) (0 0) (0 0) (0 0) (0 0) (1 0) (0 1)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1)) ((0 0 0) ;; two blocks, lower left corner, horizontal (0 0 0) (0 0 0) (0 0 0) (0 0 0) (0 0 0) (1 1 0) (0 0 1)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (0 0 1 1 1 1 1 1)) ((0 0 0 0) ;; three blocks, lower left corner, horizontal (0 0 0 0) (0 0 0 0) (0 0 0 0) (0 0 0 0) (0 0 0 0) (1 1 1 0) (0 0 0 1)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (0 0 0 1 1 1 1 1)) ((0 0 0 0) ;; four blocks, lower left corner, horizontal (0 0 0 0) (0 0 0 0) (0 0 0 0) (0 0 0 0) (0 0 0 0) (1 1 1 1) (0 0 0 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (0 0 0 0 1 1 1 1)) ((0 0) ;; two blocks, lower left corner, vertical (0 0) (0 0) (0 0) (0 0) (1 0) (0 1) (0 1)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1)) ((0 0) ;; three blocks, lower left corner, vertical (0 0) (0 0) (0 0) (1 0) (0 1) (0 1) (0 1)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1)) ((0 0) ;; four blocks, lower left corner, vertical (0 0) (0 0) (0 0) (0 1) (0 1) (0 1) (0 1)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1) (0 1 1 1 1 1 1 1)) ((0 0 0 0 0 0) ;; one block, lower right corner, beneath triomino (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 1) (0 0 0 0 1 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 0 1 1)) ((0 0 0 0 0 0) ;; three blocks, lower right corner, beneath triomino (the #\W piece...) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 1) (0 0 0 0 1 0) (0 0 0 1 0 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 0 1 1) (1 1 1 1 0 0 1 1)) ((0 0 0 0 0 0) ;; two blocks, lower right corner, horizontal, beneath triomino (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 1 1) (0 0 0 1 0 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 0 0 1 1)) ((0 0 0 0 0 0) ;; three blocks, lower right corner, horizontal, beneath triomino (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 1 1 1) (0 0 1 0 0 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 0 0 0 1 1)) ((0 0 0 0 0 0) ;; four blocks, lower right corner, horizontal, beneath triomino (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 1 1 1 1) (0 0 0 0 0 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 0 0 0 0 1 1)) ((0 0 0 0 0 0) ;; two blocks, lower right corner, vertical, beneath triomino (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 0) (0 0 0 0 0 1) (0 0 0 0 1 0) (0 0 0 0 1 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 0 1 1) (1 1 1 1 1 0 1 1)) ((0 0 0 0 0 0 0 0) ;; one block, lower right corner, beyond triomino (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 1)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 0 0) ;; two blocks, lower right corner, vertical, beyond triomino (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 1) (0 0 0 0 0 0 1 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 0 0) ;; three blocks, lower right corner, vertical, beyond triomino (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 1) (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 1 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1)) ((0 0 0 0 0 0 0 0) ;; four blocks, lower right corner, vertical, beyond triomino (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 1 0)) ((1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 0) (1 1 1 1 1 1 1 1))) by #'cddr nconc (multiple-value-list (build-board input-1 0 0)) nconc (multiple-value-list (build-board input-2 0 0))) "A list to describe 'impossible' moves") (defun make-moves (input) "Creates a list of all possible moves of the piece represented by INPUT (as a list of lists of zeros and ones starting in the upper left corner)." (let ((num-rows (length input)) (num-cols (length (first input))) ;; we have to take care of the white/black (slot/tab) ;; alternation, i.e. only half of the board's squares are ;; candidates for the upper left corner of a move (initial-nudge 0)) ;; remove the last row if it only consists of zeros, ;; repeat if necessary (loop while (every #'zerop (car (last input))) do (setq input (butlast input) num-rows (1- num-rows))) ;; remove the first row if it only consists of zeros ;; repeat if necessary (loop while (every #'zerop (first input)) do (setq input (cdr input) ;; switch the slot/tab nudge value initial-nudge (- 1 initial-nudge) num-rows (1- num-rows))) ;; remove the last column if it only consists of zeros ;; repeat if necessary (loop while (every #'(lambda (row) (zerop (first (last row)))) input) do (setq input (mapcar #'butlast input) num-cols (1- num-cols))) ;; remove the first column if it only consists of zeros ;; repeat if necessary (loop while (every #'(lambda (row) (zerop (first row))) input) do (setq input (mapcar #'cdr input) ;; switch the slot/tab nudge value initial-nudge (- 1 initial-nudge) num-cols (1- num-cols))) (loop with first-row = (first input) ;; compute the "width" (i.e. the length of the leftmost ;; sequence of consecutive ones in the first row) of this ;; piece; we need this to advance NEXT-SQUARE in TRY with zero-width = (position 1 first-row :test '=) with width = (- (or (position 0 first-row :start zero-width :test '=) (length first-row)) zero-width) ;; loop through all rows of the board which can hold the ;; first row of this piece for v-offset from 0 to (- +board-size+ num-rows) ;; switch the slot/tab nudge for each row for nudge = initial-nudge then (- 1 nudge) nconc (loop with part-0 and part-1 and part-2 ;; now loop through all columns of the board ;; which can hold the first column of this piece for h-offset from nudge to (- +board-size+ num-cols) by 2 ;; compute the piece's internal representation do (setf (values part-0 part-1 part-2) (build-board input v-offset h-offset)) ;; make sure the pieces isn't "caged" unless (or (loop for (cage-one-0 cage-one-1 cage-one-2 cage-zero-0 cage-zero-1 cage-zero-2) on *cages* by #'(lambda (list) (nthcdr 6 list)) thereis (and (= (logand part-0 cage-one-0) cage-one-0) (= (logand part-1 cage-one-1) cage-one-1) (= (logand part-2 cage-one-2) cage-one-2) (= (logior part-0 cage-zero-0) cage-zero-0) (= (logior part-1 cage-zero-1) cage-zero-1) (= (logior part-2 cage-zero-2) cage-zero-2))) ;; make sure the piece doesn't cover the triomino (not (zerop (logand part-2 *part-2*)))) collect (make-move :part-0 part-0 :part-1 part-1 :part-2 part-2 :width width ;; compute the indices of this move into *RESULT-STRING* :markers (loop for 1st-char-in-1st-row from (+ (* v-offset 16) (* 2 h-offset)) by 16 for row in input nconc (loop for char from 1st-char-in-1st-row by 2 for content in row when (= 1 content) collect char))))))) (defun build-piece (char/input) "Given a piece represented as a character and a list of lists of ones and zeros translate it into a PIECE structure and compute all possible MOVE structures for this piece." (let* ((char (car char/input)) (input (cdr char/input)) ;; rotate the piece by 90 degrees; do this four times for ;; each piece (but only twice for #\N and #\Q because these ;; are symmetrical) (moves (loop for i below (case char ((#\N #\Q) 2) (otherwise 4)) for rotated-input = input then (loop for col downfrom (1- (length (first rotated-input))) downto 0 collect (mapcar #'(lambda (row) (nth col row)) rotated-input)) nconc (make-moves rotated-input))) (piece (make-piece :char char :moves moves))) (dolist (move moves) ;; make all MOVE structures point back to the PIECE structure ;; they belong to (setf (move-piece move) piece)) piece)) (defun try (part-0 part-1 part-2 depth next-square) "The workhose of the algorithm which does the backtracking. PART-0 through PART-1 represent the current board, NEXT-SQUARE is the next candidate for an empty square to fill, DEPTH should be obvious." (when (= depth *num-pieces*) ;; we're done if DEPTH equals the number of pieces to place on the ;; board, so print the result now, i.e. loop through all square ;; and all moves corresponding to these squares... (dotimes (square +board-squares+) (loop for move in (svref *moves* square) when (move-in-use-p move) ;; ...and insert the corresponding character into ;; *RESULT-STRING* if this particular move was used for ;; the solution do (let ((char (piece-char (move-piece move)))) (dolist (marker (move-markers move)) (setf (schar *result-string* marker) char))))) ;; finally print the string (princ *result-string*) ;; return NIL so backtracking will proceed (return-from try nil)) (let ((next-square ;; loop through all remaining squares and find the next one ;; which is empty (i.e. where the corresponding bit is zero) (loop for square from next-square below +board-squares+ when (zerop (cond ((<= 0 square 21) (ldb (byte 1 square) part-0)) ((<= 22 square 43) (ldb (byte 1 (- square 22)) part-1)) (t (ldb (byte 1 (- square 44)) part-2)))) do (return square)))) ;; now loop through all moves which match NEXT-SQUARE and try them (loop with move-part-0 and move-part-1 and move-part-2 for move in (svref *moves* next-square) for piece = (move-piece move) ;; of course we can only try if this piece isn't already in ;; use - if we do we'll now mark both the piece and the move do (and (not (piece-in-use-p piece)) (setf (piece-in-use-p piece) t (move-in-use-p move) t) (prog1 ;; first check whether the move in question only ;; touches empty squares... (and (zerop (logand (setq move-part-0 (move-part-0 move)) part-0)) (zerop (logand (setq move-part-1 (move-part-1 move)) part-1)) (zerop (logand (setq move-part-2 (move-part-2 move)) part-2)) ;; ...then try it (try (logior move-part-0 part-0) (logior move-part-1 part-1) (logior move-part-2 part-2) (1+ depth) (+ next-square ;; we know the width of this move so ;; we know how many squares we can ;; skip (move-width move)))) ;; we're done, so we unmark piece and move (setf (piece-in-use-p piece) nil (move-in-use-p move) nil))))) (values)) (defun solve (pieces initial-board) "Solve the puzzle given the list of pieces and the initial (almost) empty board." (multiple-value-bind (*part-0* *part-1* *part-2*) ;; convert initial board into its internal representation (build-board initial-board 0 0) (let* ((*num-pieces* (length pieces)) ;; convert pieces into their internal representations (converted-pieces (mapcar #'build-piece pieces)) ;; this array will map each move to the first square it ;; touches (*moves* (make-array +board-squares+ :initial-element nil))) (dolist (converted-piece converted-pieces) (dolist (move (piece-moves converted-piece)) (dotimes (square +board-squares+) ;; if this move hasn't been seen before and if it touches ;; the current square... (when (and (not (move-seen-p move)) (= 1 (cond ((<= 0 square 21) (ldb (byte 1 square) (move-part-0 move))) ((<= 22 square 43) (ldb (byte 1 (- square 22)) (move-part-1 move))) (t (ldb (byte 1 (- square 44)) (move-part-2 move)))))) ;; ...we put it into the right place in *moves* (setf (move-seen-p move) t) (push move (svref *moves* square)))))) ;; start the backtracking (try *part-0* *part-1* *part-2* 0 0)))) (defparameter *initial-board* '((0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 1 1)) "The initial, empty board with the triomino already in place") (defparameter *pieces* ;; upper left corner must be "white", numbers of rows and columns ;; must be both odd '((#\F . ((1 0 0) (1 1 0) (1 0 0) (1 0 0) (0 0 0))) (#\J . ((0 0 1) (0 0 1) (0 0 1) (0 1 1) (0 0 0))) (#\L . ((0 1 0) (0 1 0) (0 1 0) (0 1 1) (0 0 0))) (#\N . ((0 0 0) (0 0 1) (1 1 1) (1 0 0) (0 0 0))) (#\Q . ((1 0 0) (1 1 1) (0 0 1) (0 0 0) (0 0 0))) (#\S . ((0 1 0) (0 1 1) (0 0 1) (0 0 1) (0 0 0))) (#\T . ((0 1 0) (1 1 0) (0 1 0) (0 1 0) (0 0 0))) (#\W . ((1 0 0) (1 1 0) (0 1 1) (0 0 0) (0 0 0))) (#\Z . ((1 1 1 0 0) (0 0 1 1 0) (0 0 0 0 0))) (#\j . ((0 1 0) (0 1 0) (1 1 0))) (#\l . ((1 0 0) (1 0 0) (1 1 0))) (#\s . ((1 0 0) (1 1 0) (0 1 0))) (#\t . ((0 1 0) (1 1 0) (0 1 0)))) "The list of pieces to place into the board") ;; now do it... (solve *pieces* *initial-board*) ;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/edi-weitz.lisp#2 $