tga.scm - bitstring - A fork of the CHICKEN bitstring egg for CHICKEN 5
 (HTM) git clone git://vernunftzentrum.de/bitstring.git
 (DIR) Log
 (DIR) Files
 (DIR) Refs
 (DIR) README
       ---
       tga.scm (2914B)
       ---
            1 
            2 ; Basic TGA image parser.
            3 ; Support True-Image type format and Run-Length-Encoding compression.
            4 ; SPEC: http://www.dca.fee.unicamp.br/~martino/disciplinas/ea978/tgaffs.pdf
            5 
            6 (use bitstring posix srfi-4)
            7 
            8 (bitpacket TGA-Header
            9   (ID-length 8)
           10   (ColorMapType 8)
           11   (ImageType 8)
           12   (TGA-ColorMapSpec bitpacket)
           13   (TGA-ImageSpec bitpacket))
           14 
           15 (bitpacket TGA-ColorMapSpec
           16   (FirstEntryIndex 16 little)
           17   (ColorMapLength 16 little)
           18   (ColorMapEntrySize 8))
           19 
           20 (bitpacket TGA-ImageSpec
           21   (X-Origin 16 little)
           22   (Y-Origin 16 little)
           23   (ImageWidth 16 little)
           24   (ImageHeight 16 little)
           25   (PixelDepth 8)
           26   (ImageTransferOrder 2)
           27   (#x00 2) ; reserved
           28   (AttributesBitsPerPixel 4))
           29 
           30 (define (parse-tga file file-out)
           31   (let* ((fi (file-open file (+ open/rdonly open/binary)))
           32          (fo (file-open file-out (+ open/write open/creat open/trunc open/binary)))
           33          (size (file-size fi))
           34          (res (file-read fi size))
           35          (data (car res)))
           36     (bitmatch data
           37       ; True-Color uncompressed
           38       (((TGA-Header bitpacket)
           39               (check (and (= 0 ColorMapType) (= 2 ImageType)))
           40               (ID-data ID-length bitstring)
           41         (Image-data (* ImageWidth ImageHeight PixelDepth) bitstring)
           42         (Rest-data bitstring))
           43                 (begin
           44                   (print "True-Color uncompressed")
           45                   (print ImageWidth "x" ImageHeight "x" PixelDepth)
           46                   (parse-image-uncompressed
           47                     (lambda (color)
           48                       (file-write fo (bitstring->blob color)))
           49                     PixelDepth Image-data)))
           50       ; True-Color compressed
           51       (((TGA-Header bitpacket)
           52               (check (and (= 0 ColorMapType) (= 10 ImageType)))
           53               (ID-data ID-length bitstring)
           54               (Image-data bitstring))
           55                       (begin
           56                         (print "True-Color compressed")
           57                         (print ImageWidth "x" ImageHeight "x" PixelDepth)
           58                         (parse-image-compressed
           59                       (lambda (color)
           60                               (file-write fo (bitstring->blob color)))
           61                       PixelDepth Image-data))))))
           62 
           63 (define (parse-image-uncompressed func depth image)
           64   (bitmatch image
           65     ((())
           66               'ok)
           67     (((Color depth bitstring) (Rest bitstring))
           68       (begin
           69               (func Color)
           70               (parse-image-uncompressed func depth Rest)))))
           71 
           72 (define (parse-image-compressed func depth image)
           73   (bitmatch image
           74     ((())
           75               'ok)
           76     (((1 1) (Count 7) (Color depth bitstring) (Rest bitstring))
           77               (let loop ((i 0))
           78           (func Color)
           79           (if (< i Count)
           80             (loop (+ i 1))
           81             (parse-image-compressed func depth Rest))))
           82     (((0 1) (Count 7) (RAW-data (* depth (+ Count 1)) bitstring) (Rest bitstring))
           83               (begin
           84                 (parse-image-uncompressed func depth RAW-data)
           85                 (parse-image-compressed func depth Rest)))))
           86 
           87 ; Convert images to raw pixels 
           88 (parse-tga "tests/24compressed.tga" "tests/24c.raw")
           89 (parse-tga "tests/24uncompressed.tga" "tests/24u.raw")
           90