;;; bad-glsl --- elisp to gpu with glsl -*- lexical-binding: t -*-
;;; Commentary:
;;; Code:

(require 'cl-lib)
(cl-pushnew "." load-path :test #'string=)
(require 'luki-lisp)

(-> 'bad-color)

;; +----------------+
;; | dynamic module |
;; +----------------+

(let ((dm (@f "bad-sdl%s" module-file-suffix)))
  (load dm nil t)
  (declare-function sdl_glsl_init     dm)
  (declare-function sdl_glsl_clear    dm)
  (declare-function sdl_glsl_triangle dm)
  (declare-function sdl_glsl_swap     dm)
  (declare-function sdl_glsl_quit     dm))

;; +-----+
;; | ecs |
;; +-----+

(defvar ecs-entities   nil)
(defvar ecs-components nil)
(defvar ecs-triangles  nil)

;; +------+
;; | time |
;; +------+

(defun bad-hz    () (let ((current-time-list nil)) (cdr (time-convert nil nil))))
(defun bad-ticks () (let ((current-time-list nil)) (1st (time-convert nil nil))))

;; +------+
;; | mesh |
;; ++-----+

;; (defvar bad-mesh)
;; (require 'bad-mesh)

(defconst ecs-tetrahedron
  (let ((v   0.5)
        (nv -0.5))
    `[[[ ,v  ,v ,v  1.0 ]  [ ,nv ,v  ,nv 1.0 ]  [ ,v  ,nv ,nv 1.0 ]]
      [[ ,nv ,v ,nv 1.0 ]  [ ,nv ,nv ,v  1.0 ]  [ ,v  ,nv ,nv 1.0 ]]
      [[ ,v  ,v ,v  1.0 ]  [ ,v  ,nv ,nv 1.0 ]  [ ,nv ,nv ,v  1.0 ]]
      [[ ,v  ,v ,v  1.0 ]  [ ,nv ,nv ,v  1.0 ]  [ ,nv ,v  ,nv 1.0 ]]]))

(defconst ecs-octahedron
  (let* ((a  (// 1 (* 2 (sqrt 2)))) (na (- a))
         (b  0.5)                   (nb (- b)))
    `[[[ ,na 0 ,a  1.0 ]  [ ,na 0.0 ,na 1.0 ]  [ 0.0 ,b  0.0 1.0 ]]
      [[ ,na 0 ,na 1.0 ]  [ ,a  0.0 ,na 1.0 ]  [ 0.0 ,b  0.0 1.0 ]]
      [[ ,a  0 ,na 1.0 ]  [ ,a  0.0 ,a  1.0 ]  [ 0.0 ,b  0.0 1.0 ]]
      [[ ,a  0 ,a  1.0 ]  [ ,na 0.0 ,a  1.0 ]  [ 0.0 ,b  0.0 1.0 ]]
      [[ ,a  0 ,na 1.0 ]  [ ,na 0.0 ,na 1.0 ]  [ 0.0 ,nb 0.0 1.0 ]]
      [[ ,na 0 ,na 1.0 ]  [ ,na 0.0 ,a  1.0 ]  [ 0.0 ,nb 0.0 1.0 ]]
      [[ ,a  0 ,a  1.0 ]  [ ,a  0.0 ,na 1.0 ]  [ 0.0 ,nb 0.0 1.0 ]]
      [[ ,na 0 ,a  1.0 ]  [ ,a  0.0 ,a  1.0 ]  [ 0.0 ,nb 0.0 1.0 ]]]))

(defconst ecs-hexahedron
  (let* ((v 0.5) (nv (- v)))
    `[[[ ,nv ,v  ,v  1 ]  [ ,v  ,v  ,nv 1.0 ]  [ ,v  ,v  ,v  1.0 ]]    ; top    a (y =  1) BEG A SIDE
      [[ ,nv ,nv ,v  1 ]  [ ,v  ,v  ,v  1.0 ]  [ ,v  ,nv ,v  1.0 ]]    ; front  a (z =  1)
      [[ ,nv ,nv ,nv 1 ]  [ ,nv ,v  ,v  1.0 ]  [ ,nv ,nv ,v  1.0 ]]    ; left   a (x =  1)
      [[ ,v  ,nv ,v  1 ]  [ ,v  ,v  ,nv 1.0 ]  [ ,v  ,nv ,nv 1.0 ]]    ; right  a (x = -1)
      [[ ,v  ,nv ,nv 1 ]  [ ,nv ,v  ,nv 1.0 ]  [ ,nv ,nv ,nv 1.0 ]]    ; back   a (z = -1)
      [[ ,v  ,nv ,nv 1 ]  [ ,nv ,nv ,v  1.0 ]  [ ,v  ,nv ,v  1.0 ]]    ; bottom a (y = -1) END A SIDE
      [[ ,v  ,nv ,nv 1 ]  [ ,nv ,nv ,nv 1.0 ]  [ ,nv ,nv ,v  1.0 ]]    ; bottom b (y = -1) BEG B SIDE
      [[ ,v  ,nv ,nv 1 ]  [ ,v  ,v  ,nv 1.0 ]  [ ,nv ,v  ,nv 1.0 ]]    ; back   b (z = -1)
      [[ ,v  ,nv ,v  1 ]  [ ,v  ,v  ,v  1.0 ]  [ ,v  ,v  ,nv 1.0 ]]    ; right  b (x = -1)
      [[ ,nv ,nv ,nv 1 ]  [ ,nv ,v  ,nv 1.0 ]  [ ,nv ,v  ,v  1.0 ]]    ; left   b (x =  1)
      [[ ,nv ,nv ,v  1 ]  [ ,nv ,v  ,v  1.0 ]  [ ,v  ,v  ,v  1.0 ]]    ; front  b (z =  1)
      [[ ,nv ,v  ,v  1 ]  [ ,nv ,v  ,nv 1.0 ]  [ ,v  ,v  ,nv 1.0 ]]])) ; top    b (y =  1) END B SIDE

(defconst ecs-phi (* 0.5 (1+ (sqrt 5))))

(defconst ecs-icosahedron
  (let* ((a  0.5)
         (b  (// 1 (* 2 ecs-phi)))
         (na (- a))
         (nb (- b)))
   `[[[  0  ,b  ,na 1 ]  [ ,b  ,a   0  1 ]  [ ,nb ,a   0  1 ]]
     [[  0  ,b  ,a  1 ]  [ ,nb ,a   0  1 ]  [ ,b  ,a   0  1 ]]
     [[  0  ,b  ,a  1 ]  [  0  ,nb ,a  1 ]  [ ,na  0  ,b  1 ]]
     [[  0  ,b  ,a  1 ]  [ ,a   0  ,b  1 ]  [  0 ,nb  ,a  1 ]]
     [[  0  ,b  ,na 1 ]  [  0  ,nb ,na 1 ]  [ ,a   0  ,nb 1 ]]
     [[  0  ,b  ,na 1 ]  [ ,na  0  ,nb 1 ]  [  0  ,nb ,na 1 ]]
     [[  0  ,nb ,a  1 ]  [ ,b  ,na  0  1 ]  [ ,nb ,na  0  1 ]]
     [[  0  ,nb ,na 1 ]  [ ,nb ,na  0  1 ]  [ ,b  ,na  0  1 ]]
     [[ ,nb ,a   0  1 ]  [ ,na  0  ,b  1 ]  [ ,na  0  ,nb 1 ]]
     [[ ,nb ,na  0  1 ]  [ ,na  0  ,nb 1 ]  [ ,na  0  ,b  1 ]]
     [[ ,b  ,a   0  1 ]  [ ,a   0  ,nb 1 ]  [ ,a   0  ,b  1 ]]
     [[ ,b  ,na  0  1 ]  [ ,a   0  ,b  1 ]  [ ,a   0  ,nb 1 ]]
     [[  0  ,b  ,a  1 ]  [ ,na  0  ,b  1 ]  [ ,nb ,a   0  1 ]]
     [[  0  ,b  ,a  1 ]  [ ,b  ,a   0  1 ]  [ ,a   0  ,b  1 ]]
     [[  0  ,b  ,na 1 ]  [ ,nb ,a   0  1 ]  [ ,na  0  ,nb 1 ]]
     [[  0  ,b  ,na 1 ]  [ ,a   0  ,nb 1 ]  [ ,b  ,a   0  1 ]]
     [[  0  ,nb ,na 1 ]  [ ,na  0  ,nb 1 ]  [ ,nb ,na  0  1 ]]
     [[  0  ,nb ,na 1 ]  [ ,b  ,na  0  1 ]  [ ,a   0  ,nb 1 ]]
     [[  0  ,nb ,a  1 ]  [ ,nb ,na  0  1 ]  [ ,na  0  ,b  1 ]]
     [[  0  ,nb ,a  1 ]  [ ,a   0  ,b  1 ]  [ ,b  ,na  0  1 ]]]))

;; (defun ecs-pentagon (p0 p1 p2 p3 p4)
;;   (pcase-let* ((`[ ,p0a ,p0b ,p0c ] p0)
;;                (`[ ,p1a ,p1b ,p1c ] p1)
;;                (`[ ,p2a ,p2b ,p2c ] p2)
;;                (`[ ,p3a ,p3b ,p3c ] p3)
;;                (`[ ,p4a ,p4b ,p4c ] p4)
;;                (pc (mapcar (L (e) (// e 5)) `[ ,(+ p0a p1a p2a p3a p4a)
;;                                                ,(+ p0b p1b p2b p3b p4b)
;;                                                ,(+ p0c p1c p2c p3c p4c) ])))
;;     `[[[ ,@p0 1 ]  [ ,@p1 1 ]  [ ,@pc 1 ]]
;;       [[ ,@p1 1 ]  [ ,@p2 1 ]  [ ,@pc 1 ]]
;;       [[ ,@p2 1 ]  [ ,@p3 1 ]  [ ,@pc 1 ]]
;;       [[ ,@p3 1 ]  [ ,@p4 1 ]  [ ,@pc 1 ]]
;;       [[ ,@p4 1 ]  [ ,@p0 1 ]  [ ,@pc 1 ]]]))

;; WARNING! BR0KE, DISGUSTING! YUK!
;; YOU SEE WHAT IS WRONG? -> FIX IT
;; NOT SO? -> DO NOT TRY YOUR LUCK!
;; more info on the web pile:
;;   https://dataswamp.org/~incal/bad-el

;; (defconst ecs-dodecahedron
;;   (let* ((k  0.5)
;;          (v  (* k 1))
;;          (b  (* k (// 1 ecs-phi )))
;;          (c  (* k (-  2 ecs-phi )))
;;          (nv (- v))
;;          (nb (- b))
;;          (nc (- c)))
;;     `[ ,@(ecs-pentagon `[ ,c   0  ,v  ]  `[ ,nc  0  ,v  ]  `[ ,nb ,b  ,b  ]  `[  0  ,v  ,c  ]  `[ ,b  ,b  ,b  ])
;;        ,@(ecs-pentagon `[ ,nc  0  ,v  ]  `[ ,c   0  ,v  ]  `[ ,b  ,nb ,b  ]  `[  0  ,nv ,c  ]  `[ ,nb ,nb ,b  ])
;;        ,@(ecs-pentagon `[ ,c   0  ,nv ]  `[ ,nc  0  ,nv ]  `[ ,nb ,nb ,nb ]  `[  0  ,nv ,nc ]  `[ ,b  ,nb ,nb ])
;;        ,@(ecs-pentagon `[ ,nc  0  ,nv ]  `[ ,c   0  ,nv ]  `[ ,b  ,b  ,nb ]  `[  0  ,v  ,nc ]  `[ ,nb ,b  ,nb ])
;;        ,@(ecs-pentagon `[  0  ,v  ,nc ]  `[  0  ,v  ,c  ]  `[ ,b  ,b  ,b  ]  `[ ,v  ,c   0  ]  `[ ,b  ,b  ,nb ])
;;        ,@(ecs-pentagon `[  0  ,v  ,c  ]  `[  0  ,v  ,nc ]  `[ ,nb ,b  ,nb ]  `[ ,nv ,c   0  ]  `[ ,nb ,b  ,b  ])
;;        ,@(ecs-pentagon `[  0  ,nv ,nc ]  `[  0  ,nv ,c  ]  `[ ,nb ,nb ,b  ]  `[ ,nv ,nc  0  ]  `[ ,nb ,nb ,nb ])
;;        ,@(ecs-pentagon `[  0  ,nv ,c  ]  `[  0  ,nv ,nc ]  `[ ,b  ,nb ,nb ]  `[ ,v  ,nc  0  ]  `[ ,b  ,nb ,b  ])
;;        ,@(ecs-pentagon `[ ,v  ,c   0  ]  `[ ,v  ,nc  0  ]  `[ ,b  ,nb ,b  ]  `[ ,c   0  ,v  ]  `[ ,b  ,b  ,b  ])
;;        ,@(ecs-pentagon `[ ,v  ,nc  0  ]  `[ ,v  ,c   0  ]  `[ ,b  ,b  ,nb ]  `[ ,c   0  ,nv ]  `[ ,b  ,nb ,nb ])
;;        ,@(ecs-pentagon `[ ,nv ,c   0  ]  `[ ,nv ,nc  0  ]  `[ ,nb ,nb ,nb ]  `[ ,nc  0  ,nv ]  `[ ,nb ,b  ,nb ])
;;        ,@(ecs-pentagon `[ ,nv ,nc  0  ]  `[ ,nv ,c   0  ]  `[ ,nb ,b  ,b  ]  `[ ,nc  0  ,v  ]  `[ ,nb ,nb ,b  ])
;;        ]))

;; +------+
;; | draw |
;; +------+

(cl-defmethod ecs-draw-triangles ()
  (pcase-dolist     (`[[ ,x0 ,y0 ,z0 ]
                       [ ,x1 ,y1 ,z1 ]
                       [ ,x2 ,y2 ,z2 ]
                       [ ,r0 ,g0 ,b0 ]
                       [ ,r1 ,g1 ,b1 ]
                       [ ,r2 ,g2 ,b2 ]] ecs-triangles)
    (sdl_glsl_triangle    x0  y0  z0
                          x1  y1  z1
                          x2  y2  z2
                          r0  g0  b0
                          r1  g1  b1
                          r2  g2  b2 ))
  (setf ecs-triangles nil))

;; +--------+
;; | matrix |
;; +--------+

(cl-defmethod make-matrix (&optional (w 3) (h w) (init 0))
  (cl-loop
   with N = (make-vector h nil)
   for n across-ref N
   do (setf n (make-vector w init))
   finally return N))

(cl-defmethod Mh ((M vector)) (length M))
(cl-defmethod Mw ((M vector)) (if (& (sequ M)
                                     (sequ (seq-first M)))
                                     (length (seq-first M))
                                0))

(defun matrixp (M)
  (& (vectorp M) (sequ M)
     (let ((l (length (seq-first M))))
       (cl-every (L (v) (& (vectorp v) (= l (length v)))) M))))

(cl-defmethod M34*M44 ((A vector) (B vector))
  (pcase-let
      ((`[[           ,a0x                                                             ,a0y                                                                         ,a0z                                                 ,a0w   ]
          [           ,a1x                                                             ,a1y                                                                         ,a1z                                                 ,a1w   ]
          [           ,a2x                                                             ,a2y                                                                         ,a2z                                                 ,a2w   ]] A)
       (`[[           ,b0x                                                             ,b0y                                                                         ,b0z                                                 ,b0w   ]
          [           ,b1x                                                             ,b1y                                                                         ,b1z                                                 ,b1w   ]
          [           ,b2x                                                             ,b2y                                                                         ,b2z                                                 ,b2w   ]
          [           ,b3x                                                             ,b3y                                                                         ,b3z                                                 ,b3w   ]] B))
        `[[ ,(+ (* a0x b0x) (* a0y b1x) (* a0z b2x) (* a0w b3x)) ,(+ (* a0x b0y) (* a0y b1y) (* a0z b2y) (* a0w b3y)) ,(+ (* a0x b0z) (* a0y b1z) (* a0z b2z) (* a0w b3z)) ,(+ (* a0x b0w) (* a0y b1w) (* a0z b2w) (* a0w b3w)) ]
          [ ,(+ (* a1x b0x) (* a1y b1x) (* a1z b2x) (* a1w b3x)) ,(+ (* a1x b0y) (* a1y b1y) (* a1z b2y) (* a1w b3y)) ,(+ (* a1x b0z) (* a1y b1z) (* a1z b2z) (* a1w b3z)) ,(+ (* a1x b0w) (* a1y b1w) (* a1z b2w) (* a1w b3w)) ]
          [ ,(+ (* a2x b0x) (* a2y b1x) (* a2z b2x) (* a2w b3x)) ,(+ (* a2x b0y) (* a2y b1y) (* a2z b2y) (* a2w b3y)) ,(+ (* a2x b0z) (* a2y b1z) (* a2z b2z) (* a2w b3z)) ,(+ (* a2x b0w) (* a2y b1w) (* a2z b2w) (* a2w b3w)) ]]))

(cl-defmethod M44*M44 ((A vector) (B vector))
  (pcase-let
      ((`[[           ,a0x                                                             ,a0y                                                                         ,a0z                                                 ,a0w   ]
          [           ,a1x                                                             ,a1y                                                                         ,a1z                                                 ,a1w   ]
          [           ,a2x                                                             ,a2y                                                                         ,a2z                                                 ,a2w   ]
          [           ,a3x                                                             ,a3y                                                                         ,a3z                                                 ,a3w   ]] A)
       (`[[           ,b0x                                                             ,b0y                                                                         ,b0z                                                 ,b0w   ]
          [           ,b1x                                                             ,b1y                                                                         ,b1z                                                 ,b1w   ]
          [           ,b2x                                                             ,b2y                                                                         ,b2z                                                 ,b2w   ]
          [           ,b3x                                                             ,b3y                                                                         ,b3z                                                 ,b3w   ]] B))
        `[[ ,(+ (* a0x b0x) (* a0y b1x) (* a0z b2x) (* a0w b3x)) ,(+ (* a0x b0y) (* a0y b1y) (* a0z b2y) (* a0w b3y)) ,(+ (* a0x b0z) (* a0y b1z) (* a0z b2z) (* a0w b3z)) ,(+ (* a0x b0w) (* a0y b1w) (* a0z b2w) (* a0w b3w)) ]
          [ ,(+ (* a1x b0x) (* a1y b1x) (* a1z b2x) (* a1w b3x)) ,(+ (* a1x b0y) (* a1y b1y) (* a1z b2y) (* a1w b3y)) ,(+ (* a1x b0z) (* a1y b1z) (* a1z b2z) (* a1w b3z)) ,(+ (* a1x b0w) (* a1y b1w) (* a1z b2w) (* a1w b3w)) ]
          [ ,(+ (* a2x b0x) (* a2y b1x) (* a2z b2x) (* a2w b3x)) ,(+ (* a2x b0y) (* a2y b1y) (* a2z b2y) (* a2w b3y)) ,(+ (* a2x b0z) (* a2y b1z) (* a2z b2z) (* a2w b3z)) ,(+ (* a2x b0w) (* a2y b1w) (* a2z b2w) (* a2w b3w)) ]
          [ ,(+ (* a3x b0x) (* a3y b1x) (* a3z b2x) (* a3w b3x)) ,(+ (* a3x b0y) (* a3y b1y) (* a3z b2y) (* a3w b3y)) ,(+ (* a3x b0z) (* a3y b1z) (* a3z b2z) (* a3w b3z)) ,(+ (* a3x b0w) (* a3y b1w) (* a3z b2w) (* a3w b3w)) ]]))

(defun ecs-view-matrix ()
  (pcase-let*
      ((  p ( ecs-camera-position ))
       (  u ( ecs-camera-up       ))
       (  r ( ecs-camera-right    ))
       (  f ( ecs-camera-forward  ))
       ( `[   ,ux                 ,uy                 ,uz                    ]  u  )
       ( `[   ,rx                 ,ry                 ,rz                    ]  r  )
       ( `[   ,fx                 ,fy                 ,fz                    ]  f  ))
        `[[   ,rx                 ,ry                 ,rz                 0  ]
          [   ,ux                 ,uy                 ,uz                 0  ]
          [   ,fx                 ,fy                 ,fz                 0  ]
          [   ,(- (ecs-dot r p))  ,(- (ecs-dot u p))  ,(- (ecs-dot f p))  1  ]]))

(defconst ecs-projection-matrix
  (let* ((fov    (degrees-to-radians 80))
         (f      (// 1 (tan (// fov 2))))
         (aspect (// 1920 1080))
         (zN     (** 2  0))
         (zF     (** 2 14))
         (a      (// f aspect))
         (b      f)
         (c      (// zF (- zF zN)))
         (d      (* (- zN) c))
         (w      1))
    `[[ ,a  0  0  0  ]
      [  0 ,b  0  0  ]
      [  0  0 ,c ,d  ]
      [  0  0 ,w  0  ]]))

(defun ecs-rotation-matrix-simple ()
  (let* ((theta  (float-time))
         (cos-t  (cos theta))
         (sin-t  (sin theta))
         (sin-tn (- sin-t)))
    `[[ ,cos-t  0 ,sin-t  0 ]
      [  0      1      0  0 ]
      [ ,sin-tn 0 ,cos-t  0 ]
      [  0      0      0  1 ]]))

(defun ecs-rotation-matrix ()
  (let* ((theta (float-time))
         (x-theta theta)
         (y-theta (* (// float-pi 3) theta))
         (z-theta (* (// float-pi 2) theta))
         (x-cos-t (cos x-theta)) (x-sin-t (sin x-theta)) (x-sin-tn (- x-sin-t))
         (y-cos-t (cos y-theta)) (y-sin-t (sin y-theta)) (y-sin-tn (- y-sin-t))
         (z-cos-t (cos z-theta)) (z-sin-t (sin z-theta)) (z-sin-tn (- z-sin-t))
         (Rx `[[     1         0         0     0 ]
               [     0     ,x-cos-t  ,x-sin-t  0 ]
               [     0     ,x-sin-tn ,x-cos-t  0 ]
               [     0         0         0     1 ]])
         (Ry `[[ ,y-cos-t      0     ,y-sin-tn 0 ]
               [     0         1         0     0 ]
               [ ,y-sin-t      0     ,y-cos-t  0 ]
               [     0         0         0     1 ]])
         (Rz `[[ ,z-cos-t  ,z-sin-t      0     0 ]
               [ ,z-sin-tn ,z-cos-t      0     0 ]
               [     0         0         1     0 ]
               [     0         0         0     1 ]]))
    (M44*M44 Rx (M44*M44 Ry Rz))))

(cl-defmethod ecs-screen-matrix ((H vector) &optional (M (ecs-world-matrix)) (V (ecs-view-matrix)) (P ecs-projection-matrix))
  (pcase-let*
      ((C (M34*M44 H (M44*M44 M (M44*M44 V P))))
       (`[[     ,c0x         ,c0y             ,c0z     ,w0 ]
          [     ,c1x         ,c1y             ,c1z     ,w1 ]
          [     ,c2x         ,c2y             ,c2z     ,w2 ]] C))
        `[[ ,(// c0x w0) ,(// c0y w0) ,(1+ (// c0z w0))    ]
          [ ,(// c1x w1) ,(// c1y w1) ,(1+ (// c1z w1))    ]
          [ ,(// c2x w2) ,(// c2y w2) ,(1+ (// c2z w2))    ]]))

(defun ecs-world-matrix (&optional k tr R)
  (or k  (setf k    1.0                       ))
  (or tr (setf tr [ 0.0 0.0 0.0 ]             ))
  (or R  (setf R (ecs-rotation-matrix-simple )))
  (pcase-let ((`[       ,tx        ,ty        ,tz      ] tr)
             (`[[      ,r0x       ,r0y       ,r0z  0.0 ]
                [      ,r1x       ,r1y       ,r1z  0.0 ]
                [      ,r2x       ,r2y       ,r2z  0.0 ]
                [       0.0        0.0        0.0  1.0 ]] R))
              `[[ ,(* k r0x) ,(* k r0y) ,(* k r0z) 0.0 ]
                [ ,(* k r1x) ,(* k r1y) ,(* k r1z) 0.0 ]
                [ ,(* k r2x) ,(* k r2y) ,(* k r2z) 0.0 ]
                [       ,tx        ,ty        ,tz  1.0 ]]))

;; +--------+
;; | vector |
;; +--------+

(cl-defmethod v+v ((a vector) (b vector)) (seq--into-vector (cl-mapcar #'+ a b)))
(cl-defmethod v-v ((a vector) (b vector)) (seq--into-vector (cl-mapcar #'- a b)))
(cl-defmethod k*v ((k number) (v vector)) (seq--into-vector (mapcar (L (c) (* k c)) v)))

;; +--------+
;; | camera |
;; +--------+

(defun ecs-camera-position () (ecs-get-component 'camera 'position ))
(defun ecs-camera-up       () (ecs-get-component 'camera 'up       ))
(defun ecs-camera-right    () (ecs-get-component 'camera 'right    ))
(defun ecs-camera-forward  () (ecs-get-component 'camera 'forward  ))

(cl-defmethod ecs-camera-distance ((target symbol))
  (let ((tpos (ecs-get-component target 'position))
        (cpos (ecs-camera-position))
        (cfwd (ecs-camera-forward)))
    (ecs-dot (v-v tpos cpos) cfwd)))

(defun ecs-camera-update ()
  (let* ((upv  (ecs-get-component 'camera 'up      ))
         (fwd  (ecs-get-component 'camera 'forward ))
         (nfwd (ecs-norm fwd))
         (nrtv (ecs-norm (ecs-cross upv nfwd)))
         (fupv (ecs-cross nfwd nrtv)))
    (ecs-set-component 'camera 'up      fupv)
    (ecs-set-component 'camera 'right   nrtv)
    (ecs-set-component 'camera 'forward nfwd)))

(defun ecs-camera-look-at (&optional target)
  (or target (setf target [ 0.0 0.0 0.0 ] ))
  (ecs-camera-update)
  (ecs-set-component 'camera 'forward (ecs-norm (v-v target (ecs-camera-position)))))

;; +------+
;; | move |
;; +------+

(defun ecs-camera-roll-right (&optional inv stp)
  (or stp (setf stp 0.07))
  (&  inv (setf stp (- stp)))
  (ecs-set-component 'camera 'up
                     (ecs-norm (v+v (k*v (cos stp) (ecs-camera-up))
                                    (k*v (sin stp) (ecs-cross (ecs-camera-forward) (ecs-camera-up)))))))

(defun ecs-camera-move-right (&optional inv stp)
  (or stp (setf stp 16))
  (&  inv (setf stp (- stp)))
  (ecs-set-component 'camera 'position (v+v
                                        (ecs-camera-position)
                                        (k*v stp (ecs-camera-right)))))

(defun ecs-camera-move-up (&optional inv stp)
  (or stp (setf stp 16))
  (&  inv (setf stp (- stp)))
  (ecs-set-component 'camera 'position (v+v
                                        (ecs-camera-position)
                                        (k*v stp (ecs-camera-up)))))

(defun ecs-camera-move-forward (&optional inv stp)
  (or stp (setf stp 128))
  (&  inv (setf stp (- stp)))
  (ecs-set-component 'camera 'position (v+v
                                        (ecs-camera-position)
                                        (k*v stp (ecs-camera-forward)))))

(defun ecs-camera-roll-left     (&optional inv stp) (ecs-camera-roll-right   (! inv) stp))
(defun ecs-camera-move-left     (&optional inv stp) (ecs-camera-move-right   (! inv) stp))
(defun ecs-camera-move-down     (&optional inv stp) (ecs-camera-move-up      (! inv) stp))
(defun ecs-camera-move-backward (&optional inv stp) (ecs-camera-move-forward (! inv) stp))

;; +----------+
;; | entities |
;; +----------+

(cl-defmethod ecs-add-entity ((id symbol) (cmps list))
  (push id ecs-entities)
  (puthash id cmps ecs-components))

;; +------------+
;; | components |
;; +------------+

(cl-defmethod ecs-get-component ((id symbol) (cmp symbol))
  (alist-get cmp (gethash id ecs-components)))

(cl-defmethod ecs-set-component ((id symbol) (cmp symbol) val)
  (setf (alist-get cmp (gethash id ecs-components)) val))

(cl-defmethod ecs-set-component-vector ((id symbol) (cmp symbol) &optional x y z)
  (& x (aset (alist-get cmp (gethash id ecs-components)) 0 x))
  (& y (aset (alist-get cmp (gethash id ecs-components)) 1 y))
  (& z (aset (alist-get cmp (gethash id ecs-components)) 2 z)))

;; +---------+
;; | vectors |
;; +---------+

(cl-defmethod ecs-dot ((a vector) (b vector))
  (pcase-let (( `[    ,ax       ,ay       ,az ] a )
              ( `[    ,bx       ,by       ,bz ] b ))
              (+ (* ax bx) (* ay by) (* az bz)    )))

(cl-defmethod ecs-cross ((a vector) (b vector))
  (pcase-let (( `[ ,ax                      ,ay                      ,az                      ] a )
              ( `[ ,bx                      ,by                      ,bz                      ] b ))
                `[ ,(- (* ay bz) (* az by)) ,(- (* az bx) (* ax bz)) ,(- (* ax by) (* ay bx)) ]   ))

(defun ecs-square (a) (* a a))
(defun ecs-cube   (a) (* a (ecs-square a)))

(cl-defmethod ecs-norm ((a vector))
  (k*v
    (sqrt
      (// 1 (+ (ecs-square (aref a 0))
               (ecs-square (aref a 1))
               (ecs-square (aref a 2)) )))
                                 a      ))

(defun ecs-camera-input (event)
  (pcase event
    ;; you can (not) advance
    (?w (ecs-camera-move-forward))
    (?s (ecs-camera-move-backward))
    ;; roll
    (?u (ecs-camera-roll-left))
    (?o (ecs-camera-roll-right))
    ;; horizontal
    (?j (ecs-camera-move-left))
    (?l (ecs-camera-move-right))
    ;; vertical
    (?i (ecs-camera-move-up))
    (?k (ecs-camera-move-down))))

(defun ecs-interface-init ()
  (discard-input)
  (set-frame-position nil 0 0     )
  (set-frame-width    nil 1 nil t )
  (set-frame-height   nil 1 nil t ))

(defun ecs-init ()
  (setf ecs-triangles  nil)
  (setf ecs-entities   nil)
  (setf ecs-components nil)
  (setf ecs-components (make-hash-table :size 304))
  (ecs-add-entity 'camera
     '((position . [  0   0 -960  ])
       (up       . [  0   1    0  ])
       (right    . [  1   0    0  ])
       (forward  . [  0   0    1  ])))
  (ecs-camera-update)
  (ecs-camera-look-at)
  (ecs-interface-init)
  (sdl_glsl_init))

(defun bad-glsl ()
  (cl-loop
   with k        =     256
   with tetra-t  =  [ -500       500             1000         ]
   with octa-t   =  [  500      -500             1000         ]
   with hexa-t   =  [ -500      -500             1000         ]
   with icosa-t  =  [  500       500             1000         ]
   with tetra-b  =  (  bad-color-decimal-vector "dodgerblue2" )
   with tetra-a  =  (  bad-color-decimal-vector "dodgerblue3" )
   with tetra-h  =  (  bad-color-decimal-vector "dodgerblue4" )
   with hexa-b   =  (  bad-color-decimal-vector "cyan2"       )
   with hexa-a   =  (  bad-color-decimal-vector "cyan3"       )
   with hexa-h   =  (  bad-color-decimal-vector "cyan4"       )
   with octa-b   =  (  bad-color-decimal-vector "aquamarine1" )
   with octa-a   =  (  bad-color-decimal-vector "aquamarine2" )
   with octa-h   =  (  bad-color-decimal-vector "aquamarine4" )
   with icosa-b  =  (  bad-color-decimal-vector "darkorchid2" )
   with icosa-a  =  (  bad-color-decimal-vector "darkorchid3" )
   with icosa-h  =  (  bad-color-decimal-vector "darkorchid4" )
   with tetra-c  = `[ ,tetra-b         ,tetra-a ,tetra-h      ]
   with hexa-c   = `[ ,hexa-b          ,hexa-a  ,hexa-h       ]
   with octa-c   = `[ ,octa-b          ,octa-a  ,octa-h       ]
   with icosa-c  = `[ ,icosa-b         ,icosa-a ,icosa-h      ]
   with hz       =  (bad-hz)
   with fps      =  60
   with delta    =  (// hz fps)
   with frames   =  2048
   with run      =  t
   with beg      =  (bad-ticks)
   with stops    =  (number-sequence (+ beg delta) (+ beg (* frames delta)) delta)
   initially (ecs-init)
   for R         = (ecs-rotation-matrix-simple)
   for tetra-M   = (ecs-world-matrix k tetra-t R)
   for hexa-M    = (ecs-world-matrix k hexa-t  R)
   for octa-M    = (ecs-world-matrix k octa-t  R)
   for icosa-M   = (ecs-world-matrix k icosa-t R)
   for next in stops while run do
     (sdl_glsl_clear)
     (ecs-camera-look-at)
     (mapc (L (tri) (push `[ ,@(ecs-screen-matrix tri tetra-M) ,@tetra-c ] ecs-triangles)) ecs-tetrahedron )
     (mapc (L (tri) (push `[ ,@(ecs-screen-matrix tri hexa-M)  ,@hexa-c  ] ecs-triangles)) ecs-hexahedron  )
     (mapc (L (tri) (push `[ ,@(ecs-screen-matrix tri octa-M)  ,@octa-c  ] ecs-triangles)) ecs-octahedron  )
     (mapc (L (tri) (push `[ ,@(ecs-screen-matrix tri icosa-M) ,@icosa-c ] ecs-triangles)) ecs-icosahedron )
     (when-let* ((evnt (& (input-pending-p) (read-event))))
       (pcase evnt
         ((or ?Q ?q 13) (setf run nil))
         (_             (ecs-camera-input evnt))))
     (ecs-draw-triangles)
     (sdl_glsl_swap)
     (sleep-for (// (- next (bad-ticks)) hz))
   finally (sdl_glsl_quit))) ; (progn (eval-buffer) (bad-glsl))

(<- 'bad-ecs)
;;; bad-ecs.el ends here