1 files changed, 49 insertions, 0 deletions
diff --git a/2ndary/12/QG-2014/ballgame.lisp b/2ndary/12/QG-2014/ballgame.lisp
new file mode 100644
index 0000000..765d85c
--- /dev/null
+++ b/2ndary/12/QG-2014/ballgame.lisp
@@ -0,0 +1,49 @@
+(defun normalize-line (line)
+  (if (or (and (= (first line) 0) (< (second line) 0))
+          (< (first line) 0))
+      (mapcar #'- line)
+      line))
+
+(defun make-line (x1 x2 y1 y2)
+  (let* ((a (- y2 y1))
+         (b (- x1 x2))
+         (c (+ (* a x1) (* b y1)))
+         (g (gcd a b c)))
+    (normalize-line (mapcar (lambda (x) (/ x g)) (list a b c)))))
+
+(defun extract-result (first-pair second-pair)
+  (let ((triple (union first-pair second-pair)))
+    (if (= (length triple) 3)
+        (format nil "~a~a~a" (first triple) (second triple) (third triple))
+        (format nil "~{~a ~}~a" first-pair (first second-pair)))))
+
+(with-open-file (instream "BALLGAME.INP")
+  (let ((n (read instream)))
+    (labels ((read-blues (m result)
+               (if (<= m n)
+                   (let* ((x (read instream)) (y (read instream)))
+                     (read-blues (1+ m) (cons (list m x y) result)))
+                   result)))
+      (let ((blues (read-blues 1 '()))
+            (lines (make-hash-table :test 'equal)))
+        (labels ((process-reds (m)
+                   (if (<= m n)
+                       (let* ((x (read instream))
+                              (y (read instream))
+                              (result
+                               (dolist (blue blues nil)
+                                 (let* ((line (make-line x (second blue)
+                                                         y (third blue)))
+                                        (this-pair (list (first blue) (+ m n)))
+                                        (that-pair (gethash line lines)))
+                                   (if (null that-pair)
+                                       (setf (gethash line lines) this-pair)
+                                       (return (extract-result this-pair
+                                                               that-pair)))))))
+                         (cond (result)
+                               (t (process-reds (1+ m)))))
+                       "-1")))
+          (with-open-file (outstream "BALLGAME.OUT" :direction :output
+                                     :if-exists :supersede)
+            (princ (process-reds 1) outstream)
+            (fresh-line outstream)))))))