;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.
(in-package :hu.dwim.number-toss)
;;;;;;
;;; Position
(def type coordinate ()
'(integer 0 8))
(def type position ()
'cons)
(def function position/make (x y)
(check-type x coordinate)
(check-type y coordinate)
(cons x y))
(def function position/x (position)
(check-type position cons)
(car position))
(def function position/y (position)
(check-type position cons)
(cdr position))
(def function position/parse (position index)
(check-type position string)
(check-type index non-negative-integer)
(position/make (- (char-code (elt position index)) 48)
(- (char-code (elt position (1+ index))) 48)))
(def function position/print (position stream)
(check-type position cons)
(princ (code-char (+ 48 (position/x position))) stream)
(princ (code-char (+ 48 (position/y position))) stream))
;;;;;;
;;; Move
(def type move ()
'cons)
(def function move/make (source target)
(check-type source position)
(check-type target position)
(bind ((move (cons source target)))
(assert (move/valid? move))
move))
(def function move/source (move)
(check-type move move)
(car move))
(def function move/target (move)
(check-type move move)
(cdr move))
(def function move/middle (move)
(check-type move move)
(bind ((source (move/source move))
(target (move/target move)))
(position/make (/ (+ (position/x source) (position/x target)) 2)
(/ (+ (position/y source) (position/y target)) 2))))
(def function move/valid? (move)
(bind ((source (move/source move))
(target (move/target move))
(dx (abs (- (position/x source) (position/x target))))
(dy (abs (- (position/y source) (position/y target)))))
(or (and (= dx 2) (= dy 0))
(and (= dx 0) (= dy 2))
(and (= dx 2) (= dy 2)))))
(def function move/parse (move index)
(check-type move string)
(check-type index non-negative-integer)
(move/make (position/parse move index)
(position/parse move (+ 2 index))))
(def function move/print (move stream)
(check-type move move)
(position/print (move/source move) stream)
(position/print (move/target move) stream))
;;;;;;
;;; Move sequence
(def type move-sequence ()
'sequence)
(def function move-sequence/make (moves)
(check-type moves move-sequence)
moves)
(def function move-sequence/parse (moves)
(check-type moves string)
(iter (for index :from 0 :below (length moves) :by 4)
(collect (move/parse moves index))))
(def function move-sequence/print (moves stream)
(check-type moves move-sequence)
(iter (for move :in-sequence moves)
(move/print move stream)))
;;;;;;
;;; Challenge id
(def type challenge-id ()
'non-negative-integer)
(def function challenge-id/size (challenge-id)
(check-type challenge-id challenge-id)
(the board-size (+ 5 (mod challenge-id 5))))
(def function challenge-id/ordinal (challenge-id)
(check-type challenge-id challenge-id)
(floor (/ challenge-id 5)))
;;;;;;
;;; Board
(def type score ()
'(integer 1 18))
(def type board ()
'sequence)
(def type board-size ()
'(integer 5 9))
(def type board-element ()
'(or null (integer 1 9)))
(def function board/make (size)
(check-type size board-size)
(iter (for y :from 0 :below size)
(collect (iter (for x :from 0 :below size)
(collect nil)))))
(def function board/copy (board)
(check-type board board)
(iter (for y :from 0 :below (length board))
(collect (iter (for x :from 0 :below (length board))
(collect (board/at board (position/make x y)))))))
(def function board/parse (size numbers)
(check-type size board-size)
(check-type numbers sequence)
(assert (= (* size size) (length numbers)))
(iter (for y :from 0 :below size)
(collect (iter (for x :from 0 :below size)
(for char = (elt numbers (+ (* y size) x)))
(for element = (unless (char= char #\Space)
(- (char-code char) 48)))
(check-type element board-element)
(collect element)))))
(def function board/print (board stream)
(check-type board board)
(iter (for y :from 0 :below (length board))
(iter (for x :from 0 :below (length board))
(for element = (board/at board (position/make x y)))
(if element
(format stream "~A" element)
(format stream " ")))))
(def function board/size (board)
(check-type board board)
(the board-size (length board)))
(def function board/at (board position)
(check-type board board)
(check-type position position)
(the board-element
(nth (position/x position)
(nth (position/y position) board))))
(def function (setf board/at) (new-value board position)
(check-type new-value board-element)
(check-type board board)
(check-type position position)
(the board-element
(setf (nth (position/x position)
(nth (position/y position) board))
new-value)))
(def function board/compute-move-score (board move)
(check-type board board)
(check-type move move)
(the score
(bind ((source (board/at board (move/source move)))
(middle (board/at board (move/middle move))))
(if (= source middle)
(* 2 middle)
middle))))
(def function board/move (board move)
(check-type board board)
(check-type move move)
(bind ((source (move/source move)))
(setf (board/at board (move/target move)) (board/at board source))
(setf (board/at board (move/middle move)) nil)
(setf (board/at board source) nil)
(values)))
(def function board/compute-score (board moves)
(check-type board board)
(check-type moves sequence)
(iter (with score = 0)
(for move :in-sequence moves)
(incf score (board/compute-move-score board move))
(board/move board move)
(finally (return score))))
(def function board/compute-score-bound (board)
(bind ((smallest 0)
(bound 0)
(size (length board))
(counts (make-array 10))
(parities (make-array 10)))
(iter (for x :from 0 :below size)
(iter (for y :from 0 :below size)
(for number = (board/at board (position/make x y)))
(when number
(setf (aref parities number) (logior (aref parities number)
(ash 1 (+ (* 2 (mod x 2))
(mod y 2)))))
(incf (aref counts number))
(when (or (zerop smallest)
(< number smallest))
(setf smallest number)))))
(setf bound (- smallest))
(iter (for i :from 0 :below (length counts))
(for count = (aref counts i))
(for parity = (aref parities i))
(incf bound
(cond ((or (= count 1)
(member parity '(1 2 4 8)))
(* count i))
((> count 1)
(+ i (* 2 i (1- count))))
(t 0))))
bound))