;;; Lisparuga
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Lisparuga 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.
;;;
;;; Lisparuga 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 Lisparuga.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; A class representing a scripted or player-controller object in the
;; game world.  Actors can emit bullets and have many hitboxes.
;;
;;; Code:


(define-module (lisparuga actor)
  #:use-module (chickadee math vector)
  #:use-module (chickadee math rect)
  #:use-module (lisparuga node)
  #:use-module (lisparuga node-2d)
  #:use-module (oop goops)
  #:use-module (srfi srfi-9)
  #:export (make-hitbox
            hitbox?
            hitbox-name
            hitbox-rect

            world-hitbox?
            world-hitbox-collision?
            world-hitbox-parent

            <actor>
            polarity
            velocity
            hitboxes
            world-hitboxes
            on-collision
            bullet-field))


;;;
;;; Hitboxes
;;;

(define-record-type <hitbox>
  (make-hitbox name rect)
  hitbox?
  (name hitbox-name)
  (rect hitbox-rect))

(define-record-type <world-hitbox>
  (%make-world-hitbox parent rect)
  world-hitbox?
  (parent world-hitbox-parent)
  (rect world-hitbox-rect))

(define (make-world-hitbox parent)
  (let ((r (hitbox-rect parent)))
    (%make-world-hitbox parent
                        (make-rect 0.0 0.0 (rect-width r) (rect-height r)))))

(define (sync-world-hitbox world-hitbox position)
  (rect-move-vec2! (world-hitbox-rect world-hitbox) position))

(define (world-hitbox-collision? a b)
  (if (world-hitbox? b)
      (rect-intersects? (world-hitbox-rect a) (world-hitbox-rect b))
      (rect-intersects? (world-hitbox-rect a) b)))


;;;
;;; Actors
;;;

(define-class <actor> (<node-2d>)
  (polarity #:accessor polarity #:init-form 'none #:init-keyword #:polarity)
  (velocity #:getter velocity #:init-form (vec2 0.0 0.0))
  (hitboxes #:accessor hitboxes #:init-form '() #:init-keyword #:hitboxes)
  (world-hitboxes #:accessor world-hitboxes #:init-form '())
  (bullet-field #:accessor bullet-field #:init-keyword #:bullet-field))

(define-method (initialize (actor <actor>) initargs)
  (next-method)
  (set! (world-hitboxes actor)
    (map make-world-hitbox (hitboxes actor))))

(define-method (update (actor <actor>) dt)
  (let ((v (velocity actor)))
    (unless (and (= (vec2-x v) 0.0)
                 (= (vec2-y v) 0.0))
      ;; Move by current velocity.
      (vec2-add! (position actor) v)
      ;; Sync hitboxes to world coordinates.
      (let ((pos (position actor)))
        (for-each (lambda (world-hitbox)
                    (sync-world-hitbox world-hitbox pos))
                  (world-hitboxes actor)))
      ;; Mark for matrix updates.
      (dirty! actor))))

;; Actor-actor collision event.
(define-method (on-collision (actor <actor>) (other-actor <actor>)
                             hitbox other-hitbox)
  #t)