1;;----------------------------------------------------------------------------
2;; tblit.scm - a terrain-blitting mech
3;;----------------------------------------------------------------------------
4
5;; Some convenient maps for blitting
6(kern-mk-map
7 'm_hall_section 3 3 pal_expanded
8 (list
9  ",, ,, ,,"
10  ",, ,, ,,"
11  ",, ,, ,,"
12  ))
13
14(kern-mk-map
15 'm_deck_section 3 3 pal_expanded
16 (list
17  "ee ee ee"
18  "ee ee ee"
19  "ee ee ee"
20  ))
21
22
23;; A curried wrapper for kern-blit-map (note that place may legitimately be
24;; null during startup)
25(define (blit-map place x y w h map)
26  (if (notnull? place)
27      (kern-blit-map (kern-place-map place) x y map 0 0 w h)))
28
29;; Syntactic sugar to set blitter state
30(define (tblit-mk place-tag x y w h map-tag) (list place-tag x y w h map-tag))
31
32;; Do the blit upon receiving an "on" signal.
33(define (tblit-on kobj)
34  (apply blit-map (map safe-eval (kobj-gob-data kobj))))
35
36;; Blit mechs are not visible.
37(define (tblit-init kobj)
38  (kern-obj-set-visible kobj #f))
39
40;; A blitter mech responds to an "on" signal by executing the blit
41(define tblit-ifc
42  (ifc '()
43       (method 'on tblit-on)
44       (method 'init tblit-init)))
45
46;; The kernel object type of a blitter
47(mk-obj-type 't_terrain_blitter '() '() layer-mechanism
48             tblit-ifc)
49
50;; Constructor
51(define (mk-tblitter place-tag x y w h map-tag)
52  (bind (kern-mk-obj t_terrain_blitter 1)
53        (tblit-mk place-tag x y w h map-tag)))
54