;;; Chickadee Game Toolkit
;;; Copyright © 2017, 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; Viewports specify the renderable section of a window.
;;
;;; Code:

(define-module (chickadee graphics viewport)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (gl)
  #:use-module (chickadee utils)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics gl)
  #:export (make-viewport
            viewport?
            viewport-x
            viewport-y
            viewport-width
            viewport-height
            viewport-clear-color
            viewport-clear-flags
            null-viewport
            clear-viewport
            g:viewport
            current-viewport
            %default-clear-flags
            %default-clear-color))

(define-record-type <viewport>
  (%make-viewport x y width height clear-color clear-flags)
  viewport?
  (x viewport-x)
  (y viewport-y)
  (width viewport-width)
  (height viewport-height)
  (clear-color viewport-clear-color)
  (clear-flags viewport-clear-flags))

(define %default-clear-flags '(color-buffer depth-buffer stencil-buffer))
;; Just a fun color from the Dawnbringer 32-color palette instead of
;; boring old black.
(define %default-clear-color tango-light-sky-blue)

(define (assert-non-negative-integer n)
  (if (and (integer? n) (>= n 0))
      n
      (error "expecting non-negative integer:" n)))

(define* (make-viewport x y width height #:key
                        (clear-color %default-clear-color)
                        (clear-flags %default-clear-flags))
  "Create a viewport that covers an area of the window starting from
coordinates (X, Y) and spanning WIDTH x HEIGHT pixels.  Fill the
viewport with CLEAR-COLOR when clearing the screen.  Clear the buffers
denoted by the list of symbols in CLEAR-FLAGS.  Possible values for
CLEAR-FLAGS are 'color-buffer', 'depth-buffer', 'accum-buffer', and
'stencil-buffer'."
  (%make-viewport (assert-non-negative-integer x)
                  (assert-non-negative-integer y)
                  (assert-non-negative-integer width)
                  (assert-non-negative-integer height)
                  clear-color
                  clear-flags))

(define null-viewport (make-viewport 0 0 0 0))

(define clear-buffer-mask
  (memoize
   (lambda (flags)
     (apply logior
            ;; Map symbols to OpenGL constants.
            (map (match-lambda
                  ('depth-buffer 256)
                  ('accum-buffer 512)
                  ('stencil-buffer 1024)
                  ('color-buffer 16384))
                 flags)))))

(define (clear-viewport)
  (gl-clear (clear-buffer-mask (viewport-clear-flags (current-viewport)))))

(define (apply-viewport viewport)
  "Set the OpenGL state for VIEWPORT.  Clip rendering to the viewport
area, set the clear color, and clear necessary buffers."
  (unless (eq? viewport null-viewport)
    (let ((x (viewport-x viewport))
          (y (viewport-y viewport))
          (w (viewport-width viewport))
          (h (viewport-height viewport))
          (c (viewport-clear-color viewport)))
      (gl-enable (enable-cap scissor-test))
      (gl-viewport x y w h)
      (gl-scissor x y w h)
      (gl-clear-color (color-r c) (color-g c) (color-b c) (color-a c)))))

(define (bind-viewport viewport)
  "Set the OpenGL state for VIEWPORT.  Clip rendering to the viewport
area, and set the clear color.."
  (unless (eq? viewport null-viewport)
    (let ((x (viewport-x viewport))
          (y (viewport-y viewport))
          (w (viewport-width viewport))
          (h (viewport-height viewport))
          (c (viewport-clear-color viewport)))
      (gl-enable (enable-cap scissor-test))
      (gl-viewport x y w h)
      (gl-scissor x y w h)
      (gl-clear-color (color-r c) (color-g c) (color-b c) (color-a c)))))

(define-graphics-state g:viewport
  current-viewport
  #:default null-viewport
  #:bind bind-viewport)