;;; -*- Common Lisp -*-

#|  Copyright (c) 2007,2008 Gustavo Henrique Milaré

    This file is part of The Feebs War.

    The Feebs War is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 3 of the License, or
    (at your option) any later version.

    The Feebs War is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with The Feebs War.  If not, see <http://www.gnu.org/licenses/>.
|#


(in-package :the-feebs-war)


;;; We start defining the main system rules by defining the classes

;;; This class is used by the system

(defclass object ()
  ((direction  :accessor object-direction  :initarg :direction)
   (x-position :accessor object-x-position :initarg :x-position)
   (y-position :accessor object-y-position :initarg :y-position)
   (lifetime   :accessor object-lifetime   :initarg :lifetime :initform 0)))

(defclass feeb (object)
  (;; These are structures accessible from behavior functions.
   (name :accessor feeb-name :reader name :initarg :name)
   (direction :reader facing :initform (random 4) :accessor feeb-facing)
   (peeking :accessor feeb-peeking :reader peeking :initform nil)
   (x-position :reader x-position :accessor feeb-x-position)
   (y-position :reader y-position :accessor feeb-y-position)
   (line-of-sight :accessor feeb-line-of-sight :reader line-of-sight
                  :initform 0)
   (energy-reserve :accessor feeb-energy-reserve :reader energy-reserve)
   (ready-to-fire :accessor feeb-ready-to-fire :reader ready-to-fire
                  :initform t)
   (aborted :accessor feeb-aborted :reader aborted)
   (last-move :accessor feeb-last-move :reader last-move
              :initform :dead)

   ;; These are available for the system
   (brain :accessor feeb-brain :initarg :brain)
   (graphics :accessor feeb-graphics :initarg :graphics)
   (time :accessor feeb-time :initform 0)
   (last-score :accessor feeb-last-score :initform 0)
   (kill-counter :accessor feeb-kill-counter :initform 0)
   (score :accessor feeb-score :initform 0)
   (turns-since-flamed :accessor feeb-turns-since-flamed :initform 0)
   (proximity :accessor feeb-proximity :initform (make-proximity))
   (vision :accessor feeb-vision
           :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
   (vision-left :accessor feeb-vision-left
           :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
   (vision-right :accessor feeb-vision-right
           :initform (make-array (list (max *maze-y-size* *maze-x-size*))))))

(defclass fireball (object)
  ((owner :accessor fireball-owner :initarg :owner)
   (x-position :accessor fireball-x-position)
   (y-position :accessor fireball-y-position)
   (direction :accessor fireball-direction)))

(declaim
 (inline fireball-p feeb-p))

(defun fireball-p (x)
  (typep x 'fireball))

(defun feeb-p (x)
  (typep x 'feeb))



;;; Place and delete

(defun create-mushroom (x y)
  (unless (member :mushroom (aref *maze* x y))
    (place-object :mushroom x y)
    t))

(defun delete-object (thing x y)
  (setf (aref *maze* x y)
        (delete thing (aref *maze* x y))))

(defun place-object (thing x j)
  (push thing (aref *maze* x j)))

(defun change-object-pos (obj x y)
  (delete-object obj (object-x-position obj)
                 (object-y-position obj))
  (place-object obj x y)
  (setf (object-x-position obj) x
        (object-y-position obj) y))

(defun get-forward-pos (object)
  (let ((new-x (+ (forward-dx (object-direction object))
                  (object-x-position object)))
        (new-y (+ (forward-dy (object-direction object))
                  (object-y-position object))))
    (values (aref *maze* new-x new-y) new-x new-y)))



;;; --**-- System Rules --**--



;;; -*- Being Born and Dying -*-

;;; Creating

(defgeneric create-object (object x-pos y-pos)
  (:documentation "Creates OBJECT and places it in position (X-POS,Y-POS)
in the maze, except for fireballs, which are placed only the next turn.")
  (:method (object x-pos y-pos)
    (place-object object x-pos y-pos)
    (setf (object-x-position object) x-pos
          (object-y-position object) y-pos))

  (:method ((feeb feeb) x-pos y-pos)
    (setf (feeb-last-move feeb) :dead)
    (push feeb *feebs*)
    (call-next-method))

  (:method ((fireball fireball) x-pos y-pos)
    (push fireball *fireballs-flying*)
    (setf (object-x-position fireball) x-pos
          (object-y-position fireball) y-pos))) ; don't place it yet, only after first move

;;; Reincarnating

(defun reincarnate-feeb (feeb)
  (let ((pos (nth (random *number-of-entry-points*) *entry-points*)))
    (create-object feeb (car pos) (cdr pos))))

;;; Dying

(defgeneric destroy-object (object cause)
  (:documentation "Called when CAUSE destroys OBJECT.
CAUSE could be :starve or a fireball (for feebs)
or :dissipate (for fireballs).")
  (:method (object cause)
    (delete-object object (object-x-position object)
                   (object-y-position object)))

  (:method ((fireball fireball) cause)
    (setf *fireballs-flying*
          (delete fireball *fireballs-flying*))
    (call-next-method))

  (:method ((feeb feeb) cause)
    (setf *dead-feebs* (nconc *dead-feebs* (list feeb))
          *feebs* (delete feeb *feebs*))
    (let* ((x (feeb-x-position feeb))
           (y (feeb-y-position feeb)))
      (push (list 0 x y) *carcasses*)
      (place-object :carcass x y))
    (call-next-method)))



;;; -*- Movement Choice -*-

;;; Lets the feeb or fireball  make a choice

(defgeneric make-move-choice (object)
  (:documentation "Lets object make its move choice.")
  (:method ((feeb feeb))
    (funcall (feeb-brain feeb)
             feeb
             (feeb-proximity feeb)
             (feeb-vision feeb)
             (feeb-vision-left feeb)
             (feeb-vision-right feeb))))



;;; -*- Moving -*-

(defgeneric make-move (object move)
  (:documentation "Applies the move MOVE to OBJECT. The MOVE is
returned from MAKE-MOVE-CHOICE for the same object.")

  (:method (object move)
    (warn "Unknown move ~a for object ~a." move object))

  (:method (object (move (eql :turn-right)))
    (setf (object-direction object)
          (right-of (object-direction object))))

  (:method (object (move (eql :turn-left)))
    (setf (object-direction object)
          (left-of (object-direction object))))

  (:method (object (move (eql :turn-around)))
    (setf (object-direction object)
          (behind (object-direction object))))

  (:method (object (move (eql :move-forward)))
    (multiple-value-bind (stuff new-x new-y)
        (get-forward-pos object)
      (unless (wallp stuff)
        (change-object-pos object new-x new-y)
        t)))

  (:method ((fireball fireball) (move (eql :dissipate)))
    (destroy-object fireball :dissipate))

  (:method ((feeb feeb) (move (eql :flame)))
    (setf (feeb-turns-since-flamed feeb) 0)
    (create-object
     (make-instance 'fireball :direction (feeb-facing feeb)
                    :owner feeb)
     (feeb-x-position feeb) (feeb-y-position feeb)))

  (:method ((feeb feeb) (move (eql :eat-mushroom)))
    (let ((x (feeb-x-position feeb))
          (y (feeb-y-position feeb)))
      (when (find :mushroom (aref *maze* x y))
        (delete-object :mushroom x y)
        t)))

  (:method ((feeb feeb) (move (eql :eat-carcass)))
    (when (find :carcass (aref *maze* (feeb-x-position feeb)
                               (feeb-y-position feeb)))
      t))

  (:method ((feeb feeb) (move (eql :peek-left)))
    (unless (wallp (get-forward-pos feeb))
      (setf (feeb-peeking feeb) move)))
  
  (:method ((feeb feeb) (move (eql :peek-right)))
    (unless (wallp (get-forward-pos feeb))
      (setf (feeb-peeking feeb) move)))

  ) ; end of make-move generic function

(defmethod make-move :after (object move)
  (incf (object-lifetime object)))