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

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

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

(-> 'bad-elem)

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

(defvar bad-buddy-boxes)
(setq bad-buddy-boxes nil)

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

(cl-defmethod bad-rect ((e elem))
  (~ (x y w h) e
     (list x y w h)))

(defun bad-rect-reduce (r1 r2)
  (unless (l= r1 r2)
    (pcase-let* ((`(,x1 ,y1 ,w1 ,h1) r1)
                 (`(,x2 ,y2 ,w2 ,h2) r2)
                 (xfar1 (+ x1 w1))
                 (xfar2 (+ x2 w2))
                 (yfar1 (+ y1 h1))
                 (yfar2 (+ y2 h2))
                 (xd (- x1 x2))
                 (yd (- y1 y2)))
      (if (<= x2 x1 xfar1 xfar2) ; vertical
          (if (<= y1 y2 yfar1 yfar2) ; bottom
              (setq h1 (- yfar1 y2))
            (when (<= y2 y1 yfar2 yfar1) ; top
              (let ((ol (- h2 yd 1)))
                (++ y1 ol)
                (-- h1 ol))))
        (when (<= y2 y1 yfar1 yfar2) ; horizontal
          (if (<= x1 x2 xfar1 xfar2) ; left
              (setq w1 (- xfar1 x2))
            (when (<= x2 x1 xfar2 xfar1) ; right
              (let ((ol (- w2 xd 1)))
                (++ x1 ol)
                (-- w1 ol))))))))
  r1)

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

(cl-defmethod bad-pos ((e elem) (new-x integer) &optional new-y)
  (~ (movable min-x x max-x min-y y max-y w h) e
     (or new-y (setq new-y (@ e y)))
     (when (& movable
              (<= 0 min-x new-x (or max-x new-x))
              (<= 0 min-y new-y (or max-y new-y)))
       (let ((r (bad-rect e)))
         (setf x new-x)
         (setf y new-y)
         (push (bad-rect-reduce r (bad-rect e)) bad-buddy-boxes)))))

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

(provide 'bad-pos)