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

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

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

(-> 'bad-blend)
(-> 'bad-color)
(-> 'bad-elem)
(-> 'bad-helpers)
(-> 'bad-triangle)
(-> 'bad-write)

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

(cl-defmethod bad-draw-to-elem ((_ elem) (_ triangle)) (ignore))

(cl-defmethod bad-draw-to-elem ((dst elem) (src elem) &optional rect)
  (~ ((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 actual-fg 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 (& (< 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) ; NOTE: OK
             initially do (goto-char (+ hx (pos-bol (1+ hy))))
             with real-w = (if (< (+ dst-x dst-w) (+ hx hw)) (- dst-w hx) hw)
             with real-h = (if (< (+ dst-y dst-h) (+ hy hh)) (- dst-h hy) hh)
             with real-d = (flatten-list ; NOTE: OK
                            (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))
             with f-col    = (or actual-fg fg)
             with the-prop = (cond
                              ((& bg f-col) `(:background ,bg :foreground ,f-col))
                              (bg    `(:background ,bg))
                              (f-col `(:foreground ,f-col)))
             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 no-clrs
                     (forward-char)
                   (let* ((fgb (bad-blend bg (foreground-color-at-point))) ; NOTE: OK
                          (bgb (bad-blend bg (background-color-at-point)))
                          (bpr `(:background ,bgb :foreground ,fgb)))
                     (forward-char)
                     (let ((pnt (point)))
                       (put-text-property (1- pnt) pnt 'face bpr))))
               (if body
                   (progn
                     (insert-char c)
                     (delete-char 1)
                     (when the-prop
                       (let ((pnt (point)))
                         (put-text-property (1- pnt) pnt 'face the-prop))))
                 (unless no-clrs
                   (setq prop (list :foreground (or f-col (foreground-color-at-point))
                                    :background (background-color-at-point))))
                 (insert-char c)
                 (delete-char 1)
                 (when prop
                   (let ((pnt (point)))
                     (put-text-property (1- pnt) pnt 'face prop)))))
             (if (< col end-col)
                 (++ col)
               (++ row)
               (setq col fst-col)
               (goto-char (+ hx (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)

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

(cl-defmethod bad-draw-to-buf ((e elem) &optional keep)
  (with-slots (data bg w h visible) e
    (when visible
      (cl-loop
       initially do (if keep (goto-beg) (erase-buffer))
       with chunks = (take h (seq-split data w))
       for c in chunks
       for str = (@f "%s\n" (seq--into-string c)) do
       (insert (if (su bg)
                   (propertize str 'face `(:background ,bg))
                 str))
       finally do (goto-beg)))))

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

(<- 'bad-draw)