-
Notifications
You must be signed in to change notification settings - Fork 0
/
puz.scm
207 lines (186 loc) · 8.27 KB
/
puz.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
;; -*- mode: scheme; compile-command: "ol-rl -r puz.scm" -*-
(import
(owl toplevel)
(owl lazy)
(owl random)
(raylib)
(puz assets)
(puz util)
(puz map)
(puz move)
(puz draw)
(puz map-cache)
(puz maze)
)
;; owl bug?
(define a 'a)
;; deleting this define causes owl to complain about lack of g5 lol lol
(define-syntax at-runtime
(syntax-rules ()
((at-runtime mf)
(λ ()
(set-target-fps! (<< 2 32))
(let ((v (save-cache (load-map-from-memory mf) #f)))
(set-target-fps! target-fps)
v)))))
(define Maps-init
(list
(load-map-maybe-cache "map.text")
;; (load-map-maybe-cache "map.temp")
(at-runtime (create-maze 8 8 (time-ms) #\1))
(at-runtime (create-maze 32 16 (time-ms) #\2))
))
;; TODO: particle w wątkach?
;; TODO: R - restart
(define (puz sounds textures finish)
(let ((finish-f (λ () (finish textures sounds)))) ;; wow
(let loop ((ppos (aq 'initial-player-pos (car Maps-init)))
(camera-pos (real-p (aq 'initial-player-pos (car Maps-init))))
(key-queue ())
(blocksq (list (aq 'initial-blocks (car Maps-init))))
(buttonsq (list (aq 'initial-button-states (car Maps-init))))
(undo ())
(mapq `(0))
(Maps Maps-init)
(debug #f))
(update-music-stream (aq 'amb sounds))
(lets ((ppos-prev ppos)
(key-queue (append key-queue (current-keys)))
(blocks (car blocksq))
(buttons (car buttonsq))
(ppos (maybe-door (aq 'doors (lref Maps (car mapq))) ppos sounds))
(Maps ppos mapq blocksq buttonsq (maybe-change-map Maps ppos mapq blocksq buttonsq))
(ppos key-queue blocks buttons
(dispatch-move (aq 'map (lref Maps (car mapq))) ppos key-queue (car blocksq) (car buttonsq) sounds finish-f))
(debug (if (key-pressed? key-g) (not debug) debug))
(camera camera-pos (camera ppos camera-pos))
;; maybe do undo?
(ppos blocks mapq undo (if (key-pressed? key-u)
(let ((lu (lref undo (max 0 (- (length undo) 2)))))
(play-sound (aq 'undo sounds))
(values (car lu) (cadr lu) (caddr lu) (ldel undo (- (length undo) 1))))
(values ppos blocks mapq undo)))
(blocksq (lset blocksq 0 blocks))
(buttonsq (lset buttonsq 0 buttons)))
(draw
(clear-background black)
(draw-background-textures textures)
(with-camera2d
camera
(begin ;; TODO: ugly hack - fix with-camera2d macro
(when debug (draw-grid-lines))
(draw-map (aq 'map (lref Maps (car mapq))) ppos textures buttons)
(draw-blocks blocks textures)
(draw-player ppos textures)))
(when debug
(draw-text (aq 'font textures) (str* buttons) '(0 0) 32 0 white))
;; the shadow thingy
(draw-rectangle
`(0 0 ,width ,height)
(color 0 0 0 (clamp 0 255 (- (floor (/ (vec2dist (real-p ppos) camera-pos) 4)) 25))))
(draw-fps '(0 0)))
(let ((undo (if (equal? (last undo ()) (list ppos blocks mapq))
undo
(begin
(play-sound (aq 'walk sounds))
(append undo (list (list ppos blocks mapq)))))))
(if (window-should-close?)
0
(loop
ppos
camera-pos
(take key-queue 4)
blocksq
buttonsq
undo
mapq
Maps
debug)))))))
(define (main-menu sounds textures finish skip-press)
(lets ((font (aq 'font textures))
(title "[puz]")
(title-w title-h (measure-text font title 42 0))
(start-btn-t "Start game")
(sb-w sb-h (measure-text font start-btn-t 32 0)))
(with-mainloop
(when skip-press
(let L ()
(if (mouse-btn-down? mouse-button-left)
(begin (draw 0) (L))
0)))
(let* ((md (mouse-delta))
(∆sum (+ (car md) (cdr md)))
(start-rect (list (- (/ width 2) (/ sb-w 2) 16)
(- (/ height 2) 16)
(+ sb-w 32)
(+ sb-h 32)))
(⍺ (if (collision-point-rect? (mouse-pos) start-rect) 255 (floor (+ 128 (* 0.25 (abs ∆sum))))))
(s-color (if (and (mouse-btn-down? mouse-button-left) (collision-point-rect? (mouse-pos) start-rect))
orange
(color 158 98 15 ⍺))))
(draw
(draw-background-textures textures)
(draw-text font title (list (- (/ width 2) (/ title-w 2)) (/ height 4)) 42 0 white)
(draw-rectangle-rounded start-rect 0.3 10 s-color)
(draw-text font start-btn-t (list (- (/ width 2) (/ sb-w 2)) (/ height 2)) 32 0 white)
)
(when (and (mouse-btn-down? mouse-button-left) (collision-point-rect? (mouse-pos) start-rect))
(play-sound (aq 'door sounds))
(puz sounds textures finish))
))))
(define (finish textures sounds)
(lets ((font (aq 'font textures))
(title "Congrats! that's that")
(title-w title-h (measure-text font title 42 0))
(mm-btn-t "back to main menu")
(mm-w mm-h (measure-text font mm-btn-t 32 0))
(exit-btn-t "exit")
(exit-w exit-h (measure-text font exit-btn-t 32 0)))
(with-mainloop
(let* ((md (mouse-delta))
(∆sum (+ (car md) (cdr md)))
(mm-rect (list (- (/ width 2) (/ mm-w 2) 16)
(- (/ height 2) 16)
(+ mm-w 32)
(+ mm-h 32)))
(exit-rect (list (- (/ width 2) (/ exit-w 2) 16)
(- height (/ height 4) 16)
(+ exit-w 32)
(+ exit-h 32)))
(mm-⍺ (if (collision-point-rect? (mouse-pos) mm-rect) 255 (floor (+ 128 (* 0.25 (abs ∆sum))))))
(exit-⍺ (if (collision-point-rect? (mouse-pos) exit-rect) 255 (floor (+ 128 (* 0.25 (abs ∆sum))))))
(mm-color (if (and (mouse-btn-down? mouse-button-left) (collision-point-rect? (mouse-pos) mm-rect))
orange
(color 158 98 15 mm-⍺)))
(exit-color (if (and (mouse-btn-down? mouse-button-left) (collision-point-rect? (mouse-pos) exit-rect))
orange
(color 158 98 15 exit-⍺))))
(draw
(draw-background-textures textures)
(draw-text font title (list (- (/ width 2) (/ title-w 2)) (/ height 4)) 42 0 white)
(draw-rectangle-rounded mm-rect 0.3 10 mm-color)
(draw-text font mm-btn-t (list (- (/ width 2) (/ mm-w 2)) (/ height 2)) 32 0 white)
(draw-rectangle-rounded exit-rect 0.3 10 exit-color)
(draw-text font exit-btn-t (list (- (/ width 2) (/ exit-w 2)) (- height (/ height 4))) 32 0 white) ;
)
(when (and (mouse-btn-down? mouse-button-left) (collision-point-rect? (mouse-pos) mm-rect))
(play-sound (aq 'door sounds))
(main-menu sounds textures finish #t))
(when (and (mouse-btn-down? mouse-button-left) (collision-point-rect? (mouse-pos) exit-rect))
(play-sound (aq 'door sounds))
(exit-owl 0))
))))
(define (main _)
(set-target-fps! target-fps)
(with-window
width height "puz"
(let* ((_ (init-audio-device))
(sounds (load-sounds))
(textures (load-textures)))
(set-master-volume! 0.3)
;; (for-each (λ (t) (set-texture-filter! (cdr t) texture-filter-bilinear)) textures)
(for-each (λ (t) (set-texture-filter! (cdr t) texture-filter-point)) textures)
;; hmmm idk which ones better
(play-music-stream (aq 'amb sounds))
(main-menu sounds textures finish #f))))
main