path: root/catbird/overlay.scm

;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; 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:
;;
;; 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 (catbird ui)
  #: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 (open-repl (overlay <overlay>))
  (unless (is-a? (major-mode overlay) <repl-mode>)
    (push-major-mode overlay (make <repl-mode>)))
  (open-repl (major-mode overlay)))

(define-method (freeze-all-regions (overlay <overlay>))
  (for-each (lambda (region)
              ;; Freeze everything except the overlay.
              (unless (eq? (scene region) overlay)
                (freeze region)))
            (all-regions)))

(define (unfreeze-all-regions)
  (for-each unfreeze (all-regions)))

(define-method (handle-error (overlay <overlay>) exception stack)
  (freeze-all-regions overlay)
  (open-repl overlay)
  (let ((repl (& overlay repl)))
    (enter-debugger repl exception stack)))

(define-method (on-enter (overlay <overlay>))
  (set! (error-handler (current-kernel))
        (lambda (exception stack)
          (handle-error overlay exception stack))))

(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-meta-command ((resume r) system repl)
  "- Resume game."
  (unfreeze-all-regions))


;;;
;;; FPS Display
;;;

(define %metrics-bg-color (make-color 1.0 0 0 0.8))

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

(define-method (initialize (fps-display <fps-display>) initargs)
  (next-method)
  (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 %metrics-bg-color))
                   (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
      (open-repl s))))


;;;
;;; GC Display
;;;

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

(define-method (initialize (gc-display <gc-display>) initargs)
  (next-method)
  (let* ((font (default-font))
         (padding 4.0))
    (attach-to gc-display
               (make <canvas>
                 #:name 'background
                 #:painter
                 (with-style ((fill-color %metrics-bg-color))
                   (fill
                    (rectangle (vec2 0.0 0.0) 10.0 10.0))))
               (make <margin-container>
                 #:name 'table
                 #:margin padding
                 #:children
                 (list (make <horizontal-container>
                         #:name 'columns
                         #:children
                         (list (make <vertical-container>
                                 #:name 'names
                                 #:children
                                 (list (make <label>
                                         #:text "GC time taken")
                                       (make <label>
                                         #:text "Heap size")
                                       (make <label>
                                         #:text "Heap free size")
                                       (make <label>
                                         #:text "Heap total allocated")
                                       (make <label>
                                         #:text "Heap allocated since GC")
                                       (make <label>
                                         #:text "Protected objects")
                                       (make <label>
                                         #:text "GC times")))
                               (make <margin-container>
                                 #:margin padding)
                               (make <vertical-container>
                                 #:name 'values
                                 #:children
                                 (list (make <label>
                                         #:name 'gc-time-taken)
                                       (make <label>
                                         #:name 'heap-size)
                                       (make <label>
                                         #:name 'heap-free-size)
                                       (make <label>
                                         #:name 'heap-total-allocated)
                                       (make <label>
                                         #:name 'heap-allocated-since-gc)
                                       (make <label>
                                         #:name 'protected-objects)
                                       (make <label>
                                         #:name 'gc-times))))))))
    (run-script gc-display
      (forever
       (refresh-gc-stats gc-display)
       (sleep 1.0)))))

(define KiB (expt 2 10))
(define MiB (expt 2 20))
(define GiB (expt 2 30))

(define (bytes->human-readable-string bytes)
  (cond
   ((< bytes KiB)
    (format #f "~d B" bytes))
   ((< bytes MiB)
    (format #f "~1,2f KiB" (/ bytes KiB)))
   ((< bytes GiB)
    (format #f "~1,2f MiB" (/ bytes MiB)))
   (else
    (format #f "~1,2f GiB" (/ bytes GiB)))))

(define second internal-time-units-per-second)
(define minute (* 60 second))
(define hour (* 60 minute))
(define day (* 24 hour))

(define (time->human-readable-string time)
  (cond
   ((< time minute)
    (format #f "~1,2f seconds" (round (/ time second))))
   ((< time hour)
    (format #f "~1,2f minutes" (round (/ time minute))))
   ((< time day)
    (format #f "~1,2f hours" (round (/ time hour))))
   (else
    (format #f "~1,2f days" (round (/ time day))))))

(define-method (refresh-gc-stats (gc-display <gc-display>))
  (define (stat-label name)
    (let ((container (& gc-display table columns values)))
      (child-ref container name)))
  (let ((stats (gc-stats)))
    (set! (text (stat-label 'gc-time-taken))
          (time->human-readable-string (assq-ref stats 'gc-time-taken)))
    (set! (text (stat-label 'heap-size))
          (bytes->human-readable-string (assq-ref stats 'heap-size)))
    (set! (text (stat-label 'heap-free-size))
          (bytes->human-readable-string (assq-ref stats 'heap-free-size)))
    (set! (text (stat-label 'heap-total-allocated))
          (bytes->human-readable-string (assq-ref stats 'heap-total-allocated)))
    (set! (text (stat-label 'heap-allocated-since-gc))
          (bytes->human-readable-string (assq-ref stats 'heap-allocated-since-gc)))
    (set! (text (stat-label 'protected-objects))
          (number->string (assq-ref stats 'protected-objects)))
    (set! (text (stat-label 'gc-times))
          (number->string (assq-ref stats 'gc-times))))
  ;; Force layout update.
  (layout (& gc-display table))
  (resize (& gc-display background)
          (width (& gc-display table))
          (height (& gc-display table))))

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

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