;;; 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-1)
  #: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
            collide
            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)
  (let ((r (hitbox-rect (world-hitbox-parent world-hitbox)))
        (wr (world-hitbox-rect world-hitbox)))
    (set-rect-x! wr (+ (vec2-x position) (rect-x r)))
    (set-rect-y! wr (+ (vec2-y position) (rect-y r)))))

(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 (sync-hitboxes (actor <actor>))
  ;; Sync hitboxes to world coordinates.
  (let ((pos (position actor)))
    (for-each (lambda (world-hitbox)
                (sync-world-hitbox world-hitbox pos))
              (world-hitboxes actor))))

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

(define-method (move-to (actor <actor>) x y)
  (next-method)
  (sync-hitboxes actor))

(define-method (teleport (actor <actor>) x y)
  (next-method)
  (sync-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 actor)
      ;; Mark for matrix updates.
      (dirty! actor))))

(define-method (collide (actor <actor>) (other-actor <actor>))
  (any (lambda (wh)
         (any (lambda (other-wh)
                (and (world-hitbox-collision? wh other-wh)
                     (on-collision actor other-actor
                                   (world-hitbox-parent wh)
                                   (world-hitbox-parent other-wh))))
              (world-hitboxes other-actor)))
       (world-hitboxes actor)))

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