(use test
     (prefix sdl2 sdl2:)
     (prefix sdl2-image img:)
     srfi-1
     (only lolevel
           object-evict))


;;; Returns #t if the given expression signals an exception of the
;;; specified kind. Returns #f if it does not signal any exception.
;;; Does not catch exceptions of unexpected kinds.
(define-syntax exn?
  (syntax-rules ()
    ((exn? (exn-kind ...) (op arg ...))
     (condition-case
      ;; Return #f if the operation completes normally.
      (begin (op arg ...) #f)
      ;; Return #t if the operation signals the correct kind of
      ;; exception. Other exceptions will not be caught.
      ((exn-kind ...) #t)))))


;;; Returns #t if given a sdl2:surface with the expected properties
;;; for a successfully loaded test image.
(define (check-surface surf)
  (and (sdl2:surface? surf)
       (not (sdl2:struct-null? surf))
       (= 100 (sdl2:surface-w surf))
       (= 75  (sdl2:surface-h surf))
       (color-approx=? (sdl2:surface-ref surf 0 0)
                       (sdl2:make-color 29 58 24 255))
       (color-approx=? (sdl2:surface-ref surf 50 38)
                       (sdl2:make-color 149 146 137 255))
       (color-approx=? (sdl2:surface-ref surf 99 74)
                       (sdl2:make-color 32 61 27 255))))


;;; Returns #t if every color component of actual is within delta of
;;; the corresponding component in expected.
(define (color-approx=? actual expected #!optional (delta 5))
  (define (check fn)
    (>= delta (abs (- (fn actual) (fn expected)))))
  (and (check sdl2:color-r)
       (check sdl2:color-g)
       (check sdl2:color-b)
       (check sdl2:color-a)))


(define (read-file-to-evicted-string filename)
  (object-evict
   (with-input-from-file filename read-string)))


(define bmp-filename "images/dog.bmp")
(define gif-filename "images/dog.gif")
(define jpg-filename "images/dog.jpg")
(define png-filename "images/dog.png")
(define tga-filename "images/dog.tga")

(define bmp-string (read-file-to-evicted-string bmp-filename))
(define gif-string (read-file-to-evicted-string gif-filename))
(define jpg-string (read-file-to-evicted-string jpg-filename))
(define png-string (read-file-to-evicted-string png-filename))
(define tga-string (read-file-to-evicted-string tga-filename))

(define invalid-bmp-filename "images/invalid.bmp")
(define invalid-gif-filename "images/invalid.gif")
(define invalid-jpg-filename "images/invalid.jpg")
(define invalid-png-filename "images/invalid.png")
(define invalid-tga-filename "images/invalid.tga")

(define invalid-bmp-string (read-file-to-evicted-string invalid-bmp-filename))
;; (define invalid-gif-string (read-file-to-evicted-string invalid-gif-filename))
;; (define invalid-jpg-string (read-file-to-evicted-string invalid-jpg-filename))
;; (define invalid-png-string (read-file-to-evicted-string invalid-png-filename))
;; (define invalid-tga-string (read-file-to-evicted-string invalid-tga-filename))



(test-begin "sdl2-image")


(test-group "init!"
  (test "Initializes (jpg png tif) by default"
        '(jpg png tif) (img:init!))
  (img:quit!)

  (test "Initializes nothing if given ()"
        '() (img:init! '()))

  (let ((result1 (img:init! '(png)))
        (result2 (img:init! '(jpg))))
    (test "Repeated calls have cumulative effect"
          '((png) (jpg png))
          (list result1 result2)))

  (test-error "Signals an error if given an invalid flag"
    (img:init! '(jpg foo))))



(test-group "current-version"
  (let ((v (img:current-version)))
    (test-assert "Returns a list of 3 integers"
      (and (= 3 (length v))
           (every integer? v)))))


(test-group "compiled-version"
  (let ((v (img:compiled-version)))
    (test-assert "Returns a list of 3 integers"
      (and (= 3 (length v))
           (every integer? v)))))



(test-group "load"
  (test-assert "Can load a BMP file"
    (check-surface (img:load bmp-filename)))
  (test-assert "Can load a GIF file"
    (check-surface (img:load gif-filename)))
  (test-assert "Can load a JPG file"
    (check-surface (img:load jpg-filename)))
  (test-assert "Can load a PNG file"
    (check-surface (img:load png-filename)))
  (test-assert "Can load a TGA file"
    (check-surface (img:load tga-filename)))

  (test-assert "Signals (exn sdl2) if loading BMP file fails"
    (exn? (exn sdl2) (img:load invalid-bmp-filename)))
  (test-assert "Signals (exn sdl2) if loading GIF file fails"
    (exn? (exn sdl2) (img:load invalid-gif-filename)))
  (test-assert "Signals (exn sdl2) if loading JPG file fails"
    (exn? (exn sdl2) (img:load invalid-jpg-filename)))
  (test-assert "Signals (exn sdl2) if loading PNG file fails"
    (exn? (exn sdl2) (img:load invalid-png-filename)))
  (test-assert "Signals (exn sdl2) if loading TGA file fails"
    (exn? (exn sdl2) (img:load invalid-tga-filename))))



(test-group "load*"
  (let ((surf (img:load* bmp-filename)))
    (test-assert "Can load a BMP file"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let ((surf (img:load* gif-filename)))
    (test-assert "Can load a GIF file"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let ((surf (img:load* jpg-filename)))
    (test-assert "Can load a JPG file"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let ((surf (img:load* png-filename)))
    (test-assert "Can load a PNG file"(check-surface surf))
    (sdl2:free-surface! surf))
  (let ((surf (img:load* tga-filename)))
    (test-assert "Can load a TGA file"
      (check-surface surf))
    (sdl2:free-surface! surf))

  (test-assert "Signals (exn sdl2) if loading BMP file fails"
    (exn? (exn sdl2) (img:load* invalid-bmp-filename)))
  (test-assert "Signals (exn sdl2) if loading GIF file fails"
    (exn? (exn sdl2) (img:load* invalid-gif-filename)))
  (test-assert "Signals (exn sdl2) if loading JPG file fails"
    (exn? (exn sdl2) (img:load* invalid-jpg-filename)))
  (test-assert "Signals (exn sdl2) if loading PNG file fails"
    (exn? (exn sdl2) (img:load* invalid-png-filename)))
  (test-assert "Signals (exn sdl2) if loading TGA file fails"
    (exn? (exn sdl2) (img:load* invalid-tga-filename))))



(test-group "load-rw"
  (let ((rwops (sdl2:rw-from-string bmp-string)))
    (test-assert "Can load a BMP from rwops"
      (check-surface (img:load-rw rwops #t))))
  (let ((rwops (sdl2:rw-from-string gif-string)))
    (test-assert "Can load a GIF from rwops"
      (check-surface (img:load-rw rwops #t))))
  (let ((rwops (sdl2:rw-from-string jpg-string)))
    (test-assert "Can load a JPG from rwops"
      (check-surface (img:load-rw rwops #t))))
  (let ((rwops (sdl2:rw-from-string png-string)))
    (test-assert "Can load a PNG from rwops"
      (check-surface (img:load-rw rwops #t))))

  ;; TGA files cannot be loaded with load-rw. You need to give the
  ;; library a type hint using load-typed-rw.
  (let ((rwops (sdl2:rw-from-string tga-string)))
    (test-assert "Signals (exn sdl2) if loading TGA from rwops fails"
      (exn? (exn sdl2) (img:load-rw rwops #t))))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (test-assert "Signals (exn sdl2) if loading from rwops fails"
      (exn? (exn sdl2) (img:load-rw rwops))))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-rw rwops)))
    (test-assert "Does not close the rwops if close? is omitted"
      (not (sdl2:struct-null? rwops))))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-rw rwops #f)))
    (test-assert "Does not close the rwops if close? is #f"
      (not (sdl2:struct-null? rwops))))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-rw rwops #t)))
    (test-assert "Closes the rwops if close? is #t"
      (sdl2:struct-null? rwops)))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (condition-case
     (img:load-rw rwops #t)
     ((exn sdl2) (void)))
    (test-assert "Closes the rwops if close? is #t even if loading fails"
      (sdl2:struct-null? rwops))))



(test-group "load-rw*"
  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-rw* rwops #t)))
    (test-assert "Can load a BMP from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let* ((rwops (sdl2:rw-from-string gif-string))
         (surf (img:load-rw* rwops #t)))
    (test-assert "Can load a GIF from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let* ((rwops (sdl2:rw-from-string jpg-string))
         (surf (img:load-rw* rwops #t)))
    (test-assert "Can load a JPG from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let* ((rwops (sdl2:rw-from-string png-string))
         (surf (img:load-rw* rwops #t)))
    (test-assert "Can load a PNG from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))

  ;; TGA files cannot be loaded with load-rw*. You need to give the
  ;; library a type hint using load-typed-rw*.
  (let ((rwops (sdl2:rw-from-string tga-string)))
    (test-assert "Signals (exn sdl2) if loading TGA from rwops fails"
      (exn? (exn sdl2) (img:load-rw* rwops #t))))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (test-assert "Signals (exn sdl2) if loading from rwops fails"
      (exn? (exn sdl2) (img:load-rw* rwops))))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-rw* rwops)))
    (test-assert "Does not close the rwops if close? is omitted"
      (not (sdl2:struct-null? rwops)))
    (sdl2:free-surface! surf))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-rw* rwops #f)))
    (test-assert "Does not close the rwops if close? is #f"
      (not (sdl2:struct-null? rwops)))
    (sdl2:free-surface! surf))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-rw* rwops #t)))
    (test-assert "Closes the rwops if close? is #t"
      (sdl2:struct-null? rwops))
    (sdl2:free-surface! surf))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (condition-case
     (img:load-rw* rwops #t)
     ((exn sdl2) (void)))
    (test-assert "Closes the rwops if close? is #t even if loading fails"
      (sdl2:struct-null? rwops))))



(test-group "load-typed-rw"
  (let ((rwops (sdl2:rw-from-string bmp-string)))
    (test-assert "Can load a BMP from rwops"
      (check-surface (img:load-typed-rw rwops #t "BMP"))))
  (let ((rwops (sdl2:rw-from-string gif-string)))
    (test-assert "Can load a GIF from rwops"
      (check-surface (img:load-typed-rw rwops #t "GIF"))))
  (let ((rwops (sdl2:rw-from-string jpg-string)))
    (test-assert "Can load a JPG from rwops"
      (check-surface (img:load-typed-rw rwops #t "JPG"))))
  (let ((rwops (sdl2:rw-from-string png-string)))
    (test-assert "Can load a PNG from rwops"
      (check-surface (img:load-typed-rw rwops #t "PNG"))))
  (let ((rwops (sdl2:rw-from-string tga-string)))
    (test-assert "Can load a TGA from rwops"
      (check-surface (img:load-typed-rw rwops #t "TGA"))))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (test-assert "Signals (exn sdl2) if loading from rwops fails"
      (exn? (exn sdl2) (img:load-typed-rw rwops #t "BMP"))))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-typed-rw rwops #f "BMP")))
    (test-assert "Does not close the rwops if close? is #f"
      (not (sdl2:struct-null? rwops))))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-typed-rw rwops #t "BMP")))
    (test-assert "Closes the rwops if close? is #t"
      (sdl2:struct-null? rwops)))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (condition-case
     (img:load-typed-rw rwops #t "BMP")
     ((exn sdl2) (void)))
    (test-assert "Closes the rwops if close? is #t even if loading fails"
      (sdl2:struct-null? rwops))))



(test-group "load-typed-rw*"
  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-typed-rw* rwops #t "BMP")))
    (test-assert "Can load a BMP from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let* ((rwops (sdl2:rw-from-string gif-string))
         (surf (img:load-typed-rw* rwops #t "GIF")))
    (test-assert "Can load a GIF from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let* ((rwops (sdl2:rw-from-string jpg-string))
         (surf (img:load-typed-rw* rwops #t "JPG")))
    (test-assert "Can load a JPG from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let* ((rwops (sdl2:rw-from-string png-string))
         (surf (img:load-typed-rw* rwops #t "PNG")))
    (test-assert "Can load a PNG from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))
  (let* ((rwops (sdl2:rw-from-string tga-string))
         (surf (img:load-typed-rw* rwops #t "TGA")))
    (test-assert "Can load a TGA from rwops"
      (check-surface surf))
    (sdl2:free-surface! surf))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (test-assert "Signals (exn sdl2) if loading from rwops fails"
      (exn? (exn sdl2) (img:load-typed-rw* rwops #t "BMP"))))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-typed-rw* rwops #f "BMP")))
    (test-assert "Does not close the rwops if close? is #f"
      (not (sdl2:struct-null? rwops)))
    (sdl2:free-surface! surf))

  (let* ((rwops (sdl2:rw-from-string bmp-string))
         (surf (img:load-typed-rw* rwops #t "BMP")))
    (test-assert "Closes the rwops if close? is #t"
      (sdl2:struct-null? rwops))
    (sdl2:free-surface! surf))

  (let ((rwops (sdl2:rw-from-string invalid-bmp-string)))
    (condition-case
     (img:load-typed-rw* rwops #t "BMP")
     ((exn sdl2) (void)))
    (test-assert "Closes the rwops if close? is #t even if loading fails"
      (sdl2:struct-null? rwops))))



(test-end "sdl2-image")
(test-exit)