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

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

(-> 'bad-alpha)
(-> 'bad-color)
(-> 'bad-mode)
(-> 'bad-meshes)
(-> 'icosa-surface)

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

(defvar ecs-circles nil) (setq ecs-circles nil)
(defvar ecs-comps   nil) (setq ecs-comps   nil)
(defvar ecs-ents    nil) (setq ecs-ents    nil)

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

(let ((dm (@f "bad-sdl%s" module-file-suffix)))
  (load dm nil t)
  (declare-function sdl_draw_init        dm)
  (declare-function sdl_draw_grid_init   dm)
  (declare-function sdl_draw_grid_toggle dm)
  (declare-function sdl_draw_clear       dm)
  (declare-function sdl_draw_text        dm)
  (declare-function sdl_draw_circle      dm)
  (declare-function sdl_draw_webp        dm)
  (declare-function sdl_draw_frame       dm)
  (declare-function sdl_draw_quit        dm)
  (declare-function sdl_glsl_clear       dm)
  (declare-function sdl_glsl_init        dm)
  (declare-function sdl_glsl_quit        dm)
  (declare-function sdl_glsl_swap        dm)
  (declare-function sdl_glsl_triangle    dm)
  (declare-function sdl_glsl_update      dm))

;; +------+
;; | 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))))

;; +------------------+
;; | platonic polyton |
;; +------------------+

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

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

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

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

(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.0 ] [ ,@p1 ] [ ,@pc ]]
      [[ ,@p2 1.0 ] [ ,@p3 ] [ ,@pc ]]
      [[ ,@p4 1.0 ] [ ,@p0 ] [ ,@pc ]]
      [[ ,@p1 1.0 ] [ ,@p2 ] [ ,@pc ]]
      [[ ,@p3 1.0 ] [ ,@p4 ] [ ,@pc ]]]))

;; This does not work two faces do not appear. The result is not appealing.
(defconst ecs-dodecahedron
  (let* ((k 0.5)
         (v (* k 1.0))            (nv (- v))
         (b (* v (// 1 ecs-phi))) (nb (- b))
         (c (* v (-  2 ecs-phi))) (nc (- c)))
    `[ ,@(ecs-pentagon `[  ,c 0.0  ,v ] `[ ,nc 0.0  ,v ] `[ ,nb  ,b  ,b ] `[ 0.0  ,v  ,c ]  `[  ,b   ,b  ,b ])
       ,@(ecs-pentagon `[ ,nc 0.0  ,v ] `[  ,c 0.0  ,v ] `[  ,b ,nb  ,b ] `[ 0.0 ,nv  ,c ]  `[ ,nb  ,nb  ,b ])
       ,@(ecs-pentagon `[  ,c 0.0 ,nv ] `[ ,nc 0.0 ,nv ] `[ ,nb ,nb ,nb ] `[ 0.0 ,nv ,nc ]  `[  ,b  ,nb ,nb ])
       ,@(ecs-pentagon `[ ,nc 0.0 ,nv ] `[  ,c 0.0 ,nv ] `[  ,b  ,b ,nb ] `[ 0.0  ,v ,nc ]  `[ ,nb   ,b ,nb ])
       ,@(ecs-pentagon `[ 0.0  ,v ,nc ] `[ 0.0  ,v  ,c ] `[  ,b  ,b  ,b ] `[  ,v  ,c 0.0 ]  `[  ,b   ,b ,nb ])
       ,@(ecs-pentagon `[ 0.0  ,v  ,c ] `[ 0.0  ,v ,nc ] `[ ,nb  ,b ,nb ] `[ ,nv  ,c 0.0 ]  `[ ,nb   ,b  ,b ])
       ,@(ecs-pentagon `[ 0.0 ,nv ,nc ] `[ 0.0 ,nv  ,c ] `[ ,nb ,nb  ,b ] `[ ,nv ,nc 0.0 ]  `[ ,nb  ,nb ,nb ])
       ,@(ecs-pentagon `[ 0.0 ,nv  ,c ] `[ 0.0 ,nv ,nc ] `[  ,b ,nb ,nb ] `[  ,v ,nc 0.0 ]  `[  ,b  ,nb  ,b ])
       ,@(ecs-pentagon `[  ,v  ,c 0.0 ] `[  ,v ,nc 0.0 ] `[  ,b ,nb  ,b ] `[  ,c 0.0  ,v ]  `[  ,b   ,b  ,b ])
       ,@(ecs-pentagon `[  ,v ,nc 0.0 ] `[  ,v  ,c 0.0 ] `[  ,b  ,b ,nb ] `[  ,c 0.0 ,nv ]  `[  ,b  ,nb ,nb ])
       ,@(ecs-pentagon `[ ,nv  ,c 0.0 ] `[ ,nv ,nc 0.0 ] `[ ,nb ,nb ,nb ] `[ ,nc 0.0 ,nv ]  `[ ,nb   ,b ,nb ])
       ,@(ecs-pentagon `[ ,nv ,nc 0.0 ] `[ ,nv  ,c 0.0 ] `[ ,nb  ,b  ,b ] `[ ,nc 0.0  ,v ]  `[ ,nb  ,nb  ,b ]) ]))

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

(cl-defmethod make-matrix (&optional (w 3) (h w) (init 0.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)) (--- M))
(cl-defmethod Mw ((M vector)) (if (& (sequ M) (sequ (seq-first M))) (---  (seq-first M)) 0))

(defun matrixp (M)
  (& (vectorp M) (sequ M)
     (let ((l (--- (seq-first M))))
       (cl-every (L (v) (& (vectorp v) (= l (--- 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.0
           ,ux                ,uy                ,uz                0.0
           ,fx                ,fy                ,fz                0.0
           ,(- (ecs-dot r p)) ,(- (ecs-dot u p)) ,(- (ecs-dot f p)) 1.0 ]))

(defconst ecs-identity-matrix
  [ 1.0  0.0  0.0  0.0
    0.0  1.0  0.0  0.0
    0.0  0.0  1.0  0.0
    0.0  0.0  0.0  1.0 ])

(cl-defmethod ecs-rotation-matrix (&optional (speed 0.1))
  (let* ((theta  (* speed (float-time)))
         (cos-t  (cos          theta ))
         (sin-t  (sin          theta ))
         (sin-tn ( - sin-t)          ))
    `[ ,cos-t  0.0 ,sin-t 0.0
        0.0    1.0  0.0   0.0
       ,sin-tn 0.0 ,cos-t 0.0
        0.0    0.0  0.0   1.0 ]))

(cl-defmethod ecs-rotation-matrix-alternative (&optional (speed 0.08))
  (let* ((theta (* speed (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.0      0.0
                 0.0      ,x-cos-t  ,x-sin-t  0.0
                 0.0      ,x-sin-tn ,x-cos-t  0.0
                 0.0       0.0       0.0      1.0 ])
         (Ry `[ ,y-cos-t   0.0      ,y-sin-tn 0.0
                 0.0       1.0       0.0      0.0
                ,y-sin-t   0.0      ,y-cos-t  0.0
                 0.0       0.0       0.0      1.0 ])
         (Rz `[ ,z-cos-t  ,z-sin-t   0.0      0.0
                ,z-sin-tn ,z-cos-t   0.0      0.0
                 0.0       0.0       1.0      0.0
                 0.0       0.0       0.0      1.0 ]))
         (M44*M44 Rx (M44*M44 Ry Rz))))

(defconst ecs-proj
  (let* ((fov    (degrees-to-radians 72))
         (f      (// 1 (tan (// fov 2))))
         (aspect (// 1920 1080))
         (zN     (** 2  0))
         (zF     (** 2 14)) ; don't try 15
         (a      (// f aspect))
         (b      f)
         (c      (// zF (- zF zN)))
         (d      (* (- zN) c))
         (w      1.0))
    `[  ,a  0.0  0.0  0.0
       0.0   ,b  0.0  0.0
       0.0  0.0   ,c   ,w
       0.0  0.0   ,d  0.0 ]))

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

(cl-defmethod ecs-world-matrix (&optional (k 1.0) (tr [0.0 0.0 0.0]) (R ecs-identity-matrix))
  (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-comp 'camera 'position))
(defun ecs-camera-up       () (ecs-get-comp 'camera 'up))
(defun ecs-camera-right    () (ecs-get-comp 'camera 'right))
(defun ecs-camera-forward  () (ecs-get-comp 'camera 'forward))

(cl-defmethod ecs-camera-distance ((target symbol))
  (let ((tp (ecs-position target))
        (p  (ecs-camera-position))
        (f  (ecs-camera-forward)))
    (ecs-dot (v-v tp p) f)))

(defun ecs-camera-update ()
  (when-let* ((u  (ecs-up      'camera))
              (f  (ecs-forward 'camera))
              (nf (ecs-norm f))
              (nr (ecs-norm (ecs-cross u nf)))
              (nu (ecs-cross nf nr)))
    (ecs-set-comp 'camera 'up      nu)
    (ecs-set-comp 'camera 'right   nr)
    (ecs-set-comp 'camera 'forward nf)))

(cl-defmethod ecs-camera-look-at (&optional (target [ 0.0 0.0 0.0 ]))
  (ecs-camera-update)
  (ecs-set-comp 'camera 'forward (ecs-norm (v-v target (ecs-camera-position)))))

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

(defun ecs-camera-roll-right (&optional inv stp)
  (or stp (setf stp 0.06))
  (&  inv (setf stp (- stp)))
  (ecs-set-comp '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 14))
  (&  inv (setf stp (- stp)))
  (ecs-set-comp '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-comp '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 124))
  (&  inv (setf stp (- stp)))
  (ecs-set-comp '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))

(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)))
  (ecs-camera-look-at))

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

(cl-defmethod ecs-add-ent ((id symbol) (cmps list))
  (push id ecs-ents)
  (puthash id cmps ecs-comps))

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

(cl-defmethod ecs-get-comp ((id symbol) (cmp symbol))
  (alist-get cmp (gethash id ecs-comps)))

(cl-defmethod ecs-set-comp ((id symbol) (cmp symbol) val)
  (setf (alist-get cmp (gethash id ecs-comps)) val))

(cl-defmethod ecs-set-comp-vector ((id symbol) (cmp symbol) &optional x y z)
  (& x (aset (alist-get cmp (gethash id ecs-comps)) 0 x))
  (& y (aset (alist-get cmp (gethash id ecs-comps)) 1 y))
  (& z (aset (alist-get cmp (gethash id ecs-comps)) 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)) ]))

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

(defun ecs-init-interface (&optional w h no-frame-change)
  (unless no-frame-change
    (or w (setf w 96))
    (or h (setf h 64)))
  (discard-input)
  (bad-mode-settings)
  (unless no-frame-change
    (set-frame-position nil 0 0)
    (set-frame-width    nil w nil t)
    (set-frame-height   nil h nil t)
    (bad-alpha-4)))

(defun ecs-init ()
  (setf ecs-ents nil)
  (setf ecs-comps (make-hash-table :size 304))
  (ecs-init-camera))

(defun ecs-init-camera ()
  (ecs-add-ent 'camera
   '((position . [ 0.0  0.0  6e3 ] )
     (up       . [ 0.0  1.0  0.0 ] )
     (right    . [ 1.0  0.0  0.0 ] )
     (forward  . [ 0.0  0.0 -6e3 ] )))
  (ecs-camera-look-at))

(defun bad-glsl (&optional no-frame-change)
  (cl-loop
   with hexa-k = 3e3
   with hexa-t =  [ 0.4 0.08 -5e2 ]
   with hexa-c = [[ 0.0 0.96  1.0 ] [ 0.0 0.88 0.96 ] [ 0.0 0.80 0.88 ]]
   with hz     = (bad-hz)
   with fps    = 60
   with delta  = (// hz fps)
   with frames = (** 2 13)
   with beg    = (bad-ticks)
   with stops  = (number-sequence (+ beg delta) (+ beg (* frames delta)) delta)
   with run    = t
   initially (ecs-init) (ecs-init-interface nil nil no-frame-change) (sdl_glsl_init)
   for R = (ecs-rotation-matrix-alternative)
   for V = (ecs-view-matrix)
   for M = (ecs-world-matrix hexa-k hexa-t R)
   while run for next in stops do
     (when-let* ((evnt (& (input-pending-p) (read-event))))
       (setf run (! (= evnt 113)))
       (ecs-camera-input evnt))
     (sdl_glsl_clear)
     (sdl_glsl_update ecs-proj V M)
     (mapc (L (e) (ecs-draw-triangle e hexa-c)) bad-meshes-hexahedron)
     (sdl_glsl_swap)
     (sleep-for (// (- next (bad-ticks)) hz))
   finally (sdl_glsl_quit)))

(cl-defmethod ecs-draw-triangle ((tri vector) (col vector) &optional (tex 0.0))
  (pcase-let   ((`[[ ,x0 ,y0 ,z0 ]
                   [ ,x1 ,y1 ,z1 ]
                   [ ,x2 ,y2 ,z2 ]
                   [ ,u0 ,v0     ]
                   [ ,u1 ,v1     ]
                   [ ,u2 ,v2     ]] tri)
                (`[[ ,r0 ,g0 ,b0 ]
                   [ ,r1 ,g1 ,b1 ]
                   [ ,r2 ,g2 ,b2 ]] col))
  (sdl_glsl_triangle  x0  y0  z0
                      x1  y1  z1
                      x2  y2  z2
                      r0  g0  b0
                      r1  g1  b1
                      r2  g2  b2
                  tex u0  v0
                      u1  v1
                      u2  v2 )))

;; +------+
;; | grid |
;; +------+

(defvar ecs-grid nil)
(setq   ecs-grid nil)

(defconst ecs-grid-h  31)
(defconst ecs-grid-w 112)

(cl-defmethod ecs-init-grid (&optional (chr ?-))
  (cl-loop
    initially (setf ecs-grid (make-vector ecs-grid-h nil))
    for row from 0 below ecs-grid-h
    do (setf (aref ecs-grid row) (make-string ecs-grid-w chr))
    finally do ($ "grid (w x h) = (%d x %d)" ecs-grid-w ecs-grid-h)))

(cl-defmethod ecs-grid-set ((row integer) (col integer) (val integer))
  (when (& (<= 0 row) (< row ecs-grid-h)
           (<= 0 col) (< col ecs-grid-w))
    (aset (aref ecs-grid row) col val)))

(defun bad-grid-string ()
  (mapconcat #'concat ecs-grid "\n"))

(cl-defmethod ecs-grid-clear (&optional (chr 32))
  (cl-loop for row being the elements of     ecs-grid do
  (cl-loop for col being the elements of-ref row      do (setf col chr))))

(defun ax (a) (aref a 0))
(defun ay (a) (aref a 1))
(defun az (a) (aref a 2))
(defun ar (a) (if (= (--- a) 3) (aref a 0) (aref a 3)))
(defun ag (a) (if (= (--- a) 3) (aref a 1) (aref a 4)))
(defun ab (a) (if (= (--- a) 3) (aref a 2) (aref a 5)))

(defun bad-minimal ()
  (cl-loop
   with hz       = (bad-hz)
   with fps      = 60
   with delta    = (// hz fps)
   with frames   = 1024
   with img-data = nil
   with beg      = (bad-ticks)
   with stops    = (number-sequence (+ beg delta) (+ beg (* frames delta)) delta)
   initially
     (sdl_draw_init)
     (setf img-data (decode-coding-string (or img-data "bogus string") 'utf-8-unix))
   for next in stops do
     (sdl_draw_webp)
     (sdl_draw_text)
     (sleep-for (// (- next (bad-ticks)) hz))
   finally
     (erase-buffer)
     (&  img-data                                        (stdout (@f "data exists:  %d\n"  1 )))
     (&  img-data (imagep (create-image img-data nil t)) (stdout (@f "image exists: %d\n"  2 )))
     (or img-data                                        (stdout (@f "NO DATA GODDAMMIT!\n"  )))
     (sleep-for 8)
     (sdl_draw_quit)))

(defun bad-fps ()
  (ecs-init-grid)
  (ecs-grid-clear 45)
  (ecs-init-interface)
  (sdl_draw_init)
  (sdl_draw_grid_toggle)
  (cl-loop
   with run           = t
   with hz            = (bad-hz)
   with fps           = 60
   with delta         = (// hz fps)
   with frames        = 4096
   with frames-done   = 0
   with slp           = 0
   with ahead         = 0
   with beg           = (bad-ticks)
   with stops         = (number-sequence (+ beg delta) (+ beg (* frames delta)) delta)
   for ver-msg        = (pad (@f "    GNU Emacs %s | debian %s | SDL 3.5.0 | OpenGL 4.6" emacs-version system-type)                          ecs-grid-w)
   for set-to-msg     = (pad (@f "    fps (set to) %d"                                   fps)                                                ecs-grid-w)
   for frames-msg     = (pad (@f "    frame %d of %d (%d%%)"                             frames-done frames (* 100 (// frames-done frames))) ecs-grid-w)
   for actual-fps-msg = (pad (@f "    fps (actual) %.1f"                                 (// (* frames-done hz) (- (bad-ticks) beg)))        ecs-grid-w)
   for ahead-msg      = (pad (@f "    total sleep %.1f s -> %.5f s/frame"                ahead (// ahead frames-done))                       ecs-grid-w)
   for ft from 0
   for next in stops while run do
     (sdl_draw_clear)
     (aset ecs-grid 14 ver-msg)
     (mapc (L (i) (aset ecs-grid i (make-string ecs-grid-w 32))) [ 13 15 17 20 22 ])
     (aset ecs-grid 16 frames-msg)
     (aset ecs-grid 18 set-to-msg)
     (aset ecs-grid 19 actual-fps-msg)
     (aset ecs-grid 21 ahead-msg)
     (sdl_draw_frame)
     (++ frames-done)
     (setf slp (// (- next (bad-ticks)) hz))
     (++ ahead slp)
     (sleep-for slp)
   finally (sdl_draw_quit)))

;; +-------+
;; | solar |
;; +-------+

(cl-defmethod ecs-kepler-e4 ((M float) (e float))
  (let ((Mm (- (m (+ M float-pi) (* 2 float-pi)) float-pi)))
    (+ Mm
    (*           e    (sin      Mm ))
    (* 0.500 (** e 2) (sin (* 2 Mm )))
    (* 0.375 (** e 3) (sin (* 3 Mm )))
    (* 0.333 (** e 4) (sin (* 4 Mm ))))))

(defun ecs-solar-update ()
  (cl-loop
   for id in ecs-ents
   for a = (ecs-get-comp id 'semi-major-axis)
   for e = (ecs-get-comp id 'eccentricity)
   for i = (ecs-get-comp id 'inclination)
   for O = (ecs-get-comp id 'node-longitude)
   for P = (ecs-get-comp id 'orbital-period)
   for w = (ecs-get-comp id 'periapsis)
   when (& a e i O P w) do
   (let* ((M     (// (* (float-time) 64) P))
          (theta (ecs-kepler-e4 M e))    (sin-t (sin theta)) (cos-t (cos theta))
          (w-rad (degrees-to-radians w)) (sin-w (sin w-rad)) (cos-w (cos w-rad))
          (i-rad (degrees-to-radians i)) (sin-i (sin i-rad)) (cos-i (cos i-rad))
          (O-rad (degrees-to-radians O)) (sin-O (sin O-rad)) (cos-O (cos O-rad))
          (er    (// (* a (- 1 (** e 2))) (1+ (* e cos-t))))
          (x-orb (* cos-t er))
          (y-orb (* sin-t er))
          ;; rotation
          (x1 (- (* cos-w x-orb) (* sin-w y-orb)))
          (y1 (+ (* sin-w x-orb) (* cos-w y-orb)))
          ;; inclination
          (y2 (* cos-i y1))
          (z2 (* sin-i y1))
          ;; ascending node longitude
          (x3 (- (* cos-O x1) (* sin-O y2)))
          (y3 (+ (* sin-O x1) (* cos-O y2))))
     (ecs-set-comp-vector id 'position x3 y3 z2))))

(defun ecs-init-solar ()
  (ecs-add-ent 'mercury   '(( periapsis       .    29.124               )
                            ( eccentricity    .     0.206               )
                            ( inclination     .     7.005               )
                            ( node-longitude  .    48.331               )
                            ( orbital-period  .    87.969               )
                            ( radius          .  2439.700               )
                            ( semi-major-axis .     0.387               )
                            ( color           .   [ 0.531 0.562 0.594 ] )
                            ( position        .   [ 0.000 0.000 0.000 ] )))

  (ecs-add-ent 'venus     '(( periapsis       .    54.884               )
                            ( eccentricity    .     0.007               )
                            ( inclination     .     3.395               )
                            ( node-longitude  .    76.680               )
                            ( orbital-period  .   224.701               )
                            ( radius          .  6051.800               )
                            ( semi-major-axis .     0.723               )
                            ( color           .   [ 0.931 0.762 0.494 ] )
                            ( position        .   [ 0.000 0.000 0.000 ] )))

  (ecs-add-ent 'earth     '(( periapsis       .   102.947               )
                            ( eccentricity    .     0.017               )
                            ( inclination     .     0.00005             )
                            ( node-longitude  .   348.739               )
                            ( orbital-period  .   365.256               )
                            ( radius          .  6371.124               )
                            ( semi-major-axis .     1.124               )
                            ( color           .   [ 0.231 0.462 0.894 ] )
                            ( position        .   [ 0.000 0.000 0.000 ] )))

  (ecs-add-ent 'mars      '(( periapsis       .   286.502               )
                            ( eccentricity    .     0.093               )
                            ( inclination     .     1.850               )
                            ( node-longitude  .    49.558               )
                            ( orbital-period  .   686.984               )
                            ( radius          .  3389.524               )
                            ( semi-major-axis .     1.523               )
                            ( color           .   [ 0.831 0.362 0.294 ] )
                            ( position        .   [ 0.000 0.000 0.000 ] )))

  (ecs-add-ent 'jupiter   '(( periapsis       .   273.867               )
                            ( eccentricity    .     0.049               )
                            ( inclination     .     1.305               )
                            ( node-longitude  .   100.464               )
                            ( orbital-period  .  4332.590               )
                            ( radius          . 69911.124               )
                            ( semi-major-axis .     5.204               )
                            ( color           .   [ 0.831 0.662 0.494 ] )
                            ( position        .   [ 0.000 0.000 0.000 ] )))

  (ecs-add-ent 'saturn    '(( periapsis       .    10.758               )
                            ( eccentricity    .     0.055               )
                            ( inclination     .     2.485               )
                            ( node-longitude  .    96.429               )
                            ( orbital-period  . 10759.000               )
                            ( radius          . 60268.000               )
                            ( semi-major-axis .     9.582               )
                            ( color           .   [ 0.780 0.590 0.780 ] )
                            ( position        .   [ 0.000 0.000 0.000 ] ))))
;; +--------+
;; | render |
;; +--------+

(defun ecs-solar-render ()
  (cl-loop
   with p      = (ecs-camera-position)
   with u      = (ecs-camera-up)
   with r      = (ecs-camera-right)
   with f      = (ecs-camera-forward)
   with char-w = 17.0
   with char-h = 34.0
   with cwgw   = (* char-w ecs-grid-w)
   with chgh   = (* char-h ecs-grid-h)
   with cxp    = (// ecs-grid-w 2)     ;; what
   with cyp    = (// ecs-grid-h 2)     ;; are
   with chb    = (*  2 (// cwgw chgh)) ;; these
   with cwb    = (* 96 (// chgh cwgw)) ;; for
   for id in (sort ecs-ents :key (L (e) (ecs-dot (v-v (ecs-position e) p) f)) :in-place t)
   for pos = (ecs-position id)
   for rad = (ecs-get-comp id 'radius)
   when (& id pos rad) do
   (cl-loop
    with rel        = (v-v     pos p)
    with rx         = (ecs-dot rel r)
    with ry         = (ecs-dot rel u)
    with rz         = (ecs-dot rel f)
    with gx         = (+ cxp (* cwb rx))
    with gy         = (- cyp (* chb ry))
    with gr         = (max 1 (* 0.6 (// rad rz)))
    with gr2        = (** gr 2)
    with sun-rel    = (k*v -1 p)
    with sun-z      = (ecs-dot sun-rel f)
    with sun-behind = (< sun-z rz)
    with chr        = (if sun-behind 120 77)
    with row-beg    = (max 0          (r (- gy gr)))
    with row-end    = (min ecs-grid-h (r (+ gy gr)))
    for row from row-beg below row-end
    for dy2 = (* 4 (** (- row gy) 2))
    for inv = (- gr2 dy2)
    when (< 0 inv) do
    (cl-loop
     with rad = (sqrt inv)
     with beg = (max 0          (r (- gx rad)))
     with end = (min ecs-grid-w (r (+ gx rad)))
     with cx  = (* gx char-w)
     with cy  = (* gy char-h)
     with cr  = (* gr char-w)
     with clr = (ecs-get-comp id 'color)
     initially (& clr (pcase-let ((`[             ,r ,g ,b ] clr          ))
                      (push        `[ ,cx ,cy ,cr ,r ,g ,b ] ecs-circles )))
     for col from beg below end
     do (aset (aref ecs-grid row) col chr)))))

(defun bad-solar ()
  (cl-loop
   with run       = t
   with circles   = t
   with hz        = (bad-hz)
   with fps       = 60
   with delta     = (// hz fps)
   with frames    = (** 2 14)
   with beg       = (bad-ticks)
   with origo     = [ 0.0 0.0 0.0 ]
   with look-pos  = origo
   with look-lbl  = "(camera) "
   with origo-lbl = (concat look-lbl "origo")
   initially
     (ecs-init)
     (ecs-init-grid)
     (ecs-init-solar)
     (ecs-init-interface)
     (sdl_draw_init)
   for fr from 0 below frames
   for next = (+ beg (* fr delta))
   while run do
     (when-let* ((evnt (& (input-pending-p) (read-event))))
       (pcase evnt
       ((or 13 81 113) (setf run nil))
       (?a (setf circles (! circles)))
       (?p (sdl_draw_grid_toggle))
       (?v         (progn (setf look-pos (& (! (equal look-pos origo)) origo)) ($ (if look-pos origo-lbl "free camera"))))
       ((or ?0 ?`) (progn (setf look-pos origo)                                ($ origo-lbl)))
       ((or ?1 ?m) (progn (setf look-pos (ecs-position 'mercury))              ($ (concat look-lbl "Mercury"))))
       ((or ?2 ?v) (progn (setf look-pos (ecs-position 'venus))                ($ (concat look-lbl "Venus"))))
       ((or ?3 ?e) (progn (setf look-pos (ecs-position 'earth))                ($ (concat look-lbl "Earth"))))
       ((or ?4 ?M) (progn (setf look-pos (ecs-position 'mars))                 ($ (concat look-lbl "Mars"))))
       ((or ?5 ?J) (progn (setf look-pos (ecs-position 'jupiter))              ($ (concat look-lbl "Jupiter"))))
       ((or ?6 ?S) (progn (setf look-pos (ecs-position 'saturn))               ($ (concat look-lbl "Saturn"))))
       (_ (ecs-camera-input evnt))))
     (sdl_draw_clear)
     (ecs-grid-clear)
     (& look-pos (ecs-camera-look-at look-pos))
     (ecs-solar-update)
     (ecs-solar-render)
     (when circles
       (pcase-dolist (`[ ,x ,y ,rad ,r ,g ,b ] ecs-circles)
         (sdl_draw_circle x  y  rad  r  g  b))
       (setf ecs-circles nil))
     (sdl_draw_frame)
     (sleep-for (// (- next (bad-ticks)) hz))
     finally (sdl_draw_quit)))

(defun ecs-position (ent) (ecs-get-comp ent 'position))
(defun ecs-up       (ent) (ecs-get-comp ent 'up))
(defun ecs-right    (ent) (ecs-get-comp ent 'right))
(defun ecs-forward  (ent) (ecs-get-comp ent 'forward))

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