summaryrefslogtreecommitdiff
path: root/apple-town-fair
diff options
context:
space:
mode:
Diffstat (limited to 'apple-town-fair')
-rw-r--r--apple-town-fair/assets.scm6
-rw-r--r--apple-town-fair/dialog-box.scm47
-rw-r--r--apple-town-fair/game.scm87
-rw-r--r--apple-town-fair/menu.scm92
-rw-r--r--apple-town-fair/place.scm28
-rw-r--r--apple-town-fair/splash.scm6
-rw-r--r--apple-town-fair/time-display.scm21
7 files changed, 265 insertions, 22 deletions
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,17 +22,22 @@
#: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)
(make <label>
@@ -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)))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-22 01:14:59 +0000