From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/mode.scm | 105 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 105 insertions(+)
 create mode 100644 catbird/mode.scm

(limited to 'catbird/mode.scm')

diff --git a/catbird/mode.scm b/catbird/mode.scm
new file mode 100644
index 0000000..e35146c
--- /dev/null
+++ b/catbird/mode.scm
@@ -0,0 +1,105 @@
+(define-module (catbird mode)
+  #:use-module (catbird config)
+  #:use-module (catbird input-map)
+  #:use-module (catbird mixins)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:export (<major-mode>
+            <minor-mode>
+            bind-input
+            unbind-input
+            name-mode
+            clear-inputs
+            input-map
+            on-key-press
+            on-key-release
+            on-text-input
+            on-mouse-press
+            on-mouse-release
+            on-mouse-move
+            on-mouse-wheel
+            on-controller-press
+            on-controller-release
+            on-controller-move
+            <nothing-mode>)
+  #:re-export (controller-move
+               controller-press
+               controller-release
+               key-press
+               key-release
+               text-input
+               mouse-move
+               mouse-press
+               mouse-release
+               mouse-wheel
+               name
+               on-enter
+               on-exit
+               on-pause
+               on-resume
+               update))
+
+(define-root-class <mode> (<scriptable> <containable> <nameable>)
+  (input-map #:accessor input-map #:allocation #:each-subclass
+             #:init-thunk make-input-map))
+
+(define-method (input-map (mode-class <class>))
+  (class-slot-ref mode-class 'input-map))
+
+(define-method (bind-input mode-class spec handler)
+  (class-slot-set! mode-class 'input-map
+                   (add-input (input-map mode-class) spec handler)))
+
+(define-method (unbind-input mode-class spec)
+  (class-slot-set! mode-class 'input-map
+                   (remove-input (input-map mode-class) spec)))
+
+(define (clear-inputs mode-class)
+  (class-slot-set! mode-class 'input-map '()))
+
+(define-method (on-key-press (mode <mode>) key modifiers)
+  (let ((handler (key-press-handler (input-map mode) key modifiers)))
+    (and handler (handler mode))))
+
+(define-method (on-key-release (mode <mode>) key modifiers)
+  (let ((handler (key-release-handler (input-map mode) key modifiers)))
+    (and handler (handler mode))))
+
+(define-method (on-text-input (mode <mode>) text)
+  (let ((handler (text-input-handler (input-map mode))))
+    (and handler (handler mode text))))
+
+(define-method (on-mouse-press (mode <mode>) button x y)
+  (let ((handler (mouse-press-handler (input-map mode) button)))
+    (and handler (handler mode x y))))
+
+(define-method (on-mouse-release (mode <mode>) button x y)
+  (let ((handler (mouse-release-handler (input-map mode) button)))
+    (and handler (handler mode x y))))
+
+(define-method (on-mouse-move (mode <mode>) x y x-rel y-rel buttons)
+  (let ((handler (mouse-move-handler (input-map mode) buttons)))
+    (and handler (handler mode x y x-rel y-rel))))
+
+(define-method (on-mouse-wheel (mode <mode>) x y)
+  (let ((handler (mouse-wheel-handler (input-map mode))))
+    (and handler (handler mode x y))))
+
+(define-method (on-controller-press (mode <mode>) controller-id button)
+  (let ((handler (controller-press-handler (input-map mode) controller-id button)))
+    (and handler (handler mode))))
+
+(define-method (on-controller-release (mode <mode>) controller-id button)
+  (let ((handler (controller-release-handler (input-map mode) controller-id button)))
+    (and handler (handler mode))))
+
+(define-method (on-controller-move (mode <mode>) controller-id axis value)
+  (let ((handler (controller-move-handler (input-map mode) controller-id axis)))
+    (and handler (handler mode value))))
+
+(define-class <major-mode> (<mode>))
+
+(define-class <minor-mode> (<mode>))
+
+(define-class <nothing-mode> (<major-mode>))
-- 
cgit v1.2.3