;;; -*- lexical-binding: t -*-

;; --------------------------------------------------------------------------

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

;; --------------------------------------------------------------------------

(-> 'bad-color)
(-> 'bad-elem)
(-> 'bad-write)

;; --------------------------------------------------------------------------

(defun bad-color-values (c)
  (let ((col-str-len 2))
    (unless (s= (substring c 0 1) "#")
      (pcase-let* ((col (color-name-to-rgb c))
                   (`(,r ,g ,b) col))
        (setq c (color-rgb-to-hex r g b col-str-len))))
    (mapcar (L (s) (s2n s 16)) (list (substring c #1=1 #2=(+ #1# col-str-len))
                                     (substring c #2#  #3=(+ #2# col-str-len))
                                     (substring c #3#     (+ #3# col-str-len))))))

;; (bad-color-values "#e5e5e5")
;; (bad-color-values "white")

(defun bad-color-clamp (val &optional mini maxi)
  (or mini (setq mini   0)) ; (1- (** 2 0))
  (or maxi (setq maxi 255)) ; (1- (** 2 8))
  (min maxi (max mini val)))

(defvar bad-boost)
(setq bad-boost 1.25) ; (* (+ 4 16) (** 2 -4))

(defun bad-blend (c1 c2 &optional p1 p2)
  (when (& c1 c2)
    (unless (& p1 (<= 0.0 p1 1.0))
      (setq p1 0.5625)) ; (* 9 (** 2 -4))
    (unless (& p2 (<= 0.0 p2 1.0))
      (setq p2 (- 1 p1)))
    (pcase-let* ((`(,r1 ,g1 ,b1) (mapcar (L (e) (* p1 (sqrt (* bad-boost e e)))) (bad-color-values c1)))
                 (`(,r2 ,g2 ,b2) (mapcar (L (e) (* p2 (sqrt (* bad-boost e e)))) (bad-color-values c2)))
                 (r (* (+ r1 r2)))
                 (g (* (+ g1 g2)))
                 (b (* (+ b1 b2))))
      (@f "#%.2x%.2x%.2x"
          (bad-color-clamp r)
          (bad-color-clamp g)
          (bad-color-clamp b)))))

;; (bad-blend "#ff00ff" "#00ffff")

;; --------------------------------------------------------------------------

(cl-defmethod bad-draw-to-elem ((dst elem) (src elem) &optional blend boost-x boost-y rect)
  (or boost-x (setq boost-x 0))
  (or boost-y (setq boost-y 0))
  (~ ((dst-name name) (dst-x x) (dst-y y) (dst-w w) (dst-h h) (dst-fg fg) (dst-bg bg)) dst
     (~ (name visible data x y w h fg bg) src
        (let (hx hy hw hh)
          (if rect
              (pcase-let* ((farx (+ x w))
                           (fary (+ y h))
                           (`(,xr ,yr ,wr ,hr) rect)
                           (farxr (+ xr wr))
                           (faryr (+ yr hr)))
                (setq hx (max x xr))
                (setq hy (max y yr))
                (setq hw (- (min farx farxr) hx))
                (setq hh (- (min fary faryr) hy))
                (unless (and (< 0 hw) (< 0 hh))
                  (setq rect 0)))
            (setq hx x)
            (setq hy y)
            (setq hw w)
            (setq hh h))
          (when (& visible data (!z rect))
            (cl-loop
             with no-clrs = (s= dst-name name)
             with real-x  = (+ boost-x hx)
             with real-y  = (+ boost-y hy)
             initially do (goto-char (+ real-x (pos-bol (1+ real-y))))
             with real-w   = (if (< (+ dst-x dst-w) (+ real-x hw)) (- dst-w real-x) hw)
             with real-h   = (if (< (+ dst-y dst-h) (+ real-y hh)) (- dst-h real-y) hh)
             ;; TODO: examine this
             with real-d   = (flatten-list
                              (take real-h
                                    (nthcdr (- hy y)
                                            (mapcar
                                             (L (e) (take real-w (nthcdr (- hx x)  e)))
                                             (seq-split data w)))))
             with fst-col  = 0
             with fst-row  = 0
             with col      = fst-col
             with row      = fst-row
             with end-col  = (1- real-w)
             with end-row  = (if (< real-h hh) real-h (1- real-h)) ; compensate y
             with end-mod  = (if (< real-w hw) -1 -2)              ; and x
             with the-prop = (cond
                              ((& bg fg) `(:background ,bg :foreground ,fg))
                              (bg `(:background ,bg))
                              (fg `(:foreground ,fg)))
             for prop   = nil
             for body-x = (< fst-col col end-col)
             for body-y = (< fst-row row end-row)
             for body   = (& body-x body-y)
             for c in real-d do
             (if (= c bad-nonsolid)
                 (if blend ; nonsolid, blend
                     (let* ((fgb (bad-blend bg (background-color-at-point)))
                            (bgb (bad-blend bg (foreground-color-at-point)))
                            (bpr `(:background ,fgb :foreground ,bgb)))
                       (forward-char)
                       (let ((pnt (point)))
                         (put-text-property (1- pnt) pnt 'face bpr)))
                   (forward-char)) ; nonsolid
               (unless (or no-clrs body) ; border
                 (setq prop
                       (list
                        :foreground (or fg (foreground-color-at-point)    our-white-b)
                        :background (or    (background-color-at-point) bg our-black))))
               (insert c)
               (delete-char 1)
               (let* ((pnt (point)))
                 (if prop
                     (put-text-property (1- pnt) pnt 'face prop)
                   (when blend
                     (put-text-property (1- pnt) pnt 'face the-prop)))))
             (if (< col end-col)
                 (++ col)
               (when (& (! blend) body-y the-prop) ; last col but not top/down border
                 (let* ((beg (- (point) col))
                        (end (+ beg real-w end-mod)))
                   (put-text-property beg end 'face the-prop)))
               (++ row)
               (setq col fst-col)
               (goto-char (+ real-x (pos-bol 2))))
             finally do (goto-beg)))))))

;; --------------------------------------------------------------------------

(defun bad-buffer-string (&optional beg end prop)
  (or beg (setq beg (point-min)))
  (or end (setq end (point-max)))
  (if prop
      (buffer-substring beg end)
    (buffer-substring-no-properties beg end)))

(let ((all))
  (cl-defmethod bad-draw-clear ((e elem) &optional keep)
    (unless keep
      (erase-buffer))
    (unless all
      (~ (w h) e
         (cl-loop
          with line = (@f "%s\n" (make-string w bad-solid))
          repeat h do (insert line)
          finally do (setq all (bad-buffer-string)))))
    (unless keep
      (insert all))
    (goto-beg)))

(declare-function bad-draw-clear nil)

;; --------------------------------------------------------------------------

(<- 'bad-draw)