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

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

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

(-> 'bad-ascii)
(-> 'bad-borderless)
(-> 'bad-helpers)
(-> 'bad-write)

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

(defvar bad-img-dir "~/img")
(defvar bad-only-ascii nil)

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

(defclass box (borderless)
  ((name :initform (@f "box-%d" (random 100)))
   (img           :initarg :img                           :initform nil)
   (img-prop-data :initarg :img-prop-data :type list      :initform nil)
   (img-w         :initarg :img-w         :type integer   :initform 0)
   (img-h         :initarg :img-h         :type integer   :initform 0)
   (iix           :initarg :iix           :type integer   :initform 0)
   (iiy           :initarg :iiy           :type integer   :initform 0)
   (c1            :initarg :c1            :type integer   :initform #1=?+)
   (c2            :initarg :c2            :type integer   :initform #1#)
   (c3            :initarg :c3            :type integer   :initform #1#)
   (c4            :initarg :c4            :type integer   :initform #1#)
   (s1            :initarg :s1            :type list      :initform #1='(?-))
   (s2            :initarg :s2            :type list      :initform #2='(?|))
   (s3            :initarg :s3            :type list      :initform #1#)
   (s4            :initarg :s4            :type list      :initform #2#)
   (redraw        :initarg :redraw        :custom boolean :initform t)))

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

(cl-defmethod bad-flip-img-y ((b box))
  (~ (img) b
     (when img
       ;; NOTE: don't change into `let'
       (setf #1=(image-property img :flip) (! #1#))
       (bad-flip-img-x b))))

(cl-defmethod bad-flip-img-x ((b box))
  (~ (img) b
     (when img
       ;; NOTE: don't change into `let'
       (setf #1=(image-property img :rotation) (m (+ #1# 180) 360))
       (setf #1=(image-property img :flip) (! #1#)))))

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

(let ((files)
      (len)
      (idx 0))
  (cl-defmethod bad-show-img ((b box) &optional reload next)
    (let ((ext ".png"))
      (when (& (or (! files) reload)
               (file-directory-p bad-img-dir))
        (setq files (directory-files bad-img-dir t ext))
        (setq len (--- files)))
      (if (! files)
          ($ "No %s files found: %s\n%s" ext bad-img-dir
             "Set another directory: (setq bad-img-dir \"~/my/img/files\")")
        (let* ((img-path (if next
                             (nth (setq idx (m (++ idx) len)) files)
                           (seq-random-elt files)))
               (img-l (create-image img-path))
               (size  (image-size img-l t)))
          (setq idx (cl-position img-path files))
          (~ (img img-prop-data img-w img-h transposable fg bg spc) b
             (setf img-w (1st size))
             (setf img-h (cdr size))
             (setf img (create-image img-path nil nil
                                     :width    img-w
                                     :height   img-h
                                     :flip     nil ; NOTE: OK
                                     :rotation 0.0 ; NOTE: OK
                                     :scale    1.0 ; NOTE: OK
                                     :ascent   'center))
             (setf bg nil)
             (setf fg (seq-random-elt (bad-fg-colors)))
             (bad-make-nonsolid b)
             (setf transposable nil)
             (setq img-prop-data nil)))))))

(cl-defmethod bad-make-nonsolid ((b box) &optional solid)
  (setf (@ b spc) (list (if solid bad-solid bad-nonsolid)))
  (bad-update b))

(cl-defmethod bad-make-solid ((b box))
  (bad-make-nonsolid b 'solid))

(cl-defmethod bad-draw-img ((b box))
  (~ (visible img img-prop-data w h iix iiy x y max-x max-y) b
    (when (& img visible)
      (let* ((cw       (frame-char-width))
             (ch       (frame-char-height))
             (rx       (1+ x))
             (ry       (1+ y))
             (img-size (image-size img t))
             (img-w-px (1st img-size))
             (img-h-px (cdr img-size))
             (img-cols (1- (/ img-w-px cw)))
             (img-rows (1- (/ img-h-px ch)))
             (box-cols (- w 3))
             (box-rows (- h 3))
             (cols     (min img-cols (+ iix box-cols)))
             (rows     (min img-rows (+ iiy box-rows)))
             (beg))
        (goto-beg)
        (goto-char (pos-bol ry))
        (setq beg (point))
        (unless img-prop-data
          (cl-loop
           for r from 0 upto img-rows do
           (cl-loop
            with line-prop-data = nil
            for c from 0 upto img-cols do
            (pushlast
              (propertize " " 'display (list (list 'slice (* c cw) (* r ch) cw ch) img))
              line-prop-data)
            finally do (pushlast line-prop-data img-prop-data))))
        (when img-prop-data
          (cl-loop
           initially do
             (goto-char beg)
             (goto-char (+ rx (pos-bol 2)))
           for ls in (bad-subseq img-prop-data iiy (1+ rows)) do
           (cl-loop
            for l in (bad-subseq ls iix (1+ cols))
            for len = (--- l) do
            (unless (or (eolp) (eobp))
              (delete-char len)
              (insert l))
            finally do (goto-char (+ rx (pos-bol 2))))
           finally do (goto-beg)))))))

(defun bad-subseq (lst beg &optional end)
  (let ((do-it t))
    (unless (l lst)
      (setq do-it nil))
    (let* ((len    (--- lst))
           (last-i (1- len)))
      (or end (setq end last-i))
      (unless (& (<= 0      beg)    ; underflow
                 (<  beg    end)    ; bogus indata
                 (<= end    last-i) ; same
                 (<  last-i len))
        (setq beg 0)
        (setq end last-i)))
    (if do-it
        (cl-subseq lst beg end)
      (prog1 nil
        ($ "Bogus indata, not doing anything")))))

(cl-defmethod bad-redraw-img ((b box))
  (~ (img img-prop-data) b
     (when (& img img-prop-data)
       (setf img-prop-data nil)
       (bad-draw-img b))))

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

(cl-defmethod bad-box-adapt-border ((b box) &optional no-gfx-style)
  (or no-gfx-style (setq no-gfx-style #'bad-make-ascii))
  (if (& (! bad-only-ascii) (gfx))
      (bad-box-unicode-border b)
    (funcall no-gfx-style b))
  (bad-update b)) ; NOTE: OK

(cl-defmethod bad-box-unicode-border ((b box))
  (~ (s1 s2 s3 s4 c1 c2 c3 c4) b
    (setf s1 '(?▁))
    (setf s2 '(?▏))
    (setf s3 '(?▔))
    (setf s4 '(?▕))
    (setf c1 #1=bad-nonsolid) ; NOTE: OK
    (setf c2 #1#)
    (setf c3 #1#)
    (setf c4 #1#)))

(cl-defmethod bad-cycle-border ((b box))
  (~ (c1 s1) b
    (if bad-only-ascii
        (cl-case c1
          (?\+ (bad-make-light       b))
          (?\┏ (bad-make-opaque      b))
          (?\s (bad-make-transparent b))
          (t   (bad-make-ascii       b)))
      (cl-case c1
        (?\+ (bad-make-light       b))
        (?\┌ (bad-make-heavy       b))
        (?\┏ (bad-make-opaque      b))
        (?\s (bad-make-transparent b))
        (?\{ (if (l= s1 `(,bad-nonsolid))
                 (bad-box-unicode-border b)
               (bad-make-ascii b)))
        (t   (bad-make-ascii b))))))

(cl-defmethod bad-make-opaque ((b box) &optional verbose)
  (bad-border b bad-solid)
  (when verbose
    ($ "border: opaque")))

(cl-defmethod bad-make-transparent ((b box) &optional verbose)
  (bad-border b bad-nonsolid)
  (when verbose
    ($ "border: transparent")))

(cl-defmethod bad-make-ascii ((b box))
  (~ (c1 c2 c3 c4 s1 s2 s3 s4) b
    (setf c1    #0=?+) (setf s1 #1='(?-)) (setf c2 #0#)
    (setf s4 #2='(?|))                    (setf s2 #2#)
    (setf c4      #0#) (setf s3 #1#)      (setf c3 #0#))
  (bad-update b))

(cl-defmethod bad-make-light ((b box))
  (~ (c1 c2 c3 c4 s1 s2 s3 s4) b
    (setf c1      ?┌)  (setf s1 #1='(?─)) (setf c2 ?┐)
    (setf s4 #2='(?│))                    (setf s2 #2#)
    (setf c4      ?└)  (setf s3 #1#)      (setf c3 ?┘))
  (bad-update b))

(cl-defmethod bad-make-heavy ((b box))
  (~ (c1 c2 c3 c4 s1 s2 s3 s4) b
         (setf c1 ?┏)  (setf s1 #1='(?━)) (setf c2 ?┓)
    (setf s4 #2='(?┃))                    (setf s2 #2#)
         (setf c4 ?┗)  (setf s3 #1#)      (setf c3 ?┛))
  (bad-update b))

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

(defun scramble (seq)
  (seq-sort (L (_ __) (z (random 2))) seq))

(cl-defmethod bad-make-bra ((b box) &optional new)
  "Does not work with all fonts."
  (~ (c1 c2 c3 c4 s1 s2 s3 s4 spc) b
     (setf c1   ?⡏)  (setf s1  '(?⠉))  (setf c2   ?⢹)
     (setf s4 '(?⡇))                   (setf s2 '(?⢸))
     (setf c4   ?⣇)  (setf s3  '(?⣀))  (setf c3   ?⣸)
     (when new
       (setf spc '(?⠁ ?⠂ ?⠄ ?⠈ ?⠐ ?⠠))))
  (bad-update b))

(cl-defmethod bad-make-bra-full ((b box) &optional new)
  "Does not work with all fonts."
  (~ (c1 c2 c3 c4 s1 s2 s3 s4 spc) b
     (setf c1 ?⡿)             (setf s1 #1=(scramble '(?⡿ ?⣟ ?⣯ ?⣾))) (setf c2 ?⣟)
     (setf s4 (scramble #1#))                                        (setf s2 (scramble #1#))
     (setf c4 ?⣾)             (setf s3    (scramble #1#))            (setf c3 ?⣯)
     (when new
       (setf spc (scramble #1#))))
  (bad-update b))

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

(cl-defmethod bad-clear ((b box) &optional fill)
  (or fill (setq fill `(,bad-solid)))
  (setf (@ b spc) fill)
  (bad-update b))

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

(cl-defmethod bad-resize-sub :after ((b box))
  (~ (sub w h pushy) b
     (dolist (sub-e sub)
       (~ (w-min h-min (sw w) (sh h) w-max h-max min-x min-y x y max-x max-y) sub-e
          (let ((hori (- w 2))
                (vert (- h 2)))
            (setf w-max (max w-min hori))
            (setf h-max (max h-min vert))
            (setf max-x (max min-x hori))
            (setf max-y (max min-y vert)))
          (when pushy
            (when (< w-max sw)
              (setf sw (max w-min w-max)))
            (when (< h-max sh)
              (setf sh (max h-min h-max)))
            (when (< w-max (- (+ x sw) min-x))
              (bad-mov-x sub-e -1))
            (when (< h-max (- (+ y sh) min-y))
              (bad-mov-y sub-e -1)))))))

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

(cl-defmethod bad-border ((b box) c)
  (~ (c1 c2 c3 c4 s1 s2 s3 s4) b
     (setf c1 c)
     (setf c2 c)
     (setf c3 c)
     (setf c4 c)
     (setf s1 `(,c))
     (setf s2 `(,c))
     (setf s3 `(,c))
     (setf s4 `(,c))
     (bad-update b)))

(cl-defmethod bad-side ((b box) n s)
  (when (su s)
    (~ (s1 s2 s3 s4) b
       (let ((lst (string-to-list s)))
         (cl-case n
           (1 (setf s1 lst))
           (2 (setf s2 lst))
           (3 (setf s3 lst))
           (4 (setf s4 lst))
           (t ($ "DNC")))))))

(cl-defmethod bad-corner ((b box) n c)
  (~ (c1 c2 c3 c4) b
    (cl-case n
      (1 (setf c1 c))
      (2 (setf c2 c))
      (3 (setf c3 c))
      (4 (setf c4 c))
      (_ ($ "DNC")))))

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

(cl-defmethod bad-add ((b box) (e elem))
  (~ (w h sub) b
     (~ (fg bg (iw w) (ih h) w-max h-max min-x min-y x y) e
        (setf fg    (or fg our-white-b))
        (setf bg    (or bg (bad-bg-random)))
        (setf iw    (or iw (- w 2)))
        (setf ih    (or ih (- h 2)))
        (setf w-max (or w-max iw))
        (setf h-max (or h-max ih))
        (setf min-x (or min-x 0))
        (setf min-y (or min-y 0))
        (setf x     (or x (1+ min-x)))
        (setf y     (or y (1+ min-y))))
     (bad-update e)
     (pushlast e sub)))

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

(cl-defmethod bad-draw-endpoint-line ((e elem) l m r len &optional n)
  (or n (setq n 1))
  (~ (w-min) e
     (when (<= w-min len)
       (cl-loop
        with len-l = (--- l)
        with len-r = (--- r)
        with len-m = (- len 2)
        for i from 0 to (1- n)
        for l-item = (nth (m i len-l) l)
        for r-item = (nth (m i len-r) r)
        for m-item = (bad-string-repeat m len-m)
        collect (@f "%c%s%c" l-item m-item r-item)))))

(cl-defmethod bad-update ((b box))
  (~ (w h data len c1 c2 c3 c4 s1 s2 s3 s4 spc sub redraw) b
     ;; border and body
     (let* ((tl (bad-draw-endpoint-line b (list c1) s1  (list c2) w))
            (ml (bad-draw-endpoint-line b s4        spc       s2  w  (- h 2)))
            (bl (bad-draw-endpoint-line b (list c4) s3  (list c3) w))
            (all `(,@tl ,@ml ,@bl))
            (str (string-join all)))
       (setf data (string-to-list str))
       (setf len (--- data)))
     ;; subs
     (bad-write-subs b)
     (setf redraw t)))

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

(cl-defmethod bad-size-adapt ((a ascii) (b box))
  (when (@ b resizable)
    (~ (w h) a
       (let ((pad 4))
         (bad-size b (+ w pad) (+ h pad))))))

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

(cl-defmethod bad-rotate-img ((b box) &optional n)
  (or n (setq n 1))
  (~ (img) b
    (when img
      (++ (image-property img :rotation) (* n 90)))))

(cl-defmethod bad-rotate-corners ((b box) &optional n)
  (or n (setq n 1))
  (~ (c1 c2 c3 c4) b
     (cond
      ((< 0 n) (cl-loop repeat      n  do (cl-rotatef c4 c3 c2 c1)))
              ((cl-loop repeat (abs n) do (cl-rotatef c1 c2 c3 c4))))))

(cl-defmethod bad-rotate-sides ((b box) &optional n)
  (or n (setq n 1))
  (~ (s1 s2 s3 s4) b
     (cond
      ((< 0 n) (cl-loop repeat      n  do (cl-rotatef s4 s3 s2 s1)))
              ((cl-loop repeat (abs n) do (cl-rotatef s1 s2 s3 s4))))))

(cl-defmethod bad-rotate-border ((b box) &optional n)
  (or n (setq n 1))
  (bad-rotate-corners b n)
  (bad-rotate-sides b n))

(cl-defmethod bad-rotate :after ((b box) &optional n inner)
  (or n (setq n 1))
  (~ (img) b
     (when img
       (bad-rotate-img b n)))
  (let ((tms (if inner (* 3 n) n)))
    (bad-rotate-border b tms))
  (bad-update b))

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

(cl-defmethod bad-write-subs ((b box))
  (~ (sub) b
     (dolist (sub-e sub)
       (when (ascii-p sub-e)
         (bad-write-replace b sub-e)))))

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

(<- 'bad-box)