5 ; SuperTux 0.3.1 tileset splitter
6 ; Copyright (C) 2008 Christoph Sommer <christoph.sommer@2008.expires.deltadevelopment.de>
8 ; This program is free software; you can redistribute it and/or
9 ; modify it under the terms of the GNU General Public License
10 ; as published by the Free Software Foundation; either version 2
11 ; of the License, or (at your option) any later version.
13 ; This program is distributed in the hope that it will be useful,
14 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ; GNU General Public License for more details.
18 ; You should have received a copy of the GNU General Public License
19 ; along with this program; if not, write to the Free Software
20 ; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 ; ---------------------------------------------------------------------------
24 ; Reads a SuperTux tileset on stdin, outputs a SuperTux tileset with only
25 ; those tiles with a tile-id in the tileset's first group.
26 ; This means that if the tileset starts with a tilegroup "snow", you
27 ; will get a tileset with only snow tiles in the output
28 ; ---------------------------------------------------------------------------
30 ; return first sublist in haystack that starts with needle or #f if none is found
31 (define (find-sublist haystack needle)
34 (not (pair? haystack))
38 (and (pair? (car haystack)) (eq? (caar haystack) needle))
43 (find-sublist (cdr haystack) needle)
48 ; input: (tile ... (id 1) ...) (1 2 3 4 5)
49 ; output: #t if "id" in "valid-ids", #f otherwise
50 (define (output-tile? children valid-ids)
52 ((id (car (find-sublist children 'id))))
56 (if (member id valid-ids)
63 ; input: (1 7 8) (1 2 3 4 5)
64 ; output: #t if any of "needles" in "haystack", #f otherwise
65 (define (any-member needles haystack)
69 (member (car needles) haystack)
70 (any-member (cdr needles) haystack)
75 ; input: (tiles ... (ids 1 7 8) ...) (1 2 3 4 5)
76 ; output: #t if any of "ids" in "valid-ids", #f otherwise
77 (define (output-tiles? children valid-ids)
79 ((ids (find-sublist children 'ids)))
83 (if (any-member ids valid-ids)
90 ; input: ((tilegroup ...) (tilegroup ...) (tile ...) (tiles ...))
91 ; output: ((tilegroup ...) (tile ...) (tiles ...))
92 (define (output-and-next children valid-ids)
94 ; tilegroup not yet found
95 (if (not (string=? (symbol->string (caar children)) "tilegroup"))
96 ; no tilegroup: just continue
97 (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
99 ; tilegroup: get valid-ids
100 (set! valid-ids (find-sublist (car children) 'tiles))
101 ; output tilegroup and continue
104 (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
109 ; tilegroup already found
111 ((string=? (symbol->string (caar children)) "tile")
112 (if (output-tile? (car children) valid-ids)
115 (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
117 (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
120 ((string=? (symbol->string (caar children)) "tiles")
121 (if (output-tiles? (car children) valid-ids)
124 (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
126 (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
130 (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
137 ; input: (supertux-tiles ... (tilegroup ...) (tilegroup ...) (tile ...) (tiles ...))
138 ; output: (supertux-tiles (tilegroup ...) (tile ...) (tiles ...))
139 (define (clip-tileset supertux-tiles)
141 (if (not (string=? (symbol->string (car supertux-tiles)) "supertux-tiles")) (error "not a supertux-tileset:" type))
142 (output-and-next (cdr supertux-tiles) '())
146 ; run conversion on stdin, output to stdout
147 (write (clip-tileset (read)))