; Misc. functions

(require 'srfi-1)
(require 'srfi-4)

;; Update an object slot to be a set with the thing added;
;; assumes there's a list there already
(define (slot-set-add! obj slotname thing)
  (slot-set! obj slotname (cons thing
                                (delete thing (slot-ref obj slotname)))))

(define (slot-set-remove! obj slotname thing)
  (slot-set! obj slotname (delete thing (slot-ref obj slotname))))

; Transforms
; --------------------------------------------------
; Keep transforms in a box so that we can free them
; when they are finalised.

(define-record-type transform
  (make-transform* to fro)
  transform?
  (to transform-to transform-to-set*)
  (fro transform-fro transform-fro-set*))

(define (make-transform)
  (let ((t (make-transform*
            (cairo-matrix-create)
            (cairo-matrix-create))))
    (set-finalizer! t (lambda (x)
                          (cairo-matrix-destroy (transform-to x))
                          (cairo-matrix-destroy (transform-fro x))))
    t))

(define (apply-transformation transform transformation)
  (transformation (transform-to transform))
  (let ((m (cairo-matrix-create))
        (tmp (cairo-matrix-create))
        (fro (transform-fro transform)))
    (transformation m)
    (cairo-matrix-invert m)
    (cairo-matrix-multiply tmp fro m)
    (cairo-matrix-copy fro tmp)
    (for-each cairo-matrix-destroy (list m tmp))))

(define (transform-copy source dest)
  (cairo-matrix-copy (transform-to dest) (transform-to source))
  (cairo-matrix-copy (transform-fro dest) (transform-fro source)))

(define (transform-translate transform dx dy)
  (apply-transformation transform (cut cairo-matrix-translate <> dx dy)))

(define (transform-rotate transform radians)
  (apply-transformation transform (cut cairo-matrix-rotate <> radians)))

(define (transform-scale transform sx sy)
  (if (or (= sx 0) (= sy 0))
      (error "Cannot scale by 0")
      (apply-transformation transform (cut cairo-matrix-scale <> sx sy))))

(define (transform-scale-about-point transform x y sx sy)
  (transform-translate transform x y)
  (transform-scale transform sx sy)
  (transform-translate transform (- x) (- y)))

;; Points and rectangles

(define-record point2d x y)
(define-record rect topleft bottomright)

(define-record-printer (point2d p out)
  (for-each (lambda (x) (display x out))
            (list "#<point2d " (point2d-x p) ", " (point2d-y p) ">")))
          
;; When drawing and clipping we typically deal with x,y,
;; width and height.
(define (rect->bounds rect)
  (let ((tl (rect-topleft rect))
        (br (rect-bottomright rect)))
    (let ((tlx (point2d-x tl))
          (tly (point2d-y tl)))
      (list tlx tly (- (point2d-x br) tlx) (- (point2d-y br) tly)))))

(define (bounds->rect x y w h)
  (make-rect (make-point2d x y)
             (make-point2d (+ x w) (+ y h))))

(define-record-printer (rect r out)
  (for-each (lambda (x) (display x out))
            (list "#<rect " (rect-topleft r) ", " (rect-bottomright r) ">")))

;; We could use f64vectors and make these destructive updates

(define (point2d-transform point matrix)
  (let ((x (f64vector (point2d-x point)))
        (y (f64vector (point2d-y point))))
    (cairo-matrix-transform-point matrix x y)
    (make-point2d (f64vector-ref x 0) (f64vector-ref y 0))))

(define (point2d-transform-to point transform)
  (point2d-transform point (transform-to transform)))

(define (point2d-transform-fro point transform)
  (point2d-transform point (transform-fro transform)))

;; %%% This assumes a non-rotating transform .. we need to something else otherwise
(define (rect-transform rect matrix)
  (make-rect (point2d-transform (rect-topleft rect) matrix)
             (point2d-transform (rect-bottomright rect) matrix)))

(define (rect-transform-to rect transform)
  (rect-transform rect (transform-to transform)))

(define (rect-transform-fro rect transform)
  (rect-transform rect (transform-fro transform)))

(define (point2d-in-rect? point rect)
  (let ((x (point2d-x point))
        (y (point2d-y point))
        (tl (rect-topleft rect))
        (br (rect-bottomright rect)))
    (and (> x (point2d-x tl))
         (< x (point2d-x br))
         (> y (point2d-y tl))
         (< y (point2d-y br)))))

;; Do the rectangles overlap?
(define (rects-overlap? recta rectb)
  (let ((tla (rect-topleft recta))
        (tlb (rect-topleft rectb))
        (bra (rect-bottomright recta))
        (brb (rect-bottomright rectb)))
  (not
   (or (< (point2d-y bra) (point2d-y tlb))
       (> (point2d-y tla) (point2d-y brb))
       (< (point2d-x bra) (point2d-x tlb))
       (> (point2d-x tla) (point2d-x brb))))))

(define (rects-overlap?/display recta rectb)
  (let ((res (rects-overlap? recta rectb)))
    (display "Test: ")(display recta)
    (display " overlaps ")(display rectb)
    (display " = ")(display res)(newline)
    res))

; Return the smallest rectangle that encloses both
; recta and rectb
(define (rects-coalesce recta rectb)
  (let ((tla (rect-topleft recta))
        (tlb (rect-topleft rectb))
        (bra (rect-bottomright recta))
        (brb (rect-bottomright rectb)))
    (make-rect (make-point2d (min (point2d-x tla) (point2d-x tlb))
                             (min (point2d-y tla) (point2d-y tlb)))
               (make-point2d (max (point2d-x bra) (point2d-x brb))
                             (max (point2d-y bra) (point2d-y brb))))))