;;; -*- lexical-binding: t -*-
;;
;; this file:
;;   https://dataswamp.org/~incal/src/bad-3/bad-studio.el
;;
;; ------------------------------------------------------------------------

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

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

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

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

(defclass studio (program)
  ((name :initform "studio")
   (benchmark        :initarg :benchmark        :custom boolean        :initform t)
   (trans-chars      :initarg :trans-chars      :type   list           :initform (list bad-solid bad-nonsolid))
   (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-setup-canvas s)
  (bad-init-keys s))

(cl-defmethod bad-setup-canvas ((s studio))
  (~ (canvas elems sel w h) s
     (setf canvas
           (box
            :name        "canvas"
            :deletable    nil
            :movable      nil
            :transposable nil
            :spc       `(,bad-solid)
            :w            w
            :h            h))
     (bad-make-opaque canvas))
  (cl-loop
   with x-beg  = 3
   with y-beg  = 2
   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 bx     = nil
   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
                )
   for ibg in cols
   for i from 0 to (--- cols)
   for ix = (+ x-beg (* i x-inc))
   for iy = (+ y-beg (* i y-inc)) do
   (setf bx (box :name (@f "%s-box" (substring #1=(symbol-name ibg) 4 -2))
                 :fg #2=(symbol-value (intern #1#))
                 :bg #2#
                 :x ix
                 :y iy
                 :w x-side
                 :h y-side))
   (bad-add s bx)
   (bad-make-light bx))
  (let ((fst (box :name "fst-box" :bg our-magenta-b :x 0 :y 0)))
    (bad-add s fst)
    (bad-make-light fst)
    (~ (ix iy) fst
       (setf ix 2)
       (setf iy 1)))
  (bad-read-ascii s nil "The world is all about money and intelligence."))

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

(defmacro bad-timing (&rest body)
  "http://nullprogram.com/blog/2009/05/28/"
  (let ((beg (make-symbol "start")))
    `(let ((,beg (float-time)))
       ,@body
       (- (float-time) ,beg))))

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

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

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

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

(cl-defmethod bad-draw ((dst box) (src box) &optional boost-x boost-y rect)
  (or boost-x (setq boost-x 0))
  (or boost-y (setq boost-y 0))
  (~ (redraw) src
     (if rect
         (bad-draw-to-elem dst src t boost-x boost-y rect)
       (when redraw
         (bad-draw-to-elem dst src t boost-x boost-y)
         (when (@ src img)
           (bad-draw-img src))
         (setf redraw nil)))))

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

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

(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)
    (with-slots (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))
  ;; unsorted
  (keymap-set bad-mode-map "DEL" (L () (bad-delete-element s)))
  (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 "dis" "en") "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 t)))

  ;; bra (inte bra)
  (keymap-set bad-mode-map "1"
              (L () (bad-operate s #'bad-make-bra      (@ s canvas))))
  (keymap-set bad-mode-map ":"
              (L () (bad-operate s #'bad-make-bra-full (@ s canvas))))

  ;; background bg/fg
  (keymap-set bad-mode-map "2" (L () (set-background-color our-black)))
  (keymap-set bad-mode-map "@" (L () (set-foreground-color our-black)))

  ;; bg bg & fg
  (keymap-set bad-mode-map "3" (L () (bad-random-color 'bg)))
  (keymap-set bad-mode-map "4" (L () (bad-random-color 'fg)))

  ;; 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       t)))
  (keymap-set bad-mode-map "H" (L () (bad-set-color s 'rand-here t)))
  (keymap-set bad-mode-map ">" (L () (bad-set-color s 'pick      t)))
  (keymap-set bad-mode-map "<" (L () (bad-set-color s 'reset     t)))

  ;; mouse
  (keymap-set bad-mode-map "<mouse-1>" #'bad-put-color-at-point)
  (keymap-set bad-mode-map "F"         #'bad-draw-fg-color)
; (keymap-set bad-mode-map "e"         #'bad-draw-bg-color)

  ;; alpha
  (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)))
  (keymap-set bad-mode-map "*" (L () (bad-alpha-set 0.4)))

  ;; elements
  (keymap-set bad-mode-map "P"    (L () (bad-advance-pos s) (bad-update s)))
  (keymap-set bad-mode-map "p" #1=(L () (bad-prev s)))
  (keymap-set bad-mode-map "n" #2=(L () (bad-next s)))
  (keymap-set bad-mode-map "<backtab>" #1#)
  (keymap-set bad-mode-map "TAB"       #2#)

  ;; 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 "N" (L () (bad-set-name     s)))
  (keymap-set bad-mode-map "t" (L () (bad-add-triangle 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 t  )))
  (keymap-set bad-mode-map "S" (L () (bad-read-ascii s nil t t)))

  ;; box
  (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 t)))

  ;; 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
  (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 nil 'fit-h)))
  ;; TODO: DNC
  ;; (keymap-set bad-mode-map "E" (L () (bad-zoom s  nil  nil 'fit-w 'fit-h)))
  (keymap-set bad-mode-map "<prior>" (L () (bad-zoom s     'in)))
  (keymap-set bad-mode-map "<next>"  (L () (bad-zoom s))) ; out

  ;; 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 "u" (L () (bad-operate s #'bad-add-col -1)))
  (keymap-set bad-mode-map "o" (L () (bad-operate s #'bad-add-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-cycle-pos s)))
  (keymap-set bad-mode-map ";" (L () (bad-operate s #'bad-pos-inside (@ s canvas))))

  ;; move
  (keymap-set bad-mode-map "i" #1=(L () (bad-operate s #'bad-up)))
  (keymap-set bad-mode-map "k" #2=(L () (bad-operate s #'bad-down)))
  (keymap-set bad-mode-map "j" #3=(L () (bad-operate s #'bad-left)))
  (keymap-set bad-mode-map "l" #4=(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)
  (~ (#1=trans-chars #2=trans-chars-more) s
     (bad-set-fill s (@f "%c" (1st #3=(if more #2# #1#))))
     (setf #3# (bad-list-shift #3#))))

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

(cl-defmethod bad-zoom ((s studio) &optional in reset fit-w fit-h)
  (~ (w sel) s
     (when (box-p sel)
       (~ (img (iw w) (ih h)) sel
          (when (& img #1=(image-property img :scale))
            (when fit-w
              (let* ((pxls  (1st (image-size img t)))
                     (crs-x (bad-pixels-to-chars pxls))
                     (new   (* pxls (1- (// crs-x iw)))))
                (setf #1# (* #1# new))))
            (when fit-h
              (let* ((pxls  (cdr (image-size img t)))
                     (crs-y (bad-pixels-to-chars pxls t))
                     (new   (// ih crs-y)))
                (setf #1# (* #1# new))))
            (when reset
              (setf #1# 1.0))
            (unless (or fit-w fit-h reset)
              (setf #1# (+ #1# (* (if in -1 1) (** 2 -6)))))
            (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
          (++ iix)
          (bad-update s)))))

(cl-defmethod bad-move-img-inner-up ((s studio))
  (~ (sel) s
     (when (& (box-p sel) (@ sel img))
       (~ (iiy y) 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
          (++ iiy)
          (bad-update s)))))

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

(cl-defmethod bad-show-img ((s studio) &optional reload next)
  (when (display-graphic-p)
    (~ (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 subi) sel
        (when deletable
          (setf elems (remove sel elems))
          (setf deleted t)
          (setf visible nil)
          (setf sel (1st elems))
          (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)))
       (~ (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))
                    (string= 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
    (setq str (read-string (@f "pattern? [%s] " #1="  bad.el") nil nil #1#)))
  (~ (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) "))
             (str  (read-string (@f "pattern: [%s] " #1="{") nil nil #1#)))
         (bad-side sel side str)
         (bad-update sel)
         (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)
             (bad-make-light sel)
           (bad-border sel c))
         (bad-update s)))))

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

(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)))
                          `(,@(take #1=(1- pos) wo) ,sel ,@(cl-subseq wo #1#)))))))
          (when lst
            (setf sub lst))))))

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

;; TODO: name

(defun bad-random-color (&optional which)
  (cl-labels
      ((do-fg (&optional fg) (set-foreground-color (or fg (bad-fg-random) our-white)))
       (do-bg (&optional bg) (set-background-color (or bg (bad-bg-random) our-black))))
    (cl-case which
      (fg (do-fg))
      (bg (do-bg))
      (t  (do-fg) (do-bg)))
    (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))))
         (when res
           (cl-loop
            for e in res
            for i from 1 upto 4 do
            (unless (= e ?\.)
              (bad-corner sel i e))
            finally do
              (bad-update sel)
              (bad-update s)))))))

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

(cl-defmethod bad-cycle-size ((s studio))
  (~ (sel size-funs) s
     (when (& sel size-funs)
       (~ (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 pos-funs)
       (~ (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)