(defpackage #:workbench
  (:use #:cl+trial)
  (:shadow #:launch)
  (:local-nicknames)
  (:export #:workbench #:launch))
(in-package #:workbench)

(defclass workbench (main) ()
  (:default-initargs
   :clear-color (vec 0.25 0.3 0.35 0)
   :context '(:vsync T)))

(defstruct (hit (:constructor %make-hit (object location &optional (time 0f0) (normal (vec 0 0)))))
  (object NIL)
  (location NIL :type vec2)
  (time 0f0 :type single-float)
  (normal NIL :type vec2))

(defun launch (&rest args)
  (apply #'trial:launch 'workbench args))

(define-pool workbench)

(define-asset (workbench 1x) mesh
    (make-rectangle 1 1))

(define-asset (workbench slope) mesh
    (with-vertex-filling ((make-instance 'vertex-mesh :vertex-type 'vertex))
      (vertex :position (vec -0.5 -0.5 0))
      (vertex :position (vec +0.5 -0.5 0))
      (vertex :position (vec +0.5 +0.5 0))))

(define-shader-entity base-entity (vertex-entity colored-entity sized-entity located-entity)
  ((vertex-array :initform (// 'workbench '1x))
   (velocity :initform (vec 0 0 0) :accessor velocity)))

(defmethod apply-transforms progn ((entity base-entity))
  (scale-by (* 2 (vx (bsize entity))) (* 2 (vy (bsize entity))) 1))

(defmethod resolve ((mover entity) (b entity))
  (let* ((loc (location mover))
         (siz (bsize mover))
         (bloc (location b))
         (bsiz (bsize b))
         (dx (- (vx loc) (vx bloc)))
         (dy (- (vy loc) (vy bloc))))
    (cond ((< (/ (abs dy) (+ (vy siz) (vy bsiz)))
              (/ (abs dx) (+ (vx siz) (vx bsiz))))
           (setf (vx (velocity mover)) 0)
           (if (< 0 dx)
               (setf (vx loc) (+ (vx bloc) (vx bsiz) (vx siz)))
               (setf (vx loc) (- (vx bloc) (vx bsiz) (vx siz)))))
          (T
           (setf (vy (velocity mover)) 0)
           (if (< 0 dy)
               (setf (vy loc) (+ (vy bloc) (vy bsiz) (vy siz)))
               (setf (vy loc) (- (vy bloc) (vy bsiz) (vy siz))))))))

(define-shader-entity collider (base-entity)
  ((bsize :initform (vec 16 16))
   (color :initform (vec 1 1 1 0.5))))

(define-shader-entity circler (collider listener)
  ())

(defmethod handle ((ev tick) (circler circler))
  (vsetf (velocity circler)
         (/ (sin (tt ev)) 1) (/ (cos (tt ev)) 1))
  (nv+ (location circler) (velocity circler)))

(define-shader-entity slope (collider)
  ((bsize :initform (vec 16 16))
   (color :initform (vec 1 1 1 0.5))
   (vertex-array :initform (// 'workbench 'slope))))

(defmethod resolve ((mover entity) (b slope))
  (let* ((loc (location mover))
         (siz (bsize mover))
         (bloc (location b))
         (bsiz (bsize b))
         (dx (- (vx loc) (- (vx siz)) (vx bloc)))
         (tt (/ (+ dx (vx bsiz)) 2 (vx bsiz))))
    (setf (vy loc) (max (vy loc) (+ (vy bloc) (vy siz) (- (vy bsiz)) (* tt 2 (vy bsiz)))))))

(define-shader-entity tester (base-entity listener)
  ((name :initform 'tester)
   (color :initform (vec 1 0 0 0.5))))

(defun intersecting-p (object bounds)
  (let ((loc (location object))
        (bsize (bsize object)))
    (and (<= (- (vx bounds) (vz bounds) (vx bsize)) (vx loc) (+ (vx bounds) (vz bounds) (vx bsize)))
         (<= (- (vy bounds) (vw bounds) (vy bsize)) (vy loc) (+ (vy bounds) (vw bounds) (vy bsize))))))

(defmethod handle ((ev tick) (tester tester))
  (let* ((tentative (make-array 16 :initial-element NIL))
         (vel (velocity tester))
         (vlen (vlength vel))
         (loc (location tester))
         (v2 (v* vel 0.5))
         (midpoint (v+ v2 loc))
         (bounds (vec (vx midpoint) (vy midpoint)
                      (+ (abs (vx v2)) (vx (bsize tester)))
                      (+ (abs (vy v2)) (vy (bsize tester)))))
         (found 0))
    (declare (dynamic-extent tentative))
    (for:for ((object over (scene +main+)))
      (when (and (typep object 'collider)
                 (intersecting-p object bounds))
        (setf (aref tentative found) object)
        (incf found)
        (when (= found 16)
          (return))))
    (vsetf bounds (vx loc) (vy loc) (vx (bsize tester)) (vy (bsize tester)))
    (flet ((try-collide ()
             (vsetf bounds (vx loc) (vy loc))
             (dotimes (i found)
               (let ((object (aref tentative i)))
                 (when (intersecting-p object bounds)
                   (resolve tester object))))))
      (cond ((<= 1 vlen)
             (let ((vstep (v/ vel vlen)))
               (nv+ loc vstep)
               (nv- vel vstep)
               (decf vlen 1)
               (try-collide)
               (when (= 0 (vx vel)) (setf (vx vstep) 0))
               (when (= 0 (vy vel)) (setf (vy vstep) 0))))
            (T
             (nv+ loc vel)
             (vsetf vel 0 0)
             (try-collide))))))

(define-shader-entity player (base-entity listener)
  ((name :initform 'player)
   (bsize :initform (vec 8 16))
   (color :initform (vec 1 1 1 1))))

(defmethod handle ((ev mouse-move) (player player))
  (let ((pos (screen->vec (pos ev) (width *context*) (height *context*))))
    (v<- (velocity player) (v- pos (location player)))))

(defmethod handle ((ev mouse-press) (player player))
  (let ((pos (screen->vec (pos ev) (width *context*) (height *context*))))
    (ecase (button ev)
      (:left
       (enter* (make-instance (if (retained :control) 'circler 'collider)
                              :location (nvalign pos 32)) (scene +main+)))
      (:middle
       (let ((res (unit 'tester (scene +main+))))
         (v<- (bsize res) (bsize player))
         (v<- (location res) (location player))
         (v<- (velocity res) (velocity player))))
      (:right
       (v<- (location player) pos)))))

(defmethod render ((player player) (program shader-program))
  (call-next-method)
  (let ((v (vec (/ (vx (velocity player)) (vx (bsize player)) 2) (/ (vy (velocity player)) (vy (bsize player)) 2))))
    (translate-by (vx v) (vy v) 0)
    (setf (uniform program "objectcolor") (vec4 1 1 1 0.1))
    (call-next-method)))

(progn
  (defmethod setup-scene ((workbench workbench) scene)
    (enter (make-instance 'trial::fps-counter) scene)
    (enter (make-instance 'player) scene)
    (enter (make-instance 'tester) scene)
    (enter (make-instance 'slope) scene)
    (enter (make-instance '2d-camera :location (vec 100 100 0)) scene)
    (enter (make-instance 'render-pass) scene))
  (maybe-reload-scene))