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

(require 'color)
(require 'eieio)

(require 'bad-alpha)
(require 'bad-animation)
(require 'bad-box)
(require 'bad-box-draw)
(require 'bad-box-rotate)
(require 'bad-caption)
(require 'bad-cyclic)
(require 'bad-demo)
(require 'bad-draw)
(require 'bad-elem)
(require 'bad-game)
(require 'bad-line)
(require 'bad-move)
(require 'bad-monospace)
(require 'bad-rotate)
(require 'bad-size)
(require 'bad-triangle)
(require 'bad-write)

(defclass studio (game)
  ((name :initform "studio")
   (trans-chars      :initarg :trans-chars      :type list           :initform (list bad-nonsolid ?\s))
   (trans-chars-more :initarg :trans-chars-more :type list           :initform (list ?░ ?▒ ?▓ ?█))
   (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-init ((s studio))
  (bad-alpha-set 0.9)
  (with-slots (screen canvas elems sel help w h) s
    (setf help (caption
                :name "help"
                :text #5=(string-join
             #3=(list #2=(format  "%s help     " #1="[H]")
                                 "[p] next  [n]"
                                 "[N] name     "
                                 "[w] color [h]"
                                 "[t] triangle "
                                 "[a] add box  "
                                 "[s] .. side  "
                                 "[c] .. corner"
                                 "[B] .. border"
                                 "[b] .. cycle "
                                 "[f] text fill"
                                 "[v] visible  "
                                 "[;] position "
                                 "[R] spin  [r]"
                                 "[F] flip  [y]"
                                 "[T] transpose"
                                 "[DEL] delete "
                                 "[q] quit  [Q]"
                                 "[#] bg bg [3]"
                                 "[$] bg fg [4]"
                                 "[`] font     "
                                 "[~] field res"
                                 "[*890] alpha "
                                 "[jikl] move  "
                                 "[d] size  [D]"
                                 "[u]  [I]  [o]"
                                 "[J]  [K]  [L]"
                                 ))
                :y #0=1
                :w #4=(length #2#) :h (min (- h #0#) (length #3#))
                :text-draw #5#
                :text-alt (string-pad #1# #4# bad-nonsolid t)))
    (bad-update help)

    (with-slots ((hw w)) help
      (bad-pos help #1=(- w hw))
      (setf canvas (box
                    :name  "canvas"
                    :fg    "dodgerblue"
                    :color "burlywood4"
                    :deletable    nil
                    :movable      nil
                    :transposable nil
                    :w #1#
                    :h h))
      ;; TODO
      (when (display-graphic-p)
        (bad-box-inverted-border canvas))
      (bad-update canvas)
      (push canvas elems)
      (setq sel canvas))

    (with-slots (sub) screen
      (setf sub (list help)))
    (bad-update screen)

    (bad-init-keys s)
    (bad-setup s)))

(cl-defmethod bad-draw-sub-colors ((e elem) &optional boost-x boost-y)
  (or boost-x (setq boost-x 0))
  (or boost-y (setq boost-y 0))
  (with-slots (x y sub) e
    (let ((bx (+ x boost-x))
          (by (+ y boost-y)))
      (dolist (s sub)
        (bad-draw-to-buf-transparent s t bx by)
        (bad-draw-sub-colors s bx by)))))

(cl-defmethod bad-update ((s studio))
  (with-slots (canvas screen elems sel) s
    (bad-update screen)
    (bad-draw-to-buf screen)
    (bad-update canvas)
    (bad-draw-to-buf-transparent canvas)
    (bad-draw-sub-colors canvas)
    (when sel
      (bad-info sel))))

(cl-defmethod bad-run ((s studio))
  (bad-init s)
  (bad-update s))

(cl-defmethod bad-init-keys ((s studio))
  (set-char-table-range (nth 1 bad-demo-mode-map) t #'ignore)

  ;; options
  (keymap-set bad-demo-mode-map "`" #'bad-set-monospace-font)
  (keymap-set bad-demo-mode-map "~" (lambda () (interactive) (funcall #'bad-game-set-field s)))

  ;; background (bg bg & bg fg)
  (keymap-set bad-demo-mode-map "2" (lambda () (interactive) (set-background-color "black")))
  (keymap-set bad-demo-mode-map "#" (lambda () (interactive) (set-foreground-color "black")))
  (keymap-set bad-demo-mode-map "3" (lambda () (interactive) (bad-color-cycle-all s nil nil)))
  (keymap-set bad-demo-mode-map "#" (lambda () (interactive) (bad-color-cycle-all s t   nil)))
  (keymap-set bad-demo-mode-map "4" (lambda () (interactive) (bad-color-cycle-all s nil t)))
  (keymap-set bad-demo-mode-map "$" (lambda () (interactive) (bad-color-cycle-all s t   t)))
  (keymap-set bad-demo-mode-map "5" (lambda () (interactive) (bad-random-color 'fg)))
  (keymap-set bad-demo-mode-map "6" (lambda () (interactive) (bad-random-color 'bg)))

  ;; fg and color of element
  (keymap-set bad-demo-mode-map "w" (lambda () (interactive) (bad-set-color s)))
  (keymap-set bad-demo-mode-map "h" (lambda () (interactive) (bad-set-color s t)))

  ;; alpha
  (keymap-set bad-demo-mode-map "9" (lambda () (interactive) (bad-alpha-more)))
  (keymap-set bad-demo-mode-map "8" (lambda () (interactive) (bad-alpha-less)))
  (keymap-set bad-demo-mode-map "*" (lambda () (interactive) (bad-alpha-set 0.4)))
  (keymap-set bad-demo-mode-map "0" (lambda () (interactive) (bad-alpha-opaque)))

  ;; elems (cycle, change order)
  (keymap-set bad-demo-mode-map "p"      (lambda () (interactive) (bad-prev s)))
  (keymap-set bad-demo-mode-map "n"   #1=(lambda () (interactive) (bad-next s)))
  (keymap-set bad-demo-mode-map "TAB" #1#)

  ;; rotate
  (keymap-set bad-demo-mode-map "r" (lambda () (interactive) (bad-operate s #'bad-rotate)))
  (keymap-set bad-demo-mode-map "R" (lambda () (interactive) (bad-operate s #'bad-rotate-back)))
  (keymap-set bad-demo-mode-map "y" (lambda () (interactive) (bad-operate s #'bad-flip-x)))
  (keymap-set bad-demo-mode-map "F" (lambda () (interactive) (bad-operate s #'bad-flip-y)))
  (keymap-set bad-demo-mode-map "T" (lambda () (interactive) (bad-operate s #'bad-transpose)))

  ;; add
  (keymap-set bad-demo-mode-map "N" (lambda () (interactive) (bad-set-name s)))
  (keymap-set bad-demo-mode-map "A" (lambda () (interactive) (bad-add-anim s)))
  (keymap-set bad-demo-mode-map "a" (lambda () (interactive) (bad-add-box  s)))
  (keymap-set bad-demo-mode-map "t" (lambda () (interactive) (bad-add-triangle s)))

  ;; box
  (keymap-set bad-demo-mode-map "c" (lambda () (interactive) (bad-set-corner s)))
  (keymap-set bad-demo-mode-map "B" (lambda () (interactive) (bad-set-border s)))
  (keymap-set bad-demo-mode-map "b" (lambda () (interactive) (bad-cycle-border s)))
  (keymap-set bad-demo-mode-map "S" (lambda () (interactive) (bad-set-side s)))
  (keymap-set bad-demo-mode-map "f" (lambda () (interactive) (bad-set-ground s)))

  (with-slots (trans-chars trans-chars-more) s
    (keymap-set bad-demo-mode-map "m"
                (lambda ()
                  (interactive)
                  (bad-set-ground s (format "%c" (car trans-chars)))
                  (setq trans-chars (bad-list-shift trans-chars))))
    (keymap-set bad-demo-mode-map "M"
                (lambda ()
                  (interactive)
                  (bad-set-ground s (format "%c" (car trans-chars-more)))
                  (setq trans-chars-more (bad-list-shift trans-chars-more)))))

  ;; img
  (keymap-set bad-demo-mode-map "="
              (lambda ()
                (interactive)
                (with-slots (sel) s
                  (when (and sel (box-p sel))
                    (bad-take-img sel)))))

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

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

  ;; col
  (keymap-set bad-demo-mode-map "u" (lambda () (interactive) (bad-operate s #'bad-add-col -1)))
  (keymap-set bad-demo-mode-map "o" (lambda () (interactive) (bad-operate s #'bad-add-col)))
  (keymap-set bad-demo-mode-map "J" (lambda () (interactive) (bad-operate s #'bad-add-col -1)))
  (keymap-set bad-demo-mode-map "L" (lambda () (interactive) (bad-operate s #'bad-add-col)))

  ;; pos
  (keymap-set bad-demo-mode-map ":" (lambda () (interactive) (bad-cycle-pos s)))
  (with-slots (canvas) s
    (keymap-set bad-demo-mode-map ";" (lambda () (interactive) (bad-operate s #'bad-pos-inside canvas))))

  ;; move
  ;; [these don't work! no idea why]
  (keymap-set bad-demo-mode-map "<up>"    (lambda () (interactive) (bad-operate s #'bad-up)))
  (keymap-set bad-demo-mode-map "<down>"  (lambda () (interactive) (bad-operate s #'bad-down)))
  (keymap-set bad-demo-mode-map "<left>"  (lambda () (interactive) (bad-operate s #'bad-left)))
  (keymap-set bad-demo-mode-map "<right>" (lambda () (interactive) (bad-operate s #'bad-right)))
  ;; [these works]
  (keymap-set bad-demo-mode-map "i" (lambda () (interactive) (bad-operate s #'bad-up)))
  (keymap-set bad-demo-mode-map "k" (lambda () (interactive) (bad-operate s #'bad-down)))
  (keymap-set bad-demo-mode-map "j" (lambda () (interactive) (bad-operate s #'bad-left)))
  (keymap-set bad-demo-mode-map "l" (lambda () (interactive) (bad-operate s #'bad-right)))

  ;; unsorted
  (keymap-set bad-demo-mode-map "H" (lambda () (interactive) (bad-help-toggle s)))
  (keymap-set bad-demo-mode-map "DEL" #1=(lambda () (interactive) (bad-delete-element  s)))
  (keymap-set bad-demo-mode-map "v" (lambda () (interactive) (bad-operate s #'bad-visible)))

  ;; quit
  (keymap-set bad-demo-mode-map "Q" #'text-mode)
  (keymap-set bad-demo-mode-map "q" #'kill-emacs))

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

(cl-defmethod bad-delete-element ((s studio))
  (with-slots (elems sel) s
    (with-slots (deletable visible deleted) sel
      (when (and deletable elems sel)
        (setf visible nil)
        (setf deleted t)
        (setf elems (remove sel elems))
        (bad-next s))))
  (bad-update s))

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

(cl-defmethod bad-next ((s studio) &optional n)
  (or n (setq n 1))
  (with-slots (elems sel ie) s
      (when elems
        (cl-loop do
          (setf sel (nth (mod (cl-incf ie n) (length elems)) elems))
          until (and sel (slot-boundp sel 'name)))
        (with-slots (name) sel
          (message 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)
  (with-slots (sel) s
    (when (and sel (functionp fun))
      (apply fun `(,sel ,@args))
      (bad-update s))))

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

(cl-defmethod bad-set-name ((s studio))
  (with-slots (sel) s
    (when sel
      (with-slots (name) sel
        (let ((new-name (read-string "name: ")))
          (if (zerop (length new-name))
              (message "(name not set)")
            (setf name new-name)
            (message "name set to %s" new-name)))))))

(cl-defmethod bad-add ((s studio) (e elem))
  (with-slots (canvas sel elems) s
    (when sel
      (let ((inner (bad-add sel e)))
        (push inner elems)
        (setf sel inner))
      (with-slots (name) sel
        (message name))
      (bad-update s))))

(cl-defmethod bad-add-box ((s studio))
  (let ((b (box)))
    (when (display-graphic-p)
      (bad-box-inverted-border b))
    (bad-add s b)))

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

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

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

(defmacro time-it (&rest body)
  (declare (indent defun))
  (let ((beg (make-symbol "beg")))
    `(let ((,beg (float-time)))
       ,@body
       (- (float-time) ,beg))))

(cl-defmethod bad-add-anim ((s studio) &optional a)
  (unless (anim-p a)
    (let* ((side 4)
           (x #1=2)
           (y #1#)
           (w side)
           (h side)
           (rb (box :name "red-box"   :color "red"   :x      x  :y y :w w :h h))
           (gb (box :name "green-box" :color "green" :x (* 2 x) :y y :w w :h h))
           (bb (box :name "blue-box"  :color "blue"  :x (* 3 x) :y y :w w :h h)))
      (dolist (b #1=(list rb gb bb))
        (bad-box-inverted-border b)
        (bad-add s b))
      (setq a (anim :frames #1# :num (length #1#)))))
  (bad-add s a))

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

(cl-defmethod bad-set-ground ((s studio) &optional ground)
  (let ((str (or ground
                 (read-string
                  (format "pattern? [%s] " #1="  bad.el")
                  nil nil #1#))))
    (with-slots (sel) s
      (when (and sel (box-p sel))
        (bad-clear sel (string-to-list str))
        (bad-update s)))))

(cl-defmethod bad-set-side ((s studio))
  (let ((side (read-number "side? (1-4) "))
        (str  (read-string (format "pattern? [%s] " #1="━") nil nil #1#)))
    (with-slots (sel) s
      (when (and sel (box-p sel))
        (bad-side sel side str)
        (bad-update s)))))

(cl-defmethod bad-cycle-border ((s studio))
  (with-slots (sel) s
    (when (and sel (box-p sel))
      (bad-cycle-border sel)
      (bad-update s))))

(cl-defmethod bad-set-border ((s studio))
    (with-slots (sel) s
      (when (and sel (box-p sel))
        (let ((c (read-char "char? [light]")))
          (if (= c 13)
              (bad-make-light sel)
            (bad-border sel c))
          (bad-update s)))))

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

(defun bad-color-get ()
  (list
   (face-attribute 'default :foreground)
   (face-attribute 'default :background)))

(defun bad-color-echo ()
  (pcase-let* ((`(,fg ,bg) (bad-color-get))
               (`(,fg-r ,fg-g ,fg-b) (color-values fg))
               (`(,bg-r ,bg-g ,bg-b) (color-values bg)))
    (message "fg: (%5d %5d %5d) %s\nbg: (%5d %5d %5d) %s"
             fg-r fg-g fg-b fg
             bg-r bg-g bg-b bg)))

(cl-defmethod bad-color-cycle-all ((_ studio) &optional less fg-mode)
    (pcase-let* ((len (length #1=(defined-colors-with-face-attributes)))
                 (`(,fg  ,bg)   (bad-color-get))
                 (`(,col ,cfun) (if fg-mode
                                    (list fg #'set-foreground-color)
                                  (list bg #'set-background-color)))
                 (pos (cl-position col #1# :test #'string=))
                 (incv (if less -1 1)))
      (if pos
          (setq pos (mod (cl-incf pos incv) len))
        (setq pos 0))
      (let ((col-nxt (nth pos #1#)))
        (funcall cfun col-nxt)))
    (bad-color-echo))

(defun bad-random-color (&optional which)
  (cl-labels
      ((do-fg (&optional col) (set-foreground-color (or col (seq-random-elt (defined-colors)))))
       (do-bg (&optional col) (set-background-color (or col (seq-random-elt (defined-colors))))))
    (cl-case which
      (fg (do-fg))
      (bg (do-bg))
      (_ (progn
           (do-fg)
           (do-bg)))))
  (bad-color-echo))

(cl-defmethod bad-set-color ((s studio) &optional set-fg)
  (with-slots (sel) s
    (when sel
      (with-slots (fg color) sel
        (let ((rand-col (seq-random-elt (defined-colors))))
          (if set-fg
              (setf fg rand-col)
            (setf color rand-col))))
      (bad-update s))))


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

(cl-defmethod bad-set-corner ((s studio) &optional pat)
  (with-slots (sel) s
    (when (and sel (box-p sel))
      (let ((str
             (or pat
                 (read-string
                  (format "pattern? (1-4 chars) [%s] " #1="1234") nil nil #1#))))
        (let* ((cs  (string-to-list str))
               (len (length cs)))
          (cl-case len
            (1 (bad-set-corner s (make-string 4 (car cs))))
            (2 (let ((cs-fst (car  cs))
                     (cs-snd (cadr cs)))
                 (bad-set-corner
                  (format "%c%c%c%c" cs-fst cs-snd cs-fst cs-snd))))
            (3 (bad-set-corner (format "%c%c%c%c"
                                       (nth 0 cs)
                                       (nth 1 cs)
                                       (nth 2 cs)
                                       (nth 2 cs))))
            (4 (dotimes (i 4)
                 (bad-corner sel i (nth i cs))))
            (_ (prog1 nil
                 (message "input 1-4 chars"))))))
      (bad-update s))))

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

(cl-defmethod bad-cycle-size ((s studio))
  (with-slots (sel size-funs) s
    (when (and sel size-funs)
      (with-slots (w h) sel
        (let ((old-w w)
              (old-h h))
          (funcall (car size-funs) sel)
          (setf size-funs (bad-list-shift size-funs))
          (when (and (= w old-w)
                     (= h old-h))
            (funcall (car size-funs) sel)
            (setq size-funs (bad-list-shift size-funs))))
        (bad-update s)))))

(cl-defmethod bad-cycle-pos ((s studio))
  (with-slots (sel pos-funs) s
    (when (and sel pos-funs)
      (with-slots (x y) sel
        (let ((old-x x)
              (old-y y))
          (funcall (car pos-funs) sel)
          (setf pos-funs (bad-list-shift pos-funs))
          (when (and (= x old-x)
                     (= y old-y))
            (funcall (car pos-funs) sel)
            (setq pos-funs (bad-list-shift pos-funs))))
        (bad-update s)))))

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

(cl-defmethod bad-draw-to-buf ((s studio) &optional e)
  (with-slots (sel) s
    (or e (setq e sel))
    (when (cl-typep e 'elem)
      (with-slots (deleted) e
        (unless deleted
          (bad-draw-to-buf e)))))
  (bad-update s))

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

(provide 'bad-studio)