From a20d05376cb2de636abebd64da3eeb6c7e8c7bac Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sat, 29 Oct 2022 21:40:09 -0400
Subject: Day 1 progress.

---
 apple-town-fair/assets.scm       |  6 ++-
 apple-town-fair/dialog-box.scm   | 47 ++++++++++++++++++++
 apple-town-fair/game.scm         | 87 ++++++++++++++++++++++++++++++++-----
 apple-town-fair/menu.scm         | 92 ++++++++++++++++++++++++++++++++++++++++
 apple-town-fair/place.scm        | 28 +++++++++++-
 apple-town-fair/splash.scm       |  6 +--
 apple-town-fair/time-display.scm | 21 ++++++---
 7 files changed, 265 insertions(+), 22 deletions(-)
 create mode 100644 apple-town-fair/dialog-box.scm
 create mode 100644 apple-town-fair/menu.scm

(limited to 'apple-town-fair')

diff --git a/apple-town-fair/assets.scm b/apple-town-fair/assets.scm
index b2fbecc..8aacf46 100644
--- a/apple-town-fair/assets.scm
+++ b/apple-town-fair/assets.scm
@@ -17,7 +17,9 @@
   #:use-module (catbird asset)
   #:export (monogram-font
             chickadee-image
-            home-background-image))
+            dialog-box-image
+            home-background-image
+            farm-stand-background-image))
 
 (define (scope-datadir file-name)
   (let ((prefix (or (getenv "APPLE_TOWN_FAIR_DATADIR") (getcwd))))
@@ -34,4 +36,6 @@
 
 (define-font monogram-font (font-file "monogram_extended.ttf") 12)
 (define-image chickadee-image (image-file "chickadee.png"))
+(define-image dialog-box-image (image-file "dialog-box.png"))
 (define-image home-background-image (image-file "home.png"))
+(define-image farm-stand-background-image (image-file "farm-stand.png"))
diff --git a/apple-town-fair/dialog-box.scm b/apple-town-fair/dialog-box.scm
new file mode 100644
index 0000000..0731e72
--- /dev/null
+++ b/apple-town-fair/dialog-box.scm
@@ -0,0 +1,47 @@
+;;; Copyright © 2022 David Thompson <davet@gnu.org>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+(define-module (apple-town-fair dialog-box)
+  #:use-module (apple-town-fair assets)
+  #:use-module (apple-town-fair common)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:export (<dialog-box>))
+
+(define-class <dialog-box> (<node-2d>)
+  (text #:accessor text #:init-keyword #:text #:init-value "" #:observe? #t))
+
+(define-method (on-boot (dialog <dialog-box>))
+  (attach-to dialog
+             (make <sprite>
+               #:name 'background
+               #:texture dialog-box-image)
+             (make <label>
+               #:name 'label
+               #:rank 1
+               #:font monogram-font
+               #:vertical-align 'top
+               #:text (text dialog)))
+  (set! (width dialog) (width (& dialog background)))
+  (set! (height dialog) (height (& dialog background)))
+  (teleport (& dialog label) 10.0 (- (height dialog) 10.0)))
+
+(define-method (on-change (dialog <dialog-box>) slot old new)
+  (case slot
+    ((text)
+     (set! (text (& dialog label)) new))))
diff --git a/apple-town-fair/game.scm b/apple-town-fair/game.scm
index 878dbac..13ec3f0 100644
--- a/apple-town-fair/game.scm
+++ b/apple-town-fair/game.scm
@@ -17,10 +17,13 @@
   #:use-module (apple-town-fair assets)
   #:use-module (apple-town-fair common)
   #:use-module (apple-town-fair config)
+  #:use-module (apple-town-fair dialog-box)
   #:use-module (apple-town-fair light-overlay)
+  #:use-module (apple-town-fair menu)
   #:use-module (apple-town-fair place)
   #:use-module (apple-town-fair save-state)
   #:use-module (apple-town-fair time-display)
+  #:use-module (catbird)
   #:use-module (catbird mode)
   #:use-module (catbird node)
   #:use-module (catbird node-2d)
@@ -38,8 +41,24 @@
 (define %day-end 2)
 (define %start-money 20.0)
 
+(define-method (make-home)
+  (make <place>
+    #:name 'place
+    #:title "Home"
+    #:background home-background-image
+    #:actions (list (make <action>
+                      #:name "Test"
+                      #:condition (const #t)
+                      #:exec (lambda (mode)
+                               (pk 'testing))))))
+
+(define-method (make-farm-stand)
+  (make <place>
+    #:name 'place
+    #:title "Farm Stand"
+    #:background farm-stand-background-image))
+
 (define-class <game-mode> (<major-mode>)
-  (place #:accessor place #:init-keyword #:place #:init-value 'home)
   (story-points #:accessor story-points #:init-keyword #:story-points
                 #:init-value 0)
   (day #:accessor day #:init-keyword #:day #:init-value 0)
@@ -51,12 +70,17 @@
 (define-method (on-enter (mode <game-mode>))
   (let ((scene (parent mode)))
     (attach-to scene
-               (make <place>
-                 #:name 'home
-                 #:background home-background-image)
                (make <light-overlay>
                  #:name 'overlay
                  #:rank 8)
+               (make <dialog-box>
+                 #:name 'dialog
+                 #:rank 9
+                 #:text "Hello, world!
+How many characters fit on a line? 50 characters!!
+Hello, world!
+Hello, world!
+Hello, world!")
                (make <time-display>
                  #:name 'time
                  #:rank 9))
@@ -65,6 +89,22 @@
               (- %game-height (height (& scene time))))
     (reset-game mode)))
 
+(define-method (change-place (mode <game-mode>) (new-place <place>))
+  (let* ((scene (parent mode))
+         (old-place (& scene place)))
+    (when old-place
+      (detach old-place))
+    (attach-to scene new-place)
+    (set! (where (& scene time)) (title new-place))
+    (advance-clock mode 1)
+    (when (& scene menu)
+      (detach (& scene menu)))
+    (attach-to scene
+               (make <menu>
+                 #:name 'menu
+                 #:rank 9
+                 #:items (map name (actions new-place))))))
+
 (define-method (change-time (mode <game-mode>) t)
   (let ((scene (parent mode)))
     (set! (time mode) (clamp %time-wake %time-sleep t))
@@ -77,11 +117,15 @@
     (set! (day (& scene time)) (day mode))))
 
 (define-method (reset-game (mode <game-mode>))
-  (change-day mode %day-start)
-  (change-time mode %time-wake)
-  (set! (inventory mode) '())
-  (set! (flags mode) '())
-  (set! (money mode) %start-money))
+  (let ((scene (parent mode)))
+    (change-day mode %day-start)
+    (change-time mode %time-wake)
+    (change-place mode (make-home))
+    (set! (story-points mode) 0)
+    (set! (inventory mode) '())
+    (set! (flags mode) '())
+    (set! (money mode) %start-money)
+    (hide (& scene dialog))))
 
 (define-method (go-to-bed (mode <game-mode>))
   (let ((scene (parent mode)))
@@ -99,8 +143,31 @@
 (define-method (advance-clock-once (mode <game-mode>))
   (advance-clock mode 1))
 
-(bind-input <game-mode> (key-press 'space) advance-clock-once)
+(define-method (quit-game (mode <game-mode>))
+  (exit-catbird))
+
+(define-method (go-to-farm-stand (mode <game-mode>))
+  (change-place mode (make-farm-stand)))
+
+(define-method (go-home (mode <game-mode>))
+  (change-place mode (make-home)))
+
+(define-method (up-selection (mode <game-mode>))
+  (up-selection (& (parent mode) menu) 1))
+
+(define-method (down-selection (mode <game-mode>))
+  (down-selection (& (parent mode) menu) 1))
+
+(define-method (confirm-selection (mode <game-mode>))
+  (pk 'chose (selection (& (parent mode) menu))))
+
 (bind-input <game-mode> (key-press 'r) reset-game)
+(bind-input <game-mode> (key-press 'escape) quit-game)
+(bind-input <game-mode> (key-press 'f) go-to-farm-stand)
+(bind-input <game-mode> (key-press 'h) go-home)
+(bind-input <game-mode> (key-press 'up) up-selection)
+(bind-input <game-mode> (key-press 'down) down-selection)
+(bind-input <game-mode> (key-press 'return) confirm-selection)
 
 (define (make-game-scene)
   (make <scene>
diff --git a/apple-town-fair/menu.scm b/apple-town-fair/menu.scm
new file mode 100644
index 0000000..ad3b893
--- /dev/null
+++ b/apple-town-fair/menu.scm
@@ -0,0 +1,92 @@
+;;; Copyright © 2022 David Thompson <davet@gnu.org>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+(define-module (apple-town-fair menu)
+  #:use-module (apple-town-fair assets)
+  #:use-module (apple-town-fair common)
+  #:use-module (catbird asset)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics path)
+  #:use-module (chickadee graphics text)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math vector)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:export (<menu>
+            down-selection
+            selection
+            up-selection))
+
+
+(define-class <menu> (<node-2d>)
+  (items #:accessor items #:init-keyword #:items)
+  (item-nodes #:accessor item-nodes)
+  (selected-item #:accessor selected-item))
+
+(define-method (on-boot (menu <menu>))
+  (let ((nodes (map (lambda (item)
+                      (make <label>
+                        #:rank 1
+                        #:font monogram-font
+                        #:text item))
+                    (items menu)))
+        (padding 2.0))
+    (attach-to menu
+               (make <canvas>
+                 #:name 'highlight
+                 #:painter
+                 (with-style ((fill-color red))
+                   (fill
+                    (rectangle (vec2 0.0 0.0)
+                               (fold (lambda (node w)
+                                       (max w (width node)))
+                                     0.0
+                                     nodes)
+                               (fold (lambda (node h)
+                                       (max h (height node)))
+                                     0.0
+                                     nodes))))))
+    (apply attach-to menu nodes)
+    (let loop ((nodes (reverse nodes))
+               (prev #f))
+      (match nodes
+        (() #t)
+        ((node . rest)
+         (when prev
+           (place-above prev node #:padding padding))
+         (loop rest node))))
+    (set! (item-nodes menu) nodes)
+    (select-item menu 0)))
+
+(define-method (select-item (menu <menu>) i)
+  (let* ((i (clamp 0 (- (length (items menu)) 1) i))
+         (node (list-ref (item-nodes menu) i)))
+    (set! (selected-item menu) i)
+    (when node
+      (set! (position-y (& menu highlight))
+            (position-y node)))))
+
+(define-method (selection (menu <menu>))
+  (let ((node (list-ref (item-nodes menu) (selected-item menu))))
+    (and node (text node))))
+
+(define-method (up-selection (menu <menu>) n)
+  (select-item menu (- (selected-item menu) n)))
+
+(define-method (down-selection (menu <menu>) n)
+  (select-item menu (+ (selected-item menu) n)))
diff --git a/apple-town-fair/place.scm b/apple-town-fair/place.scm
index 45534a9..2cfb5ed 100644
--- a/apple-town-fair/place.scm
+++ b/apple-town-fair/place.scm
@@ -14,13 +14,37 @@
 ;;; along with this program.  If not, see
 ;;; <http://www.gnu.org/licenses/>.
 (define-module (apple-town-fair place)
+  #:use-module (catbird config)
   #:use-module (catbird node)
   #:use-module (catbird node-2d)
   #:use-module (oop goops)
-  #:export (<place>))
+  #:export (<action>
+            condition
+            duration
+            exec
+            performable?
+            perform
+            <place>
+            title
+            actions))
+
+(define-root-class <action> ()
+  (name #:accessor name #:init-keyword #:name)
+  (condition #:accessor condition #:init-keyword #:condition
+             #:init-form (const #t))
+  (exec #:accessor exec #:init-keyword #:exec)
+  (duration #:accessor duration #:init-keyword #:duration #:init-value 1))
+
+(define-method (performable? (action <action>) state)
+  ((condition action) state))
+
+(define-method (perform (action <action>) state)
+  ((exec action) state))
 
 (define-class <place> (<node-2d>)
-  (background #:accessor background #:init-keyword #:background))
+  (title #:accessor title #:init-keyword #:title #:init-value "Unknown")
+  (background #:accessor background #:init-keyword #:background)
+  (actions #:accessor actions #:init-keyword #:actions #:init-value '()))
 
 (define-method (on-boot (place <place>))
   (attach-to place
diff --git a/apple-town-fair/splash.scm b/apple-town-fair/splash.scm
index 9fcbd5b..63f90c1 100644
--- a/apple-town-fair/splash.scm
+++ b/apple-town-fair/splash.scm
@@ -36,16 +36,14 @@
 (define-class <splash-mode> (<major-mode>))
 
 (define %text-color (rgb #x181425))
-(define %background-color white)
+(define %background-color (rgb #xead4aa))
 
 (define-method (on-enter (mode <splash-mode>))
   (let ((scene (parent mode)))
     (attach-to scene
                (make <canvas>
                  #:painter
-                 (with-style ((fill-color %background-color))
-                   (fill
-                    (rectangle (vec2 0.0 0.0) %game-width %game-height))))
+                 (full-screen-rectangle %background-color))
                (make <sprite>
                  #:texture chickadee-image
                  #:position (vec2 (/ %game-width 2.0)
diff --git a/apple-town-fair/time-display.scm b/apple-town-fair/time-display.scm
index c36618f..e79b0d1 100644
--- a/apple-town-fair/time-display.scm
+++ b/apple-town-fair/time-display.scm
@@ -22,16 +22,21 @@
   #:use-module (chickadee graphics path)
   #:use-module (chickadee math vector)
   #:use-module (oop goops)
-  #:export (<time-display>))
+  #:export (<time-display>
+            where))
 
 (define-class <time-display> (<node-2d>)
-  (day #:accessor day #:init-keyword #:day #:init-value 0 #:observe? #t)
-  (time #:accessor time #:init-keyword #:time #:init-value 0 #:observe? #t))
+  (where #:accessor where #:init-value "XXXXXXXXXXX" #:observe? #t)
+  (day #:accessor day #:init-value 0 #:observe? #t)
+  (time #:accessor time #:init-value 0 #:observe? #t))
 
 (define-method (on-boot (t <time-display>))
   (attach-to t
              (make <canvas>
                #:name 'background)
+             (make <label>
+               #:name 'place
+               #:font monogram-font)
              (make <label>
                #:name 'day
                #:font monogram-font)
@@ -44,15 +49,21 @@
   (let ((padding 4.0))
     (set! (text (& t day)) (day->string (day t)))
     (set! (text (& t time)) (time->string (time t)))
+    (set! (text (& t place)) (where t))
     (set! (position-x (& t day)) padding)
     (set! (position-x (& t time)) padding)
     (set! (position-y (& t time)) padding)
+    (set! (position-x (& t place)) padding)
     (place-above (& t time) (& t day) #:padding padding)
-    (set! (width t) (+ (max (width (& t day)) (width (& t time)))
+    (place-above (& t day) (& t place) #:padding padding)
+    (set! (width t) (+ (max (width (& t day))
+                            (width (& t time))
+                            (width (& t place)))
                        (* padding 2.0)))
     (set! (height t) (+ (height (& t day))
                         (height (& t time))
-                        (* padding 3.0)))
+                        (height (& t place))
+                        (* padding 4.0)))
     (unless (painter (& t background))
       (set! (painter (& t background))
             (with-style ((fill-color (make-color 1.0 0.0 0.0 0.25)))
-- 
cgit v1.2.3