From 549b762ce1c84b847faadc5b10cf8e1bb31d42d7 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sun, 4 Oct 2020 21:05:45 -0400
Subject: kernel: Add an fps counter in dev mode.

---
 starling/kernel.scm | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 57 insertions(+), 3 deletions(-)

diff --git a/starling/kernel.scm b/starling/kernel.scm
index 042e1ac..3f19d5f 100644
--- a/starling/kernel.scm
+++ b/starling/kernel.scm
@@ -26,12 +26,18 @@
   #:use-module (chickadee audio)
   #:use-module (chickadee game-loop)
   #:use-module (chickadee graphics)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics font)
   #:use-module (chickadee graphics gpu)
   #:use-module (chickadee graphics viewport)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
   #:use-module (gl)
+  #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (oop goops)
-  #:use-module (sdl2)
+  #:use-module ((sdl2) #:select (sdl-init))
   #:use-module (sdl2 events)
   #:use-module (sdl2 input game-controller)
   #:use-module (sdl2 input joystick)
@@ -39,6 +45,7 @@
   #:use-module (starling asset)
   #:use-module (starling config)
   #:use-module (starling node)
+  #:use-module (starling node-2d)
   #:use-module (starling repl)
   #:use-module (starling minibuffer)
   #:use-module (starling scene)
@@ -71,6 +78,38 @@
   (fullscreen? #:accessor window-fullscreen? #:init-form #f
                #:init-keyword #:fullscreen?))
 
+(define-class <fps-display> (<node>))
+
+(define-method (on-boot (fps-display <fps-display>))
+  (let* ((canvas (make <canvas> #:name 'canvas))
+         (font (default-font))
+         (padding 4.0)
+         (box-width (+ (font-line-width font "60.0")
+                       (* padding 2.0)))
+         (box-height (+ (font-line-height font) (* padding 2.0))))
+    (match (current-window-size)
+      ((_ window-height)
+       (attach-to canvas
+                  (make <filled-rect>
+                    #:region (make-rect 0.0
+                                        (- window-height box-height)
+                                        box-width
+                                        box-height)
+                    #:color (make-color 0.0 0.0 0.0 0.7))
+                  (make <label>
+                    #:name 'fps-label
+                    #:rank 9
+                    #:text "60.0"
+                    #:font font
+                    #:position (vec2 padding
+                                     (+ (- window-height box-height)
+                                        padding))))))
+    (attach-to fps-display canvas)))
+
+(define-method (update-fps (fps-display <fps-display>) fps)
+  (set! (text (& fps-display canvas fps-label))
+    (format #f "~1,1f" fps)))
+
 (define-class <kernel> (<scene-mux>)
   (name #:accessor name #:init-form "lisparuga-kernel"
         #:init-keyword #:name)
@@ -113,8 +152,15 @@
   (when developer-mode?
     ;; Enable live asset reloading.
     (watch-assets #t)
-    ;; Start REPL server.
-    (attach-to kernel (make <repl> #:name 'repl))))
+    (attach-to kernel
+               ;; FPS counter
+               (make <fps-display> #:name 'fps)
+               ;; REPL server
+               (make <repl> #:name 'repl))
+    (run-script kernel
+      (forever
+       (sleep 60)
+       (update-fps (& kernel fps) (fps kernel))))))
 
 (define-method (on-key-press (kernel <kernel>) key scancode modifiers repeat?)
   ;; Hot keys when in dev mode
@@ -316,9 +362,17 @@ kernel.  A convenient procedure for developers."
 (define (resume-current-scene)
   (resume (current-scene (current-kernel))))
 
+(define (show-fps)
+  (show (& (current-kernel) fps)))
+
+(define (hide-fps)
+  (hide (& (current-kernel) fps)))
+
 (add-minibuffer-command "reboot" reboot-current-scene)
 (add-minibuffer-command "pause" pause-current-scene)
 (add-minibuffer-command "resume" resume-current-scene)
+(add-minibuffer-command "show-fps" show-fps)
+(add-minibuffer-command "hide-fps" hide-fps)
 
 (define-meta-command ((debug-game lisparuga) repl)
   "debug-game
-- 
cgit v1.2.3