day-13.lisp

(in-package :advent.2019.intcode)

;; utils

(defun make-command-queue (size)
  (assert (plusp size))
  (let* ((commands (make-list size))
	 (head commands))
    (lambda (value callback)
      (setf (car head) value)
      (setf head
	    (or (cdr head)
		(prog1 commands
		  (apply callback commands)))))))

;; day 13 - part 1

(defproc v4/d13 (v4)
  ((in-queue :initform (make-command-queue 3) :reader in-queue)
   (game :reader game :initarg :game)))

(defclass game-part-1 () 
  ((counter :initform 0 :accessor counter)))

(defgeneric update-game (game x y tile)
  (:method ((game game-part-1) x y tile)
    (case tile
      (2 (incf (counter game))))))

(define-primitive .print ((p v4/d13) value)
  (funcall (in-queue p) 
	   value
	   (lambda (x y tile)
	     (update-game (game p) x y tile))))

(let ((game (make-instance 'game-part-1)))
  (run-program (make-instance 'v4/d13 
			      :game game
			      :memory (make-memory '(#P"13.in" 4096))))
  (counter game))

;; day 13 - part 2

(defclass game-part-2 ()
  ((grid :accessor grid :initform (make-hash-table))
   (paddle :accessor paddle :initform 0)
   (ball :accessor ball :initform 0)
   (bounding-box :accessor bounding-box)))

(defgeneric joystick (game))

(define-primitive .read ((p v4/d13))
  (joystick (game p)))

(defmethod update-game ((game game-part-2) x y third)
  (if (and (= -1 x) (= 0 y))
      (print `(:score ,third))
      (let ((coord (complex x y))
	    (grid (grid game))
	    (tile (aref #(:empty :wall :block :paddle :ball) third)))
	(ecase tile
	  (:empty (remhash coord grid))
	  ((:wall :block) (setf (gethash coord grid) tile))
	  (:paddle (setf (paddle game) coord))
	  (:ball (setf (ball game) coord))))))

(defmethod joystick ((game game-part-2))
  ;; basic strategy
  (realpart (- (ball game) (paddle game))))

(defun d13-p2 (&optional (class 'v4/d13))
  (let ((p (make-instance class
			  :game (make-instance 'game-part-2)
			  :memory (make-memory '(#P"13.in" 4096)))))
    (setf (at (memory p) 0) 2)
    p))

(run-program (d13-p2))

;; day-13 - part 3

(ql:quickload :sdl2)
(ql:quickload :cl-opengl)
(ql:quickload :bricabrac)
(use-package :bricabrac.sdl2.event-loop)

(defvar *win*)
(defvar *gl*)

;; estimate next position of ball

(defproc v4/d13-p3-estimate (v4/d13)
  ((estimate :accessor estimate)
   (memory :accessor memory)
   (in-queue :accessor in-queue)
   (ty :accessor ty)))

(define-primitive .read ((p v4/d13-p3-estimate)) 0)
(define-primitive .print ((p v4/d13-p3-estimate) value)
  (funcall (in-queue p)
	   value
	   (lambda (x y u)
	     (when (= u 4 #| ball |#)
	       (when (= y (ty p))
		 (setf (estimate p) x)
		 (.halt p))))))

;; interact with game loop

(defproc v4/d13-2 (v4/d13)
  ((to-read :accessor to-read :initform nil)))

(define-primitive .read ((p v4/d13-2))
  (let ((value (to-read p)))
    (unless value (.halt p))
    (setf (to-read p) nil) value))

(defun bounding-box% (game)
  (loop 
     for p in (list* (paddle game) (ball game) (hash-table-keys (grid game)))
     minimize (realpart p) into lo-x minimize (imagpart p) into lo-y
     maximize (realpart p) into hi-x maximize (imagpart p) into hi-y
     finally (return (list lo-x lo-y (1+ hi-x) (1+ hi-y)))))

(defun set-size (game width height)
  (gl:viewport 0 0 width height)
  (gl:matrix-mode :projection)
  (gl:load-identity)
  (destructuring-bind (lox loy hix hiy) (bounding-box game)
    (gl:ortho lox hix hiy loy 0 1)))

(defun quad (p &optional (margin 0))
  (with-accessors ((x realpart) (y imagpart)) p
    (gl:rect (+ x margin)
	     (+ y margin)
	     (1+ (- x margin))
	     (1+ (- y margin)))))

(defvar *colorblock*)

(defgeneric display (p shape)
  (:method (p (shape (eql :paddle)))
    (gl:color 1 1 1 1)
    (quad p -0.1))
  (:method (p (shape (eql :block)))
    (funcall *colorblock* p)
    (quad p 0.1))
  (:method (p (shape (eql :wall)))
    (gl:color 0.3 0.3 0.3 1)
    (quad p))
  (:method (p (shape (eql :ball)))
    (gl:color 1 1 0 1)
    (quad p 0.1)))

(defun colorblock (bbox)
  (destructuring-bind (lx ly hx hy) bbox
    (let ((dx (- hx lx)) (dy (- hy ly)))
      (lambda (p)
	(with-accessors ((x realpart) (y imagpart)) p
	  (let ((xr (/ (- x lx) dx))
		(yr (/ (- y ly) dy)))
	    (gl:color (float (lerp xr 0 1))
		      (float (lerp yr 1 0))
		      (float (lerp (* xr yr) 1 0))
		      1)))))))

(defclass game-part-3 (game-part-2) 
  ((score :accessor score :initform 0)))

(defmethod update-game ((g game-part-3) x y arg)
  (if (and (= x -1) (= y 0))
      (setf (score g) arg)
      (call-next-method)))

(defun play (&optional (w 600) (h 300))
  (sdl2:with-everything
      (:window (win :w w :h h :flags '(:opengl :resizable :shown)) :gl gl)
    (let* ((game (make-instance 'game-part-3))
	   (p (make-instance 'v4/d13-2
			     :game game
			     :memory (make-memory '(#P"13.in" 4096))))
	   (e (make-instance 'v4/d13-p3-estimate
			     :memory (make-memory (memory p))))
	   (active nil)
	   (score nil)
	   (old-ball nil)
	   (target nil))
      ;; insert coins
      (setf (at (memory p) 0) 2)
      ;; init
      (run-program p)
      (setf (ty e) (1- (imagpart (paddle game))))
      (setf old-ball (ball game))
      (setf (bounding-box game) (bounding-box% game))
      (set-size game w h)
      (let ((*colorblock* (colorblock (bounding-box game))))
	(flet ((estimate ()
		 (setf (estimate e) 0)
		 (setf (in-queue e) (make-command-queue 3))
		 (setf (pc e) (pc p))
		 (setf (relative-base e) (relative-base p))		   
		 (replace (buffer (memory e)) (buffer (memory p)))
		 (run-program e)
		 (estimate e))
	       (refresh ()
		 (gl:clear :color-buffer)
		 (display (paddle game) :paddle)
		 (display (ball game) :ball)
		 (maphash #'display (grid game))
		 (gl:flush)
		 (sdl2:gl-swap-window win)))
	  (setf target (estimate))
	  (gl:clear-color .1 .1 .1 1)
	  (refresh)
	  (do-match-events (:method :wait :timeout 30 :rebind (*standard-output*))
	    (with-window-event-resized (_ :width w :height h)
	      (set-size game w h))
	    (with-key-down-event (_)
	      (setf active t))
	    (:quit (return))
	    (:idle (when active
		     (run-program p)
		     (when (and (< (imagpart (ball game)) (imagpart old-ball))
				(= (imagpart old-ball) (ty e)))
		       (setf target (estimate))) 
		     (setf (to-read p)
			   (signum (- target (realpart (paddle game)))))
		     (setf old-ball (ball game))
		     (unless (eql score (score game))
		       (sdl2:set-window-title
			win (format nil "Score: ~d" (setf score (score game))))))
		   (refresh))))))))