Initial version giving Wrong Answer

c/1.lisp

+;;;; Game Sort
+
+(defun solve (&optional (in *standard-input*))
+  (dotimes (caseno (the (integer 0 1000) (read in)))
+    (format t "Case #~D: " (+ caseno 1))
+    (solve-case in)))
+
+(defun solve-case (in)
+  (let ((nchunks (read in)))
+    (let ((line (read-line in)))
+      (let ((chunks (split-at-spaces line nchunks)))
+        (let ((sol (gamesort chunks)))
+          (if sol
+              (format t "POSSIBLE~%~{~A~^ ~}~%" sol)
+              (format t "IMPOSSIBLE~%")))))))
+
+(defun split-at-spaces (s n)
+  (do* ((n n (1- n))
+       (result '())
+       (k 0)
+       (next (position #\Space s :start k)
+             (position #\Space s :start k)))
+      ((zerop n) (nreverse result))
+    (push (subseq s k next) result)
+    (when next
+      (setq k (+ next 1)))))
+
+(defun gamesort (strings)
+  (gamesort-1 strings "" '()))
+
+(defun gamesort-1 (strings last result)
+  (if (endp strings)
+      (nreverse result)
+      (let ((next (sort-after (first strings) last)))
+        (if next
+            (gamesort-1 (rest strings) next (cons next result))
+            nil))))
+
+(defun sort-after (s1 s2)
+  (sort-after-1 (sort (coerce s1 'list) #'char<) s2 0 '()))
+
+(defun sort-after-1 (c1 s2 pos result)
+  (let (next)
+    (let ((tentative-result (coerce (append (reverse result) c1) 'string)))
+      (if (string>= tentative-result s2)
+          tentative-result
+          (if (or (>= pos (length s2))
+                  (endp c1)
+                  (progn
+                    (setq next (find (char s2 pos) c1 :test #'char<=))
+                    (not next)))
+              nil
+              (sort-after-1 (remove next c1 :count 1)
+                            s2
+                            (+ pos 1)
+                            (cons next result)))))))
+
+(solve)