;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:USER -*-

;;; File "BREAKOUT"
;;; Implements the classic (read: quite dull) video game.
;;; Written by Jamie Zawinski.
;;;
;;; ChangeLog:
;;;
;;; 20 Dec 88  Jamie Zawinski    Created.
;;;


(defflavor breakout-window
	   ((speed 0)
	    (paddle-width 100)
	    (ball-x 0)
	    (ball-y 0)
	    (ball-dx 0)
	    (ball-dy 0)
	    (bricks nil)
	    (horizontal-bricks 20)
	    (vertical-bricks 6)
	    (brick-count 0)
	    (ball-size 10)
	    (paddle-height 15)
	    (brick-height 20)
	    (top-margin 50)
	    (bottom-margin 150)
	    (score 0)
	    (balls 3)
	    (demo-mode nil)
	    (accelerated-p nil)
	    )
	   (w:window)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)



(defvar *breakout-ball-offset* 6 "The value added to the background color to draw the ball.")
(defvar *breakout-paddle-offset* 1 "The value added to the background color to draw the paddle.")
(defvar *breakout-background-color* W:DARK-BLUE)
(defvar *breakout-foreground-color* W:WHITE)

(defvar *breakout-brick-colors*
	(make-array 6 :initial-contents
		      (list W:PURPLE W:ORANGE W:75%-GRAY-COLOR W:50%-GRAY-COLOR W:33%-GRAY-COLOR W:WHITE))
  "The colors of the rows of bricks.")


(defmethod (breakout-window :after :init) (ignore)
  (send self :set-font-map #26(fonts:cmr10))
  (cond ((tv:color-system-p self)
	 (send self :set-foreground-color *breakout-foreground-color*)
	 (send self :set-background-color *breakout-background-color*))
	(t (setq tv:erase-aluf tv:alu-setz))))


(defmethod (breakout-window :reset-bricks) ()
  (cond (bricks
	 (dotimes (i (array-dimension bricks 0))
	   (dotimes (j (array-dimension bricks 1))
	     (setf (aref bricks i j) 1))))
	(t
	 (setq bricks (make-array (list horizontal-bricks vertical-bricks)
				  :element-type 'bit :initial-element 1))))
  (setq brick-count (* horizontal-bricks vertical-bricks)))


;
;(defmethod (breakout-window :erase-ball) ()
;  (send self :draw-filled-circle ball-x ball-y ball-size *breakout-ball-offset* TV:ALU-SUB 8))
;
;(defmethod (breakout-window :draw-ball) ()
;  (send self :draw-filled-circle ball-x ball-y ball-size *breakout-ball-offset* TV:ALU-ADD 8))
;

(defmethod (breakout-window :erase-ball) ()
  (send self :draw-filled-rectangle ball-x ball-y ball-size ball-size *breakout-ball-offset* TV:ALU-SUB))

(defmethod (breakout-window :draw-ball) ()
  (send self :draw-filled-rectangle ball-x ball-y ball-size ball-size *breakout-ball-offset* TV:ALU-ADD))



(defmethod (breakout-window :erase-paddle) (x)
  (send self :draw-filled-rectangle x (- (tv:sheet-inside-height) (+ bottom-margin paddle-height))
				    paddle-width paddle-height *breakout-paddle-offset* TV:ALU-SUB))

(defmethod (breakout-window :draw-paddle) (x)
  (send self :draw-filled-rectangle x (- (tv:sheet-inside-height) (+ bottom-margin paddle-height))
				    paddle-width paddle-height *breakout-paddle-offset* TV:ALU-ADD))


(defmethod (breakout-window :erase-brick) (x y)
  (let* ((width (round (tv:sheet-inside-width) horizontal-bricks))
	 (real-x (* x width))
	 (real-y (+ top-margin (* y brick-height))))
    (send self :draw-filled-rectangle real-x real-y width brick-height 0 tv:erase-aluf)))

(defmethod (breakout-window :draw-brick) (x y)
  (let* ((width (round (tv:sheet-inside-width) horizontal-bricks))
	 (real-x (* x width))
	 (real-y (+ top-margin (* y brick-height)))
	 (color (if (tv:color-system-p self)
		    (if (< y (length *breakout-brick-colors*))
			(or (aref *breakout-brick-colors* y) W:WHITE)
			W:WHITE)
		    (case y
		      (0 W:75%-GRAY-COLOR)
		      (1 W:88%-GRAY-COLOR)
		      (t (if (oddp y) W:50%-GRAY-COLOR W:12%-GRAY-COLOR)))))
	 (gap 1))
    (send self :draw-filled-rectangle real-x real-y (- width gap) (- brick-height gap) color TV:ALU-TRANSP)))


(defmethod (breakout-window :draw-all-bricks) ()
  (send self :erase-ball)
  (dotimes (i (array-dimension bricks 0))
    (dotimes (j (array-dimension bricks 1))
      (if (plusp (aref bricks i j))
	  (send self :draw-brick i j)
	  (send self :erase-brick i j))))
  (send self :draw-ball))


(defmethod (breakout-window :move-ball) ()
  (let* ((dx (if accelerated-p (* ball-dx 2) ball-dx))
	 (dy (if accelerated-p (* ball-dy 2) ball-dy))
	 (new-x (+ ball-x dx))
	 (new-y (+ ball-y dy))
	 (paddle-x tv:mouse-x)
	 (erase-brick-x nil)
	 (erase-brick-y nil)
	 )
    (cond ;;
          ;; In the danger zone.
          ;;
          ((and (plusp ball-dy)
		(<= (- (tv:sheet-inside-height) (+ bottom-margin paddle-height))
		    new-y))
	   (cond ;;
	         ;; A Hit!
	         ;;
	         ((or demo-mode
		      (and (<= new-y (- (tv:sheet-inside-height) bottom-margin))
			   (<= paddle-x new-x (+ paddle-x paddle-width))))
		  (breakout-beep :paddle)
		  (setq ball-dy (- ball-dy))
		  (when (zerop brick-count)
		    (send self :reset-bricks)
		    (send self :draw-all-bricks)
		    (setq speed (min 10 (1+ speed)))))
		 ;;
		 ;; A Miss!
		 ;;
		 ((> new-y (tv:sheet-inside-height))
		  (send self :erase-ball)
		  (decf balls)
		  (throw 'MISS t))))
	  ;;
	  ;; Bounce off a wall.
	  ;;
	  ((<= new-x 0)
	   (unless (plusp ball-dx)
	     (breakout-beep :wall)
	     (setq ball-dx (- ball-dx))))
	  ((>= new-x (tv:sheet-inside-width))
	   (unless (minusp ball-dx)
	     (breakout-beep :wall)
	     (setq ball-dx (- ball-dx))))
	  ((<= new-y 0)
	   (unless (plusp ball-dy)
	     (breakout-beep :wall)
	     (setq ball-dy (- ball-dy))))
	  ;;
	  ;; In the brick zone.
	  ;;
	  ((<= (- top-margin brick-height)
	       new-y
	       (+ top-margin (* (1+ vertical-bricks) brick-height)))
	   (let* ((max-x (array-dimension bricks 0))
		  (max-y (array-dimension bricks 1))
		  (brick-x (floor new-x (round (tv:sheet-inside-width) horizontal-bricks)))
		  (brick-y (floor (- new-y top-margin) brick-height)))
	     
	     (cond #+COMMENT ((and (<= 0 brick-x (1- max-x))
			 (<= 0 brick-y (1- max-y))
			 (plusp (aref bricks brick-x brick-y)))
		    (setq erase-brick-x brick-x
			  erase-brick-y brick-y))
		   
		   ((and (minusp ball-dy)
			 (<= 0 brick-x      (1- max-x))
			 (<= 0 (1- brick-y) (1- max-y))
			 (plusp (aref bricks brick-x (1- brick-y))))
		    (setq erase-brick-x brick-x
			  erase-brick-y (1- brick-y)))
		   
		   ((and (plusp ball-dy)
			 (<= 0 brick-x      (1- max-x))
			 (<= 0 (1+ brick-y) (1- max-y))
			 (plusp (aref bricks brick-x (1+ brick-y))))
		    (setq erase-brick-x brick-x
			  erase-brick-y (1+ brick-y)))))
	   
	   (when erase-brick-x
	     (setq ball-dy (- ball-dy))
	     (setf (aref bricks erase-brick-x erase-brick-y) 0))))
    (send self :erase-ball)
    (when erase-brick-x
      (breakout-beep :brick)
      (send self :erase-brick erase-brick-x erase-brick-y)
      (incf score)
      (send self :show-stats)
      (when (< erase-brick-y 2) (setq accelerated-p t))
      (decf brick-count))
    (setq ball-x new-x
	  ball-y new-y)
    (send self :draw-ball)))


(defmethod (breakout-window :drop-ball) ()
  (let* ((dx (- (random 5) 10)))
    (setq ball-x (round (tv:sheet-inside-width) 2)
	  ball-y (round (tv:sheet-inside-height) 2)
	  ball-dx (ceiling (* (1+ speed) dx) 2)
	  ball-dy (ceiling (* (1+ speed) 5) 2)
	  accelerated-p nil
	  ))
  (send self :draw-ball))


(defmethod (breakout-window :loop) ()
  (send self :expose)
  (send self :select)
  (send self :refresh)
  (let* ((old-paddle-x nil)
	 (paddle-x nil)
	 (ball-tick (get-internal-run-time))
	 (color-p (tv:color-system-p self))
	 (*breakout-ball-offset* (if color-p *breakout-ball-offset* 8))
	 (*breakout-paddle-offset* (if color-p *breakout-paddle-offset* 8)))
    (loop
      (block GAME-OVER
	(setq score 0 balls 2)
	(send self :reset-bricks)
	(send self :draw-all-bricks)
	(send self :show-stats "Any key to begin.")
	(loop
	  (catch 'MISS
	    (when (minusp balls)
	      (send self :show-stats (format nil "GAME OVER!  ~D points." score))
	      (tv:read-any self)
	      (return-from GAME-OVER))
	    (send self :show-stats "Any key for next ball.")
	    (tv:read-any self)
	    (send (car (send self :blinker-list)) :set-visibility nil)
	    (send self :drop-ball)
	    (send self :show-stats)
	    (loop
	      (setq paddle-x (min tv:mouse-x (- (tv:sheet-inside-width) paddle-width)))
	      (when (and old-paddle-x
			 (/= paddle-x old-paddle-x))
		(send self :erase-paddle old-paddle-x))
	      (when (or (null old-paddle-x)
			(/= paddle-x old-paddle-x))
		(send self :draw-paddle paddle-x))
	      (let* ((now (get-internal-run-time)))
		(when (/= now ball-tick)
		  (send self :move-ball)
		  (setq ball-tick now)))
	      (setq old-paddle-x paddle-x)
	      (when (tv:read-any-no-hang self)
		(send self :show-stats "Any key to continue.")
		(tv:read-any self)
		(send self :show-stats))
	      )))))))


(defmethod (breakout-window :set-speed) (n)
  (check-type n (integer 0 10))
  (setq speed n)
  (setq paddle-width (+ 50 (* (- 10 n) 5)))
  (when (tv:sheet-exposed-p self)
    (send self :show-stats))
  n)


(defmethod (breakout-window :show-stats) (&optional string)
  (send self :set-cursorpos 0 (- (tv:sheet-inside-height self) tv:line-height))
  (send self :clear-eol)
  (if string
      (princ string self)
      (format self "Balls: ~D;  Speed: ~D;  Score: ~D." balls speed score))
  (send (car (send self :blinker-list)) :set-visibility nil)
  )


(defun breakout-beep (type)
  (ecase type
    (:PADDLE (tv:simple-beep 128 50))
    (:WALL   (tv:simple-beep 512 50))
    (:BRICK  (tv:simple-beep 1024 50))))


(defun breakout (&optional (speed 1) demo-p)
  "Play the world's dullest video game."
  (let* ((window (tv:find-window-of-flavor 'BREAKOUT-WINDOW)))
    (unless window
      (setq window (make-instance 'BREAKOUT-WINDOW)))
    (send window :set-speed speed)
    (send window :set-demo-mode demo-p)
    (send window :loop)))