Patch title: Release 85 bulk changes
Abstract:
File: /pliant/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"

constant trace false
constant default_tile_x 512
constant default_tile_y 16
# so a tile is roughly (6 coulours image) 512*16*6 = 48 KB
constant minimum_clear_cache 4*2^20
constant maximum_clear_cache 16*2^20
constant advanced_thresholding false

# memory_decommit_threshold := 2^24

type PackedTile
  field ListNode_ clear_node
  field Address clear <- null
  field Address packed <- null
  field Int size_x size_y
  field Int packed_size <- 0
  field CBool modified <- false
  field Sem sem
  field Intn disk_offset
  
function destroy t
  arg_w PackedTile t
  memory_free t:packed
  memory_free t:clear


type ImagePacked
  inherit ImagePrototype
  field Int tile_x tile_y
  field Array:PackedTile tiles ; field Int nb_x nb_y
  field Address cbuf <- null
  field Sem cbuf_sem
  field Int packed_size <- 0
  field Int clear_size <- 0
  if advanced_thresholding
    field Int clear_threshold1 clear_threshold2
  else
    field Int clear_threshold
  field List_ clear_list
  field Sem clear_sem
  field CBool disk <- false
  field Str disk_file
  field Stream disk_stream
  field Sem disk_sem

ImagePrototype maybe ImagePacked


method p pack t
  arg_rw ImagePacked p ; arg_rw PackedTile t
  if t:modified
    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_x*p:pixel_size) (p:cbuf translate Byte csize) p:pixel_size t:size_x (shunt y=0 null (t:clear translate Byte (y-1)*t:size_x*p:pixel_size))
    memory_free t:packed
    t packed := memory_allocate csize addressof:p
    memory_copy p:cbuf t:packed csize
    atomic_add p:packed_size csize-t:packed_size ; t packed_size := 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 unpack t
  arg_rw ImagePacked p ; arg_rw PackedTile t
  var CBool disk := p:disk and t:packed=null
  if disk
    p:disk_sem request
    t packed := memory_allocate t:packed_size addressof:p
    p:disk_stream configure "seek "+(string t:disk_offset)
    p:disk_stream raw_read t:packed t:packed_size
  if t:packed<>null
    t clear := memory_allocate t:size_x*t:size_y*p:pixel_size addressof:p
    var Int csize := 0
    for (var Int y) 0 t:size_y-1
      csize += pack4_decode (t:packed translate Byte csize) (t:clear translate Byte y*t:size_x*p:pixel_size) p:pixel_size t:size_x (t:clear translate Byte (y-1)*t:size_x*p:pixel_size)
  else
    t clear := memory_zallocate t:size_x*t:size_y*p:pixel_size addressof:p
  if disk
    memory_free t:packed ; t packed := null
    p:disk_sem release
  t modified := false
  atomic_add p:clear_size t:size_x*t:size_y*p:pixel_size

method p tile_map x y offset_x offset_y -> t
  arg_rw ImagePacked p ; arg Int x y ; arg_w Int offset_x offset_y ; arg_RW PackedTile t
  var Int ix := x\p:tile_x ; offset_x := x%p:tile_x
  var Int iy := y\p:tile_y ; offset_y := y%p:tile_y
  t :> p:tiles ix+iy*p:nb_x
  t:sem rd_request
  while t:clear=null
    t:sem rd_release
    part make_room
      if advanced_thresholding
        var CBool too_much := p:clear_size>p:clear_threshold2 or (p:clear_size>p:clear_threshold1 and memory_current_consumed>memory_assigned)
      else
        var CBool too_much := p:clear_size>p:clear_threshold
      if too_much
        p:clear_sem request
        var Pointer:ListNode_ ptr :> p:clear_list:first
        while exists:ptr
          var Pointer:PackedTile t2 :> addressof:ptr map PackedTile
          if (t2:sem nowait_request)
            p:clear_list remove ptr
            p:clear_sem release
            p pack t2
            t2:sem release
            restart make_room
          else
            ptr :> ptr next
        p:clear_sem release
    t:sem request
    if t:clear=null
      p unpack t
      p:clear_sem request
      p:clear_list append t:clear_node
      p:clear_sem release
    t:sem release
    t:sem rd_request


function destroy p
  arg_w ImagePacked p
  memory_free p:cbuf
  p:disk_stream close
  if p:disk_file<>""
    file_delete p:disk_file


method p setup proto options -> status
  arg_rw ImagePacked p ; arg ImagePrototype proto ; arg Str options ; arg ExtendedStatus status
  memory_free p:cbuf
  addressof:p map ImagePrototype := proto
  p tile_x := options option "tile_x" Int (min p:size_x default_tile_x)
  p tile_y := options option "tile_y" Int (min p:size_y default_tile_y)
  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_size minimum_clear_cache maximum_clear_cache
    p clear_threshold2 := max 4*processor_count*p:tile_y*p:size_x*p:pixel_size p:clear_threshold1
  else
    p clear_threshold := bound 2*p:tile_y*p:size_x*p:pixel_size minimum_clear_cache maximum_clear_cache
  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 addressof:p
  p packed_size := 0
  p clear_size := 0  
  status := success


method p read x y count adr
  arg_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 y<p:size_y
  var Int xx := x
  while xx<x+count
    var Pointer:PackedTile t :> p tile_map xx y (var Int offset_x) (var Int offset_y)
    var Int step := min x+count-xx t:size_x-offset_x
    memory_copy (t:clear translate Byte (offset_x+offset_y*t:size_x)*p:pixel_size) (adr translate Byte (xx-x)*p:pixel_size) step*p:pixel_size
    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
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and y<p:size_y
  var Int xx := x
  while xx<x+count
    var Pointer:PackedTile t :> p tile_map xx y (var Int offset_x) (var Int offset_y)
    var Int step := min x+count-xx t:size_x-offset_x
    memory_copy (adr translate Byte (xx-x)*p:pixel_size) (t:clear translate Byte (offset_x+offset_y*t:size_x)*p:pixel_size) step*p:pixel_size
    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 count ; arg Address adr
  check mini>0 and maxi>=mini and x>=0 and count>=0 and x+maxi<=p:size_x and y>=0 and y<p:size_y
  if mini>p:tile_x
    return null
  var Pointer:PackedTile t :> p tile_map x y (var Int offset_x) (var Int offset_y)
  count := t:size_x-offset_x
  if count>=mini
    count := min count maxi
    adr := t:clear translate Byte (offset_x+offset_y*t:size_x)*p:pixel_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
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and y<p:size_y
  var Pointer:PackedTile t :> p tile_map x y (var Int offset_x) (var Int offset_y)
  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 count ; arg Address adr
  check mini>0 and maxi>=mini and x>=0 and count>=0 and x+maxi<=p:size_x and y>=0 and y<p:size_y
  if mini>p:tile_x
    return null
  var Pointer:PackedTile t :> p tile_map x y (var Int offset_x) (var Int offset_y)
  count := t:size_x-offset_x
  if count>=mini
    count := min count maxi
    adr := t:clear translate Byte (offset_x+offset_y*t:size_x)*p:pixel_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
  check x>=0 and count>=0 and x+count<=p:size_x and y>=0 and y<p:size_y
  var Pointer:PackedTile t :> p tile_map x y (var Int offset_x) (var Int offset_y)
  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 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


method p fast_save filename -> status
  oarg_rw ImagePacked p ; arg Str filename ; arg Status status
  if p:disk
    return failure
  while p: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:csize Int32:size
    s raw_write t:packed csize
    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-dt:seconds Int) " seconds" eol


method p fast_load filename options -> status
  oarg_rw ImagePacked p ; arg Str filename ; arg Str options ; arg Status status
  if trace
    var DateTime dt := datetime
  (var Stream s) open "gzip:"+filename in+safe
  if s=failure
    return failure
  if s:readline<>"pliant image packed"
    return failure
  var ImagePrototype proto 
  while { var Str l := s readline ; l<>"" }
    l parse word:"x0" proto:x0
    l parse word:"y0" proto:y0
    l parse word:"x1" proto:x1
    l parse word:"y1" proto:y1
    l parse word:"size_x" proto:size_x
    l parse word:"size_y" proto:size_y
    l parse word:"tile_x" (var Int tile_x)
    l parse word:"tile_y" (var Int tile_y)
    l parse word:"gamut" (var Str gamut_name)
    l parse word:"options" proto:options
  if (gamut_name search ":" -1)=(-1) and (gamut_name 0 3)<>"rgb"
    gamut_name := "pantone:"+gamut_name
  proto gamut :> color_gamut gamut_name
  if proto:gamut=failure
    return failure
  proto complete
  if (p setup proto options+" tile_x "+string:tile_x+" tile_y "+string:tile_y)=failure
    return failure
  p disk := options option "disk"
  if p:disk
    if trace
      console "leave " filename " on disk" eol
    if p:disk_file=""
      p disk_file := file_temporary
    p:disk_stream open p:disk_file in+out+safe
  for (var Int i) 0 p:nb_x*p:nb_y-1
    var Pointer:PackedTile t :> p:tiles i
    s raw_read addressof:(var Int32 csize) Int32:size
    t packed_size := csize
    if p:disk
      if not ((p:disk_stream query "seek") parse t:disk_offset)
        p:disk_stream error "failed to get position"
      if (raw_copy s p:disk_stream csize csize)<>csize
        p:disk_stream error "failed to copy"
    else
      t packed := memory_allocate csize addressof:p
      s raw_read t:packed csize
      p packed_size += csize
  status := s:close
  if p:disk and p:disk_stream=failure
    status := failure
  if trace
    console "loaded " filename " in " (cast datetime:seconds-dt:seconds Int) " seconds" eol


export ImagePacked '. packed_size' '. shrink' '. fast_save' '. fast_load'