Patch title: Release 91 bulk changes
Abstract:
File: /graphic/draw/image.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/math/transform.pli"
module "prototype.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/image/transparency.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/vector/outline.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/graphic/image/transform.pli"
module "/pliant/graphic/image/convert.pli"
module "/pliant/graphic/image/clip.pli"

constant source_transparency true


type DrawImage
  field Link:ImagePrototype image
  field Link:ImagePrototype draw_image trouble_image
  field List:Str warnings

DrawPrototype maybe DrawImage


method d bind image options
  oarg_rw DrawImage d ; oarg_rw ImagePrototype image ; arg Str options
  d image :> image
  d draw_image :> image


method d setup proto options -> status
  oarg_rw DrawImage d ; arg ImagePrototype proto ; arg Str options ; arg ExtendedStatus status
  if not (exists d:image)
    var Link:ColorGamut g :> color_gamut (replace proto:gamut:name "+transparencies" "")
    if g=failure
      return g
    d:image :> new ImagePacked
    d:image setup (image_prototype proto:x0 proto:y0 proto:x1 proto:y1 proto:size_x proto:size_y g) options
    if proto:gamut:model=color_gamut_additive
      var Int white := -1
      for (var Int y) 0 d:image:size_y-1
        d:image fill 0 y d:image:size_x addressof:white
    d draw_image :> d image
    if proto:gamut:transparency>0
      var Link:ImageTransparency transp :> new ImageTransparency
      if (transp bind d:image "")=success
        d image :> transp
    var Link:ImagePrototype image
    if (options option "packed")
      image :> new ImagePacked
    else
      image :> new ImagePixmap
    image setup (image_prototype proto options) options
    if proto:gamut:model=color_gamut_additive or not (options option "packed")
      var ColorBuffer pixel ; memory_clear addressof:pixel image:pixel_size
      if image:gamut:model=color_gamut_additive
        addressof:pixel map Int := -1
      for (var Int y) 0 image:size_y-1
        image fill 0 y image:size_x addressof:pixel
    d bind image options
  if proto:gamut:transparency>0 and entry_type:(addressof d:image)<>ImageTransparency
    var Link:ImageTransparency transp :> new ImageTransparency
    status := transp bind d:image ""
    if status=failure
      return
    d image :> transp
  status := success


method d gamut -> g
  oarg_rw DrawImage d ; oarg_R ColorGamut g
  g :> d:image gamut


method d image img t
  oarg_rw DrawImage d ; oarg_rw ImagePrototype img ; arg Transform2 t
  var Link:ImagePrototype final
  var Link:ImagePrototype final :> img
  var Link:ImageTransform timg :> new ImageTransform
  timg bind img t d:image "always_inside"
  timg bind final t d:image "always_inside"
  final :> timg
  var Int tx := cast (final:x0-d:image:x0)/(d:image:x1-d:image:x0)*d:image:size_x Int
  var Int ty := cast (final:y0-d:image:y0)/(d:image:y1-d:image:y0)*d:image:size_y Int
  var Int ix0 := 0
  var Int iy0 := 0
  var Int ix1 := final size_x
  var Int iy1 := final size_y
  ix0 += tx ; iy0 += ty ; ix1 += tx ; iy1 += ty
  d:image clip ix0 iy0 ix1 iy1
  ix0 -= tx ; iy0 -= ty ; ix1 -= tx ; iy1 -= ty
  if ix0>=ix1 or iy0>=iy1
    return
  if final:gamut:name<>d:image:gamut:name
    var Link:ImageConvert conv :> new ImageConvert
    conv bind final d:image:gamut ""
    final :> conv
  var Address buffer := memory_allocate final:line_size null
  for (var Int y) iy0 iy1-1
    var Int x := ix0 ; var Int count := ix1-ix0
    timg line_clip x y count
    if count>0
      final read x y count buffer
      d:image write x+tx y+ty count buffer
  memory_free buffer
  if source_transparency and final:gamut:transparency=1 and d:image:gamut:transparency=0
    var Address buffer := memory_allocate final:line_size null ; var Int psize := final:pixel_size
    var Address cbuffer := memory_allocate d:image:line_size null
    var Arrow speedup := d:image:gamut speedup final:gamut ""
    for (var Int y) iy0 iy1-1
      var Int x := ix0 ; var Int count := ix1-ix0
      timg line_clip x y count
      if count>0
        final read x y count buffer
        var Address cursor := buffer translate Byte final:gamut:dimension
        var Address stop := cursor translate Byte count*psize
        var Int done := 0
        while done<count
          var Int transp := cursor map uInt8 ; cursor := cursor translate Byte psize
          while cursor<>stop and (cursor map uInt8)=transp
            cursor := cursor translate Byte psize
          var Int next := ((cast cursor Int) .-. (cast buffer Int))\psize
          if transp>=128
            d:image:gamut convert final:gamut (buffer translate Byte done*psize) cbuffer next-done speedup
            d:image write x+tx+done y+ty next-done cbuffer
          done := next
    memory_free buffer
    memory_free cbuffer
  else
    if final:gamut:name<>d:image:gamut:name
      var Link:ImageConvert conv :> new ImageConvert
      conv bind final d:image:gamut ""
      final :> conv
    var Address buffer := memory_allocate final:line_size null
    for (var Int y) iy0 iy1-1
      var Int x := ix0 ; var Int count := ix1-ix0
      timg line_clip x y count
      if count>0
        final read x y count buffer
        d:image write x+tx y+ty count buffer
    memory_free buffer
  if (entry_type addressof:img)=ImagePacked
    (addressof:img map ImagePacked) shrink


method d rectangle x0 y0 x1 y1 color
  oarg_rw DrawImage d ; arg Float x0 y0 x1 y1 ; arg Address color
  d:image rectangle x0 y0 x1 y1 color

method d fill curves mode t color
  oarg_rw DrawImage d ; arg Array:Curve curves ; arg Int mode ; arg Transform2 t ; arg Address color
  d:image fill curves mode t color


method d text txt font kerning length t color
  oarg_rw DrawImage d ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
  d:image text txt font kerning length t color


method d clip_open x0 y0 x1 y1 -> dc
  oarg_rw DrawImage d ; arg Float x0 y0 x1 y1 ; arg Link:DrawPrototype dc
  var Link:ImageClip clipped :> new ImageClip
  clipped bind d:image x0 y0 x1 y1 "" (var Link:ImagePrototype mask)
  d image :> clipped
  var Link:DrawImage dm :> new DrawImage
  dm image :> mask
  dc :> dm

method d clip_close
  oarg_rw DrawImage d
  if entry_type:(addressof d:image)=ImageClip
    d image :> ((addressof d:image) map ImageClip) image


method d warning message
  oarg_rw DrawImage d ; arg Str message
  d warnings += message

method d trouble_open -> dt
  oarg_rw DrawImage d ; arg Link:DrawPrototype dt
  if not (exists d:trouble_image)
    var Link:ImagePrototype i :> d draw_image
    var Link:ImagePacked packed :> new ImagePacked
    packed setup (image_prototype i:x0 i:y0 i:x1 i:y1 i:size_x i:size_y color_gamut:"grey") ""
    d trouble_image :> packed
  var Link:DrawImage draw_trouble :> new DrawImage
  draw_trouble image :> d trouble_image
  dt :> draw_trouble


export DrawImage '. image' '. draw_image' '. trouble_image' '. warnings'
export DrawImage '. bind' '. image' '. draw_image' '. trouble_image' '. warnings'