autumn-lisp-game-jam-2024/game.scm

437 lines
18 KiB
Scheme
Raw Permalink Normal View History

;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; 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:
;;;
;;; Example game showing off several common game programming things.
;;;
;;; Code:
2024-10-27 13:34:16 +01:00
(use-modules (scheme base)
(dom document)
(dom element)
2024-10-27 13:34:16 +01:00
(dom event)
2024-10-28 17:22:51 +01:00
(dom window)
(math vector)
(hoot ffi)
2024-10-28 17:22:51 +01:00
(hoot debug)
(hoot hashtables)
2024-10-28 17:22:51 +01:00
(srfi srfi-9)
2024-11-03 22:40:57 +01:00
(ice-9 match)
(math))
2024-10-28 09:25:14 +01:00
2024-10-27 13:34:16 +01:00
(define (sxml->dom exp)
(match exp
;; The simple case: a string representing a text node.
((? string? str)
(make-text-node str))
;; An element tree. The first item is the HTML tag.
(((? symbol? tag) . body)
;; Create a new element with the given tag.
(let ((elem (make-element (symbol->string tag))))
(define (add-children children)
;; Recursively call sxml->dom for each child node and
;; append it to elem.
(for-each (lambda (child)
(append-child! elem (sxml->dom child)))
children))
(match body
;; '@' denotes an attribute list. Child nodes follow.
((('@ . attrs) . children)
;; Set attributes.
(for-each (lambda (attr)
(match attr
;; Attributes are (symbol string) tuples.
(((? symbol? name) (? string? val))
(set-attribute! elem
(symbol->string name)
val))
(((? symbol? name) (? boolean? val))
(set-attribute! elem
(symbol->string name)
val))
(((? symbol? name) (? procedure? proc))
(add-event-listener! elem
(symbol->string name)
(procedure->external proc)))))
attrs)
(add-children children))
;; No attributes, just a list of child nodes.
(children (add-children children)))
elem))))
;; Lib
(define (sub-string-list string-list start len func)
(define (sub-string-list-iter string-list start len func part)
(if (string? (car string-list))
(if (> (string-length (car string-list)) start)
(append part
(if (= start 0 )
'()
2024-11-02 17:16:32 +01:00
(list (substring (car string-list) 0 start)))
2024-11-03 06:08:19 +01:00
(list (func (substring (car string-list) start len)))
(if (= len (string-length (car string-list)))
'()
2024-11-03 07:36:43 +01:00
(list (substring (car string-list) len (string-length (car string-list)))))
(cdr string-list))
(sub-string-list-iter (cdr string-list)
2024-11-03 06:08:19 +01:00
(abs (- start (string-length (car string-list))))
(abs (- len (string-length (car string-list))))
func
(append part (list (car string-list)))))
(sub-string-list-iter (cdr string-list)
(- start (string-length (car (last-pair (car string-list)))))
2024-11-03 06:08:19 +01:00
(- len (string-length (car (last-pair (car string-list)))))
func
(append part (list (car string-list))))))
(sub-string-list-iter string-list start len func '()))
2024-10-31 16:40:26 +01:00
(define (find-string-list-len string-list)
(define (find-string-list-len-iter string-list offset)
(if (string? (car string-list))
(if (string-index (car string-list) #\newline)
2024-11-03 07:36:43 +01:00
(+ (string-index (car string-list) #\newline) offset 1)
(find-string-list-len-iter (cdr string-list) (+ (string-length (car string-list)) offset)))
(find-string-list-len-iter (cdr string-list) (+ (string-length (car (last-pair (car string-list)))) offset) )))
(find-string-list-len-iter string-list 0))
2024-11-02 16:38:24 +01:00
(define (gen-update-list string-length x y xlen ylen)
(define (up-iter string-length x y xlen llen part)
2024-11-02 16:17:33 +01:00
(if (= 0 llen)
part
(up-iter string-length
2024-11-03 07:36:43 +01:00
x
2024-11-02 16:17:33 +01:00
(+ 1 y)
2024-11-02 16:38:24 +01:00
xlen
2024-11-02 16:17:33 +01:00
(- llen 1)
(append part
(list (list
(+ (* y string-length) x )
2024-11-02 16:38:24 +01:00
(+ xlen (+ (* y string-length) x))
2024-11-02 16:17:33 +01:00
))))))
2024-11-03 07:36:43 +01:00
(up-iter string-length x y xlen ylen '()))
2024-11-02 16:17:33 +01:00
2024-11-03 06:08:19 +01:00
(define (gen-string-list string-list update-list func)
(let loop ((string-list string-list)
(update-list update-list))
(if (equal? update-list '())
string-list
(loop (sub-string-list string-list
(car (car update-list))
(cadr (car update-list))
func)
(cdr update-list)))))
2024-11-03 22:40:57 +01:00
;; render
(define *template* '())
(define (wrap-template template)
`(div (@ (id "container"))
(div
(span ,(number->string *wood*) " wood ")
(span ,(number->string *stone*) " stone ")
(span ,(number->string *seed*) " seed "))
(button (@ (click ,(lambda (event)
(set! *template* template-map)
(render))))
"Map")
(div (@ (id "application")) ,(template))))
(define (render)
(let ((old (get-element-by-id "container")))
(unless (external-null? old) (remove! old))
(append-child! (document-body) (sxml->dom (wrap-template *template*)))))
;; woods
(define *gather* #f)
(define (template-woods)
(define wood-script '(
" 888888888/' 888888888/' "
" 88\\*888;*/88 888888888/' 88\\*888;*/88 "
"888'\\*88|/8888 88\\*888;*/88 888'\\*88|/8888"
"8888{888}88_/8 888'\\*88|/8888 8888{888}88_/8 "
"88\\88\\. /_'88 8888{888}88_/8 88\\88\\. /_'88 "
" \\_} { 88\\88\\. /_'88 \\_} { "
" { } \\_} { { } "
" } { { } } { "
" { } } { o { } "
"_o__//..\\\\____O______{ }______|_____//..\\\\_ "
" //..\\\\ "
))
`(pre ,(string-append (string-join wood-script "\n") "\n")
,(if *gather*
`(button (@ (click ,(lambda (event)
(set! *gather* #f)
(render))))
"Stop gather")
`(button (@ (click ,(lambda (event)
(set! *gather* #t)
(render))))
"Start gather"))))
;; Map
(define (template-map)
2024-11-03 06:08:19 +01:00
(define (blod string)
2024-11-03 22:40:57 +01:00
`(b (@ (click ,(lambda (event)
(set! *template* template-woods)
(render)))
(style "cursor: pointer;")
(title "Woods"))
,string ))
(define (farm string)
`(b (@ (click ,(lambda (event)
(set! *template* template-farm)
(render)))
(style "cursor: pointer;")
(title "Farm"))
,string ))
(define map-script '(
"______________________________________"
"| 88 88 88 88 |"
"|8888 88 8888 8888 88888 |"
"| || 8888 || || || |"
"| || 88 88 88 |"
"| 8888 8888 88888 88888 |"
"| || || || || |"
"| |"
"| |"
"| |"
"| _ |"
"| /%\\ |"
"| | | |"
"| |"
":____________________________________:"
2024-11-03 06:08:19 +01:00
))
2024-11-03 22:40:57 +01:00
`(pre ,@(gen-string-list (gen-string-list (list (string-join map-script "\n"))
(gen-update-list
(find-string-list-len (list (string-join map-script "\n"))) 1 1 36 6)
blod)
(gen-update-list
(find-string-list-len (list (string-join map-script "\n"))) 29 10 3 3)
farm)))
;; Plant
(define-record-type <plant>
(make-plant name time watering?)
plant?
(name plant-name)
(time plant-time set-plant-time!)
(watering? plant-watering? set-plant-watering!))
(define *plants* '())
(define (add-plant! plant)
(set! *plants* (cons plant *plants*)))
(define (remove-plant! plant)
(set! *plants* (delq plant *plants*)))
(define (template-plant)
(define (plant-template plant)
`(li
(span (@ (style "padding: 0 1em 0 1em;"))
,(string-append (plant-name plant) " "(number->string (plant-time plant))))
,(if (plant-watering? plant)
`(span "")
(if *well-build?*
`(a (@ (href "#")
(click ,(lambda (event)
(set-plant-time! plant (ceiling (/ (plant-time plant) 2)))
(set-plant-watering! plant #t)
(render)))) "watering ")
`(span "")))
(a (@ (href "#")
(click ,(lambda (event)
(remove-plant! plant)
(render))))
,(if (= 0 (plant-time plant))
"gather "
"remove "))))
(define (plant)
(list-ref '("🍆" "🥔" "🥕" "🌽" "🌶️" "🫑" "🥒" "🥬" "🥦" "🧄" "🧅" "🥜" "🫘" "🌰" "🫚" "🫛" "🍄‍"
"🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" "🎃" ) (random-int 34)))
`(div
(h2 "Fields")
(ul ,@(map plant-template (reverse *plants*)))
,(if *fields-clean?*
`(button (@ (click ,(lambda (event)
(when (> *seed* 0)
(set! *seed* (- *seed* 1))
(add-plant! (make-plant (plant) (+ 300 (random-int 300)) #f))
(render)))))
"Plant")
`(button (@ (click ,(lambda (event)
(when (and (> *wood* 30) (> *stone* 10))
(set! *wood* (- *wood* 30))
(set! *stone* (- *wood* 10))
(set! *seed* (+ *seed* 7))
(set! *fields-clean?* #t)
(render)))))
"Clear the fields (wood x30 stone x10)")
)))
(define *workshop-clean?* #f)
(define *cart-build?* #f)
(define *reaping-hook-build?* #f)
(define *well-build?* #f)
(define (template-workshop)
`(div
(h2 "Workshop")
,(if *workshop-clean?*
`(ul
(li
,(if *cart-build?*
`(span "Cart")
`(button (@ (click ,(lambda (event)
(when (> *wood* 100)
(set! *wood* (- *wood* 100))
(set! *cart-build?* #t)
(render)))))
"Cart (wood x100)")))
(li
,(if *reaping-hook-build?*
`(span "Reaping hook")
`(button (@ (click ,(lambda (event)
(when (and (> *wood* 20) (> *stone* 20))
(set! *wood* (- *wood* 20))
(set! *stone* (- *stone* 20))
(set! *reaping-hook-build?* #t)
(render)))))
"Reaping hook (wood x20 stone x20)")))
(li
,(if *well-build?*
`(span "Well")
`(button (@ (click ,(lambda (event)
(when (and (> *wood* 50) (> *stone* 200))
(set! *wood* (- *wood* 50))
(set! *stone* (- *stone* 200))
(set! *well-build?* #t)
(render)))))
"Well (wood x50 stone x200)"))))
`(button (@ (click ,(lambda (event)
(when (and (> *wood* 200) (> *stone* 50))
(set! *wood* (- *wood* 200))
(set! *stone* (- *stone* 50))
(set! *workshop-clean?* #t)
(render)))))
"Clear the workshop (wood x200 stone x50)"))))
;; Farm
(define (template-farm)
(define (blod string)
`(b (@ (click ,(lambda (event)
(set! *template* template-woods)
(render)))
(style "cursor: pointer;")
(title "Woods"))
,string ))
(define map-script '(
" __ "
" ,-_ (` ). "
" |-_'-, ( ). "
" |-_'-' _( '`. "
" _ |-_'/ .=(`( . )"
" /;-,_ |-_' ( (.__.:-`-_.' "
" /-.-;,-,___|' `( ) ) "
" /;-;-;-;_;_/|\\_ _ _ _ _ ` __.:' ) "
" x_( __`|_P_|`-;-;-;,| `--' "
" |\\ \\ _|| `-;-;-' "
" | \\` -_|. '-' "
" | / /-_| ` "
" |/ ,'-_| \\ "
" /____|'-_|___\\ "
" _..,____]__|_\\-_'|_[___,.._ "
" ' ``'--,..,. "
" "
" :--:---:---:---:---:---:--: "
" | #.|%& #.|%& #.|%& #.|%& | "
" | #.|%& #.|%& #.|%& #.|%& | "
" | #.|%& #.|%& #.|%& #.|%& | _ "
" | #.|%& #.|%& #.|%& #.|%& | (O) "
" | #.|%& #.|%& #.|%& #.|%& | ¨ "
" | #.|%& #.|%& #.|%& #.|%& | "
" | #.|%& #.|%& #.|%& #.|%& | "
" | #.|%& #.|%& #.|%& #.|%& | "
" | #.|%& #.|%& #.|%& #.|%& | "
" :--:---:---:---:---:---:--: "
))
`(pre ,(string-append (string-join map-script "\n") "\n")
,(template-plant)
,(template-workshop)))
2024-11-03 06:08:19 +01:00
2024-10-27 13:34:16 +01:00
;; Main
2024-11-03 22:40:57 +01:00
(set! *template* template-map)
(define *wood* 0)
(define *stone* 0)
(define *seed* 0)
(define *fields-clean?* #f)
(define (template-main)
`(div
(span ,(number->string *wood*) " wood ")
(span ,(number->string *stone*) " stone ")
(span ,(number->string *seed*) " seed ")))
2024-10-28 17:22:51 +01:00
(define *update-list* '())
2024-11-03 22:40:57 +01:00
(define dt 1000.0)
2024-10-28 17:22:51 +01:00
(define-record-type <timeout-function>
(make-timeout-function interval countdown func)
timeout-function?
(interval timeout-function-interval set-timeout-function-interval!)
(countdown timeout-function-countdown set-timeout-function-countdown!)
(func timeout-function-func))
2024-11-03 22:40:57 +01:00
(define *cart-build?* #f)
(define *reaping-hook-build* #f)
(define (plus-res)
(if *gather*
(begin
(if *cart-build?*
(set! *wood* (+ *wood* 12))
(set! *wood* (+ *wood* 5)))
(if *cart-build?*
(set! *stone* (+ *stone* 7))
(set! *stone* (+ *stone* 3)))
(if *reaping-hook-build?*
(when (> 30 (random-int 100))
(set! *seed* (+ *seed* 1)))
(when (> 5 (random-int 100))
(set! *seed* (+ *seed* 1)))))))
(define (update-plant-time)
(for-each (lambda (i)
(unless (= (plant-time i) 0)
(set-plant-time! i (- (plant-time i) 1))
(render)))
*plants*))
2024-10-28 17:22:51 +01:00
2024-11-03 22:40:57 +01:00
(set! *update-list* (append *update-list* (list (make-timeout-function 1 1 plus-res))))
(set! *update-list* (append *update-list* (list (make-timeout-function 1 1 update-plant-time))))
2024-10-28 17:22:51 +01:00
(define (update)
(for-each (lambda (i)
(if (= (timeout-function-countdown i) 0)
(begin
((timeout-function-func i))
(set-timeout-function-countdown! i (timeout-function-interval i))
2024-11-03 22:40:57 +01:00
(render))
2024-10-28 17:22:51 +01:00
(set-timeout-function-countdown! i (- (timeout-function-countdown i) 1))))
*update-list*)
(timeout update-callback dt))
(define update-callback (procedure->external update))
2024-10-27 13:34:16 +01:00
(render)
2024-10-28 17:22:51 +01:00
(timeout update-callback dt)