Patch title: Release 91 bulk changes
Abstract:
File: /graphic/image/clip.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "prototype.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/misc/mtbuffer.pli"
module "/pliant/graphic/misc/float.pli"


type ImageClip
  inherit ImagePrototype
  field Link:ImagePrototype image
  field Link:ImagePrototype clip
  field Int tx ty
  field MtBuffer buffers

ImagePrototype maybe ImageClip


method p index_x x -> i
  arg ImagePrototype p ; arg Float x ; arg Int i
  i := cast (x-p:x0)/(p:x1-p:x0)*p:size_x-0.499 Int

method p index_y y -> i
  arg ImagePrototype p ; arg Float y ; arg Int i
  i := cast (y-p:y0)/(p:y1-p:y0)*p:size_y-0.499 Int

method p mm_x i -> x
  arg ImagePrototype p ; arg Int i ; arg Float x
  x := p:x0+i/p:size_x*(p:x1-p:x0)

method p mm_y i -> y
  arg ImagePrototype p ; arg Int i ; arg Float y
  y := p:y0+i/p:size_y*(p:y1-p:y0)

method c bind image x0 y0 x1 y1 options clip -> status
  oarg_rw ImageClip c ; oarg ImagePrototype image ; arg Float x0 y0 x1 y1 ; arg Str options ; arg_w Link:ImagePrototype clip ; arg ExtendedStatus status
  var Int ix0 := image index_x (shunt x0=defined (max x0 image:x0) image:x0)
  var Int iy0 := image index_y (shunt y0=defined (max y0 image:y0) image:y0)
  var Int ix1 := min (image index_x (shunt x1=defined (min x1 image:x1) image:x1))+1 image:size_x
  var Int iy1 := min (image index_y (shunt y1=defined (min y1 image:y1) image:y1))+1 image:size_y
  var Int ix0 := image index_x (shunt x0=defined (bound x0 image:x0 image:x1) image:x0)
  var Int iy0 := image index_y (shunt y0=defined (bound y0 image:y0 image:y1) image:y0)
  var Int ix1 := min (image index_x (shunt x1=defined (bound x1 image:x0 image:x1) image:x1))+1 image:size_x
  var Int iy1 := min (image index_y (shunt y1=defined (bound y1 image:y0 image:y1) image:y1))+1 image:size_y
  image clip ix0 iy0 ix1 iy1
  if ix1=ix0
    if ix1<image:size_x
      ix1 += 1
    else
      ix0 -= 1
  if iy1=iy0
    if iy1<image:size_y
      iy1 += 1
    else
      iy0 -= 1
  check ix0>=0 and iy0>=0 and ix1<=image:size_x and iy1<=image:size_y
  check ix1>ix0 and iy1>iy0
  c image :> image
  c tx := ix0
  c ty := iy0
  clip :> new ImagePacked
  clip setup (image_prototype (image mm_x ix0) (image mm_y iy0) (image mm_x ix1) (image mm_y iy1) ix1-ix0 iy1-iy0 color_gamut:"grey") ""
  c clip :> clip
  c:buffers size := clip line_size
  addressof:c map ImagePrototype := image_prototype clip:x0 clip:y0 clip:x1 clip:y1 clip:size_x clip:size_y image:gamut
  status := success


function bytes_count_0 adr size -> count
  arg Address adr ; arg Int size count
  count := 0
  while count+Int:size<=size and ((adr translate Byte count) map Int)=0
    count += Int size
  while count<size and ((adr translate Byte count) map uInt8)=0
    count += 1

function bytes_count_255 adr size -> count
  arg Address adr ; arg Int size count
  count := 0
  while count+Int:size<=size and ((adr translate Byte count) map Int)=(-1)
    count += Int size
  while count<size and ((adr translate Byte count) map uInt8)=255
    count += 1

method c write x y count adr
  oarg_rw ImageClip c ; arg Int x y count ; arg Address adr
  var Address buffer := c:buffers allocate
  c:clip read x y count buffer
  var Int i := 0
  while i<count
    var Int skip := bytes_count_0 (buffer translate Byte i) count-i
    i += skip
    var Int write := bytes_count_255 (buffer translate Byte i) count-i
    if write>0
      c:image write c:tx+x+i c:ty+y write (adr translate Byte i*c:image:pixel_size)
    eif i<>count
      error error_id_missing "Partial transparency is not implemented yet" ?
    i += write
  c:buffers free buffer


method c fill x y count pixel
  oarg_rw ImageClip c ; arg Int x y count ; arg Address pixel
  var Address buffer := c:buffers allocate
  c:clip read x y count buffer
  var Int i := 0
  while i<count
    var Int skip := bytes_count_0 (buffer translate Byte i) count-i
    i += skip
    var Int write := bytes_count_255 (buffer translate Byte i) count-i
    if write>0
      c:image fill c:tx+x+i c:ty+y write pixel
    eif i<>count
      error error_id_missing "Partial transparency is not implemented yet" ?
    i += write
  c:buffers free buffer


method c clip x0 y0 x1 y1
  oarg ImageClip c ; arg_rw Int x0 y0 x1 y1
  x0 := max x0 0
  y0 := max y0 0
  x1 := min x1 c:size_x
  y1 := min y1 c:size_y
  x0 += c tx ; y0 += c ty ; x1 += c tx ; y1 += c ty
  c:image clip x0 y0 x1 y1
  x0 -= c tx ; y0 -= c ty ; x1 -= c tx ; y1 -= c ty


export ImageClip '. bind' '. image'