-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathuser-interface.scm
230 lines (212 loc) · 10.1 KB
/
user-interface.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
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
;;; user-interface.scm
;;; Hoitaa kommunikoinnin käyttäjän kanssa,
;;; eli hoitaa ikkunaa ja näppäimistöä
;;; Avaa ikkunan, käsittelee inputtia
;;; silmukassa ja pyörittää koko roskaa, lopulta
;;; sulkee ikkunan ja palaa.
(define (user-interface maze-interface player camera ticker)
(load "realtime-and-cached-image-mixer.scm")
(let* ((xo (new-xdraw "-geometry" initial-window-size-string))
(image-mixer (new-realtime-and-cached-image-mixer xo
camera
player
maze-interface))
; Luodaan parilista, joka sisältää jokaisen käytetyn näppäimen
; tilan listana muodossa ( <key-cmd-id> . <key-cmd-state> )
(keys (map (lambda (key-id)
(cons key-id false))
(map cadr key-bindings))))
;;; ==================================================
;;; user-interface -apufunktiot
;;; ==================================================
(define (event-id e) (cadr e))
(define (event-params e) (cddr e))
(define (resize-event-width e) (caddr e))
(define (resize-event-height e) (cadddr e))
(define (key-event-keyname e) (cadddr (cddr e)))
; Muuntaa x-drawin palauttaman napin nimen vastaavan sidonnan nimeksi
(define (keyname->key-command name)
(let ((binding (assoc name key-bindings)))
(if binding
(cadr binding)
false)))
; Onko näppäinkomento määritelty stickyksi, eli.. joo, katso handle-key-event :)
(define (sticky-key-cmd? key-cmd)
(eq? 'sticky (cadr (assq key-cmd (map cdr key-bindings)))))
; Asettaa näppäinkomennon tilan, eli tiedon onko vastaava nappi pohjassa
(define (key-cmd-set! key-cmd state)
(set-cdr! (assq key-cmd keys)
state))
; Onko sidontaa vastaava nappi pohjassa?
(define (key-cmd-active? key-cmd)
(cdr (assq key-cmd keys)))
;;; ==================================================
;;; user-interfacen pääsilmukka (input-loop)
;;; ==================================================
;;; -Tutkitaan odottavat eventit (handle-events)
;;; -Toimitaan näppäimistön tilanteen mukaan (check-keys)
;;; -Piirretään näkymä (draw-scene)
;;; -Toistetaan, mikäli käyttäjä ei ole sulkemassa ohjelmaa
(define (input-loop done?)
;;; ==================================================
;;; input-loop -apufunktiot
;;; ==================================================
; Käsitellään x-ikkunassa odottavat eventit
(define (handle-events)
; handle-events -apufunktiot -------------------------------------
; Päivitetään tieto ikkunan koosta
(define (handle-resize-event event)
((camera 'set-window-size-x.y!) (cons (resize-event-width event)
(resize-event-height event)))
((image-mixer 'update-cached-images!)))
; Päivitetään eventtiä vastaavan näppäimen tila keys-listassa
(define (handle-key-event event press-event?)
(let ((key-cmd (keyname->key-command (key-event-keyname event))))
(if key-cmd
; Vain sticky-näppäimet nostetaan jo tässä
; (ennenkuin niiden mukainen toiminto on välttämättä suoritettu)
(if (or (sticky-key-cmd? key-cmd)
press-event?)
(key-cmd-set! key-cmd press-event?)))))
; handle-events -runko -------------------------------------------
; Kutsutaan handle-*-event -funktioita kunnes eventtijono on tyhjä
(let ((event (xo 'get-event)))
(if (not (null? event))
(let ((id (event-id event)))
(begin
(cond ((eq? id 'Resize) (handle-resize-event event))
((eq? id 'KeyPress) (handle-key-event event true))
((eq? id 'KeyRelease) (handle-key-event event false)))
(handle-events))))))
; Toimitaan&liikutaan painettuna olevien näppäinten mukaan
; (lähinnä käskytetään pelaajaoliota/kameraa)
; Nostetaan non-sticky -näppäimet ylös käsittelyn jälkeen
(define (check-keys)
; check-keys -apufunktiot ----------------------------------------
(define (take-actions)
; Vasemmalle/oikealle -nappi painettuna?
(if (and (key-cmd-active? 'step-left)
(key-cmd-active? 'step-right))
((player 'move) 'stop-left-right)
(if (key-cmd-active? 'step-left)
((player 'move) 'step-left)
(if (key-cmd-active? 'step-right)
((player 'move) 'step-right))))
; Eteen/taakse -nappi painettuna?
(if (and (key-cmd-active? 'step-forward)
(key-cmd-active? 'step-backward))
((player 'move) 'stop-forward-backward)
(if (key-cmd-active? 'step-forward)
((player 'move) 'step-forward)
(if (key-cmd-active? 'step-backward)
((player 'move) 'step-backward))))
; Käännös vasemmalle/oikealle -nappi painettuna?
(if (and (key-cmd-active? 'turn-left)
(key-cmd-active? 'turn-right))
((player 'move) 'stop-turning)
(if (key-cmd-active? 'turn-left)
((player 'move) 'turn-left)
(if (key-cmd-active? 'turn-right)
((player 'move) 'turn-right))))
; True inertia?
(if (key-cmd-active? 'toggle-true-inertia)
(set! true-inertia? (not true-inertia?))
(((player 'locator) 'set-kinetic-attributes!) (if true-inertia?
player-true-inertia-kinetic-attributes
player-normal-kinetic-attributes)))
; Soihdun heitto?
(if (key-cmd-active? 'throw-torch-1)
((player 'throw-torch!) torch-1-light-color))
(if (key-cmd-active? 'throw-torch-2)
((player 'throw-torch!) torch-2-light-color))
(if (key-cmd-active? 'throw-torch-3)
((player 'throw-torch!) torch-3-light-color))
(if (key-cmd-active? 'throw-torch-4)
((player 'throw-torch!) torch-4-light-color))
; Ratkaisureitin näyttö/piilotus?
(if (key-cmd-active? 'toggle-solve-route)
(begin
(if (maze-interface 'solve-route-marked?)
(maze-interface 'erase-solve-route!)
(begin
(maze-interface 'mark-solve-route!
(((player 'locator) 'get-loc-as-cell-index-x.y)))
((player 'player-light-off!))))
((image-mixer 'update-cached-images!))))
; Taustojen päivitys?
(if (key-cmd-active? 'update-backgrounds)
((image-mixer 'update-cached-images!)))
; Pelaajavalon sytytys/sammutus?
(if (and (key-cmd-active? 'switch-player-light)
(not (maze-interface 'solve-route-marked?)))
((player 'switch-player-light!)))
; Näkymän vaihto?
(if (key-cmd-active? 'switch-viewmode)
((camera 'switch-viewmode!)))
; Exit?
(if (or (key-cmd-active? 'exit)
(not (xo 'alive?)))
(set! done? true)))
; Nostetaan non-sticky -napit ylös
(define (release-non-sticky-keys)
(for-each (lambda (x)
(if (and (cdr x)
(not (sticky-key-cmd? (car x))))
(set-cdr! x false)))
keys))
; check-keys -runko ------------------------------------------------
(take-actions)
(release-non-sticky-keys))
(define (tick!)
((ticker 'tick!)))
;((player 'move) 'move!)
;((camera 'move!))
;((light-source-manager 'move) 'move!))
;;; ==================================================
;;; input-loop -runko
;;; ==================================================
;(let ((start-time (current-milliseconds)))
(let ((elapsed-time
(measure-time (lambda ()
(handle-events)
(check-keys)
;(display 'tick:)
;(time
(tick!)
;)
;(display 'image-mixer:)
;(time
((image-mixer 'update-window!))
;)
))))
(if (< elapsed-time
(/ 1000 max-fps))
(sleep (/ (- (/ 1000 max-fps)
elapsed-time)
1000))))
(if (not done?)
(input-loop false)))
;;; ==================================================
;;; user-interface -runko
;;; ==================================================
;
; Ikkunan ja kameran säätöä
(xo 'send 'Reset)
(xo 'send 'SetWindowDrawing 'off 'off)
(xo 'send 'ReportResizeEvents 'on)
(xo 'send 'ReportKeyEvents 'on 'on)
(sleep 1)
(do ((event '(true) (xo 'get-event)))
((null? event)))
(let ((GetWindowSize-result (xo 'send-with-result 'GetWindowSize)))
((camera 'set-window-size-x.y!) (cons (cadr GetWindowSize-result)
(caddr GetWindowSize-result))))
((camera 'follow-player!) player)
(xo 'buffer-commands 500)
;(xo 'display-commands #t)
((image-mixer 'update-cached-images!))
; Homma käyntiin
;(with-input-from-file "kartta.text" (maze 'load-from-current!))
(input-loop false)
; Suljetaan ikkuna ja palataan
(xo 'exit)))