;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Catbird is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Catbird is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Catbird.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; System overlay scene for notifications and developer tools.
;;
;;; Code:
(define-module (catbird overlay)
  #:use-module (catbird kernel)
  #:use-module (catbird input-map)
  #:use-module (catbird minibuffer)
  #:use-module (catbird node)
  #:use-module (catbird node-2d)
  #:use-module (catbird region)
  #:use-module (catbird repl)
  #:use-module (catbird scene)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics text)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 format)
  #:use-module (oop goops)
  #:export (make-overlay))

(define %background-color (make-color 0.2 0.2 0.2 0.8))

(define-class <overlay> (<scene>))

(define (make-overlay)
  (make <overlay> #:name 'overlay))

(define-method (notify (scene <overlay>) message)
  (run-script scene
    (let* ((padding 8.0)
           (label (make <label>
                    #:name 'message
                    #:rank 1
                    #:position (vec2 padding padding)
                    #:text message))
           (region (car (regions scene)))
           (bg (make <canvas>
                 #:name 'background
                 #:painter
                 (with-style ((fill-color %background-color))
                   (fill
                    (rounded-rectangle (vec2 0.0 0.0)
                                       (+ (width label) padding padding)
                                       (+ (height label) padding)
                                       #:radius 2.0)))))
           (notification (make <node-2d>
                           #:position (vec2 padding
                                            (- (height (camera region))
                                               (height bg)
                                               padding)))))
      (attach-to notification bg label)
      (attach-to scene notification)
      (sleep 5.0)
      (detach notification))))

(define-class <fps-display> (<node-2d>))

(define-method (on-boot (fps-display <fps-display>))
  (let* ((font (default-font))
         (padding 4.0)
         (box-width (+ (font-line-width font "999.9")
                       (* padding 2.0)))
         (box-height (+ (font-line-height font) padding)))
    (attach-to fps-display
               (make <canvas>
                 #:name 'background
                 #:painter
                 (with-style ((fill-color (make-color 0 0 0 0.5)))
                   (fill
                    (rectangle (vec2 0.0 0.0)
                               box-width
                               box-height))))
               (make <label>
                 #:name 'label
                 #:rank 1
                 #:font font
                 #:position (vec2 padding padding)))
    (set! (width fps-display) box-width)
    (set! (height fps-display) box-height)
    (set! (origin-y fps-display) box-height)
    (update-fps fps-display)
    (run-script fps-display
      (forever
       (sleep 1.0)
       (update-fps fps-display)))))

(define-method (update-fps (fps-display <fps-display>))
  (set! (text (& fps-display label))
    (format #f "~1,1f" (frames-per-second (current-kernel)))))

(define (scene-for-region name)
  (let ((r (find-region-by-name name)))
    (and r (scene r))))

(define-minibuffer-command show-fps
  (let* ((r (find-region-by-name 'overlay))
         (s (and r (scene r))))
    (when (and s (not (& s fps-display)))
      (attach-to s (make <fps-display>
                     #:name 'fps-display
                     #:rank 99
                     #:position (vec2 0.0 (area-height r)))))))

(define-minibuffer-command hide-fps
  (let* ((s (scene-for-region 'overlay))
         (f (and s (& s fps-display))))
    (when f (detach f))))

(define-minibuffer-command repl
  (let ((s (scene-for-region 'overlay)))
    (when s
      (push-major-mode s (make <repl-mode>)))))