/pliant/graphic/filter/png.pli
 
 1  abstract 
 2    [The PNG file format interface.] ; eol 
 3    [PNG is a clear, highly recommended file format.] ; eol 
 4    highlight "warning: " ; [reading is not available yet.] 
 5   
 6  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 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 version 2 
 10  # as published by the Free Software Foundation. 
 11  # 
 12  # This program is distributed in the hope that it will be useful, 
 13  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 14  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 15  # GNU General Public License for more details. 
 16  # 
 17  # You should have received a copy of the GNU General Public License 
 18  # version 2 along with this program; if not, write to the Free Software 
 19  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 20   
 21   
 22  module "/pliant/language/compiler.pli" 
 23  module "/pliant/language/context.pli" 
 24  module "/pliant/language/os.pli" 
 25  module "/pliant/language/stream.pli" 
 26  module "prototype.pli" 
 27  module "/pliant/graphic/color/gamut.pli" 
 28   
 29  constant read_resolution true 
 30  constant buffer_size 8192 
 31   
 32  constant pliant_alloc os_api<>"win32" 
 33  constant buggy true 
 34   
 35   
 36 
 
 37   
 38   
 39  type z_stream_s 
 40    packed 
 41   
 42    field Address next_in 
 43    field Int avail_in 
 44    field Int total_in 
 45   
 46    field Address next_out 
 47    field Int avail_out 
 48    field Int total_out 
 49   
 50    field Address msg internal_state 
 51   
 52    field Address zalloc zfree opaque 
 53     
 54    field Int data_type 
 55    field Int adler 
 56    field Int reserved 
 57   
 58  constant zlib os_zlib_filename 
 59  constant version "1.1.3" 
 60   
 61   
 62  function deflateInit_ stream level version len -> err 
 63    arg_rw z_stream_s stream ; arg Int level ; arg Address version ; arg Int len err 
 64    external zlib "deflateInit_" 
 65   
 66  function deflateInit stream level -> err 
 67    arg_rw z_stream_s stream ; arg Int level ; arg Int err 
 68    err := deflateInit_ stream level version:characters z_stream_s:size 
 69   
 70  function deflate stream flush -> ret 
 71    arg_rw z_stream_s stream ; arg Int flush ; arg Int ret 
 72    external zlib "deflate" 
 73   
 74  function deflateEnd stream 
 75    arg_rw z_stream_s stream 
 76    external zlib "deflateEnd" 
 77   
 78   
 79  function inflateInit_ stream version len -> err 
 80    arg_rw z_stream_s stream ; arg CStr version ; arg Int len err 
 81    external zlib "inflateInit_" 
 82   
 83  function inflateInit stream -> err 
 84    arg_rw z_stream_s stream ; arg Int err 
 85    err := inflateInit_ stream version z_stream_s:size 
 86   
 87  function inflate stream flush 
 88    arg_rw z_stream_s stream ; arg Int flush 
 89    external zlib "inflate" 
 90   
 91  function inflateReset stream 
 92    arg_rw z_stream_s stream 
 93    external zlib "inflateReset" 
 94   
 95  function inflateEnd stream -> err 
 96    arg_rw z_stream_s stream ; arg Int err 
 97    external zlib "inflateEnd" 
 98   
 99   
 100 
 
 101   
 102   
 103  type PNG_CRC 
 104    field uInt32 crc 
 105    field (Array uInt32 256) crc_table 
 106     
 107  method table init 
 108    arg_rw PNG_CRC table 
 109    for (var Int n) 0 255 
 110      var uInt32 := n 
 111      for (var Int k) 0 7 
 112        if (.and. 1)<>0 
 113          := 0EDB88320h .xor. (c\2) 
 114        else 
 115          := c\2 
 116        table:crc_table := c 
 117    table crc := .not. 0 
 118   
 119  method table update buf size 
 120    arg_rw PNG_CRC table ; arg Address buf ; arg Int size 
 121    for (var Int n) size-1 
 122      # var uInt32 bufn := buf map uInt8 n 
 123      # var uInt32 indice := (table:crc .xor. bufn) .and. 0FFh 
 124      # table crc := table:crc_table:indice .xor. (table:crc\2^8) 
 125      table crc := table:crc_table:(table:crc .xor. (buf map uInt8 n) .and. 0FFh) .xor. (table:crc\2^8) 
 126    
 127  method table terminate -> crc 
 128    arg_rw PNG_CRC table ; arg uInt32 crc 
 129    crc := table:crc .xor. .not. 0 
 130     
 131   
 132 
 
 133   
 134   
 135  if pliant_alloc 
 136   
 137    function pliant_zalloc opaque items size -> adr 
 138      arg Address opaque ; arg uInt items size ; arg Address adr 
 139      external_calling_convention 
 140      if buggy 
 141        var Address ptr := memory_allocate items*size+2*uInt:size null 
 142        ptr map uInt := 763F526Ch 
 143        ptr map uInt := 946E0497h 
 144        adr := ptr translate uInt 2 
 145      else 
 146        adr := memory_allocate items*size null 
 147     
 148    function pliant_zfree opaque adr 
 149      arg Address opaque ; arg Address adr 
 150      external_calling_convention 
 151      if buggy 
 152        var Address ptr := adr translate uInt -2 
 153        if (ptr map uInt)=763F526Ch and (ptr map uInt 1)=946E0497h 
 154          ptr map uInt := AC76EF15h 
 155          ptr map uInt := 037356C1h 
 156          memory_free ptr 
 157        else 
 158          (var Stream s) open "file:/tmp/zlib_bug.log" append+safe 
 159          writeline string:datetime+(shunt (ptr map uInt)=AC76EF15h and (ptr map uInt 1)=037356C1h " twice" "wrong") 
 160          close 
 161      else 
 162        memory_free adr 
 163   
 164   
 165 
 
 166   
 167   
 168  type PNGHeader 
 169    packed 
 170    field uInt32_hi size_x size_y 
 171    field uInt8 depth 
 172    field uInt8 color 
 173    field uInt8 compression 
 174    field uInt8 filter 
 175    field uInt8 interlace 
 176     
 177  type PNGResolution 
 178    packed 
 179    field uInt32_hi rx ry 
 180    field uInt8 unit 
 181   
 182  method s raw_write8 i 
 183    arg_rw Stream s ; arg Int i 
 184    var uInt8 i8 := i 
 185    raw_write addressof:i8 uInt8:size 
 186   
 187  method s raw_write32 i 
 188    arg_rw Stream s ; arg Int i 
 189    var uInt32_hi i32 := i 
 190    raw_write addressof:i32 uInt32:size 
 191   
 192  method s raw_write32 i 
 193    arg_rw Stream s ; arg uInt i 
 194    var uInt32_hi i32 := i 
 195    raw_write addressof:i32 uInt32:size 
 196   
 197   
 198 
 
 199   
 200   
 201  type ImageWriteFilterPng 
 202    field Pointer:Stream stream 
 203    field Int line_size 
 204    field z_stream_s w 
 205    field Address buffer 
 206   
 207  ImageWriteFilter maybe ImageWriteFilterPng 
 208   
 209   
 210  method f open stream options h -> status 
 211    arg_rw ImageWriteFilterPng f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status 
 212    var Int psize := h:gamut pixel_size 
 213    if psize<>and psize<>and psize<># h:gamut:name<>"rgb" and h:gamut:name<>"rgba" and h:gamut:name<>"grey" 
 214      return failure:"Only RGB images are currently supported by PNG output filter" 
 215    line_size := h:pixel_size*h:size_x 
 216    stream :> stream 
 217    stream raw_write8 137 
 218    stream raw_write8 80 
 219    stream raw_write8 78 
 220    stream raw_write8 71 
 221    stream raw_write8 13 
 222    stream raw_write8 10 
 223    stream raw_write8 26 
 224    stream raw_write8 10 
 225   
 226    stream raw_write32 PNGHeader:size 
 227    stream writechars "IHDR" 
 228    var PNGHeader hdr 
 229    hdr size_x := size_x 
 230    hdr size_y := size_y 
 231    hdr depth := 8 
 232    hdr color := shunt psize=1 0 psize=3 2 psize=4 6 0 
 233    hdr compression := 0 
 234    hdr filter := 0 
 235    hdr interlace := 0 
 236    stream raw_write addressof:hdr PNGHeader:size 
 237    (var PNG_CRC table) init ; table update "IHDR":characters 4 
 238    table update addressof:hdr PNGHeader:size 
 239    stream raw_write32 table:terminate 
 240   
 241    stream raw_write32 PNGResolution:size 
 242    stream writechars "pHYs" 
 243    var PNGResolution r 
 244    rx := cast h:size_x/(abs h:x1-h:x0)*1000 Int 
 245    ry := cast h:size_y/(abs h:y1-h:y0)*1000 Int 
 246    unit := 1 
 247    stream raw_write addressof:PNGResolution:size 
 248    (var PNG_CRC table) init ; table update "pHYs":characters 4 
 249    table update addressof:PNGResolution:size 
 250    stream raw_write32 table:terminate 
 251   
 252    buffer := memory_allocate buffer_size null 
 253    var Pointer:z_stream_s :> w 
 254    memory_clear addressof:z_stream_s:size 
 255    next_out := buffer 
 256    avail_out := buffer_size 
 257    data_type := 2 
 258    if pliant_alloc 
 259      zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable 
 260      zfree := (the_function pliant_zfree Address Address) executable 
 261    deflateInit -1 
 262    status := success 
 263   
 264   
 265  method f flush 
 266    arg_rw ImageWriteFilterPng f 
 267    var Pointer:Stream stream :> stream 
 268    var Pointer:z_stream_s :> w 
 269    stream raw_write32 buffer_size-w:avail_out 
 270    stream writechars "IDAT" 
 271    (var PNG_CRC table) init ; table update "IDAT":characters 4 
 272    stream raw_write f:buffer buffer_size-w:avail_out 
 273    table update f:buffer buffer_size-w:avail_out 
 274    stream raw_write32 table:terminate 
 275    next_out := buffer 
 276    avail_out := buffer_size 
 277   
 278  method f writeline adr -> status 
 279    arg_rw ImageWriteFilterPng f ; arg Address adr ; arg Status status 
 280    var Pointer:z_stream_s :> w 
 281    var uInt8 zero := 0 
 282    next_in := addressof zero 
 283    avail_in := 1 
 284    part compress1 
 285      deflate 0 
 286      if w:avail_in<>0 
 287        flush 
 288        restart compress1 
 289    next_in := adr 
 290    avail_in := line_size 
 291    part compress2 
 292      deflate # Z_NO_FLUSH 
 293      if w:avail_in<>0 
 294        flush 
 295        restart compress2 
 296    status := success 
 297   
 298   
 299  method f close -> status 
 300    arg_rw ImageWriteFilterPng f ; arg ExtendedStatus status 
 301    var Pointer:z_stream_s :> w 
 302    part compress 
 303      deflate # Z_FINISH 
 304      if w:avail_out<>buffer_size 
 305        flush 
 306        restart compress 
 307    deflateEnd f:w 
 308    memory_free f:buffer 
 309    var Pointer:Stream stream :> stream 
 310    stream raw_write32 0 
 311    stream writechars "IEND" 
 312    (var PNG_CRC table) init ; table update "IEND":characters 4 
 313    stream raw_write32 table:terminate 
 314    status := success 
 315   
 316   
 317 
 
 318   
 319   
 320  type ImageReadFilterPng 
 321    field Pointer:Stream s 
 322    field Int pixel_size line_size 
 323    field z_stream_s r 
 324    field Int remain 
 325    field Int y 
 326    field Address buffer 
 327    field Address previous 
 328   
 329  ImageReadFilter maybe ImageReadFilterPng 
 330   
 331   
 332  method f open stream options h -> status 
 333    arg_rw ImageReadFilterPng f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status 
 334    var Str sign := ".PNG...." 
 335    stream raw_read sign:characters sign:len 
 336    if sign<>character:137+"PNG[cr][lf]"+character:26+"[lf]" 
 337      return failure:"This is not a .png image" 
 338    stream raw_read addressof:(var uInt32_hi len) uInt32:size 
 339    var Str tag := "1234" ; stream raw_read tag:characters tag:len 
 340    if tag<>"IHDR" or len<>PNGHeader:size 
 341      return failure:"Expected PNG header tag to be the first one" 
 342    stream raw_read addressof:(var PNGHeader hdr) PNGHeader:size 
 343    if hdr:depth<>or (hdr:color<>and hdr:color<>and hdr:color<>6) 
 344      return failure:"Only 24 bits or 32 bits per pixel PNG files are currently supported" 
 345    if hdr:compression<>or hdr:filter<>or hdr:interlace<>0 
 346      return failure:"This PNG file encoding is not supported yet" 
 347    # FIXME: rather scan all tags until iDAT 
 348    if not ((options (options option_position "resolution" 0) options:len) parse word:"resolution" (var Float dpi_x) (var Float dpi_y) any) 
 349      dpi_x := options option "resolution" Float 72 ; dpi_y := dpi_x 
 350    if read_resolution and not stream:atend and (cast stream:stream_read_stop uInt)-(cast stream:stream_read_cur uInt)>=12 
 351      var uInt32_hi len := (stream:stream_read_cur translate Byte 4) map uInt32_hi 
 352      tag set (stream:stream_read_cur translate Byte 8) 4 false 
 353      if tag="pHYs" and len=PNGResolution:size 
 354        stream:stream_read_cur := stream:stream_read_cur translate Byte 12 
 355        stream raw_read addressof:(var PNGResolution res) PNGResolution:size 
 356        dpi_x := res:rx/1000*25.4 
 357        dpi_y := res:ry/1000*25.4 
 358    := 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="grey" hdr:color="rgb" hdr:color="rgba" "") 
 359    :> stream 
 360    pixel_size := pixel_size 
 361    line_size := line_size 
 362    remain := 0 
 363    var Pointer:z_stream_s :> r 
 364    memory_clear addressof:z_stream_s:size 
 365    data_type := 2 
 366    if pliant_alloc 
 367      zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable 
 368      zfree := (the_function pliant_zfree Address Address) executable 
 369    if (inflateInit r)<>0 
 370      return failure:"failed to initialize Zlib" 
 371    remain := 0 
 372    := 0 
 373    buffer := (memory_zallocate h:line_size+h:pixel_size addressof:f) translate Byte f:pixel_size 
 374    previous := (memory_zallocate h:line_size+h:pixel_size addressof:f) translate Byte f:pixel_size 
 375    status := success 
 376   
 377  function predicator a b c -> r 
 378    arg Int r 
 379    var Int := a+b-c 
 380    var Int pa := abs p-a 
 381    var Int pb := abs p-b 
 382    var Int pc := abs p-c 
 383    := shunt pa<=pb and pa<=pc pb<=pc c 
 384   
 385  method f readline adr -> status 
 386    arg_rw ImageReadFilterPng f ; arg Address adr ; arg Status status 
 387    var Pointer:z_stream_s :> r 
 388    var Pointer:Stream :> s 
 389    next_out := addressof (var uInt8 filter) 
 390    avail_out := 1 
 391    var CBool mode := false 
 392    while r:avail_out<>or not mode 
 393      if r:avail_out=0 
 394        next_out := buffer 
 395        avail_out := line_size 
 396        mode := true 
 397      if r:avail_in=0 
 398        while f:remain=0 
 399          raw_read addressof:(var uInt32_hi crc) uInt32:size 
 400          if s:atend 
 401            return failure 
 402          raw_read addressof:(var uInt32_hi len) uInt32:size 
 403          var Str tag := "1234" ; raw_read tag:characters tag:len 
 404          if tag="IDAT" 
 405            remain := len 
 406          else 
 407            for (var Int i) len-1 
 408              raw_read addressof:(var uInt8 drop) 1 
 409        if s:atend 
 410          return failure 
 411        next_in := stream_read_cur 
 412        avail_in := min (cast s:stream_read_stop Int)-(cast s:stream_read_cur Int) f:remain 
 413        stream_read_cur := s:stream_read_cur translate Byte r:avail_in 
 414        remain -= avail_in 
 415      inflate 0 
 416    var Address cur := buffer 
 417    var Address stop := f:buffer translate Byte f:line_size 
 418    var Int left := -(pixel_size) 
 419    var Int top := (cast f:previous Int).-.(cast f:buffer Int) 
 420    var Int topleft := left+top 
 421    if filter=0 
 422      void 
 423    eif filter=1 
 424      while cur<>stop 
 425        cur map uInt8 := (cur map uInt8)+(cur map uInt8 left) .and. 255 
 426        cur := cur translate uInt8 1 
 427    eif filter=2 
 428      while cur<>stop 
 429        cur map uInt8 := (cur map uInt8)+(cur map uInt8 top) .and. 255 
 430        cur := cur translate uInt8 1 
 431    eif filter=3 
 432      while cur<>stop 
 433        cur map uInt8 := (cur map uInt8)+((cur map uInt8 left)+(cur map uInt8 top))\.and. 255 
 434        cur := cur translate uInt8 1 
 435    eif filter=4 
 436      while cur<>stop 
 437        cur map uInt8 := (cur map uInt8)+(predicator (cur map uInt8 left) (cur map uInt8 top) (cur map uInt8 topleft)) .and. 255 
 438        cur := cur translate uInt8 1 
 439    else 
 440      return failure 
 441    memory_copy f:buffer adr f:line_size 
 442    memory_copy adr f:previous f:line_size 
 443    += 1 
 444    status := success 
 445   
 446  method f close -> status 
 447    arg_rw ImageReadFilterPng f ; arg ExtendedStatus status 
 448    status := success 
 449    if (inflateEnd f:r)<>0 
 450      status := failure 
 451    memory_free (f:buffer translate Byte -(f:pixel_size)) 
 452    memory_free (f:previous translate Byte -(f:pixel_size)) 
 453   
 454   
 455  image_record_filters ".png" ImageReadFilterPng false ImageWriteFilterPng false