Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/draw/displaylist.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/math/transform.pli"
module "prototype.pli"
module "misc.pli"
module "/pliant/language/compiler.pli"
module "/pliant/math/transform.pli"
module "prototype.pli"
module "misc.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/image/clip.pli"
module "/pliant/graphic/draw/image.pli"
module "/pliant/graphic/misc/bytes.pli"


type DisplayListText
  if clip_text
    field Float x0 y0 x1 y1
  field Str32 txt
  field Link:Font font
  field Str kerning


type DisplayListText
  if clip_text
    field Float x0 y0 x1 y1
  field Str32 txt
  field Link:Font font
  field Str kerning
  field Float length
  field Transform2 t
  field ColorBuffer color

  field Transform2 t
  field ColorBuffer color

method d text1 txt font kerning length t color
  oarg_rw DrawDisplayList d ; arg Str32 txt ; arg Font font 
method d text1 txt font kerning t color
  oarg_rw DrawDisplayList d ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Transform2 t ; arg Address color
  var Link:DisplayListText dt :> new DisplayListText
  if clip_text
  var Link:DisplayListText dt :> new DisplayListText
  if clip_text
    font bbox txt kerning length (var Float x0) (var Float y
    font bbox txt kerning (var Float x0) (var Float y0) (var Float x1) (var Float y1)
    apply x0 y0 x1 y1 t dt:x0 dt:y0 dt:x1 dt:y1
  dt txt := txt
  dt font :> font
  if kerning<>null
    dt kerning := repeat txt:len*Float:size " "
    memory_copy kerning dt:kerning:characters txt:len*Float:
    apply x0 y0 x1 y1 t dt:x0 dt:y0 dt:x1 dt:y1
  dt txt := txt
  dt font :> font
  if kerning<>null
    dt kerning := repeat txt:len*Float:size " "
    memory_copy kerning dt:kerning:characters txt:len*Float:
  dt length := length
  dt t := t
  memory_copy color (addressof dt:color) ColorBuffer:size
  d:list append addressof:dt

  dt t := t
  memory_copy color (addressof dt:color) ColorBuffer:size
  d:list append addressof:dt

method d text txt font kerning length t color
  oarg_rw DrawDisplayList d ; arg Str32 txt ; arg Font font 
method d text txt font kerning t color
  oarg_rw DrawDisplayList d ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Transform2 t ; arg Address color
  d clip_draw_close
  d clip_draw_close
  d text1 txt font kerning length t color
  d text1 txt font kerning t color






method d text txt font kerning length t color
  oarg_rw DrawDisplayListClip d ; arg Str32 txt ; arg Font f
method d text txt font kerning t color
  oarg_rw DrawDisplayListClip d ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Transform2 t ; arg Address color
  d:main clip_draw_open
  d:main clip_draw_open
  d:main text1 txt font kerning length t color
  d:main text1 txt font kerning t color



method d include list filter options -> arrow
  oarg_rw DrawDisplayList d ; arg DrawPrototype list ; arg T



method d include list filter options -> arrow
  oarg_rw DrawDisplayList d ; arg DrawPrototype list ; arg T
  d clip_draw_close
  var Link:DisplayListInclude di :> new DisplayListInclude
  di list :> list
  di filter :> filter
  di options := options
  d:list append addressof:di
  arrow :> di arrow


method d play draw options
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw ; a
  var Link:DisplayListInclude di :> new DisplayListInclude
  di list :> list
  di filter :> filter
  di options := options
  d:list append addressof:di
  arrow :> di arrow


method d play draw options
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw ; a
  later

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

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

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


method d flat_play draw filter model options -> status
  oarg_rw DrawPrototype d draw filter ; arg Str model options ; arg Status status
  var Link:ImagePrototype bd :> draw backdrop ""
  if not exists:bd
    return failure
  var ImagePrototype proto ; var Int tx ty
  var Link:ImagePrototype mask :> draw backdrop "clip_mask"
  if exists:mask
    # console "group mask" eol
    proto := image_prototype mask:x0 mask:y0 mask:x1 mask:y1 mask:size_x mask:size_y bd:gamut
    tx := bd index_x mask:x0
    ty := bd index_y mask:y0
  else
    proto := bd
    tx := 0
    ty := 0
  var Float opacity := model option "opacity" Float 1
  # if opacity<>1
  #   console "group opacity " opacity eol
  var Str mixture := model option "mixture" Str
  # if mixture<>""
  #   console "grou mixture " mixture eol
  var Link:ImagePrototype backup :> entry_new:(entry_type addressof:bd) map ImagePrototype
  backup setup proto ""
  var Int psize := bd pixel_size
  for (var Int y) 0 backup:size_y-1
    var Int offset := 0
    while offset<backup:size_x
      var Address bd1 := bd write_map offset+tx y+ty 1 backup:size_x-offset (var Int count1)
      var Address backup1 := backup write_map offset y 1 backup:size_x-offset (var Int count2)
      var Int count := min count1 count2
      memory_copy(bd1 translate Byte offset*psize) (backup1 translate Byte offset*psize) count*psize
      if mixture="Screen"
        bytes_fill bd1 1 count*psize
      bd write_unmap offset+tx y+ty count1 bd1
      backup write_unmap offset y count2 backup1
      offset += count
  if exists:mask
    draw backdrop "clip_suspend"
  d play filter options
  if exists:mask
    draw backdrop "clip_restore"
  for (var Int y) 0 backup:size_y-1
    var Int offset := 0
    while offset<backup:size_x
      var Int count1
      if exists:mask
        var Address mask1 := mask read_map offset y 1 backup:size_x-offset count1
      else
        count1 := backup size_x
      var Address backup1 := backup read_map offset y 1 backup:size_x-offset (var Int count2)
      var Address bd1 := bd write_map offset+tx y+ty 1 backup:size_x-offset (var Int count3)
      var Int count := min (min count1 count2) count3
      if mixture="Screen"
        for (var Int i) 0 count*psize-1
          bd1 map uInt8 i := (bd1 map uInt8 i)*(backup1 map uInt8 i)\255
      if opacity<>1
        var Int t := cast opacity*255 Int
        for (var Int i) 0 count*psize-1
          bd1 map uInt8 i := (t*(bd1 map uInt8 i)+(255-t)*(backup1 map uInt8 i))\255
      if exists:mask
        var Int i := 0
        while i<count
          var Int skip := bytes_count_0 (mask1 translate Byte i) count-i
          if skip>0
            memory_copy (backup1 translate Byte i*psize) (bd1 translate Byte i*psize) skip*psize
          i += skip
          var Int write := bytes_count_255 (mask1 translate Byte i) count-i
          if write>0
            i += write
          var Int mid := bytes_count_mid (mask1 translate Byte i) count-i
          if mid>0
            var Address mask2 := mask1 translate Byte i
            var Address backup2 := backup1 translate Byte i*psize
            var Address bd2 := bd1 translate Byte i*psize
            for (var Int j) 0 mid-1
              var Int t := mask2 map uInt8 j
              for (var Int k) 0 psize-1
                bd2 map uInt8 k := (t*(bd2 map uInt8 k)+(255-t)*(backup2 map uInt8 k))\255
              backup2 := backup2 translate Byte psize
              bd2 := bd2 translate Byte psize
            i += mid
      if exists:mask
        mask read_unmap offset y count1 mask1
      backup read_unmap offset y count2 backup1
      bd write_unmap offset+tx y+ty count3 bd1
      offset += count
  status := success


method d play draw options
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw ; arg Str options
  var ImagePrototype proto := draw image_prototype options
  var ImagePrototype proto := draw image_prototype options
  var Float outline_minimum := options option "outline_minimum" Float
  var Link:DrawPrototype clipped
  var Link:DrawPrototype target :> draw
  var Pointer:Arrow c :> d:list first
  var Link:DrawPrototype clipped
  var Link:DrawPrototype target :> draw
  var Pointer:Arrow c :> d:list first
  var Float outline_minimum := options option "outline_minim
  while c<>null
    var Pointer:Type t :> entry_type c
    if t=DisplayListImage
      var Link:DisplayListImage di :> c map DisplayListImage
      if not clip_image or proto:x0=undefined or (di:x0<prot
        target image di:img di:t
    eif t=DisplayListRectangle
      var Link:DisplayListRectangle dr :> c map DisplayListR
      if not clip_rectangle or proto:x0=undefined or (dr:x0<
        target rectangle dr:x0 dr:y0 dr:x1 dr:y1 (addressof 
    eif t=DisplayListFill
      var Link:DisplayListFill df :> c map DisplayListFill
      if not clip_fill or proto:x0=undefined or (df:x0<proto
        part draw_outline
          if outline_minimum=defined
            var Point2 p0 := df:t (point df:x0 df:y0)   
            var Point2 p1 := df:t (point df:x1 df:y1)
            var Float d2 := (p1:x-p0:x)*(p1:x-p0:x)+(p1:y-p0
            if d2<outline_minimum*outline_minimum
              leave draw_outline
          target fill df:curves df:mode df:t (addressof df:c
    eif t=DisplayListText
      var Link:DisplayListText dt :> c map DisplayListText
      if not clip_text or proto:x0=undefined or (dt:x0<proto
  while c<>null
    var Pointer:Type t :> entry_type c
    if t=DisplayListImage
      var Link:DisplayListImage di :> c map DisplayListImage
      if not clip_image or proto:x0=undefined or (di:x0<prot
        target image di:img di:t
    eif t=DisplayListRectangle
      var Link:DisplayListRectangle dr :> c map DisplayListR
      if not clip_rectangle or proto:x0=undefined or (dr:x0<
        target rectangle dr:x0 dr:y0 dr:x1 dr:y1 (addressof 
    eif t=DisplayListFill
      var Link:DisplayListFill df :> c map DisplayListFill
      if not clip_fill or proto:x0=undefined or (df:x0<proto
        part draw_outline
          if outline_minimum=defined
            var Point2 p0 := df:t (point df:x0 df:y0)   
            var Point2 p1 := df:t (point df:x1 df:y1)
            var Float d2 := (p1:x-p0:x)*(p1:x-p0:x)+(p1:y-p0
            if d2<outline_minimum*outline_minimum
              leave draw_outline
          target fill df:curves df:mode df:t (addressof df:c
    eif t=DisplayListText
      var Link:DisplayListText dt :> c map DisplayListText
      if not clip_text or proto:x0=undefined or (dt:x0<proto
        target text dt:txt dt:font dt:kerning:characters dt:
        target text dt:txt dt:font dt:kerning:characters dt:t (addressof dt:color)
    eif t=DisplayListClipOpen
      var Link:DisplayListClipOpen dc :> c map DisplayListCl
      if not clip_clip or proto:x0=undefined or dc:x0=undefi
        clipped :> draw clip_open dc:x0 dc:y0 dc:x1 dc:y1
      else
        var Int level := 1
    eif t=DisplayListClipOpen
      var Link:DisplayListClipOpen dc :> c map DisplayListCl
      if not clip_clip or proto:x0=undefined or dc:x0=undefi
        clipped :> draw clip_open dc:x0 dc:y0 dc:x1 dc:y1
      else
        var Int level := 1
        while level>0
        while level>0 # and (d:list next c)<>null
          c :> d:list next c
          var Pointer:Type t :> entry_type c
          if t=DisplayListClipOpen
            level += 1
          eif t=DisplayListClipClose
            level -= 1
    eif t=DisplayListClipDrawOpen
      target :> clipped
    eif t=DisplayListClipDrawClose
      target :> draw
    eif t=DisplayListClipClose
      draw clip_close
    eif t=DisplayListInclude
      var Link:DisplayListInclude sub :> c map DisplayListIn
      var Link:DrawPrototype filter
      if (exists sub:filter)
        var Link:DrawPrototype filter :> (entry_new sub:filt
        filter bind draw sub:options
      else
        filter :> draw
          c :> d:list next c
          var Pointer:Type t :> entry_type c
          if t=DisplayListClipOpen
            level += 1
          eif t=DisplayListClipClose
            level -= 1
    eif t=DisplayListClipDrawOpen
      target :> clipped
    eif t=DisplayListClipDrawClose
      target :> draw
    eif t=DisplayListClipClose
      draw clip_close
    eif t=DisplayListInclude
      var Link:DisplayListInclude sub :> c map DisplayListIn
      var Link:DrawPrototype filter
      if (exists sub:filter)
        var Link:DrawPrototype filter :> (entry_new sub:filt
        filter bind draw sub:options
      else
        filter :> draw
      sub:list play filter options
      if (sub:options option "flat_transparency")
        if (sub:list flat_play draw filter sub:options options)=failure
          console "flat transparency recovery" eol
          sub:list play filter options
      else
        sub:list play filter options
    c :> d:list next c



method d image_prototype options -> proto
  oarg DrawDisplayList d ; arg Str options ; arg ImageProtot
  proto := d proto
  if (options option "bbox")
    var BoundingBox b
    var Pointer:Arrow c :> d:list first
    while c<>null
      var Pointer:Type t :> entry_type c
      if t=DisplayListImage
        var Link:DisplayListImage di :> c map DisplayListIma
        if clip_image
          b apply di:x0 di:y0 di:x1 di:y1
        else
          b apply di:img:x0 di:img:y0 di:img:x1 di:img:y1 di
      eif t=DisplayListRectangle
        var Link:DisplayListRectangle dr :> c map DisplayLis
        b apply dr:x0 dr:y0 dr:x1 dr:y1
      eif t=DisplayListFill
        var Link:DisplayListFill df :> c map DisplayListFill
        if clip_fill
          b apply df:x0 df:y0 df:x1 df:y1
        else
          for (var Int i) 0 df:curves:size-1
            df:curves:i bbox (var Float xx0) (var Float yy0)
            b apply xx0 yy0 xx1 yy1 df:t
      eif t=DisplayListText
        var Link:DisplayListText dt :> c map DisplayListText
        if clip_text
          b apply dt:x0 dt:y0 dt:x1 dt:y1
        else
          dt:font bbox dt:txt dt:kerning:characters dt:lengt
          b apply xx0 yy0 xx1 yy1 dt:t
      eif t=DisplayListInclude
        var Link:DisplayListInclude sub :> c map DisplayList
        var ImagePrototype pr := sub:list image_prototype op
        var Transform2 tr
        var Str op := sub options
        if (op option "translate") or (op option "scale") or
          if not ((op (op option_position "translate" 0) op:
            tx := op option "translate" Float 0
            ty := tx
          if not ((op (op option_position "scale" 0) op:len)
            sx := op option "scale" Float 1
            sy := sx
          if not ((op (op option_position "rotate" 0) op:len
            rx := op option "rotate" Float 0
            ry := rx
          tr := transform tx ty sx sy rx ry
        else
          tr xx := op option "xx" Float 1
          tr xy := op option "xy" Float 0
          tr xt := op option "xt" Float 0
          tr yx := op option "yx" Float 0
          tr yy := op option "yy" Float 1
          tr yt := op option "yt" Float 0
          tr compute
        b apply pr:x0 pr:y0 pr:x1 pr:y1 tr
      c :> d:list next c
    proto x0 := b x0 ; proto y0 := b y0 ; proto x1 := b x1 ;
    c :> d:list next c



method d image_prototype options -> proto
  oarg DrawDisplayList d ; arg Str options ; arg ImageProtot
  proto := d proto
  if (options option "bbox")
    var BoundingBox b
    var Pointer:Arrow c :> d:list first
    while c<>null
      var Pointer:Type t :> entry_type c
      if t=DisplayListImage
        var Link:DisplayListImage di :> c map DisplayListIma
        if clip_image
          b apply di:x0 di:y0 di:x1 di:y1
        else
          b apply di:img:x0 di:img:y0 di:img:x1 di:img:y1 di
      eif t=DisplayListRectangle
        var Link:DisplayListRectangle dr :> c map DisplayLis
        b apply dr:x0 dr:y0 dr:x1 dr:y1
      eif t=DisplayListFill
        var Link:DisplayListFill df :> c map DisplayListFill
        if clip_fill
          b apply df:x0 df:y0 df:x1 df:y1
        else
          for (var Int i) 0 df:curves:size-1
            df:curves:i bbox (var Float xx0) (var Float yy0)
            b apply xx0 yy0 xx1 yy1 df:t
      eif t=DisplayListText
        var Link:DisplayListText dt :> c map DisplayListText
        if clip_text
          b apply dt:x0 dt:y0 dt:x1 dt:y1
        else
          dt:font bbox dt:txt dt:kerning:characters dt:lengt
          b apply xx0 yy0 xx1 yy1 dt:t
      eif t=DisplayListInclude
        var Link:DisplayListInclude sub :> c map DisplayList
        var ImagePrototype pr := sub:list image_prototype op
        var Transform2 tr
        var Str op := sub options
        if (op option "translate") or (op option "scale") or
          if not ((op (op option_position "translate" 0) op:
            tx := op option "translate" Float 0
            ty := tx
          if not ((op (op option_position "scale" 0) op:len)
            sx := op option "scale" Float 1
            sy := sx
          if not ((op (op option_position "rotate" 0) op:len
            rx := op option "rotate" Float 0
            ry := rx
          tr := transform tx ty sx sy rx ry
        else
          tr xx := op option "xx" Float 1
          tr xy := op option "xy" Float 0
          tr xt := op option "xt" Float 0
          tr yx := op option "yx" Float 0
          tr yy := op option "yy" Float 1
          tr yt := op option "yt" Float 0
          tr compute
        b apply pr:x0 pr:y0 pr:x1 pr:y1 tr
      c :> d:list next c
    proto x0 := b x0 ; proto y0 := b y0 ; proto x1 := b x1 ;