smalltalk-tng
view r1/ui.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | |
| children |
line source
1 (require 'srfi-1)
2 (require 'sdl)
4 (if (zero? (sdl-was-init SDL_INIT_VIDEO))
5 (error "Please initialise SDL (use sdl-csi)."))
7 (ttf-init)
8 (sdl-net-init)
10 (define *system-font*
11 (or (ttf-open-font "/sw/lib/X11/fonts/applettf/Monaco.ttf" 11)
12 (ttf-open-font "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMono.ttf" 11)))
14 (define *event-type-map* (make-hash-table eq?))
16 (define (traits-for-sdl-event-type t)
17 (or (hash-table-ref *event-type-map* t #f)
18 (error "No traits for event type" t)))
20 (let-syntax ((def-sdl-event-type
21 (syntax-rules ()
22 ((_ (global-var sdl-event-type) ...)
23 (begin
24 (define global-var '*) ...)))))
25 (include "sdl-events.scm"))
27 (define (update-sdl-event-type-map!)
28 (let-syntax ((def-sdl-event-type
29 (syntax-rules ()
30 ((_ (global-var sdl-event-type) ...)
31 (begin
32 (hash-table-set! *event-type-map* sdl-event-type global-var) ...)))))
33 (include "sdl-events.scm")))
35 (push! global-load-hooks
36 (lambda ()
37 (let-syntax ((def-sdl-event-type
38 (syntax-rules ()
39 ((_ (global-var sdl-event-type) ...)
40 (begin
41 (set! global-var (hash-table-ref *image-root* 'global-var)) ...
42 (update-sdl-event-type-map!))))))
43 (include "sdl-events.scm"))))
45 (push! global-store-hooks
46 (lambda ()
47 (let-syntax ((def-sdl-event-type
48 (syntax-rules ()
49 ((_ (global-var sdl-event-type) ...)
50 (begin
51 (hash-table-set! *image-root* 'global-var global-var) ...)))))
52 (include "sdl-events.scm"))))
54 (push! bootstrap-hooks
55 (lambda ()
56 (let-syntax ((def-sdl-event-type
57 (syntax-rules ()
58 ((_ (global-var sdl-event-type) ...)
59 (begin
60 (set! global-var (make-traits (symbol->string 'sdl-event-type)
61 `(#(sdlEvent ,*traits-sdl-event*)
62 (sdlEventNumber ,sdl-event-type))))
63 ...
64 (update-sdl-event-type-map!))))))
65 (include "sdl-events.scm"))))
67 (let ((old-hook (primitive-traits-hook)))
68 (primitive-traits-hook
69 (lambda (o)
70 (cond
71 ((sdl-tcp-socket? o) *traits-socket*)
72 ((sdl-surface? o) *traits-sdl-surface*)
73 ((sdl-event? o) (traits-for-sdl-event-type (sdl-event-type o)))
74 ((ttf-font? o) *traits-ttf-font*)
75 (else (old-hook o))))))
77 (sdl-wm-set-caption "ThiNG" "ThiNG")
79 (define (shutdown-sdl!)
80 (let ((e (make-sdl-event)))
81 (sdl-event-type-set! e SDL_QUIT)
82 (sdl-push-event e)))
84 (define *socket-set* (sdl-net-alloc-socket-set 100))
85 (define *active-sockets* '())
86 (define *the-eof-object* (read-char (open-input-string "")))
88 (define (activate-socket! sock suspension)
89 (push! *active-sockets* (cons sock suspension))
90 (debug 1 "Adding "sock" to set "*socket-set*)
91 (sdl-net-tcp-add-socket! *socket-set* sock))
93 (define (wait-for-socket-activity! sock)
94 (metalevel-suspend-thread
95 (lambda (suspension)
96 (activate-socket! sock suspension))))
98 (define (read-from-socket sock)
99 (wait-for-socket-activity! sock)
100 (sdl-net-tcp-recv-string sock 4096))
102 (define (accept-from-socket sock)
103 (wait-for-socket-activity! sock)
104 (sdl-net-tcp-accept sock))
106 (define (make-char-provider-thunk-for-socket sock)
107 (let ((state "")
108 (len 0)
109 (index 0))
110 (define (provider)
111 (cond
112 ((eof-object? state) state)
113 ((>= index len)
114 (let ((new-state (read-from-socket sock)))
115 (if (string? new-state)
116 (begin
117 (set! state new-state)
118 (set! len (string-length state))
119 (set! index 0)
120 (provider))
121 (begin
122 (set! state *the-eof-object*)
123 (set! len 0)
124 (set! index 0)
125 (provider)))))
126 (else
127 (let ((result (string-ref state index)))
128 (set! index (+ index 1))
129 result))))
130 provider))
132 (define (check-socket-set/delay delay-ms)
133 (let ((next-event-time (+ (get-time-of-day) (/ delay-ms 1000.0)))
134 (result (sdl-net-check-sockets *socket-set* 0)))
135 (if (and result (positive? result))
136 (let-values (((ready unready) (partition (lambda (record)
137 (sdl-net-socket-ready? (car record)))
138 *active-sockets*)))
139 (set! *active-sockets* unready)
140 (for-each (lambda (record)
141 (let ((sock (car record))
142 (suspension (cdr record)))
143 (debug 1 "Removing "sock" from set "*socket-set*)
144 (sdl-net-tcp-del-socket! *socket-set* sock)
145 (metalevel-resume-thread! suspension sock)))
146 ready)))
147 (metalevel-run-runnable-suspensions next-event-time)))
149 (define *video-surface* #f)
151 (define (discover-best-resolution!)
152 (let loop ((resolutions '(
153 ;;(1600 1200) (1280 1024) (1024 768) (800 600)
154 (640 480))))
155 (if (null? resolutions)
156 (error "No resolution supported.")
157 (let* ((res (car resolutions))
158 (maxx (car res))
159 (maxy (cadr res))
160 (s (sdl-set-video-mode maxx maxy 0 (+ SDL_HWSURFACE
161 ;;SDL_FULLSCREEN
162 SDL_HWPALETTE
163 SDL_RESIZABLE
164 SDL_DOUBLEBUF))))
165 (if (not (sdl-surface-pointer s))
166 (loop (cdr resolutions))
167 (set! *video-surface* s))))))
169 (define (ui-mainloop)
170 (discover-best-resolution!)
171 (sdl-fill-rect *video-surface*
172 (make-sdl-rect 0 0
173 (sdl-surface-width *video-surface*)
174 (sdl-surface-height *video-surface*))
175 (sdl-map-rgb (sdl-surface-pixel-format *video-surface*) 0 0 255))
176 (sdl-flip *video-surface*)
178 (let ((start-time (get-time-of-day)))
179 (let loop ((count 1))
180 (sdl-add-absolute-timer! (+ start-time (* count *invocation-count-update-interval*))
181 (lambda ()
182 (decay-invocation-counts!)
183 (loop (+ count 1))))))
185 (do ()
186 ((metalevel-stopped?))
187 (let ((event (make-sdl-event)))
188 (sdl-wait-event!* check-socket-set/delay event)
189 (metalevel-spawn *nil* (lambda () (send handle event)))))
191 (sdl-net-quit)
192 (ttf-quit)
193 (sdl-quit))