(in-package :cl-user)
(defpackage :continuo
(:use :common-lisp)
(:export
:clear :play
:*write-ps* :*ps-board*
:random-player :greedy-player :good-player :mr-memory))
(in-package :continuo)
(defvar *write-ps* nil
"Write postscript output when T.")
(defvar *ps-board* "board.ps"
"Graphical board output filename.")
(defparameter *board-size* 334) (defparameter *offset* 165)
(defvar *board*
(make-array (list *board-size* *board-size*) :initial-element nil))
(defvar *bounding-box* '((0 0) (0 0)))
(defvar *scored-squares*
(make-array (list *board-size* *board-size*) :initial-element nil))
(defconstant +cards+
'((:rgrg . (red green red green))
(:rbrb . (red blue red blue))
(:ryry . (red yellow red yellow))
(:grgr . (green red green red))
(:gbgb . (green blue green blue))
(:gygy . (green yellow green yellow))
(:brbr . (blue red blue red))
(:bgbg . (blue green blue green))
(:byby . (blue yellow blue yellow))
(:yryr . (yellow red yellow red))
(:ygyg . (yellow green yellow green))
(:ybyb . (yellow blue yellow blue))
(:rgrb . (red green red blue))
(:rgbr . (red green blue red))
(:rgbg . (red green blue green))
(:rgry . (red green red yellow))
(:rgyr . (red green yellow red))
(:rgyg . (red green yellow green))
(:rbrg . (red blue red green))
(:rbgr . (red blue green red))
(:rbgb . (red blue green blue))
(:rbry . (red blue red yellow))
(:rbyr . (red blue yellow red))
(:rbyb . (red blue yellow blue))
(:ryrg . (red yellow red green))
(:rygr . (red yellow green red))
(:rygy . (red yellow green yellow))
(:ryrb . (red yellow red blue))
(:rybr . (red yellow blue red))
(:ryby . (red yellow blue yellow))
(:grgb . (green red green blue))
(:grbg . (green red blue green))
(:grbr . (green red blue red))
(:grgy . (green red green yellow))
(:gryg . (green red yellow green))
(:gryr . (green red yellow red))
(:gbgr . (green blue green red))
(:gbrg . (green blue red green))
(:gbrb . (green blue red blue))
(:gbgy . (green blue green yellow))
(:gbyg . (green blue yellow green))
(:gbyb . (green blue yellow blue))
(:gygr . (green yellow green red))
(:gyrg . (green yellow red green))
(:gyry . (green yellow red yellow))
(:gygb . (green yellow green blue))
(:gybg . (green yellow blue green))
(:gyby . (green yellow blue yellow))
(:brbg . (blue red blue green))
(:brgb . (blue red green blue))
(:brgr . (blue red green red))
(:brby . (blue red blue yellow))
(:bryb . (blue red yellow blue))
(:bryr . (blue red yellow red))
(:bgbr . (blue green blue red))
(:bgrb . (blue green red blue))
(:bgrg . (blue green red green))
(:bgby . (blue green blue yellow))
(:bgyb . (blue green yellow blue))
(:bgyg . (blue green yellow green))
(:bybr . (blue yellow blue red))
(:byrb . (blue yellow red blue))
(:byry . (blue yellow red yellow))
(:bybg . (blue yellow blue green))
(:bygb . (blue yellow green blue))
(:bygy . (blue yellow green yellow))
(:yryg . (yellow red yellow green))
(:yrgy . (yellow red green yellow))
(:yrgr . (yellow red green red))
(:yryb . (yellow red yellow blue))
(:yrby . (yellow red blue yellow))
(:yrbr . (yellow red blue red))
(:ygyr . (yellow green yellow red))
(:ygry . (yellow green red yellow))
(:ygrg . (yellow green red green))
(:ygyb . (yellow green yellow blue))
(:ygby . (yellow green blue yellow))
(:ygbg . (yellow green blue green))
(:ybyr . (yellow blue yellow red))
(:ybry . (yellow blue red yellow))
(:ybrb . (yellow blue red blue))
(:ybyg . (yellow blue yellow green))
(:ybgy . (yellow blue green yellow))
(:ybgb . (yellow blue green blue))))
(defvar *remaining-cards* (mapcar #'car +cards+)
"Cards remaining since the last CLEAR.")
(defun rotate (card)
"Finds the rotated variant of CARD."
(car (rassoc (reverse (cdr (assoc card +cards+))) +cards+ :test #'equal)))
(defun select-one (lst)
"Chooses an element randomly from a list.
Returns NIL if LST is the empty list."
(if lst (elt lst (random (length lst))) nil))
(defun generate-cards ()
"Generates a random sequence of cards."
(do* ((cards (mapcar #'car +cards+)
(let ((last-one (first generated)))
(remove last-one (remove (rotate last-one) cards))))
(generated (list (select-one cards))
(cons (select-one cards) generated)))
((null cards) (rest generated))))
(defun get-color (card spin i j)
"Gets the color of CARD at position (I, J).
If SPIN is T the card is rotated 90 degrees."
(let ((top-row (if spin
(reverse (cdr (assoc card +cards+)))
(cdr (assoc card +cards+))))
(i (if (> j (- 3 i)) (- 3 j) i))
(j (if (> j (- 3 i)) (- 3 i) j)))
(cond ((and (< i 1) (< j 1)) (first top-row))
((and (< i 2) (< j 2)) (second top-row))
((and (< i 3) (< j 3)) (third top-row))
(t (fourth top-row)))))
(defun clear ()
"Clears the board and the remaining card list and resets the bounding box."
(setf *bounding-box* '((0 0) (0 0)))
(setf *remaining-cards* (mapcar #'car +cards+))
(dotimes (i *board-size*)
(dotimes (j *board-size*)
(setf (aref *board* i j) nil))))
(defun get-square (x y)
(aref *board* (+ *offset* x) (+ *offset* y)))
(defun set-square (x y color)
(setf (aref *board* (+ *offset* x) (+ *offset* y)) color))
(defun clear-scored-flag (x y)
(setf (aref *scored-squares* (+ *offset* x) (+ *offset* y)) nil))
(defun set-scored-flag (x y)
(setf (aref *scored-squares* (+ *offset* x) (+ *offset* y)) t))
(defun scoredp (x y)
(aref *scored-squares* (+ *offset* x) (+ *offset* y)))
(defun write-ps-board ()
"Prints the board to a postscript file, zooming automatically.
The paper size of the output is A4 (8.3 x 11.7 inches)."
(let* ((total-width (* 8.3 72))
(total-height (* 11.7 72))
(width (- (first (second *bounding-box*))
(first (first *bounding-box*))))
(height (- (second (second *bounding-box*))
(second (first *bounding-box*))))
(edge-length (min (/ total-width width) (/ total-height height)))
(x-margin (* (- total-width (* width edge-length)) 0.5))
(y-margin (* (- total-height (* height edge-length)) 0.5))
(colors '((red (1 0 0)) (green (0 1 0))
(blue (0 0 1)) (yellow (1 1 0)))))
(with-open-file (s *ps-board* :direction :output :if-exists :supersede)
(format s "%!PS~%~
/box {~% ~
~f~:* 0 rlineto 0 -~f~:* rlineto -~f 0 rlineto closepath ~%~
} def~%" edge-length)
(dotimes (i width)
(dotimes (j height)
(let* ((bi (+ i (first (first *bounding-box*))))
(bj (+ j (second (first *bounding-box*))))
(color (second (assoc (get-square bi bj) colors))))
(when color
(format s "newpath~% ~
~f ~f moveto box gsave~% ~
~{~f ~}setrgbcolor fill~% ~
grestore stroke~%"
(+ (* i edge-length) x-margin)
(- total-height (* j edge-length) y-margin)
color)))))
(format s "showpage~%"))))
(defun enough-space-p (x y)
"Checks if there is enough space for a card to put at (X, Y)."
(not (or (get-square (+ x 3) (+ y 3))
(get-square (+ x 3) (+ y 2))
(get-square (+ x 3) (+ y 1))
(get-square (+ x 3) (+ y 0))
(get-square (+ x 2) (+ y 3))
(get-square (+ x 2) (+ y 2))
(get-square (+ x 2) (+ y 1))
(get-square (+ x 2) (+ y 0))
(get-square (+ x 1) (+ y 3))
(get-square (+ x 1) (+ y 2))
(get-square (+ x 1) (+ y 1))
(get-square (+ x 1) (+ y 0))
(get-square (+ x 0) (+ y 3))
(get-square (+ x 0) (+ y 2))
(get-square (+ x 0) (+ y 1))
(get-square (+ x 0) (+ y 0)))))
(defun can-place-card-p (x y)
"Checks if there is another card overlapping and if there is edge contact."
(and (enough-space-p x y)
(or (get-square (- x 1) (+ y 0))
(get-square (- x 1) (+ y 1))
(get-square (- x 1) (+ y 2))
(get-square (- x 1) (+ y 3))
(get-square (+ x 4) (+ y 0))
(get-square (+ x 4) (+ y 1))
(get-square (+ x 4) (+ y 2))
(get-square (+ x 4) (+ y 3))
(get-square (+ x 0) (- y 1))
(get-square (+ x 1) (- y 1))
(get-square (+ x 2) (- y 1))
(get-square (+ x 3) (- y 1))
(get-square (+ x 0) (+ y 4))
(get-square (+ x 1) (+ y 4))
(get-square (+ x 2) (+ y 4))
(get-square (+ x 3) (+ y 4)))))
(defun continuable-p (x y)
"Is there space for a card that has an edge connecting to this position?"
(or (enough-space-p (- x 0) (- y 4))
(enough-space-p (- x 0) (+ y 1))
(enough-space-p (- x 4) (- y 0))
(enough-space-p (+ x 1) (- y 0))
(enough-space-p (- x 1) (- y 4))
(enough-space-p (- x 1) (+ y 1))
(enough-space-p (- x 4) (- y 1))
(enough-space-p (+ x 1) (- y 1))
(enough-space-p (- x 2) (- y 4))
(enough-space-p (- x 2) (+ y 1))
(enough-space-p (- x 4) (- y 2))
(enough-space-p (+ x 1) (- y 2))
(enough-space-p (- x 3) (- y 4))
(enough-space-p (- x 3) (+ y 1))
(enough-space-p (- x 4) (- y 3))
(enough-space-p (+ x 1) (- y 3))))
(defun card-left-p (i j color &optional (cards *remaining-cards*))
"Is there a card left with COLOR at its (I, J) position?"
(unless (null cards)
(let ((card (first cards)))
(or (eq (get-color card nil i j) color)
(eq (get-color card t i j) color)
(card-left-p i j color (rest cards))))))
(defun order-of-continuity (x y)
"Returns the number of places you can place a card to be connected to the
given position (with the same color). Uses remaining card data."
(let ((color (get-square x y)))
(apply #'+ (mapcar #'(lambda (p q)
(if (and (enough-space-p (- x (first p))
(- y (second p)))
(card-left-p (first q) (second q) color))
1 0))
'((0 4) (0 -1) (4 0) (-1 0)
(1 4) (1 -1) (4 1) (-1 1)
(2 4) (2 -1) (4 2) (-1 2)
(3 4) (3 -1) (4 3) (-1 3))
'((0 3) (0 0) (3 0) (0 0)
(1 3) (1 0) (3 1) (0 1)
(2 3) (2 0) (3 2) (0 2)
(3 3) (3 0) (3 3) (0 3))))))
(defun put-card (card spin x y)
"Puts CARD at position (X, Y). If SPIN is T the card is rotated 90 degrees.
The function doesn't check if there is another card overlapping."
(dotimes (i 4)
(dotimes (j 4)
(set-square (+ x i) (+ y j) (get-color card spin i j)))))
(defun remove-card (x y)
"Clears a card's space starting from position (X, Y).
The function doesn't check if a card _was_ there or not."
(dotimes (i 4)
(dotimes (j 4)
(set-square (+ x i) (+ y j) nil))))
(defun same-neighbours (x y)
"A list of the same-color neighbouring squares of (X, Y)."
(let ((color (get-square x y)))
(append (if (eq (get-square (1- x) y) color) (list (list (1- x) y)) nil)
(if (eq (get-square (1+ x) y) color) (list (list (1+ x) y)) nil)
(if (eq (get-square x (1- y)) color) (list (list x (1- y))) nil)
(if (eq (get-square x (1+ y)) color) (list (list x (1+ y))) nil))))
(defun count-recursively (pos old-pos)
"Counts the length of consecutive same-color squares from position POS.
OLD-POS is the position where we have come from."
(set-scored-flag (first pos) (second pos))
(let ((neighbours (same-neighbours (first pos) (second pos))))
(if (= (length neighbours) 1)
1
(1+ (count-recursively (first (remove old-pos neighbours
:test #'equal))
pos)))))
(defun count-loop (pos origin last-pos)
"Counts the length of a loop of same-color squars from position POS.
If POS is NIL or not part of a loop, it returns NIL.
ORIGIN and OLD-POS are both the position where we have come from."
(when pos
(set-scored-flag (first pos) (second pos))
(if (equal pos origin)
0
(let ((neighbours (same-neighbours (first pos) (second pos))))
(if (= (length neighbours) 1)
nil
(let* ((remaining (remove last-pos neighbours :test #'equal))
(rlength (count-loop (first remaining) origin pos)))
(when rlength (1+ rlength))))))))
(defun count-chain (pos min)
"Counts the length of a chain from the seed point POS.
First checks if the chain is a loop; if not, adds the two halves.
Returns 0 if the result is less than MIN."
(let* ((neighbours (same-neighbours (first pos) (second pos)))
(result
(or (count-loop (first neighbours) pos pos)
(apply #'+ (mapcar #'(lambda (position)
(count-recursively position pos))
neighbours)))))
(if (< result min) 0 (1+ result))))
(defun score-card (x y)
"Calculates score as if the card at (X, Y) has just been put down."
(dotimes (i 4)
(dotimes (j 4)
(clear-scored-flag (+ x i) (+ y j))))
(apply #'+ (mapcar #'(lambda (pos min)
(if (scoredp (first pos) (second pos))
0
(count-chain pos min)))
(list (list x y)
(list (+ x 1) y)
(list (+ x 2) y)
(list (+ x 3) y)
(list x (+ y 3))
(list (+ x 1) (+ y 3))
(list (+ x 2) (+ y 3))
(list (+ x 3) (+ y 3)))
'(1 3 3 1 1 3 3 1))))
(defun score-play (card spin x y)
"Returns the total score of playing CARD at (X, Y).
The card is placed rotated 90 degrees if SPIN is T.
The function doesn't check if there is another card overlapping."
(put-card card spin x y)
(prog1 (score-card x y)
(remove-card x y)))
(defun put-card-with-score (card spin x y)
"Puts down CARD at (X, Y) and returns the score earned.
The card is placed rotated 90 degrees if SPIN is T.
This function also updates the bounding box."
(put-card card spin x y)
(setf *bounding-box* (list (mapcar #'min (first *bounding-box*)
(list x y))
(mapcar #'max (second *bounding-box*)
(list (+ x 4) (+ y 4)))))
(when *write-ps* (write-ps-board))
(list x y spin (score-card x y)))
(defun find-possible-moves ()
"Returns a list of all possible moves (by the list of top-left coordinates)."
(let* ((min-x (- (first (first *bounding-box*)) 4))
(min-y (- (second (first *bounding-box*)) 4))
(width (- (+ (first (second *bounding-box*)) 4) min-x))
(height (- (+ (second (second *bounding-box*)) 4) min-y))
moves)
(dotimes (i width)
(dotimes (j height)
(let ((x (+ i min-x))
(y (+ j min-y)))
(when (can-place-card-p x y)
(push (list x y) moves)))))
moves))
(defun scored-positions (card)
"Returns all possible moves with the corresponding scores."
(let ((positions (find-possible-moves)))
(append (mapcar #'(lambda (pos)
(list pos nil
(score-play card nil (first pos) (second pos))))
positions)
(mapcar #'(lambda (pos)
(list pos t
(score-play card t (first pos) (second pos))))
positions))))
(defun count-sum-of-usable-chains (position)
(if (continuable-p (first position) (second position))
(count-chain position 0)
0))
(defun count-sum-of-usable-chains-with-memory (position)
(let ((number-of-possibilities (order-of-continuity (first position)
(second position))))
(if (= number-of-possibilities 0)
0
(* (count-chain position 0) number-of-possibilities))))
(defun usable-chains (memory-mode card position spin score)
"Sum of the length of the chains that are still usable with a new card.
Uses remaining card data when MEMORY-MODE is set.
Chains with two free sides are counted twice.
The function erases the space below the card, without checking."
(declare (ignore score))
(let ((x (first position))
(y (second position))
(counting-function (if memory-mode
#'count-sum-of-usable-chains-with-memory
#'count-sum-of-usable-chains)))
(put-card card spin x y)
(prog1 (apply #'+ (mapcar counting-function
(list (list (+ x 0) (+ y 0))
(list (+ x 0) (+ y 3))
(list (+ x 1) (+ y 0))
(list (+ x 1) (+ y 3))
(list (+ x 0) (+ y 1))
(list (+ x 3) (+ y 1))
(list (+ x 2) (+ y 0))
(list (+ x 2) (+ y 3))
(list (+ x 0) (+ y 2))
(list (+ x 3) (+ y 2))
(list (+ x 3) (+ y 0))
(list (+ x 3) (+ y 3)))))
(remove-card x y))))
(defun random-player (card)
"Places CARD on a random position, sometimes rotated 90 degrees."
(let ((position (select-one (find-possible-moves))))
(append (list card (if (= (random 2) 0) nil t)) position)))
(defun greedy-player (card)
"Scores all possible moves, finally choosing one
randomly from the highest-scoring positions."
(let* ((positions (scored-positions card))
(max (apply #'max (mapcar #'third positions)))
(chosen (select-one (remove-if #'(lambda (x) (< (third x) max))
positions))))
(append (list card (second chosen)) (first chosen))))
(defun good-player (card)
"Scores all possible moves, then chooses one from the best ones (within
some tolerance), according to the maximal length of its usable chains."
(let* ((positions (scored-positions card))
(max (apply #'max (mapcar #'third positions)))
(good-list (remove-if #'(lambda (x) (< (third x) (- max 2)))
positions))
(sorted-list (sort good-list #'>
:key #'(lambda (x)
(apply #'usable-chains nil card x))))
(chosen (first sorted-list)))
(append (list card (second chosen)) (first chosen))))
(defun mr-memory (card)
"Like Good Player, just Mr. Memory also knows what cards are still in the
deck, so his definition of `usable chains' is more accurate."
(let* ((positions (scored-positions card))
(max (apply #'max (mapcar #'third positions)))
(good-list (remove-if #'(lambda (x) (< (third x) (- max 3)))
positions))
(sorted-list (sort good-list #'>
:key #'(lambda (x)
(apply #'usable-chains t card x))))
(chosen (first sorted-list)))
(setf *remaining-cards*
(remove card (remove (rotate card) *remaining-cards*)))
(append (list card (second chosen)) (first chosen))))
(defun play (card &optional (algorithm #'mr-memory))
"Places CARD at a `good' position.
The first card is placed at (0, 0), sometimes rotated 90 degrees."
(if (null (get-square 0 0))
(put-card-with-score card (if (= (random 2) 0) nil t) 0 0)
(apply #'put-card-with-score (funcall algorithm card))))
(defparameter *test-deck*
'(:YRBY :RBRB :BGYG :YGYB :GBRG :BGRG :BRBY :BYBG :GYRY :RBRY :YRGY :BYRB
:GYBG :GRYG :BGRB :YRGR :YRYB :YGRG :RYRG :RBYB :GBGR :BRGR :RGYR :RGYG
:RGBR :YBYG :YBGB :GBRB :GBGY :YBYR :RYRY :BGBG :YBGY :YGYG :RYBR :RBRG
:RBGB :YGYR :RYRB :GRGR :BGYB :YBYB)
"Test deck. A greedy algorithm earns about 750-800 points with this.")
(defun test-play (algorithm &optional (deck *test-deck*))
(clear)
(apply #'+ (mapcar #'(lambda (x) (fourth (play x algorithm))) deck)))
(defun who-is-better (number-of-games &rest players)
"Play NUMBER-OF-GAMES games and print a scoring board."
(let* ((n (length players))
(scores (make-array n :initial-element 0))
(totals (make-array n :initial-element 0)))
(dotimes (i number-of-games)
(let* ((deck (generate-cards))
(points (mapcar #'(lambda (x) (test-play x deck)) players)))
(dotimes (i n)
(setf (elt totals i) (+ (elt totals i) (elt points i))))
(let ((maximum (apply #'max points)))
(if (= (length (remove-if #'(lambda (x) (< x maximum)) points)) 1)
(dotimes (i n)
(when (= (elt points i) maximum)
(setf (elt scores i) (1+ (elt scores i)))))
(format t "Tie between: ~{~a~^ ~}~%"
(mapcar #'(lambda (x y) (if (= x maximum) y ""))
points players))))))
(format t "PLAYER / WINS / TOTAL~%~{~{~a~^ / ~}~%~}"
(loop for i below n collecting (list (elt players i)
(elt scores i)
(elt totals i))))))
(in-package :cl-user)
(use-package :continuo)