;;; juv-el --- boxy stone gems -*- lexical-binding: t -*-
;;
;;; Commentary:
;;
;; (keymap-set emacs-lisp-mode-map "<f10>" (L () (juv)))
;; (keymap-set emacs-lisp-mode-map "M-1" (L () (progn (eval-buffer) (juv))))
;;
;;; Code:

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

(require 'll      nil t)
(require 'll-char nil t)
(require 'll-list nil t)
(require 'll-time nil t)
(require 'll-type nil t)

;; helpers

(defun juv-aref-mod (v i)
  (cl-assert (sequ v))
  (cl-assert (ni i))
  (aref v (m i (--- v))))

;; names

(defun juv-emacs-name () (@f " GNU Emacs %s.%s " emacs-major-version emacs-minor-version))

(defun juv-str (str &optional fg bg &rest prop)
  (cl-assert (su str))
  (cl-assert (or (! fg) (su fg)))
  (cl-assert (or (! bg) (su bg)))
  (let ((props prop))
   (& fg (setf props `(,@props :foreground ,fg)))
   (& bg (setf props `(,@props :background ,bg)))
   (if props
       (propertize str 'face props)
     str)))

(defun juv-name ()
  (juv-str " juv-el " (juv-col* "cyan4" 0.72) (juv-col* "cyan1" 0.96) '(:inverse-video t)))

;; buttons

(defun juv-button (label fun &rest args)
  (cl-assert (su label))
  (cl-assert (functionp fun))
  (insert-text-button (@f "[ %s ]" label) 'action (L () (apply fun args))))

;; error

(defun juv-col-dnc (not-a-col)
  (let ((a-col "white"))
    ($ "color %s is not defined; setting it to '%s'." not-a-col a-col)
    "white"))

;; color

(defun juv-color-values (col)
  (or (color-defined-p col) (setf col (juv-col-dnc col)))
  (mapcar (L (v) (// v 65535)) (tty-color-values col)))

(defun juv-col* (col &optional k)
  (or (color-defined-p col) (setf col (juv-col-dnc col)))
  (setf k (cond ((nf k) k) ((ni k) (* 1.0 k)) (1.0)))
  (pcase-let ((`(,R ,G ,B) (mapcar (L (v) (* 255 (min 1 (max 0 (* k v))))) (juv-color-values col))))
    (@f "#%02x%02x%02x" R G B)))

;; types

(cl-defstruct juv-box
  (buf        nil        :type buffer  )
  (boxes      nil        :type vector  )
  (bench      nil        :type boolean )
  (x          0          :type integer )
  (y          0          :type integer )
  (w          (juv-cols) :type integer )
  (h          (juv-rows) :type integer )
  (adapt-size nil        :type boolean )
  (border     [ 48 49 50 51 52 53 54 55 ] :type vector)
  (border-fg  "orange"   :type string  )
  (border-bg  "gold"     :type string  )
  (focus      nil        :type boolean )
  (orient     0.0        :type float   )
  (fg         "white"    :type string  )
  (bg         "cyan"     :type string  )
  (bg-style   0          :type integer )
  (bg-trans   0.88       :type float   )
  ;; (fg-trans   0.96       :type float   )
  (data       nil        :type vector ))

;; benchmark

(cl-defmethod juv-bench ((c juv-box) (beg float))
  (& (juv-box-bench c)
     ($ " [ resolution %d × %d ] [ %d chars ] [ %.1f ms ]"
        (juv-cols)
        (juv-rows)
        (- (point-max) (point-min))
        (* 1e3 (- (luki-time) beg )))))

;; box bg

(cl-defmethod juv-gen-bg ((c juv-box) (x integer) (y integer))
  (when-let* ((funs (vector #'juv-gen-bg-logior #'juv-gen-bg-plasma))
              (fun  (juv-aref-mod funs (juv-box-bg-style c))))
    (funcall fun c x y)))

(cl-defmethod juv-gen-bg-logior ((c juv-box) (x integer) (y integer))
  (juv-col* (juv-box-bg c)
            (max 0.015
                 (// (logior x y)
                     (logior (juv-cols) (juv-rows))))))

;; (progn (eval-buffer) (juv))

(cl-defmethod juv-gen-bg-plasma ((c juv-box) (x integer) (y integer))
  (let ((w (juv-cols))
        (h (juv-rows)))
    (juv-col* (juv-box-bg c) (// (+ (* (sin (//      x       w))   2)
                                    (* (sin (//      y       h))   4)
                                    (* (sin (// (+ x y) (+ w h))) 16)) 19.8))))

;; distance

(defun juv-dist (Ax Ay Bx By)
  (sqrt (+ (** (- Ax Bx) 2)
           (** (- Ay By) 2))))

;; movement

(cl-defmethod juv-right ((b juv-box) &optional n) (or (ni n) (setf n 1)) (++ (juv-box-x b) n))
(cl-defmethod juv-down  ((b juv-box) &optional n) (or (ni n) (setf n 1)) (++ (juv-box-y b) n))
(cl-defmethod juv-up    ((b juv-box) &optional n) (or (ni n) (setf n 1)) (-- (juv-box-x b) n))
(cl-defmethod juv-left  ((b juv-box) &optional n) (or (ni n) (setf n 1)) (-- (juv-box-y b) n))

;; orient

(cl-defmethod juv-orient ((b juv-box))
  (let* ((on    (juv-box-orient b))
         (o     (- on (floor on)))
         (w     (juv-cols))
         (h     (juv-rows))
         (bw    (juv-box-w b))
         (bh    (juv-box-h b))
         (max-x (- w bw))
         (max-y (- h bh))
         (1q    (& (<= 0.00 o) (<  o 0.25)))
         (2q    (& (<= 0.25 o) (<  o 0.50)))
         (3q    (& (<= 0.50 o) (<  o 0.75)))
         (4q    (& (<= 0.75 o) (<= o 1.00)))
         (Dq    (// 1 4))
         (x     (max 0 (min max-x (cond        (1q (* w (// (- o (* 0 Dq)) Dq))) (2q w) (3q (- w (* w (// (- o (* 2 Dq)) Dq)))) (4q 0)))))
         (y     (max 0 (min max-y (cond (1q 0) (2q (* h (// (- o (* 1 Dq)) Dq))) (3q h) (4q (- h (* h (// (- o (* 3 Dq)) Dq)))))))))
    (setf (juv-box-x b) x)
    (setf (juv-box-y b) y)))

;; toggle

(cl-defmethod juv-toggle-focus ((b juv-box))
  (setf (juv-box-focus b) (! (juv-box-focus b))))

;; draw box

(cl-defmethod juv-draw-2 ((b juv-box) &optional no-newline)
  (cl-loop
   ;; with fg-trans  = (juv-box-fg-trans  b)
   with bg-trans  = (juv-box-bg-trans  b) with _ = (ignore bg-trans)
   with x         = (floor (juv-box-x  b))
   with y         = (floor (juv-box-y  b))
   with w         = (floor (juv-box-w  b))
   with h         = (floor (juv-box-h  b))
   with box-bg    = (juv-box-bg        b)
   with box-fg    = (juv-box-fg        b)
   with border    = (juv-box-border    b)
   with border-fg = (juv-box-border-fg b)
   with border-bg = (juv-box-border-bg b)
   with data      = (juv-box-data      b)
   with data-i    = 0
   with x-beg     = (max 0 x)
   with x-end     = (min (+ x w) (juv-cols))
   with y-beg     = (max 0 y)
   with y-end     = (min (+ y h) (juv-rows))
   initially (goto-beg) (forward-line y-beg) (forward-char x-beg)
   for row   from y-beg below y-end
   for row-i from 0
   for top   = (z row-i)
   for down  = (= (- h row-i) 1) ; (juv)
   do (cl-loop
       for col from x-beg below x-end
       for col-i from 0
       for left      = (z col-i)
       for right     = (= 1 (- w col-i))
       for brd-chr-i = (& border (cond ((& top  left)  0)
                                       ((& top  right) 2)
                                       ((& down right) 4)
                                       ((& down left)  6)
                                       (top            1)
                                       (right          3)
                                       (down           5)
                                       (left           7)))
       for brd-chr  = (& brd-chr-i (aref border brd-chr-i))
       for data-chr = (& (! brd-chr) data (juv-aref-mod data (++ data-i)))
       for chr      = (or data-chr brd-chr 32)
       ;;  for fgap     = (faces--attribute-at-point :foreground)
       for bgap     = (faces--attribute-at-point :background)
       for bg-gen   = (juv-gen-bg b col-i row-i)
       for bg       = (cond (brd-chr-i (or bgap      border-bg  box-bg))
                            (data-chr  (or bg-gen    box-bg    "black")))
       for fg       = (cond (brd-chr-i (or border-fg box-fg))
                            (data-chr  (or box-fg    border-fg "white")))
       ;; for blend-fg = (juv-col* fgap fg-trans)
       ;; for blend-bg = (juv-col* bgap bg-trans)
       ;; for fade-fg  = (juv-col* fgap  (+ 1.7 (// col-i (- x-beg x-end))))
       ;; for final-fg = (or fg fade-fg)
       ;; for final-bg = bg
       do      (juv-char chr nil fg bg)
       finally (if no-newline (goto-char (+ (pos-bol 2) x-beg)) (@i 10)))))

;; draw char

(defun juv-char (chr &optional pos fg bg)
  (or pos (setf pos (point)))
  (or fg  (setf fg  "white"))
  (or bg  (setf bg  "cyan"))
  (ll-delete-char 1 'not-eol)
  (@i chr)
  (ll-put-char-face pos (list :foreground fg :background bg)))

;; box size

(defun juv-rows (&optional n) (or (nf n) (setf n 1.0)) (r (* n (1- (window-size nil nil)))))
(defun juv-cols (&optional n) (or (nf n) (setf n 1.0)) (r (* n (1- (window-size nil t  )))))

;; erase buffer

(cl-defmethod juv-erase ((b juv-box))
  (& (juv-box-buf b) (erase-buffer)))

;; draw box

(cl-defmethod juv-adapt-size ((b juv-box))
  (when (juv-box-adapt-size b)
    (setf (juv-box-w b) (juv-cols))
    (setf (juv-box-h b) (juv-rows))))

(cl-defmethod juv-draw ((b juv-box))
  (let ((inhibit-redisplay t)
        (inhibit-modification-hooks nil))
    (cl-loop
     with beg = (luki-time)
     initially (juv-erase b) (juv-adapt-size b) (juv-draw-2 b)
     for B across-ref (juv-box-boxes b) do
     (juv-orient B)
     (juv-draw-2 B 'no-newline)
     finally (goto-beg)
     (juv-bench b beg))))

;; keys

(cl-defmethod juv-keys ((b juv-box))
  (keymap-local-set "w" #'kill-buffer)
  (keymap-local-set "1"
                    (L ()
                       (setf (juv-box-bg-style b) 1)
                       (setf (juv-box-bg b) (juv-col* "cyan" 1.0))
                       (juv-draw b)))
  (keymap-local-set "2"
                    (L ()
                       (setf (juv-box-bg-style b) 0)
                       (setf (juv-box-bg b) (juv-col* "purple" 1.0))
                       (juv-draw b)))
  (keymap-local-set "r" (L () (juv-draw         b)))
  )

;; run

(cl-defmethod juv-init-canvas ((can juv-box) (juv-buf buffer))
  (let ((box0 (make-juv-box               :w (* 0.5 (juv-cols)) :h (* 1.00 (juv-rows)) :data [ 32 32 32 32 32 32 32    48 49 50 ]))
        (box1 (make-juv-box :orient 0.250 :w (* 0.5 (juv-cols)) :h (* 0.33 (juv-rows)) :data [ 32 32 32 32       50 51 52 53 54 ]))
        (box2 (make-juv-box :orient 0.375 :w (* 0.5 (juv-cols)) :h (* 0.33 (juv-rows)) :data [ 32 32       55 56 57 58 59 60 61 ]))
        (box3 (make-juv-box :orient 0.500 :w (* 0.5 (juv-cols)) :h (* 0.33 (juv-rows)) :data [ 32       62 63 64 65 66 67 68 69 ])))
    (cl-with-accessors (( ac-adapt-size juv-box-adapt-size )
                        ( ac-buf        juv-box-buf        )
                        ( ac-border     juv-box-border     )
                        ( ac-boxes      juv-box-boxes      )
                        ( ac-bench      juv-box-bench      )
                        ( ac-fg         juv-box-fg         )
                        ( ac-bg         juv-box-bg         )
                        ( ac-data       juv-box-data       )) can
      (setf ac-adapt-size t)
      (setf ac-buf        t)
      (setf ac-border     nil)
      (setf ac-bench      t)
      (setf ac-boxes     `[ ,box0 ,box1 ,box2 ,box3 ])
      (setf ac-buf        juv-buf)
      (setf ac-fg         "white")
      (setf ac-bg         "purple")
      (setf ac-data       (seq--into-vector " the GNU Emacs juv-el   ")))))

(defun juv (&optional full)
  (when-let* ((buf "*juv-el*")
              (new (get-buffer-create buf))
              (can (make-juv-box)))
    (juv-init-canvas can new)
    (with-current-buffer (juv-box-buf can)
      (& full (setq mode-line-format (@f "▒▒▒▒%s▒▒▒▒%s▒▒▒▒" (juv-emacs-name) (juv-name))))
      (juv-keys can)
      (juv-draw can)
      (display-buffer (juv-box-buf can)))))

;; (juv)
;; (progn (eval-buffer) (juv))

(provide 'juv)
;;; juv.el ends here