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

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

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

(-> 'bad-alpha)
(-> 'bad-ascii)
(-> 'bad-box)
(-> 'bad-color)
(-> 'bad-draw)
(-> 'bad-helpers)
(-> 'bad-mode)
(-> 'bad-program)
(-> 'bad-proximity)
(-> 'bad-rotate)
(-> 'bad-triangle)
(-> 'bad-write)

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

(defclass studio (program)
  ((name :initform "studio")
   (benchmark        :initarg :benchmark        :custom boolean        :initform nil)
   (trans-chars      :initarg :trans-chars      :type   list           :initform `(,bad-solid ,bad-nonsolid))
   (trans-chars-more :initarg :trans-chars-more :type   list           :initform '(?░ ?▒ ?▓ ?█))
   (canvas           :initarg :canvas           :type   (or null box)  :initform nil)
   (elems            :initarg :elems            :type   list           :initform nil)
   (sel              :initarg :sel              :type   (or null elem) :initform nil)
   (ie               :initarg :ie               :type   integer        :initform 0)
   (pos-funs         :initarg :pos-funs         :type   list           :initform (list #'bad-origo #'bad-center))
   (size-funs        :initarg :size-funs        :type   list           :initform (list #'bad-size-half #'bad-size-square #'bad-size-max #'bad-size-min))))

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

(cl-defmethod bad-setup-canvas ((s studio))
  (~ (canvas elems sel w h) s
     (setf canvas (box :name "canvas" :spc `(,bad-solid) :w w :h h))
     (bad-make-opaque canvas)
     (when (gfx)
       (cl-loop
        with res    =  (// (frame-char-height) (frame-char-width))
        with y-side =  16
        with x-side =  (floor (* res y-side))
        with y-inc  =  (/ y-side 5)
        with x-inc  =  (floor (* res y-inc))
        with cols   = '(our-white-b   our-black-b  our-red-b      our-green-b
                        our-yellow-b  our-blue-b   our-magenta-b  our-cyan-b)
        with names  =  (mapcar (L (e) (@f "%s-box" (substring (symbol-name e) 4 -2))) cols)
        with rcols  =  (mapcar (L (e) (symbol-value e)) cols)
        with its    =  (--- cols)
        for ix in (number-sequence x-inc (* its x-inc) x-inc)
        for iy in (number-sequence y-inc (* its y-inc) y-inc)
        for n in names
        for r in rcols do
        (when-let* ((bx (box :name n :fg r :bg r :x ix :y iy :w x-side :h y-side)))
          (bad-make-light bx)
          (bad-add s bx))
        finally do (setf elems nil)))
     (when-let* ((fst (box :name "fst" :bg our-magenta-b :spc `(,bad-solid) :x 23 :y 9)))
       (bad-make-light fst)
       (bad-add s fst))
     (bad-read-ascii s nil "The world is all about money and intelligence.")))

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

(cl-defmethod bad-update ((s studio))
  (~ (elems sel benchmark) s
     (or sel (setf sel (& (lu elems) (1st elems))))
     (if benchmark
         ($ "FPS: %d" (/ 1 (bad-timing #1=(bad-draw s nil))))
       #1#)))

(cl-defmethod bad-draw-first ((s studio))
  (~ (canvas) s
     (bad-draw-clear canvas)
     (dolist (u (@ canvas sub))
       (setf (@ u redraw) t)
       (bad-draw canvas u))))

(cl-defmethod bad-draw-again ((s studio))
  (~ (canvas) s
     (bad-draw-clear canvas 'keep)
     (~ (sub) canvas
        (dolist (b bad-buddy-boxes)
          (dolist (u (cons canvas sub))
            (bad-draw canvas u b))
          (setq bad-buddy-boxes nil))
        (dolist (u sub)
          (bad-draw canvas u)))))

(cl-defmethod bad-draw ((s studio) &rest _)
  (if (=(point-min) (point-max))
      (bad-draw-first s)
    (bad-draw-again s)))

(cl-defmethod bad-draw ((_ elem) (__ elem) &optional ___)
  (ignore))

(cl-defmethod bad-draw ((dst box) (src box) &optional rect)
  (if rect
    (bad-draw-to-elem dst src rect)
    (~ (img redraw) src
       (when redraw
         (bad-draw-to-elem dst src)
         (when img
           (bad-draw-img src))
         (setf redraw nil)))))

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

(cl-defmethod bad-init ((s studio))
  (bad-setup-canvas s)
  (bad-init-keys s))

(cl-defmethod bad-run ((s studio))
  (bad-setup  s)
  (bad-init   s)
  (bad-update s)
  (setq unread-command-events (listify-key-sequence "k")))

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

(cl-defmethod bad-next-font-studio ((s studio) &optional prev)
  (when (gfx)
    (erase-buffer)
    (bad-next-font s prev)
    (~ (canvas w h elems) s
       (~ ((cw w) (ch h)) canvas
          (setf cw w)
          (setf ch h))
       (dolist (e elems)
         (~ (max-x max-y w-max h-max) e
            (setf max-x w)
            (setf max-y h)
            (setf w-max (- w 2))
            (setf h-max (- h 2)))
         (when (box-p e)
           (bad-box-adapt-border e)
           (when (@ e img)
             (bad-redraw-img e)))))
    (bad-update s)
    (bad-font-report s)))

(cl-defmethod bad-font-report ((s studio))
  (when (gfx)
    (~ (w h) s
      (let* ((nom (aref (font-info (font-at (point-min))) 1))
             (str (@f "[%dx%d] %s" w h nom)))
        ($ (substring str nil (min w (--- str))))))))

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

(cl-defmethod bad-init-keys ((s studio))
  ;; deleten
  (keymap-set bad-mode-map "DEL" (L () (bad-delete-element s)))

  ;; element info
  (keymap-set bad-mode-map "E" (L () (bad-info (@ s sel))))

  ;; benchmark
  (keymap-set bad-mode-map "v" (L () (~ (benchmark) s
                                        (setf benchmark (! benchmark))
                                        ($ "%s%s" (if benchmark "en" "dis") "abled"))))

  ;; visible
  (keymap-set bad-mode-map "V" (L () (~ (visible) (@ s sel)
                                        (setf visible (! visible))
                                        (bad-update s))))

  ;; font
  (keymap-set bad-mode-map "`" (L () (bad-next-font-studio s)))
  (keymap-set bad-mode-map "~" (L () (bad-next-font-studio s 'prev)))

  ;; background bg/fg -> black, random
  (keymap-set bad-mode-map "2" (L () (set-background-color our-black)))
  (keymap-set bad-mode-map "@" (L () (set-foreground-color our-black)))
  (keymap-set bad-mode-map "3" (L () (bad-set-background     'bg)))
  (keymap-set bad-mode-map "4" (L () (bad-set-background nil 'fg)))

  ;; alpha
  (keymap-set bad-mode-map "*" (L () (bad-alpha-set 0.4)))
  (keymap-set bad-mode-map "0" (L () (bad-alpha-none)))
  (keymap-set bad-mode-map "8" (L () (bad-alpha-less)))
  (keymap-set bad-mode-map "9" (L () (bad-alpha-more)))

  ;; element bg
  (keymap-set bad-mode-map "w" (L () (bad-set-color s           )))
  (keymap-set bad-mode-map "W" (L () (bad-set-color s 'rand-here)))
  (keymap-set bad-mode-map "." (L () (bad-set-color s 'pick     )))
  (keymap-set bad-mode-map "," (L () (bad-set-color s 'reset    )))

  ;; element fg
  (keymap-set bad-mode-map "h" (L () (bad-set-color s  nil       'fg)))
  (keymap-set bad-mode-map "H" (L () (bad-set-color s 'rand-here 'fg)))
  (keymap-set bad-mode-map ">" (L () (bad-set-color s 'pick      'fg)))
  (keymap-set bad-mode-map "<" (L () (bad-set-color s 'reset     'fg)))

  ;; elements
  (keymap-set bad-mode-map "P" (L () (bad-advance-pos s) (bad-update s))) ; vertically
  (dolist (k '("p" "<backtab>")) (keymap-set bad-mode-map k (L () (bad-prev s))))
  (dolist (k '("n" "TAB"))       (keymap-set bad-mode-map k (L () (bad-next s))))

  ;; spinorama
  (keymap-set bad-mode-map "r" (L () (bad-operate s #'bad-rotate        )))
  (keymap-set bad-mode-map "R" (L () (bad-operate s #'bad-rotate-reverse)))
  (keymap-set bad-mode-map "T" (L () (bad-operate s #'bad-transpose     )))
  (keymap-set bad-mode-map "x" (L () (bad-operate s #'bad-flip-x        )))
  (keymap-set bad-mode-map "y" (L () (bad-operate s #'bad-flip-y        )))

  ;; add element
  (keymap-set bad-mode-map "a" (L () (bad-add-box      s)))
  (keymap-set bad-mode-map "t" (L () (bad-add-triangle s)))
  (keymap-set bad-mode-map "N" (L () (bad-set-name     s)))

  ;; ascii
  (keymap-set bad-mode-map "A" (L () (bad-read-ascii s                    )))
  (keymap-set bad-mode-map "s" (L () (bad-read-ascii s nil 'str           )))
  (keymap-set bad-mode-map "S" (L () (bad-read-ascii s nil 'str 'keep-size)))

  ;; box, fill
  (keymap-set bad-mode-map "f" (L () (bad-set-fill s)))

  ;; border
  (keymap-set bad-mode-map "B" (L () (bad-set-border   s)))
  (keymap-set bad-mode-map "b" (L () (bad-cycle-border s)))

  ;; corner
  (keymap-set bad-mode-map "c" (L () (bad-set-corner s)))
  (keymap-set bad-mode-map "C" (L () (bad-set-corner s (@f "%c" bad-nonsolid))))

  ;; transparency effects
  (keymap-set bad-mode-map "m" (L () (bad-cycle-transparency-effect-chars s  )))
  (keymap-set bad-mode-map "M" (L () (bad-cycle-transparency-effect-chars s 'more)))

  ;; ing
  (keymap-set bad-mode-map "+"   (L () (bad-show-img s)))
  (keymap-set bad-mode-map "RET" (L () (bad-show-img s nil 'next)))

  ;; inner (almost the inner circle, the inner box)
  (keymap-set bad-mode-map "<up>"    (L () (bad-move-img-inner-up    s)))
  (keymap-set bad-mode-map "<down>"  (L () (bad-move-img-inner-down  s)))
  (keymap-set bad-mode-map "<left>"  (L () (bad-move-img-inner-left  s)))
  (keymap-set bad-mode-map "<right>" (L () (bad-move-img-inner-right s)))

  ;; zoom
  (keymap-set bad-mode-map "-" (L () (bad-zoom s nil 'reset    )))
  (keymap-set bad-mode-map "e" (L () (bad-zoom s nil nil 'fit-h))) ; DNC ? TODO
  (keymap-set bad-mode-map "<prior>" (L () (bad-zoom s 'in))) ; AKA PageUp
  (keymap-set bad-mode-map "<next>"  (L () (bad-zoom s    ))) ; AKA PageDown

  ;; proximity
  (keymap-set bad-mode-map "u" (L () (bad-operate s #'bad-retreat)))
  (keymap-set bad-mode-map "o" (L () (bad-operate s #'bad-advance)))

  ;; size
  (keymap-set bad-mode-map "d" (L () (bad-cycle-size s)))
  (keymap-set bad-mode-map "D" (L () (bad-operate s #'bad-size-max)))

  ;; row
  (keymap-set bad-mode-map "I" (L () (bad-operate s #'bad-add-row -1)))
  (keymap-set bad-mode-map "K" (L () (bad-operate s #'bad-add-row   )))

  ;; col
  (keymap-set bad-mode-map "J" (L () (bad-operate s #'bad-add-col -1)))
  (keymap-set bad-mode-map "L" (L () (bad-operate s #'bad-add-col   )))

  ;; pos
  (keymap-set bad-mode-map ";" (L () (bad-operate s #'bad-pos-inside (@ s canvas))))

  ;; move
  (keymap-set bad-mode-map "i" (L () (bad-operate s #'bad-up)))
  (keymap-set bad-mode-map "k" (L () (bad-operate s #'bad-down)))
  (keymap-set bad-mode-map "j" (L () (bad-operate s #'bad-left)))
  (keymap-set bad-mode-map "l" (L () (bad-operate s #'bad-right)))

  ;; exit, quit
  (keymap-set bad-mode-map "Q" #'text-mode)
  (keymap-set bad-mode-map "q" (L () (bad-quit s))))

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

(cl-defmethod bad-cycle-transparency-effect-chars ((s studio) &optional more)
  "Not real/full transparency, but can loook cool in combination with screen alpha."
  (~ (trans-chars trans-chars-more) s
     (let ((chrs (if more trans-chars-more trans-chars)))
       (bad-set-fill s (@f "%c" (1st chrs)))
       (setf chrs (bad-list-shift chrs)))))

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

(cl-defmethod bad-zoom ((s studio) &optional in reset fit-h)
  (~ (sel) s
     (when (box-p sel)
       (~ (img h redraw) sel
          (when (& img #1=(image-property img :scale))
            (if fit-h
                ;; TODO: bug here?
                (let* ((pxls  (cdr (image-size img 'pxls)))
                       (crs-y (bad-pixels-to-chars pxls 'h))
                       (new   (/ h crs-y)))
                  (setf #1# (* #1# new)))
              (if reset
                  (setf #1# 1.0)
                (setf #1# (+ #1# (* (if in -1 1) 0.015625))))) ; AS: (= (// 1 64) (** 2 -6))
            (bad-update sel)
            (bad-update s))))))

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

(cl-defmethod bad-move-img-inner-left ((s studio))
  (~ (sel) s
     (when (& (box-p sel) (@ sel img))
       (~ (iix) sel
          (when (< 0 iix)
            (-- iix)
            (bad-update s))))))

(cl-defmethod bad-move-img-inner-right ((s studio))
  (~ (sel) s
     (when (& (box-p sel) (@ sel img))
       (~ (iix) sel
          ;; TODO: no check here?
          (++ iix)
          (bad-update s)))))

(cl-defmethod bad-move-img-inner-up ((s studio))
  (~ (sel) s
     (when (& (box-p sel) (@ sel img))
       (~ (iiy) sel
          (when (< 0 iiy)
            (-- iiy)
            (bad-update s))))))

(cl-defmethod bad-move-img-inner-down ((s studio))
  (~ (sel) s
     (when (& (box-p sel) (@ sel img))
       (~ (iiy) sel
          ;; TODO: no check here?
          (++ iiy)
          (bad-update s)))))

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

(cl-defmethod bad-show-img ((s studio) &optional reload next)
  (when (gfx)
    (~ (w h sel) s
       (when (box-p sel)
         (~ (max-x max-y) sel
            (setf max-x w)
            (setf max-y h)
            (bad-show-img sel reload next) ; NOTE: OK
            (bad-update s))))))

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

(cl-defmethod bad-delete-element ((s studio))
  (~ (elems sel) s
     (~ (deletable deleted visible) sel
        (when deletable
          (setf elems (remove sel elems))
          (push (bad-rect sel) bad-buddy-boxes)
          (setf visible nil) ; NOTE: OK
          (setf deleted t)
          (bad-update s)))))

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

(cl-defmethod bad-next ((s studio) &optional n)
  (or n (setq n 1))
  (~ (elems sel ie) s
     (when elems
       (cl-loop do
                (setf sel (nth (m (++ ie n) (--- elems)) elems))
                until (& sel (slot-boundp sel 'name)))
       ($ (@ sel name)))))

(cl-defmethod bad-prev ((s studio) &optional n)
  (or n (setq n 1))
  (bad-next s (- n)))

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

(cl-defmethod bad-operate ((s studio) fun &rest args)
  (~ (sel) s
     (when (& sel (functionp fun))
       (apply fun `(,sel ,@args))
       (bad-update sel)
       (bad-update s))))

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

(cl-defmethod bad-set-name ((s studio))
  (~ (sel) s
     (when sel
       (~ (name) sel
          (let* ((new-name (read-string "name: " nil nil name)))
            (if (or (z (--- new-name))
                    (s= new-name name))
                ($ "didn't do anything")
              (setf name new-name)
              ($ "name set to %s" new-name)))))))

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

(cl-defmethod bad-add ((s studio) (e elem) &optional verbose)
  (~ (canvas sel elems) s
     (bad-add canvas e)
     (pushlast e elems)
     (setf sel e)
     (bad-update s)
     (when verbose
       ($ (@ e name)))))

(cl-defmethod bad-add-box ((s studio))
  (let ((b (box)))
    (bad-box-adapt-border b)
    (bad-add s b)))

(cl-defmethod bad-add-triangle ((s studio))
  (bad-add s (triangle)))

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

(cl-defmethod bad-set-fill ((s studio) &optional str)
  (or str
      (let ((def "  bad.el"))
        (setq str (read-string (@f "pattern? [%s] " def) nil nil def))))
  (~ (sel) s
     (when (box-p sel)
       (bad-clear sel (string-to-list str))
       (bad-update s))))

(cl-defmethod bad-set-side ((s studio))
  (~ (sel) s
     (when (box-p sel)
       (let* ((side (read-number "side? (1-4) "))
              (def (char-to-string bad-nonsolid))
              (str  (read-string (@f "pattern: [%s] " def) nil nil def)))
         (bad-side sel side str)
         (bad-update s)))))

(cl-defmethod bad-cycle-border ((s studio))
  (~ (sel) s
     (when (box-p sel)
       (bad-cycle-border sel)
       (bad-update s))))

(cl-defmethod bad-set-border ((s studio))
  (~ (sel) s
     (when (box-p sel)
       (let ((c (read-char "char? [light]")))
         (if (= c 13) ; RET
             (bad-make-light sel)
           (bad-border sel c))))))

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

(cl-defmethod bad-advance-pos ((s studio))
  (~ (sel canvas) s
     (~ (sub) canvas
        (let ((lst (let ((pos (cl-position sel sub)))
                     (when (& pos (!z pos))
                       (let ((wo (cl-remove sel sub))
                             (num (1- pos)))
                         `(,@(take num wo) ,sel ,@(cl-subseq wo num)))))))
          (when lst
            (setf sub lst))))))

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

(defun bad-set-background (&optional bg fg)
  (when (nor bg fg)
    (setq bg (bad-bg-random))
    (setq fg (bad-fg-random)))
  (when (& bg (! (color-defined-p bg)))
    (setq bg (bad-bg-random)))
  (when (& fg (! (color-defined-p fg)))
    (setq fg (bad-fg-random)))
  (when bg
    (set-background-color bg))
  (when fg
    (set-foreground-color fg))
  (bad-color-echo))

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

(cl-defmethod bad-set-color ((s studio) &optional do set-fg)
  (~ (sel) s
     (when sel
       (~ (fg bg) sel
          (let ((new (cl-case do
                       (pick (or (pick-close-color nil nil "color close to: [random] ")
                                 #1=(pick-close-color (if set-fg fg bg))))
                       (rand-here #1#)
                       (t (if set-fg
                              (bad-fg-random)
                            (bad-bg-random))))))
            (if set-fg
                (setf fg new)
              (setf bg new))
            (bad-update sel)
            (bad-update s))))))

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

(cl-defmethod bad-set-corner ((s studio) &optional def)
  (~ (sel) s
     (when (box-p sel)
       (let* ((also "(try \'1.3.\')")
              (cdef "1234")
              (ps   (@f "Input 1-4 chars: %s [%s] " also cdef))
              (str  (or def (read-string ps nil nil def)))
              (cs   (& (s str) (string-to-list str)))
              (len  (--- cs))
              (res  (cl-case len
                      (1 (list #1=(0i cs) #1# #1# #1#))
                      (2 (list #1# #2=(1i cs) #2# #1#))
                      (3 (list #1# #2# #3=(2i cs) #3#))
                      (4 (list #1# #2# #3#    (3i cs)))
                      (t nil))))
         (cl-loop
          for e in res
          for i from 1 upto 4 do
          (unless (= e ?\.)
            (bad-corner sel i e))
          finally do (bad-update s))))))

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

(cl-defmethod bad-cycle-size ((s studio))
  (~ (sel size-funs) s
     (when sel
       (~ (w h) sel
          (let ((old-w w)
                (old-h h))
            (funcall (1st size-funs) sel)
            (setf size-funs (bad-list-shift size-funs))
            (when (& (= w old-w)
                     (= h old-h))
              (funcall (1st size-funs) sel)
              (setq size-funs (bad-list-shift size-funs))))))
     (bad-update s)))

(cl-defmethod bad-cycle-pos ((s studio))
  (~ (sel pos-funs) s
     (when sel
       (~ (x y) sel
          (let ((old-x x)
                (old-y y))
            (funcall (1st pos-funs) sel)
            (setf pos-funs (bad-list-shift pos-funs))
            (when (& (= x old-x)
                     (= y old-y))
              (funcall (1st pos-funs) sel)
              (setq pos-funs (bad-list-shift pos-funs)))))))
  (bad-update s))

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

(cl-defmethod bad-read-ascii ((s studio) &optional file str keep-size)
  (unless (or file str)
    (let ((def "fireworks"))
      (setq file (read-string (@f "name: [%s] " def) nil nil def))))
  (when (& (! file) str (!s str))
    (let ((def "All systems ready."))
      (setq str (read-string (@f "string: [%s] " def) nil nil def))))
  (~ (sel elems) s
     (when (& (box-p sel) (or file str))
       (~ (sub) sel
          (let* ((pos 2)
                 (new (ascii :x pos :y pos)))
            (if file
                (bad-read-file new file "data/ascii")
              (bad-read-string new str))
            (cl-pushnew new sub)
            (if keep-size
                (cl-pushnew new elems)
              (bad-clear sel)
              (bad-size-adapt new sel))
            (bad-update sel)
            (bad-update s))))))

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

(<- 'bad-studio)