Skip to content
Switch branches/tags
Go to file
Cannot retrieve contributors at this time
;;; Google Code Jam 2020, Qualification Round, Problem 5: Indicium
(declaim (ftype (function ((integer 0 1000) (integer 0 1000000)) t) latin))
(declaim (ftype (function ((integer 0 1000) (integer 0 1000)) t) boring-latin))
(declaim (ftype (function ((integer 0 1000) (integer 0 1000) (integer 0 1000) (integer 0 1000)) t) interesting-latin))
(declaim (ftype (function ((integer 0 1000) (integer 0 1000000)) t) solve-case-1))
(declaim (ftype (function ((integer 0 1000) (integer 0 1000000) (simple-array t (* *))) t) check-response))
(declaim (ftype (function ((simple-array t (* *)) (integer 0 1000)) t) latin-square-p))
(declaim (ftype (function ((simple-array t (* *))) (integer 0 1000000)) array-trace))
(defun solve (&optional (in *standard-input*))
(dotimes (caseno (the (integer 0 1000) (read in)))
(format t "Case #~D: " (+ caseno 1))
(solve-case in)))
(defun latin (n k)
(multiple-value-bind (div rem)
(truncate k n)
(if (= rem 0)
(boring-latin n div)
(do ((a (max 1 (truncate (- k n n) n)) (+ a 1))
(max (min n (ceiling k n))))
((> a max) nil)
(do ((b 1 (1+ b))) ((> b n))
(when (/= a b)
(do ((c 1 (1+ c))) ((> c n))
(when (and (/= a c)
(= (+ (* (- n 2) a) b c) k))
(let ((result (interesting-latin n a b c)))
(when result (return-from latin result)))))))))))
(defun boring-latin (n a)
(let ((m (make-array (list n n))))
(dotimes (i n)
(dotimes (j n)
(setf (aref m i (- n j 1))
(1+ (mod (+ i j a) n)))))
(defun interesting-latin (n a b c)
(cond ((/= a b c)
(let ((seq (make-array (list n))))
(setf (aref seq 0) a
(aref seq 1) b
(aref seq (- n 1)) c)
(do ((index 2)
(i 1 (+ i 1)))
((> i n))
(unless (or (= i a) (= i b) (= i c))
(setf (aref seq index) i)
(incf index)))
(let ((m (make-array (list n n))))
(dotimes (i n)
(dotimes (j n)
(setf (aref m (if (< i 2) (- 1 i) i) j)
(aref seq (mod (- i j) n)))))
((and (= b c) (evenp n) (>= n 4))
(let ((seq (make-array (list n)))
(swap-index (truncate n 2)))
(setf (aref seq 0) a
(aref seq swap-index) b)
(do ((index 1)
(i 1 (+ i 1)))
((> i n))
(unless (or (= i a) (= i b))
(setf (aref seq index) i)
(incf index)
(when (= index swap-index)
(incf index))))
;;(warn "SEQ ~A" seq)
(let ((m (make-array (list n n))))
(dotimes (i n)
(dotimes (j n)
(setf (aref m (if (or (= i 0) (= i swap-index))
(- swap-index i)
(aref seq (mod (- j i) n)))))
(t nil)))
(defun out-square (a)
(declare (type (simple-array t (* *)) a))
(let ((n (array-dimension a 0)))
(dotimes (i n)
(dotimes (j n)
(format t "~D " (aref a i j)))
(format t "~%"))))
(defun solve-case (in)
(solve-case-1 (read in) (read in)))
(defun solve-case-1 (N K)
(if (< K N)
(format t "IMPOSSIBLE~%")
(let ((a (latin N K)))
(if a (progn
(format t "POSSIBLE~%")
(out-square a))
(format t "IMPOSSIBLE~%")))))
;;; Tests
(defun check-response (n k a)
(and (= (length (array-dimensions a)) 2)
(= (array-dimension a 0) n)
(= (array-dimension a 1) n)
(latin-square-p a n)
(= (array-trace a) k)))
(defun latin-square-p (a n)
(labels ((check-row (a n i) (check-unique n #'(lambda (j) (aref a i j))))
(check-col (a n i) (check-unique n #'(lambda (j) (aref a j i))))
(check-unique (n fun)
(dotimes (i n t)
(let ((values-seen (make-array (list (+ n 1)) :element-type 'bit :initial-element 0)))
(dotimes (j n)
(let ((value (funcall fun j)))
(if (not (zerop (aref values-seen value)))
(return-from check-unique nil)
(setf (aref values-seen value) 1))))))))
(dotimes (i n t)
(unless (check-col a n i)
(return nil))
(unless (check-row a n i)
(return nil)))))
(defun array-trace (a)
(let ((n (array-dimension a 0))
(result 0))
(dotimes (i n result)
(incf result (aref a i i)))))
(defun find-permut (n)
(labels ((v (i j) (mod (- j i) n)))
(do ((i 0 (1+ i))) ((>= i (- n 1)))
(do ((j (+ i 1) (1+ j))) ((> j (- n 1)))
(when (= (v i j) (v j i))
(return-from find-permut (values i j)))))))
(defun test (&optional (n 50))
(declare (type (integer 0 1000) n))
(do ((k n (+ k 2))) ((>= k (* n n)))
(let ((s (latin n k)))
(if (not s)
(warn "n=~D k=~D: no solution" n k)
(unless (check-response n k s)
(warn "n=~D k=~D: WRONG solution" n k))))))