Patch title: Release 90 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/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"


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

DrawPrototype maybe DrawImage


method d bind image options
  oarg_rw DrawImage d ; arg ImagePrototype image ; arg Str options
  d 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


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:ImageTransform timg :> new ImageTransform
  timg bind img t d:image ""
  var Int tx := cast (timg:x0-d:image:x0)/(d:image:x1-d:image:x0)*d:image:size_x Int
  var Int ty := cast (timg:y0-d:image:y0)/(d:image:y1-d:image:y0)*d:image:size_y Int
  var Link:ImagePrototype final
  if timg:gamut:name<>d:image:gamut:name
  var Link:ImageTransform timg :> new ImageTransform
  timg bind img 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 timg d:image:gamut ""
    conv bind final d:image:gamut ""
    final :> conv
  else
    final :> timg
  if tx<0 or tx+final:size_x>d:image:size_x or ty<0 or ty+final:size_y>d:image:size_y
    error error_id_unexpected "transformed image does not fit" ?
  var Address buffer := memory_allocate final:line_size null
  for (var Int y) 0 final:size_y-1
    final read 0 y final:size_x buffer
    d:image write tx y+ty final:size_x buffer
  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
  oarg_rw DrawImage d ; arg Float x0 y0 x1 y1
  var Arrow a := addressof d:image ; d:stack += a
  var Arrow a := addressof d:clip ; d:stack += a
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 undefined undefined undefined undefined "" d:clip
  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_draw_open
  oarg_rw DrawImage d
  var Arrow a := addressof d:image ; d:stack += a
  d image :> d clip

method d clip_draw_close
  oarg_rw DrawImage d
  d image :> d:stack:last map ImagePrototype
  d:stack remove d:stack:last
 
method d clip_close
  oarg_rw DrawImage d
  d clip :> d:stack:last map ImagePrototype
  d:stack remove d:stack:last
  d image :> d:stack:last map ImagePrototype
  d:stack remove d:stack:last
  if entry_type:(addressof d:image)=ImageClip
    d image :> ((addressof d:image) map ImageClip) image


method d tag line mode
  oarg_rw DrawImage d ; arg Str line ; arg Int mode
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 '. bind'

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