about summary refs log tree commit diff stats
diff options
context:
space:
mode:
authorCase Duckworth2023-05-29 22:42:29 -0500
committerCase Duckworth2023-05-29 22:42:29 -0500
commit5462ffbe3c4584d0838611d4c7006ce02d4a1358 (patch)
tree70f4e7b6e494f202c8053da9a1caee47ce2c68c7
downloadapple-5462ffbe3c4584d0838611d4c7006ce02d4a1358.tar.gz
apple-5462ffbe3c4584d0838611d4c7006ce02d4a1358.zip
Initial commit
-rwxr-xr-xgame.scm177
-rwxr-xr-xgame2.scm205
2 files changed, 382 insertions, 0 deletions
diff --git a/game.scm b/game.scm new file mode 100755 index 0000000..a799ba7 --- /dev/null +++ b/game.scm
@@ -0,0 +1,177 @@
1#!/bin/sh
2#| -*- scheme -*-
3exec csi -R r7rs -ss "$0" "$@"
4|#
5#+chicken (import r7rs)
6
7(import (scheme base)
8 (scheme write)
9 (chicken io)
10 (chicken port)
11 (srfi 133)
12 (yolk common)
13 (yolk xterm)
14 (yolk erase)
15 (yolk cursor)
16 (matchable)
17 (stty))
18
19(define (draw . instructions)
20 (for-each (lambda (i)
21 (cond
22 ((string? i)
23 (display i))
24 ((list? i)
25 (apply draw i))))
26 instructions))
27
28(define me
29 (string-append "@" (cursor-left 1)))
30
31(define rock
32 (string-append "o" (cursor-left 1)))
33
34(define blank
35 (string-append " " (cursor-left 1)))
36
37(define WIDTH
38 (make-parameter 80))
39
40(define HEIGHT
41 (make-parameter 24))
42
43(define WORLD
44 (make-vector (* (WIDTH) (HEIGHT)) 0))
45
46(define (get-position x y)
47 (if (or (> x (WIDTH))
48 (< x 0)
49 (> y (HEIGHT))
50 (< y 0))
51 #f
52 (vector-ref WORLD (+ y (* (WIDTH) x)))))
53
54(define (set-position! x y thing)
55 (if (or (> x (WIDTH))
56 (< x 0)
57 (> y (HEIGHT))
58 (< y 0))
59 (error "Out of bounds" (list (WIDTH) (HEIGHT)) (list x y))
60 (vector-set! WORLD (+ y (* (WIDTH) x)) thing)))
61
62(define X
63 (make-parameter (/ (WIDTH) 2)))
64
65(define Y
66 (make-parameter (/ (HEIGHT) 2)))
67
68(define (move-up)
69 (unless (<= (Y) 2)
70 (draw blank (cursor-up 1) me)
71 (Y (- (Y) 1))))
72
73(define (move-left)
74 (unless (<= (X) 2)
75 (draw blank (cursor-left 1) me)
76 (X (- (X) 1))))
77
78(define (move-right)
79 (unless (>= (X) (- (WIDTH) 1))
80 (draw blank (cursor-right 1) me)
81 (X (+ (X) 1))))
82
83(define (move-down)
84 (unless (>= (Y) (- (HEIGHT) 1))
85 (draw blank (cursor-down 1) me)
86 (Y (+ (Y) 1))))
87
88(define (game-setup)
89 (stty '(raw (not echo)))
90 (set-buffering-mode! (current-input-port) #:none 1)
91 (set-buffering-mode! (current-output-port) #:none 1)
92 ;; Set up screen
93 (draw alt-buffer-enable
94 erase-screen
95 (cursor-save)
96 invisible-cursor)
97
98 ;; Draw borders
99 (draw cursor-home
100 "/"
101 (list->string
102 (let loop ((c 1)
103 (acc '()))
104 (if (>= c (- (WIDTH) 1))
105 acc
106 (loop (+ 1 c)
107 (cons #\- acc)))))
108 "\\"
109 (let loop ((r 2)
110 (acc '()))
111 (if (>= r (HEIGHT))
112 acc
113 (loop (+ 1 r)
114 (append `(,(cursor-move 0 r)
115 "|"
116 ,(cursor-move (WIDTH) r)
117 "|")
118 acc))))
119 (cursor-move 1 (HEIGHT))
120 "\\"
121 (list->string
122 (let loop ((c 1)
123 (acc '()))
124 (if (>= c (- (WIDTH) 1))
125 acc
126 (loop (+ 1 c)
127 (cons #\- acc)))))
128 "/")
129
130 ;; Draw character
131 (draw (cursor-move (X) (Y))
132 me))
133
134(define (game-cleanup)
135 (stty '(cooked echo))
136 (draw cursor-home
137 (cursor-restore)
138 alt-buffer-disable
139 visible-cursor))
140
141(define (readch)
142 (integer->char (read-byte)))
143
144(define (car* x)
145 (and (pair? x)
146 (car x)))
147
148(define (game-loop)
149 (let loop ((c (readch)))
150 (if (eq? c 'done)
151 #t
152 (let ((done? #f))
153 (match c
154 ((or #\q #\) (set! done? #t))
155 (#\h (move-left))
156 (#\j (move-down))
157 (#\k (move-up))
158 (#\l (move-right))
159 ;; Escape characters
160 (#\escape
161 (match (readch)
162 (#\[ (match (readch)
163 (#\A (move-up))
164 (#\B (move-down))
165 (#\C (move-right))
166 (#\D (move-left))
167 (else)))
168 (else)))
169 (else))
170 (loop (if done? 'done (readch)))))))
171
172(define (main args)
173 (dynamic-wind
174 game-setup
175 game-loop
176 game-cleanup)
177 #t)
diff --git a/game2.scm b/game2.scm new file mode 100755 index 0000000..f3d67db --- /dev/null +++ b/game2.scm
@@ -0,0 +1,205 @@
1#!/bin/sh
2#| -*- scheme -*-
3exec csi -R r7rs -ss "$0" "$@"
4game
5|#
6
7(import (scheme base)
8 (scheme write)
9 (chicken io)
10 (chicken port)
11 (yolk common)
12 (yolk xterm)
13 (yolk erase)
14 (yolk cursor)
15 (matchable)
16 (stty))
17
18(define (log . xs)
19 (with-output-to-port (current-error-port)
20 (lambda ()
21 (for-each (lambda (x) (display x) (display " ") x)
22 xs)
23 (newline))))
24
25(define (main args)
26 (parameterize ((world (make-world 80 25)))
27 (dynamic-wind game-setup
28 game-loop
29 game-cleanup))
30 #t)
31
32(define (game-setup)
33 ;; Prepare terminal
34 (stty '(raw (not echo)))
35 (set-buffering-mode! (current-input-port) #:none 1)
36 (set-buffering-mode! (current-output-port) #:none 1)
37 (draw alt-buffer-enable
38 erase-screen
39 (cursor-save)
40 invisible-cursor)
41 ;; Set up world
42 (world-init (world))
43 (world-draw (world)))
44
45(define (game-cleanup)
46 ;; Restore terminal
47 (stty '(cooked echo))
48 (draw cursor-home
49 (cursor-restore)
50 alt-buffer-disable
51 visible-cursor))
52
53(define (game-loop)
54 (let loop ((c (readch)))
55 (if (eq? c 'done)
56 #t
57 (let ((done? #f))
58 (match c
59 ((or #\q #\)
60 (set! done? #t))
61 ;; Escape characters
62 (#\escape
63 (match (readch)
64 (#\[ (match (readch)
65 (#\A (up!))
66 (#\B (down!))
67 (#\C (right!))
68 (#\D (left!))
69 (else)))
70 (else)))
71 (else))
72 (world-draw (world))
73 (loop (if done? 'done (readch)))))))
74
75(define (readch)
76 (let ((c (integer->char (read-byte))))
77 c))
78
79(define (draw . instructions)
80 (for-each (lambda (i)
81 (cond
82 ((string? i) (display i))
83 ((list? i) (apply draw i))
84 (else (error "Don't know how to draw" i))))
85 instructions))
86
87(define-record-type world
88 (%make-world width height map)
89 world?
90 (width world-width world-width-set!)
91 (height world-height world-height-set!)
92 (map world-map world-map-set!))
93
94(define (in-bounds? world x y)
95 (or (< x (world-width world))
96 (> x 0)
97 (< y (world-height world))
98 (> y 0)))
99
100(define (coords->index world x y)
101 (if (in-bounds? world x y)
102 (+ x (* (world-width world) y))
103 (error "Out of bounds"
104 (list (world-width world) (world-height world))
105 (list x y))))
106
107(define (world-get world x y)
108 (vector-ref (world-map world) (coords->index world x y)))
109
110(define (world-set! world x y obj)
111 (vector-set! (world-map world)
112 (coords->index world x y)
113 obj))
114
115(define (make-world width height)
116 (%make-world width height (make-vector (* width height) #f)))
117
118(define world (make-parameter #f))
119
120(define (for-world proc world)
121 (do ((y 1 (+ y 1)))
122 ((= y (world-height world)) #t)
123 (do ((x 1 (+ x 1)))
124 ((= x (world-width world)) #t)
125 (proc world x y))))
126
127(define (world-draw world)
128 (draw cursor-home)
129 (for-world (lambda (w x y)
130 (cond
131 ((thing? (world-get w x y))
132 (draw (cursor-move x y)
133 (thing-look (world-get w x y))))
134 (else
135 (draw (cursor-move x y)
136 " "))))
137 world))
138
139(define (world-init world)
140 (for-world (lambda (w x y)
141 (cond
142 ((or (= x 1)
143 (= y 1)
144 (= x (- (world-width world) 1))
145 (= y (- (world-height world) 1)))
146 (thing-place! w (wall x y)))
147 (else)))
148 world)
149 (thing-place! world (me)))
150
151(define-record-type thing
152 (make-thing name look x y z attrs)
153 thing?
154 (name thing-name)
155 (look thing-look thing-look-set!)
156 (x thing-x thing-x-set!)
157 (y thing-y thing-y-set!)
158 (z thing-z thing-z-set!)
159 (attrs thing-attrs thing-attrs-set!))
160
161(define (thing-place! world thing)
162 (world-set! world (thing-x thing) (thing-y thing) thing))
163
164(define (thing-move! world thing x y)
165 (world-set! world (thing-x thing) (thing-y thing) #f)
166 (thing-x-set! thing x)
167 (thing-y-set! thing y)
168 (world-set! world x y thing))
169
170(define (thing-move-relative! world thing dx dy)
171 (let* ((new-x (+ (thing-x thing) dx))
172 (new-y (+ (thing-y thing) dy))
173 (other (world-get world new-x new-y)))
174 (cond
175 ((and (thing? other)
176 (> (thing-z other) (thing-z thing))))
177 (else
178 (cond ((< new-x 1)
179 (set! new-x 1))
180 ((> new-x (- (world-width world) 1))
181 (set! new-x (- (world-width world) 1))))
182 (cond ((< new-y 1)
183 (set! new-y 1))
184 ((> new-y (- (world-height world) 1))
185 (set! new-y (- (world-height world) 1))))
186 (thing-move! world thing new-x new-y)))))
187
188(define (wall x y)
189 (make-thing 'wall "#" x y 100 '()))
190
191(define me
192 (make-parameter
193 (make-thing 'me "@" 40 10 2 '())))
194
195(define (up!)
196 (thing-move-relative! (world) (me) 0 -1))
197
198(define (down!)
199 (thing-move-relative! (world) (me) 0 1))
200
201(define (right!)
202 (thing-move-relative! (world) (me) 1 0))
203
204(define (left!)
205 (thing-move-relative! (world) (me) -1 0))