Patch title: Release 96 bulk changes
Abstract:
File: /pliant/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 Link:ImagePrototype clip_mask ; field (List Link:ImagePrototype) clip_suspended
  field Link:Type image_type
  field Str options
  field List:Str warnings
  field Int text_speedup <- 0

DrawPrototype maybe DrawImage

function build d
  arg_w DrawImage d
  d image_type :> ImagePixmap


method d bind image options
  oarg_rw DrawImage d ; oarg_rw ImagePrototype image ; arg Str options
  d image :> image
  d draw_image :> image
  d options := options
  d text_speedup := options option "text_speedup" Int 0


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:ImagePrototype image :> (entry_new d:image_type) map ImagePrototype
    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 image img t
  oarg_rw DrawImage d ; oarg_rw ImagePrototype img ; arg Transform2 t
  var Link:ImagePrototype final :> img
  var Link:ImageTransform timg :> new ImageTransform
  if (timg bind final t d:image "always_inside")=failure
    return
  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 source_transparency and final:gamut:transparency=1 and d:image:gamut:transparency=0
    # console "using image source transparency" eol
    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 d:options
    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
      # console "convert image " final:gamut:name " -> " d:image:gamut:name eol
      var Link:ImageConvert conv :> new ImageConvert
      conv bind final d:image:gamut d:options
      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
  img configure "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 t color
  oarg_rw DrawImage d ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Transform2 t ; arg Address color
  d:image text txt font kerning t color d:text_speedup


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
  d clip_mask :> mask
  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
    d clip_mask :> null map ImagePrototype


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
    d:trouble_image :> (entry_new d:image_type) map ImagePrototype
    d:trouble_image setup (image_prototype i:x0 i:y0 i:x1 i:y1 i:size_x i:size_y color_gamut:"grey") ""
  var Link:DrawImage draw_trouble :> new DrawImage
  draw_trouble image :> d trouble_image
  dt :> draw_trouble


method d image_prototype options -> proto
  oarg DrawImage d ; arg Str options ; arg ImagePrototype proto
  proto := d image

method d backdrop options -> image
  oarg_rw DrawImage d ; arg Str options ; arg_C ImagePrototype image
  if (options option "clip_image")
    image :> d image
  eif (options option "clip_mask")
    if entry_type:(addressof d:image)=ImageClip
      image :> d clip_mask
    else
      image :> null map ImagePrototype
  else
    image :> d draw_image
  if (options option "clip_suspend")
    if entry_type:(addressof d:image)=ImageClip
      d clip_suspended += d image
      d image :> ((addressof d:image) map ImageClip) image
    else
      console "failed to suspend clipping (" entry_type:(addressof d:image):name ")" eol
  eif (options option "clip_restore")
    if (addressof Link:ImagePrototype d:clip_suspended:first)<>null
      d image :> d:clip_suspended first
      d:clip_suspended remove d:clip_suspended:first
    if (addressof Link:ImagePrototype d:clip_suspended:last)<>null
      d image :> d:clip_suspended last
      d:clip_suspended remove d:clip_suspended:last
    else
      console "failed to restore clipping" eol
    

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