#!/Local/Applications/core024/rebol -cs

REBOL [
  Title: "OTA bitmap to GIF converter"
  Date: 25-Sep-2004
  Version: 1.1
  File: %converter.r
  Author: "HY"
  Purpose: {
           Converts so-called operator logos for cell phones, i.e. OTA bitmaps
           into ordinary two-colour GIFs.
  }
  Comment: {
            This script is heavily inspired by java code. I used Adam Doppelts
            GifEncoder (cf. http://www.gurge.com/amd/old/java/GIFEncoder/index.html),
            which in turn is based upon Sverre H. Huseby's gifsave.c
            (cf. http://www.scintilla.utwente.nl/users/frank/gifsave.txt), as
            a template.

            I wrote this script in part to learn rebol. LZW compression is, I believe,
            subject to licencing (Unisys). See http://www.unisys.com/unisys/lzw/
            for details. I don't have any licence, and so if you want to use the script
            in an application, don't blame me if you get in any trouble. This code is
            revealed to the public only because someone (e.g. myself!) could learn
            something from it, NOT because I have a licence.
           }
  History: [
     1.0 [ 10-Sep-2001 "Created the script." "HY" ]
     1.1 [ 25-Sep-2004 "Added the script library header." "HY" ]
  ]
  Library: [
    level: 'intermediate
    domain: [compression graphics]
    license: none
    Platform: 'all
    Tested-under: none
    Type: [function]
    Support: none
  ]
]


codesize: 0
compression-block: make binary! #{}

shift-left: func [value shift-count] [to-integer (value * (2 ** shift-count))]
shift-right: func [value shift-count] [to-integer (value / (2 ** shift-count))]


bit-holder: make object! [

  get-ready: func[] [
    buffer: copy array 256
    bindex: 0
    bitsleft: 8
  ]

  flush: func [/local numberofbytes] [
    numberofbytes: either bitsleft = 8 [bindex] [bindex + 1]
    if numberofbytes > zero [
      append compression-block load rejoin ["#{" pick to-hex numberofbytes 7
                                                 pick to-hex numberofbytes 8
                                            "}"]
      buffer: head buffer
      loop numberofbytes [
        append compression-block first buffer
        buffer: next buffer
      ]
      change at head buffer 0 #{00}
      bindex: 0
      bitsleft: 8
    ]
  ]

  append-bits: func [bits number-of-bits /local bits-written numberofbytes] [
    bits-written: 0
    numberofbytes: 255
    while [
      ; this was a java do-block. I put the whole thing into the
      ; while-evaluation, and then nothing into the execution block.

      if ((bindex = 254) and (bitsleft = zero)) or (bindex > 254) [
        append compression-block load rejoin ["#{" pick to-hex numberofbytes 7
                                                   pick to-hex numberofbytes 8
                                              "}"]
        buffer: head buffer
        loop numberofbytes [
          append compression-block first buffer
          buffer: next buffer
        ]
        change at head buffer 0 #{00}
        bindex: 0
        bitsleft: 8
      ]

      either number-of-bits <= bitsleft [
        a: (to-integer pick head buffer (bindex + 1)) or shift-left (bits and ((shift-left 1 number-of-bits) - 1)) (8 - bitsleft)
        b: load rejoin ["#{" pick to-hex a 7 pick to-hex a 8 "}"]
        change at head buffer (bindex + 1) b
        bits-written: bits-written + number-of-bits
        bitsleft: bitsleft - number-of-bits
        number-of-bits: 0
      ] [
        a: (to-integer pick head buffer (bindex + 1)) or shift-left (bits and ((shift-left 1 bitsleft) - 1)) (8 - bitsleft)
        b: load rejoin ["#{" pick to-hex a 7 pick to-hex a 8 "}"]
        change at head buffer (bindex + 1) b
        bits-written: bits-written + bitsleft
        bits: shift-right bits bitsleft
        number-of-bits: number-of-bits - bitsleft
        bindex: bindex + 1
        change at head buffer (bindex + 1) #{00}
        bitsleft: 8
      ]

      number-of-bits <> zero

    ] [ comment { empty while execution block } ]
  ]
]

  LZW-stringtable: make object! [
    res-codes: 2
    hash-free: -1
    next-first: -1
    maxbits: 12
    maxstr: shift-left 1 maxbits
    hashsize: 9973
    hashstep: 2039
    num-strings: 0

    get-ready: func[] [
      str-chr: copy array maxstr
      str-nxt: copy array maxstr
      str-hsh: copy array hashsize
    ]


    clear-table: func [codesize /local w] [
      num-strings: 0
      str-hsh: copy array/initial hashsize hash-free

      w: (shift-left 1 codesize) + res-codes
      repeat current w [
        add-char-string -1 (current - 1)
      ]
    ] ; end clear-table


    add-char-string: func [aindex byte /local hashindex hash-plus-one] [

      if num-strings >= maxstr [ return -1 ]

      hashindex: hash-it aindex byte
      hash-plus-one: hashindex + 1
      while [ str-hsh/:hash-plus-one <> hash-free] [
        hashindex: remainder (hashindex + hashstep) hashsize
      ]

      change at str-hsh (hashindex + 1) num-strings
      change at str-chr (num-strings + 1) byte
      change at str-nxt (num-strings + 1) either aindex = hash-free [next-first] [aindex]

      num-strings: num-strings + 1
      return num-strings

    ] ; end add-char-string


    find-char-string: func [findex byte /local hashindex nextindex] [

      if findex = hash-free [ return byte ]

      hashindex: hash-it findex byte

      while [ nextindex: to-integer pick head str-hsh (hashindex + 1)
              hash-free <> nextindex ]
            [
        if ((to-integer (pick head str-nxt (nextindex + 1))) = findex) and
           ((to-integer (pick head str-chr (nextindex + 1))) = byte) [
             return nextindex ]
        hashindex: remainder (hashindex + hashstep) hashsize
      ]

      return -1

    ]


    hash-it: func [hindex lastbyte] [
      return remainder (((shift-left lastbyte 8) xor hindex) and to-integer #{FFFF}) hashsize
    ] ; end hash-it


] ; end LZW-stringtable



 bits-needed: func [n [integer!] ] [
  ret: 1

  if n - 1 = zero [ return zero ]

  while [(n: to-integer n / 2) <> zero] [
    ret: ret + 1
  ]

  ret
]

LZW-compress: func [tobecompressed [string!] the-size [integer!] /local index] [
  prefix: -1

  holder: make bit-holder []
  holder/get-ready
  stringtable: make LZW-stringtable []
  stringtable/get-ready

  clearcode: shift-left 1 the-size
  endofinfo: clearcode + 1
  numberofbits: the-size + 1
  limit: (shift-left 1 numberofbits) - 1

  stringtable/clear-table the-size
  holder/append-bits clearcode numberofbits

  foreach c tobecompressed [
    index: stringtable/find-char-string prefix to-integer to-string c
    either index = -1 [
      holder/append-bits prefix numberofbits
      gg: (stringtable/add-char-string prefix to-integer to-string c) - 1
      if gg > limit [
        numberofbits: numberofbits + 1
        if numberofbits > 12 [
          holder/append-bits clearcode (numberofbits - 1)
          stringtable/clear-table
          numberofbits: codesize + 1
        ]
        limit: (shift-left 1 numberofbits) - 1
      ]
      prefix: (to-integer to-string c) and (to-integer #{FF})
    ][ prefix: index ]
  ]

  if prefix <> -1 [
    holder/append-bits to-integer prefix numberofbits
  ]

  holder/append-bits endofinfo numberofbits
  holder/flush

  compression-block

]


imagedescriptor: func [separator [char!] w [integer!] h [integer!]] [

  descriptor: make block! 10
  append descriptor to-binary separator

  infobyte: 0
  infobyte: infobyte or 0  ; The rightmost bit: Local Color Table (OFF)
  infobyte: infobyte or 0  ; Interlace flag (next bit) (OFF)
  infobyte: infobyte or 0  ; Sort flag (1 bit) (not sorted)
  infobyte: infobyte or 24 ; Two reserved bits - OFF or ON -- no difference
  infobyte: infobyte or 7  ; Size of Local Colour Table (3 last bits)
                           ; (No local colour table, so this may be whatever pleases the most)

  ; simply setting left and top offsets to zero:
  append descriptor #{0000}
  append descriptor #{0000} ; two bytes for each offset value

  ; width and height parameters:
  append descriptor load rejoin ["#{" pick to-hex w 7
                                      pick to-hex w 8
                                      pick to-hex w 5
                                      pick to-hex w 6
                                 "}"]

  append descriptor load rejoin ["#{" pick to-hex h 7
                                      pick to-hex h 8
                                      pick to-hex h 5
                                      pick to-hex h 6
                                 "}"]

  append descriptor load rejoin ["#{"  pick to-hex infobyte 7
                                       pick to-hex infobyte 8
                                 "}"]

  descriptor
]

graphiccontrolextension: func [] [

  extension: make block! 7

  infobyte: 0 ; this infobyte contains lots of unimportant, unspecified information
  infobyte: infobyte or 0 ; The rightmost bit: Transparent Colour Flag.

  ; First, two bytes with fixed values:
  append extension #{21} ; Extension introducer
  append extension #{F9} ; Graphic Control Label

  append extension #{04} ; Block Size - fixed value, according to the GIF89 spec

  append extension load rejoin ["#{" pick to-hex infobyte 7
                                     pick to-hex infobyte 8
                                "}"]

  append extension #{00} ; Delay Time (we don't use animation)
  append extension #{00} ; Delay Time (we don't use animation) (two bytes, unsigned)

  append extension #{00} ; Transparency index (if  not transparent, this will be the Block Terminator instead)

  rejoin extension
]

screendescriptor: func [] [

  descriptor: make block! 7

  infobyte: 0
  infobyte: infobyte or 128 ; Global Colour Table flag (first bit)
  infobyte: infobyte or 112 ; Colour resolution (next 3 bits)
  infobyte: infobyte or zero ; Sort flag (fifth bit; set to 0, since our Global Colour Table is _not_ sorted)
  infobyte: infobyte or ((bits-needed(2) - 1) and 7) ; Global Colour Table size (last 3 bits)

  append descriptor load rejoin ["#{" pick to-hex width 7
                                      pick to-hex width 8
                                      pick to-hex width 5
                                      pick to-hex width 6
                                 "}"]

  append descriptor load rejoin ["#{" pick to-hex height 7
                                      pick to-hex height 8
                                      pick to-hex height 5
                                      pick to-hex height 6
                                 "}"]

  append descriptor load rejoin ["#{"  pick to-hex infobyte 7
                                       pick to-hex infobyte 8
                                 "}"]

  append descriptor load rejoin ["#{"  skip tail reverse to-hex zero -2 "}"] ; index of background colour in colour table

  append descriptor load rejoin ["#{"  skip tail reverse to-hex zero -2 "}"] ; i.e. no pixel aspect ratio information is given

  comment {
    Something is very wrong here, but I use this script for OTA bitmap conversion only,
    and it works for that purpose. I recommend anyone who want to use this script for
    any other purpose to completely rewrite the screendescriptor method!
  }

  rejoin descriptor

]

convert: func [ bitmap /local gif ] [

  if not (length? bitmap) = 260 [
    print "Wrong length of argument."
    ;return
  ]

  gif-header: to-binary "GIF89a"
  gif: gif-header

  if (first bitmap) <> #"0" [ print "First character is non-null!" ]
  if (second bitmap) <> #"0" [ print "Second character is non-null!" ] ; both of which are wrong, in OTAs...
  bitmap: skip bitmap 2

  ; first the width parameter as hex,
  width: to-integer to-issue append to-string first bitmap second bitmap
  bitmap: skip bitmap 2

  ; then the height,
  height: to-integer to-issue append to-string first bitmap second bitmap
  bitmap: skip bitmap 2

  ; and finally the number of colours. This number should be 1, in OTAs:
  colours: to-integer to-issue append to-string first bitmap second bitmap
  bitmap: skip bitmap 2
  if colours > 1 [ print "Bitmap claims to have more than two colours!" ]

  raster: make block! width * height
  loop (width * height) / 4 [
    append raster to-string skip (to-string enbase/base load rejoin ["#{0" first bitmap "}"] 2) 4
    bitmap: next bitmap
  ]

  if (length? bitmap) > 0 [ print "There seems to be unread bytes left in the input bitmap!" ]


  append gif #{48000E00F00000} ; should be: append gif screendescriptor

  ; I could have made a sub-routine to set the colour table,
  ; but since I know this is a two-colour gif, I'll simply add
  ; it statically, like this:
  append gif #{FFFFFF000000}

  append gif #{21F90400000000} ; should be: append gif graphiccontrolextension

  append gif #{00} ; Block Terminator for Graphic Control Extension

  append gif #{2C0000000048000E001F} ; should be: append gif imagedescriptor #"," width height

  codesize: bits-needed(2) ; LZW Minimum Code Size (for two colours)
  if codesize = 1 [ codesize: 2 ]

  append gif load rejoin ["#{" pick to-hex codesize 7
                               pick to-hex codesize 8
                          "}"]

  append gif LZW-compress to-string raster codesize

  append gif #{00}

  append gif #{3B00000000000000001F} ; should be: append gif imagedescriptor #";" 0 0

  append gif to-binary "!žImage generated with REBOL"

  append gif #{00} ; closes the comment block

  gif

]

get-bitmap: func [query /local bitmap] [
  bitmap: find query "bitmap="
  if not none? bitmap [ bitmap: skip bitmap 7 ]
  to-string bitmap
]

print "Content-Type: image/gif^/"
OTA-bitmap: get-bitmap system/options/cgi/query-string
bytes: convert OTA-bitmap
write-io system/ports/output bytes length? bytes

; example OTA bitmap follows underneath. Replace the four lines above with the one underneath to se the result.
;write %converted.gif convert "00480E0118000000F80FC007F818003803FC0FF007F818006F03BC0EF807F018007F83000E3C07F00800C382001C1403E01800C1C2001C1C03E01800C0C2000C1C01E01801C0C6000E1C01C01801C1C61F063800C01801C1821F03F800801800E3820101F0000019C0FF0387000000001FE03E01FF000001C01FC00000FB000001C0"