Patch title: Release 90 bulk changes
Abstract:
File: /graphic/filter/png.pli
Key:
    Removed line
    Added line
abstract
  [The PNG file format interface.] ; eol
  [PNG is a clear, highly recommended file format.] ; eol
  highlight "warning: " ; [reading is not available yet.]

# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.


module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/os.pli"
module "/pliant/language/stream.pli"
module "prototype.pli"
module "/pliant/graphic/color/gamut.pli"

constant read_resolution true
constant buffer_size 8192

constant pliant_alloc os_api<>"win32"
constant buggy true


#----------------------------------------------------------------------


type z_stream_s
  packed

  field Address next_in
  field Int avail_in
  field Int total_in

  field Address next_out
  field Int avail_out
  field Int total_out

  field Address msg internal_state

  field Address zalloc zfree opaque
  
  field Int data_type
  field Int adler
  field Int reserved

constant zlib os_zlib_filename
constant version "1.1.3"


function deflateInit_ stream level version len -> err
  arg_rw z_stream_s stream ; arg Int level ; arg Address version ; arg Int len err
  external zlib "deflateInit_"

function deflateInit stream level -> err
  arg_rw z_stream_s stream ; arg Int level ; arg Int err
  err := deflateInit_ stream level version:characters z_stream_s:size

function deflate stream flush -> ret
  arg_rw z_stream_s stream ; arg Int flush ; arg Int ret
  external zlib "deflate"

function deflateEnd stream
  arg_rw z_stream_s stream
  external zlib "deflateEnd"


function inflateInit_ stream version len -> err
  arg_rw z_stream_s stream ; arg CStr version ; arg Int len err
  external zlib "inflateInit_"

function inflateInit stream -> err
  arg_rw z_stream_s stream ; arg Int err
  err := inflateInit_ stream version z_stream_s:size

function inflate stream flush
  arg_rw z_stream_s stream ; arg Int flush
  external zlib "inflate"

function inflateReset stream
  arg_rw z_stream_s stream
  external zlib "inflateReset"

function inflateEnd stream -> err
  arg_rw z_stream_s stream ; arg Int err
  external zlib "inflateEnd"


#----------------------------------------------------------------------


type PNG_CRC
  field uInt32 crc
  field (Array uInt32 256) crc_table
  
method table init
  arg_rw PNG_CRC table
  for (var Int n) 0 255
    var uInt32 c := n
    for (var Int k) 0 7
      if (c .and. 1)<>0
        c := 0EDB88320h .xor. (c\2)
      else
        c := c\2
      table:crc_table n := c
  table crc := .not. 0

method table update buf size
  arg_rw PNG_CRC table ; arg Address buf ; arg Int size
  for (var Int n) 0 size-1
    # var uInt32 bufn := buf map uInt8 n
    # var uInt32 indice := (table:crc .xor. bufn) .and. 0FFh
    # table crc := table:crc_table:indice .xor. (table:crc\2^8)
    table crc := table:crc_table:(table:crc .xor. (buf map uInt8 n) .and. 0FFh) .xor. (table:crc\2^8)
 
method table terminate -> crc
  arg_rw PNG_CRC table ; arg uInt32 crc
  crc := table:crc .xor. .not. 0
  

#----------------------------------------------------------------------


if pliant_alloc

  function pliant_zalloc opaque items size -> adr
    arg Address opaque ; arg uInt items size ; arg Address adr
    external_calling_convention
    if buggy
      var Address ptr := memory_allocate items*size+2*uInt:size null
      ptr map uInt := 763F526Ch
      ptr map uInt 1 := 946E0497h
      adr := ptr translate uInt 2
    else
      adr := memory_allocate items*size null
  
  function pliant_zfree opaque adr
    arg Address opaque ; arg Address adr
    external_calling_convention
    if buggy
      var Address ptr := adr translate uInt -2
      if (ptr map uInt)=763F526Ch and (ptr map uInt 1)=946E0497h
        ptr map uInt := AC76EF15h
        ptr map uInt 1 := 037356C1h
        memory_free ptr
      else
        (var Stream s) open "file:/tmp/zlib_bug.log" append+safe
        s writeline string:datetime+(shunt (ptr map uInt)=AC76EF15h and (ptr map uInt 1)=037356C1h " twice" "wrong")
        s close
    else
      memory_free adr


#----------------------------------------------------------------------


type PNGHeader
  packed
  field uInt32_hi size_x size_y
  field uInt8 depth
  field uInt8 color
  field uInt8 compression
  field uInt8 filter
  field uInt8 interlace
  
type PNGResolution
  packed
  field uInt32_hi rx ry
  field uInt8 unit

method s raw_write8 i
  arg_rw Stream s ; arg Int i
  var uInt8 i8 := i
  s raw_write addressof:i8 uInt8:size

method s raw_write32 i
  arg_rw Stream s ; arg Int i
  var uInt32_hi i32 := i
  s raw_write addressof:i32 uInt32:size

method s raw_write32 i
  arg_rw Stream s ; arg uInt i
  var uInt32_hi i32 := i
  s raw_write addressof:i32 uInt32:size


#----------------------------------------------------------------------


type ImageWriteFilterPng
  field Pointer:Stream stream
  field Int line_size
  field z_stream_s w
  field Address buffer

ImageWriteFilter maybe ImageWriteFilterPng


method f open stream options h -> status
  arg_rw ImageWriteFilterPng f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status
  if h:gamut:name<>"rgb" and h:gamut:name<>"rgba"
  if h:gamut:name<>"rgb" and h:gamut:name<>"rgba" and h:gamut:name<>"grey"
    return failure:"Only RGB images are currently supported by PNG output filter"
  f line_size := h:pixel_size*h:size_x
  f stream :> stream
  stream raw_write8 137
  stream raw_write8 80
  stream raw_write8 78
  stream raw_write8 71
  stream raw_write8 13
  stream raw_write8 10
  stream raw_write8 26
  stream raw_write8 10

  stream raw_write32 PNGHeader:size
  stream writechars "IHDR"
  var PNGHeader hdr
  hdr size_x := h size_x
  hdr size_y := h size_y
  hdr depth := 8
  hdr color := shunt h:gamut:name="rgb" 2 h:gamut:name="rgba" 6 0
  hdr color := shunt h:gamut:name="grey" 0 h:gamut:name="rgb" 2 h:gamut:name="rgba" 6 0
  hdr compression := 0
  hdr filter := 0
  hdr interlace := 0
  stream raw_write addressof:hdr PNGHeader:size
  (var PNG_CRC table) init ; table update "IHDR":characters 4
  table update addressof:hdr PNGHeader:size
  stream raw_write32 table:terminate

  stream raw_write32 PNGResolution:size
  stream writechars "pHYs"
  var PNGResolution r
  r rx := cast h:size_x/(abs h:x1-h:x0)*1000 Int
  r ry := cast h:size_y/(abs h:y1-h:y0)*1000 Int
  r unit := 1
  stream raw_write addressof:r PNGResolution:size
  (var PNG_CRC table) init ; table update "pHYs":characters 4
  table update addressof:r PNGResolution:size
  stream raw_write32 table:terminate

  f buffer := memory_allocate buffer_size null
  var Pointer:z_stream_s w :> f w
  memory_clear addressof:w z_stream_s:size
  w next_out := f buffer
  w avail_out := buffer_size
  w data_type := 2
  if pliant_alloc
    w zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable
    w zfree := (the_function pliant_zfree Address Address) executable
  deflateInit w -1
  status := success


method f flush
  arg_rw ImageWriteFilterPng f
  var Pointer:Stream stream :> f stream
  var Pointer:z_stream_s w :> f w
  stream raw_write32 buffer_size-w:avail_out
  stream writechars "IDAT"
  (var PNG_CRC table) init ; table update "IDAT":characters 4
  stream raw_write f:buffer buffer_size-w:avail_out
  table update f:buffer buffer_size-w:avail_out
  stream raw_write32 table:terminate
  w next_out := f buffer
  w avail_out := buffer_size

method f writeline adr -> status
  arg_rw ImageWriteFilterPng f ; arg Address adr ; arg Status status
  var Pointer:z_stream_s w :> f w
  var uInt8 zero := 0
  w next_in := addressof zero
  w avail_in := 1
  part compress1
    deflate w 0
    if w:avail_in<>0
      f flush
      restart compress1
  w next_in := adr
  w avail_in := f line_size
  part compress2
    deflate w 0 # Z_NO_FLUSH
    if w:avail_in<>0
      f flush
      restart compress2
  status := success


method f close -> status
  arg_rw ImageWriteFilterPng f ; arg ExtendedStatus status
  var Pointer:z_stream_s w :> f w
  part compress
    deflate w 4 # Z_FINISH
    if w:avail_out<>buffer_size
      f flush
      restart compress
  deflateEnd f:w
  memory_free f:buffer
  var Pointer:Stream stream :> f stream
  stream raw_write32 0
  stream writechars "IEND"
  (var PNG_CRC table) init ; table update "IEND":characters 4
  stream raw_write32 table:terminate
  status := success


#----------------------------------------------------------------------


type ImageReadFilterPng
  field Pointer:Stream s
  field Int pixel_size line_size
  field z_stream_s r
  field Int remain
  field Int y
  field Address buffer
  field Address previous

ImageReadFilter maybe ImageReadFilterPng


method f open stream options h -> status
  arg_rw ImageReadFilterPng f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status
  var Str sign := ".PNG...."
  stream raw_read sign:characters sign:len
  if sign<>character:137+"PNG[cr][lf]"+character:26+"[lf]"
    return failure:"This is not a .png image"
  stream raw_read addressof:(var uInt32_hi len) uInt32:size
  var Str tag := "1234" ; stream raw_read tag:characters tag:len
  if tag<>"IHDR" or len<>PNGHeader:size
    return failure:"Expected PNG header tag to be the first one"
  stream raw_read addressof:(var PNGHeader hdr) PNGHeader:size
  if hdr:depth<>8 or (hdr:color<>2 and hdr:color<>6)
  if hdr:depth<>8 or (hdr:color<>0 and hdr:color<>2 and hdr:color<>6)
    return failure:"Only 24 bits or 32 bits per pixel PNG files are currently supported"
  if hdr:compression<>0 or hdr:filter<>0 or hdr:interlace<>0
    return failure:"This PNG file encoding is not supported yet"
  # FIXME: rather scan all tags until iDAT
  if not ((options (options option_position "resolution" 0) options:len) parse word:"resolution" (var Float dpi_x) (var Float dpi_y) any)
    dpi_x := options option "resolution" Float 72 ; dpi_y := dpi_x
  if read_resolution and not stream:atend and (cast stream:stream_read_stop uInt)-(cast stream:stream_read_cur uInt)>=12
    var uInt32_hi len := (stream:stream_read_cur translate Byte 4) map uInt32_hi
    tag set (stream:stream_read_cur translate Byte 8) 4 false
    if tag="pHYs" and len=PNGResolution:size
      stream:stream_read_cur := stream:stream_read_cur translate Byte 12
      stream raw_read addressof:(var PNGResolution res) PNGResolution:size
      dpi_x := res:rx/1000*25.4
      dpi_y := res:ry/1000*25.4
  h := image_prototype 0 0 hdr:size_x/dpi_x*25.4 hdr:size_y/dpi_y*25.4 hdr:size_x hdr:size_y color_gamut:(shunt hdr:color=2 "rgb" hdr:color=6 "rgba" "")
  h := image_prototype 0 0 hdr:size_x/dpi_x*25.4 hdr:size_y/dpi_y*25.4 hdr:size_x hdr:size_y color_gamut:(shunt hdr:color=0 "grey" hdr:color=2 "rgb" hdr:color=6 "rgba" "")
  f s :> stream
  f pixel_size := h pixel_size
  f line_size := h line_size
  f remain := 0
  var Pointer:z_stream_s r :> f r
  memory_clear addressof:r z_stream_s:size
  r data_type := 2
  if pliant_alloc
    r zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable
    r zfree := (the_function pliant_zfree Address Address) executable
  if (inflateInit r)<>0
    return failure:"failed to initialize Zlib"
  f remain := 0
  f y := 0
  f buffer := (memory_zallocate h:line_size+h:pixel_size addressof:f) translate Byte f:pixel_size
  f previous := (memory_zallocate h:line_size+h:pixel_size addressof:f) translate Byte f:pixel_size
  status := success

function predicator a b c -> r
  arg Int a b c r
  var Int p := a+b-c
  var Int pa := abs p-a
  var Int pb := abs p-b
  var Int pc := abs p-c
  r := shunt pa<=pb and pa<=pc a pb<=pc b c

method f readline adr -> status
  arg_rw ImageReadFilterPng f ; arg Address adr ; arg Status status
  var Pointer:z_stream_s r :> f r
  var Pointer:Stream s :> f s
  r next_out := addressof (var uInt8 filter)
  r avail_out := 1
  var CBool mode := false
  while r:avail_out<>0 or not mode
    if r:avail_out=0
      r next_out := f buffer
      r avail_out := f line_size
      mode := true
    if r:avail_in=0
      while f:remain=0
        s raw_read addressof:(var uInt32_hi crc) uInt32:size
        if s:atend
          return failure
        s raw_read addressof:(var uInt32_hi len) uInt32:size
        var Str tag := "1234" ; s raw_read tag:characters tag:len
        if tag="IDAT"
          f remain := len
        else
          for (var Int i) 0 len-1
            s raw_read addressof:(var uInt8 drop) 1
      if s:atend
        return failure
      r next_in := s stream_read_cur
      r avail_in := min (cast s:stream_read_stop Int)-(cast s:stream_read_cur Int) f:remain
      s stream_read_cur := s:stream_read_cur translate Byte r:avail_in
      f remain -= r avail_in
    inflate r 0
  var Address cur := f buffer
  var Address stop := f:buffer translate Byte f:line_size
  var Int left := -(f pixel_size)
  var Int top := (cast f:previous Int).-.(cast f:buffer Int)
  var Int topleft := left+top
  if filter=0
    void
  eif filter=1
    while cur<>stop
      cur map uInt8 := (cur map uInt8)+(cur map uInt8 left) .and. 255
      cur := cur translate uInt8 1
  eif filter=2
    while cur<>stop
      cur map uInt8 := (cur map uInt8)+(cur map uInt8 top) .and. 255
      cur := cur translate uInt8 1
  eif filter=3
    while cur<>stop
      cur map uInt8 := (cur map uInt8)+((cur map uInt8 left)+(cur map uInt8 top))\2 .and. 255
      cur := cur translate uInt8 1
  eif filter=4
    while cur<>stop
      cur map uInt8 := (cur map uInt8)+(predicator (cur map uInt8 left) (cur map uInt8 top) (cur map uInt8 topleft)) .and. 255
      cur := cur translate uInt8 1
  else
    return failure
  memory_copy f:buffer adr f:line_size
  memory_copy adr f:previous f:line_size
  f y += 1
  status := success

method f close -> status
  arg_rw ImageReadFilterPng f ; arg ExtendedStatus status
  status := success
  if (inflateEnd f:r)<>0
    status := failure
  memory_free (f:buffer translate Byte -(f:pixel_size))
  memory_free (f:previous translate Byte -(f:pixel_size))


image_record_filters ".png" ImageReadFilterPng ImageWriteFilterPng