tools/tileset-splitter.scm

   1 ;
   2 ;
   3 ; $Id$
   4 ;
   5 ; SuperTux 0.3.1 tileset splitter
   6 ; Copyright (C) 2008 Christoph Sommer <christoph.sommer@2008.expires.deltadevelopment.de>
   7 ;
   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.
  12 ;
  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.
  17 ;
  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.
  21 ;
  22
  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 ; ---------------------------------------------------------------------------
  29
  30 ; return first sublist in haystack that starts with needle or #f if none is found
  31 (define (find-sublist haystack needle)
  32   (cond
  33     (
  34      (not (pair? haystack))
  35      #f
  36      )
  37     (
  38      (and (pair? (car haystack)) (eq? (caar haystack) needle))
  39      (cdar haystack)
  40      )
  41     (
  42      else
  43      (find-sublist (cdr haystack) needle)
  44      )
  45     )
  46   )
  47
  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)
  51   (let
  52     ((id (car (find-sublist children 'id))))
  53     (if (not id)
  54       #f
  55       )
  56     (if (member id valid-ids)
  57       #t
  58       #f
  59       )
  60     )
  61   )
  62
  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)
  66   (if (null? needles)
  67     #f
  68     (or
  69       (member (car needles) haystack)
  70       (any-member (cdr needles) haystack)
  71       )
  72     )
  73   )
  74
  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)
  78   (let
  79     ((ids (find-sublist children 'ids)))
  80     (if (not ids)
  81       #f
  82       )
  83     (if (any-member ids valid-ids)
  84       #t
  85       #f
  86       )
  87     )
  88   )
  89
  90 ; input: ((tilegroup ...) (tilegroup ...) (tile ...) (tiles ...))
  91 ; output: ((tilegroup ...) (tile ...) (tiles ...))
  92 (define (output-and-next children valid-ids)
  93   (if (null? 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) '())
  98       (begin
  99         ; tilegroup: get valid-ids
 100         (set! valid-ids (find-sublist (car children) 'tiles))
 101         ; output tilegroup and continue
 102         (cons
 103           (car children)
 104           (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
 105           )
 106         )
 107       )
 108     (begin
 109       ; tilegroup already found
 110       (cond
 111         ((string=? (symbol->string (caar children)) "tile")
 112          (if (output-tile? (car children) valid-ids)
 113            (cons
 114              (car children)
 115              (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
 116              )
 117            (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
 118            )
 119          )
 120         ((string=? (symbol->string (caar children)) "tiles")
 121          (if (output-tiles? (car children) valid-ids)
 122            (cons
 123              (car children)
 124              (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
 125              )
 126            (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
 127            )
 128          )
 129         (else
 130           (if (not (null? (cdr children))) (output-and-next (cdr children) valid-ids) '())
 131           )
 132         )
 133       )
 134     )
 135   )
 136
 137 ; input: (supertux-tiles ... (tilegroup ...) (tilegroup ...) (tile ...) (tiles ...))
 138 ; output: (supertux-tiles (tilegroup ...) (tile ...) (tiles ...))
 139 (define (clip-tileset supertux-tiles)
 140   (let ()
 141     (if (not (string=? (symbol->string (car supertux-tiles)) "supertux-tiles")) (error "not a supertux-tileset:" type))
 142     (output-and-next (cdr supertux-tiles) '())
 143     )
 144   )
 145
 146 ; run conversion on stdin, output to stdout
 147 (write (clip-tileset (read)))
 148 (newline)
 149 (quit)
 150