;;; -*- 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=?+) ; NOTE: OK
   (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='(?-)) ; NOTE: OK
   (s2            :initarg :s2            :type list      :initform #2='(?|)) ; NOTE: OK
   (s3            :initarg :s3            :type list      :initform #1#)
   (s4            :initarg :s4            :type list      :initform #2#)))

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

(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 #2=(image-property img :flip) (! #2#)))))

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

(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 (zerop len)
          ($ "No %s files found in: %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-w img-h img-prop-data bg fg transposable w-min h-min redraw) b
             (setf w-min 3)
             (setf h-min 3)
             (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 our-black)
             (setf fg our-cyan-b) ; debug
             ;; (setf fg (seq-random-elt (bad-fg-colors)))
             (setf transposable  nil) ; NOTE: OK
             (setf img-prop-data nil) ; NOTE: OK
             (setf redraw t)))))))

(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      (point)))
        (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)))))))

(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))))

;; --------------------------------------------------------------------------\

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

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

(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-box-adapt-border ((b box) &optional no-gfx-style)
  (or no-gfx-style (setq no-gfx-style #'bad-make-ascii))
  (if (& (gfx) (! bad-only-ascii))
      (bad-box-unicode-border b)
    (funcall no-gfx-style b)))

(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#)
    (bad-update b)))

(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))
  (bad-border b bad-solid)
  ($ "border: opaque"))

(cl-defmethod bad-make-transparent ((b box))
  (bad-border b bad-nonsolid)
  ($ "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))
  "Not supported monospaced by all supposedly monospaced fonts."
  (~ (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)
  "Not supported by all fonts"
  (~ (c1 c2 c3 c4 s1 s2 s3 s4 spc) b
     (setf c1   ?⡏)  (setf s1  '(?⠉))  (setf c2   ?⢹)  ;
     (setf s4 '(?⡇))                   (setf s2 '(?⢸)) ; see? not monospaced
     (setf c4   ?⣇)  (setf s3  '(?⣀))  (setf c3   ?⣸)  ;  with font "Hack" 21
     (when new
       (setf spc '(?⠁ ?⠂ ?⠄ ?⠈ ?⠐ ?⠠))))
  (bad-update b))

(cl-defmethod bad-make-bra-full ((b box) &optional new)
  "Not supported by all fonts"
  (~ (c1 c2 c3 c4 s1 s2 s3 s4 spc) b
     (let ((chrs '(?⡿ ?⣟ ?⣯ ?⣾)))
       (setf c1 (1st chrs))      (setf s1 (scramble chrs)) (setf c2 (2nd chrs))
       (setf s4 (scramble chrs))                           (setf s2 (scramble chrs))
       (setf c4 (4th chrs))      (setf s3 (scramble chrs)) (setf c3 (3rd chrs))
       (when new
         (setf spc (scramble chrs)))))
  (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
     (let ((hori (- w 2))
           (vert (- h 2)))
       (dolist (u sub)
         (~ (w-min h-min (sw w) (sh h) w-max h-max min-x min-y x y max-x max-y) u
            (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-move-x u -1))
              (when (< h-max (- (+ y sh) min-y))
                (bad-move-y u -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)))
         (bad-update b)))))

(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)))
    (bad-update b)))

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

(cl-defmethod bad-add ((b box) (e elem) &rest _)
  (~ (w h sub) b
     (~ (bg dist-fg fg (ew w) (eh h) w-max h-max min-x min-y x y) e
        (setf bg      (or bg (bad-bg-random)))
        (setf dist-fg (or dist-fg our-black-b))
        (setf fg      (or fg our-white-b))
        (setf ew      (or ew (- w 2)))
        (setf eh      (or eh (- h 2)))
        (setf w-max   (or w-max ew))
        (setf h-max   (or h-max eh))
        (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))
  (~ (img img-prop-data w h c1 c2 c3 c4 s1 s2 s3 s4 spc sub) b
     (let* ((tl (bad-draw-endpoint-line b `(,c1)  s1  `(,c2) w))
            (ml (bad-draw-endpoint-line b    s4   spc    s2  w  (- h 2)))
            (bl (bad-draw-endpoint-line b `(,c4)  s3  `(,c3) w))
            (all `(,@tl ,@ml ,@bl))
            (str (string-join all))
            (str-data (string-to-list str)))
       (bad-set-data b str-data)
       (when (& img img-prop-data)
         (bad-redraw-img b))
       (bad-write-subs b))))

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

(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))
  (when (@ b 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))
  (dolist (u (@ b sub))
    (when (ascii-p u)
      (bad-write-replace b u))))

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

(<- 'bad-box)