Patch title: Release 92 bulk changes
Abstract:
File: /graphic/image/packed.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
submodule "prototype.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/util/encoding/pack4.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/misc/int.pli"
module "/pliant/graphic/misc/filepool.pli"


module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
submodule "prototype.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/util/encoding/pack4.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/misc/int.pli"
module "/pliant/graphic/misc/filepool.pli"


method p disk_shrink
  arg_rw ImagePacked p
  p:disk_shrink_sem request
  if p:packed_size>p:packed_limit
    p:disk_sem request
    if p:disk_file=""
      p disk_file := file_temporary
      p:disk_stream open p:disk_file in+out+nocache
    p:disk_sem release
    for (var Int i) 0 p:tiles:size-1
      var Pointer:PackedTile t :> p:tiles i
      t:sem request
      if t:packed<>null
        if t:disk_offset=undefined
          p:disk_sem request
          t disk_offset := p:disk_pool allocate t:packed_siz
          p:disk_stream configure "seek "+(string t:disk_off
          p:disk_stream raw_write t:packed t:packed_size
          p:disk_sem release
        memory_free t:packed ; t packed := null
        atomic_add p:packed_size -(t:packed_size)
      t:sem release
    if p:auto_clip
      p clip_y1 := p:clip_y0+(max (p:clip_y1-p:clip_y0)\2 1)
  p:disk_shrink_sem release


method p pack t
  arg_rw ImagePacked p ; arg_rw PackedTile t
  if t:modified
    if t:disk_offset<>undefined
      p:disk_sem request
      p:disk_pool free t:disk_offset t:packed_size
      t disk_offset := undefined
      p:disk_sem release
    p:cbuf_sem request
    var Int csize := 0
    for (var Int y) 0 t:size_y-1
      csize += pack4_encode (t:clear translate Byte y*t:size
    if t:packed<>null
      memory_free t:packed
      atomic_add p:packed_size -(t:packed_size)
    atomic_add p:packed_size csize
    t packed := memory_allocate csize addressof:p ; t packed
    memory_copy p:cbuf t:packed csize
    p:cbuf_sem release
  memory_free t:clear ; t clear := null
  atomic_add p:clear_size -(t:size_x*t:size_y*p:pixel_size)


method p setup proto options -> status
method p pack t
  arg_rw ImagePacked p ; arg_rw PackedTile t
  if t:modified
    if t:disk_offset<>undefined
      p:disk_sem request
      p:disk_pool free t:disk_offset t:packed_size
      t disk_offset := undefined
      p:disk_sem release
    p:cbuf_sem request
    var Int csize := 0
    for (var Int y) 0 t:size_y-1
      csize += pack4_encode (t:clear translate Byte y*t:size
    if t:packed<>null
      memory_free t:packed
      atomic_add p:packed_size -(t:packed_size)
    atomic_add p:packed_size csize
    t packed := memory_allocate csize addressof:p ; t packed
    memory_copy p:cbuf t:packed csize
    p:cbuf_sem release
  memory_free t:clear ; t clear := null
  atomic_add p:clear_size -(t:size_x*t:size_y*p:pixel_size)


method p setup proto options -> status
  arg_rw ImagePacked p ; arg ImagePrototype proto ; arg Str 
  oarg_rw ImagePacked p ; arg ImagePrototype proto ; arg Str options ; arg ExtendedStatus status
  check proto:size_x>0 and proto:size_y>0
  memory_free p:cbuf
  addressof:p map ImagePrototype := proto
  p tile_x := options option "tile_x" Int (min p:size_x defa
  p tile_y := options option "tile_y" Int (min p:size_y defa
  p nb_x := (p:size_x+p:tile_x-1)\p:tile_x
  p nb_y := (p:size_y+p:tile_y-1)\p:tile_y
  if advanced_thresholding
    p clear_threshold1 := bound 2*p:tile_y*p:size_x*p:pixel_
    p clear_threshold2 := max 4*processor_count*p:tile_y*p:s
  else
    p clear_threshold := options option "clear_cache_size" I
  p:tiles size := 0
  p:tiles size := p:nb_x*p:nb_y
  for (var Int iy) 0 p:nb_y-1
    for (var Int ix) 0 p:nb_x-1
      var Pointer:PackedTile t :> p:tiles ix+iy*p:nb_x
      t size_x := min p:tile_x p:size_x-ix*p:tile_x
      t size_y := min p:tile_y p:size_y-iy*p:tile_y
  p cbuf := memory_allocate p:tile_x*p:tile_y*p:pixel_size*2
  p clear_size := 0
  p packed_size := 0
  p packed_limit := options option "packed_cache_size" Int u
  p disk_pool := var FilePool empty_disk_pool
  p auto_clip := false
  p clip_y0 := 0 ; p clip_y1 := p size_y
  status := success


method p read x y count adr
  check proto:size_x>0 and proto:size_y>0
  memory_free p:cbuf
  addressof:p map ImagePrototype := proto
  p tile_x := options option "tile_x" Int (min p:size_x defa
  p tile_y := options option "tile_y" Int (min p:size_y defa
  p nb_x := (p:size_x+p:tile_x-1)\p:tile_x
  p nb_y := (p:size_y+p:tile_y-1)\p:tile_y
  if advanced_thresholding
    p clear_threshold1 := bound 2*p:tile_y*p:size_x*p:pixel_
    p clear_threshold2 := max 4*processor_count*p:tile_y*p:s
  else
    p clear_threshold := options option "clear_cache_size" I
  p:tiles size := 0
  p:tiles size := p:nb_x*p:nb_y
  for (var Int iy) 0 p:nb_y-1
    for (var Int ix) 0 p:nb_x-1
      var Pointer:PackedTile t :> p:tiles ix+iy*p:nb_x
      t size_x := min p:tile_x p:size_x-ix*p:tile_x
      t size_y := min p:tile_y p:size_y-iy*p:tile_y
  p cbuf := memory_allocate p:tile_x*p:tile_y*p:pixel_size*2
  p clear_size := 0
  p packed_size := 0
  p packed_limit := options option "packed_cache_size" Int u
  p disk_pool := var FilePool empty_disk_pool
  p auto_clip := false
  p clip_y0 := 0 ; p clip_y1 := p size_y
  status := success


method p read x y count adr
  arg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  oarg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  if clip and (y<p:clip_y0 or y>=p:clip_y1)
    memory_clear adr count*p:pixel_size
    return
  if p:packed_limit<>undefined and p:packed_size>p:packed_li
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  if clip and (y<p:clip_y0 or y>=p:clip_y1)
    memory_clear adr count*p:pixel_size
    return
  if p:packed_limit<>undefined and p:packed_size>p:packed_li
    p disk_shrink
    p configure "disk_shrink"
  var Int xx := x
  while xx<x+count
    var Pointer:PackedTile t :> p tile_map xx y (var Int off
    var Int step := min x+count-xx t:size_x-offset_x
    memory_copy (t:clear translate Byte (offset_x+offset_y*t
    t:sem rd_release
    xx += step


method p write x y count adr
  var Int xx := x
  while xx<x+count
    var Pointer:PackedTile t :> p tile_map xx y (var Int off
    var Int step := min x+count-xx t:size_x-offset_x
    memory_copy (t:clear translate Byte (offset_x+offset_y*t
    t:sem rd_release
    xx += step


method p write x y count adr
  arg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  oarg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  if clip and (y<p:clip_y0 or y>=p:clip_y1)
    return
  if p:packed_limit<>undefined and p:packed_size>p:packed_li
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  if clip and (y<p:clip_y0 or y>=p:clip_y1)
    return
  if p:packed_limit<>undefined and p:packed_size>p:packed_li
    p disk_shrink
    p configure "disk_shrink"
  var Int xx := x
  while xx<x+count
    var Pointer:PackedTile t :> p tile_map xx y (var Int off
    var Int step := min x+count-xx t:size_x-offset_x
    memory_copy (adr translate Byte (xx-x)*p:pixel_size) (t:
    t modified := true
    t:sem rd_release
    xx += step


method p read_map x y mini maxi count -> adr
  var Int xx := x
  while xx<x+count
    var Pointer:PackedTile t :> p tile_map xx y (var Int off
    var Int step := min x+count-xx t:size_x-offset_x
    memory_copy (adr translate Byte (xx-x)*p:pixel_size) (t:
    t modified := true
    t:sem rd_release
    xx += step


method p read_map x y mini maxi count -> adr
  arg_rw ImagePacked p ; arg Int x y mini maxi ; arg_w Int c
  oarg_rw ImagePacked p ; arg Int x y mini maxi ; arg_w Int count ; arg Address adr
  check mini>0 and maxi>=mini and x>=0 and count>=0 and x+ma
  if mini>p:tile_x or (clip and (y<p:clip_y0 or y>=p:clip_y1
    return null
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  count := t:size_x-offset_x
  if count>=mini
    count := min count maxi
    adr := t:clear translate Byte (offset_x+offset_y*t:size_
  else
    t:sem rd_release
    adr := null
    
method p read_unmap x y count adr
  check mini>0 and maxi>=mini and x>=0 and count>=0 and x+ma
  if mini>p:tile_x or (clip and (y<p:clip_y0 or y>=p:clip_y1
    return null
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  count := t:size_x-offset_x
  if count>=mini
    count := min count maxi
    adr := t:clear translate Byte (offset_x+offset_y*t:size_
  else
    t:sem rd_release
    adr := null
    
method p read_unmap x y count adr
  arg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  oarg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  t:sem rd_release
  t:sem rd_release
  

method p write_map x y mini maxi count -> adr
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  t:sem rd_release
  t:sem rd_release
  

method p write_map x y mini maxi count -> adr
  arg_rw ImagePacked p ; arg Int x y mini maxi ; arg_w Int c
  oarg_rw ImagePacked p ; arg Int x y mini maxi ; arg_w Int count ; arg Address adr
  check mini>0 and maxi>=mini and x>=0 and x+maxi<=p:size_x 
  if mini>p:tile_x or (clip and (y<p:clip_y0 or y>=p:clip_y1
    return null
  if p:packed_limit<>undefined and p:packed_size>p:packed_li
  check mini>0 and maxi>=mini and x>=0 and x+maxi<=p:size_x 
  if mini>p:tile_x or (clip and (y<p:clip_y0 or y>=p:clip_y1
    return null
  if p:packed_limit<>undefined and p:packed_size>p:packed_li
    p disk_shrink
    p configure "disk_shrink"
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  count := t:size_x-offset_x
  if count>=mini
    count := min count maxi
    adr := t:clear translate Byte (offset_x+offset_y*t:size_
    t modified := true
  else
    t:sem rd_release
    adr := null
    
method p write_unmap x y count adr
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  count := t:size_x-offset_x
  if count>=mini
    count := min count maxi
    adr := t:clear translate Byte (offset_x+offset_y*t:size_
    t modified := true
  else
    t:sem rd_release
    adr := null
    
method p write_unmap x y count adr
  arg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  oarg_rw ImagePacked p ; arg Int x y count ; arg Address adr
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  t:sem rd_release
  t:sem rd_release
  


  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and
  var Pointer:PackedTile t :> p tile_map x y (var Int offset
  t:sem rd_release
  t:sem rd_release
  


method p shrink -> status
  arg_rw ImagePacked p ; arg Status status
  part shrink
    status := success
    p:clear_sem request
    var Pointer:ListNode_ ptr :> p:clear_list first
    while exists:ptr
      var Pointer:PackedTile t :> addressof:ptr map PackedTi
      if (t:sem nowait_request)
        p:clear_list remove ptr
        p:clear_sem release
        p pack t
method p configure command -> status
  oarg_rw ImagePacked p ; arg Str command ; arg ExtendedStatus status
  if command="shrink"
    part shrink
      status := success
      p:clear_sem request
      var Pointer:ListNode_ ptr :> p:clear_list first
      while exists:ptr
        var Pointer:PackedTile t :> addressof:ptr map PackedTile
        if (t:sem nowait_request)
          p:clear_list remove ptr
          p:clear_sem release
          p pack t
          t:sem release
          restart shrink
        else
          status := failure
          ptr :> ptr next
      p:clear_sem release
  eif command="disk_shrink"
    p:disk_shrink_sem request
    if p:packed_size>p:packed_limit
      p:disk_sem request
      if p:disk_file=""
        p disk_file := file_temporary
        p:disk_stream open p:disk_file in+out+nocache
      p:disk_sem release
      for (var Int i) 0 p:tiles:size-1
        var Pointer:PackedTile t :> p:tiles i
        t:sem request
        if t:packed<>null
          if t:disk_offset=undefined
            p:disk_sem request
            t disk_offset := p:disk_pool allocate t:packed_size
            p:disk_stream configure "seek "+(string t:disk_offset)
            p:disk_stream raw_write t:packed t:packed_size
            p:disk_sem release
          memory_free t:packed ; t packed := null
          atomic_add p:packed_size -(t:packed_size)
        t:sem release
        t:sem release
        restart shrink
      else
        status := failure
        ptr :> ptr next
    p:clear_sem release
      if p:auto_clip
        p clip_y1 := p:clip_y0+(max (p:clip_y1-p:clip_y0)\2 1)
    p:disk_shrink_sem release
    status := success
  else
    status := failure:"unkown command"


method p fast_save filename -> status
  oarg_rw ImagePacked p ; arg Str filename ; arg Status stat


method p fast_save filename -> status
  oarg_rw ImagePacked p ; arg Str filename ; arg Status stat
  while p:shrink=failure
  while (p configure "shrink")=failure
    void
  if trace
    var DateTime dt := datetime
  (var Stream s) open "gzip:"+filename+".tmp" out+safe
  if s=failure
    return failure
  file_delete filename
  s writeline "pliant image packed"
  s writeline "x0 "+(string p:x0)
  s writeline "y0 "+(string p:y0)
  s writeline "x1 "+(string p:x1)
  s writeline "y1 "+(string p:y1)
  s writeline "size_x "+(string p:size_x)
  s writeline "size_y "+(string p:size_y)
  s writeline "tile_x "+(string p:tile_x)
  s writeline "tile_y "+(string p:tile_y)
  s writeline "gamut "+(string p:gamut:name)
  s writeline "pixel_size "+(string p:gamut:pixel_size)
  if p:options<>""
    s writeline "options "+(string p:options)
  s writeline ""
  for (var Int i) 0 p:nb_x*p:nb_y-1
    var Pointer:PackedTile t :> p:tiles i
    t:sem request
    var Int32 csize := t packed_size ; s raw_write addressof
    if t:packed<>null or t:disk_offset=undefined
      s raw_write t:packed csize
    else
      p:disk_sem request
      p:disk_stream configure "seek "+(string t:disk_offset)
      raw_copy p:disk_stream s csize csize
      p:disk_sem release
    t:sem release
  if s:close=failure
    file_delete filename+".tmp"
    return failure
  status := file_move filename+".tmp" filename
  if trace
    console "saved " filename " in " (cast datetime:seconds-



    void
  if trace
    var DateTime dt := datetime
  (var Stream s) open "gzip:"+filename+".tmp" out+safe
  if s=failure
    return failure
  file_delete filename
  s writeline "pliant image packed"
  s writeline "x0 "+(string p:x0)
  s writeline "y0 "+(string p:y0)
  s writeline "x1 "+(string p:x1)
  s writeline "y1 "+(string p:y1)
  s writeline "size_x "+(string p:size_x)
  s writeline "size_y "+(string p:size_y)
  s writeline "tile_x "+(string p:tile_x)
  s writeline "tile_y "+(string p:tile_y)
  s writeline "gamut "+(string p:gamut:name)
  s writeline "pixel_size "+(string p:gamut:pixel_size)
  if p:options<>""
    s writeline "options "+(string p:options)
  s writeline ""
  for (var Int i) 0 p:nb_x*p:nb_y-1
    var Pointer:PackedTile t :> p:tiles i
    t:sem request
    var Int32 csize := t packed_size ; s raw_write addressof
    if t:packed<>null or t:disk_offset=undefined
      s raw_write t:packed csize
    else
      p:disk_sem request
      p:disk_stream configure "seek "+(string t:disk_offset)
      raw_copy p:disk_stream s csize csize
      p:disk_sem release
    t:sem release
  if s:close=failure
    file_delete filename+".tmp"
    return failure
  status := file_move filename+".tmp" filename
  if trace
    console "saved " filename " in " (cast datetime:seconds-



export ImagePacked '. packed_size' '. shrink' '. disk_shrink
export ImagePacked '. packed_size'
export '. fast_save' '. fast_load'
if clip
  export '. auto_clip' '. clip_y0' '. clip_y1'
  export '. recommended_draw_tile'

export '. fast_save' '. fast_load'
if clip
  export '. auto_clip' '. clip_y0' '. clip_y1'
  export '. recommended_draw_tile'