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/graphic/image/packed.pli"
module "/pliant/graphic/image/clip.pli"
module "/pliant/graphic/draw/image.pli"
module "/pliant/graphic/misc/bytes.pli"

constant clip_image true
constant clip_rectangle true
constant clip_fill true
constant clip_text true
constant clip_clip true
constant share true
constant trace_share false


if share

  module "/pliant/admin/md5.pli"

  function signature img -> sign
    oarg_rw ImagePrototype img ; arg Str sign
    var MD5_CTX ctx
    MD5Init ctx
    MD5Update ctx (addressof img:size_x) Int:size
    MD5Update ctx (addressof img:size_y) Int:size
    MD5Update ctx (addressof img:x0) Float:size
    MD5Update ctx (addressof img:y0) Float:size
    MD5Update ctx (addressof img:x1) Float:size
    MD5Update ctx (addressof img:y1) Float:size
    MD5Update ctx img:gamut:name:characters img:gamut:name:len
    for (var Int i) 0 (min img:size_x img:size_y)-1
      img read i i 1 addressof:(var ColorBuffer pixel)
      MD5Update ctx addressof:pixel img:gamut:pixel_size
    MD5Final ctx
    sign := MD5BinarySignature ctx
    img configure "shrink"
   
  function same img1 img2 -> c
    oarg_rw ImagePrototype img1 img2 ; arg CBool c
    if img1:size_x<>img2:size_x or img1:size_y<>img2:size_y
      return false
    if img1:x0<>img2:x0 or img1:y0<>img2:y0 or img1:x1<>img2:x1 or img1:y1<>img2:y1
      return false
    if img1:gamut:name<>img2:gamut:name
      return false
    c := true
    var Address buf1 := memory_allocate img1:line_size null
    var Address buf2 := memory_allocate img2:line_size null
    part compare_lines
      for (var Int y) 0 img1:size_y-1
        img1 read 0 y img1:size_x buf1
        img2 read 0 y img1:size_x buf2
        if (memory_different buf1 img1:line_size buf2 img2:line_size)
          c := false
          leave compare_lines
    memory_free buf1
    memory_free buf2
    img1 configure "shrink"
    img2 configure "shrink"

  function origin_x curves -> ox
    arg Array:Curve curves ; arg Float ox
    if curves:size>0 and curves:0:size>0
      ox := (curves:0 point 0) x
    else
      ox := 0
  function origin_y curves -> oy
    arg Array:Curve curves ; arg Float oy
    if curves:size>0 and curves:0:size>0
      oy := (curves:0 point 0) y
    else
      oy := 0


  function signature curves -> sign
    arg Array:Curve curves ; arg Str sign
    var MD5_CTX ctx
    MD5Init ctx
    var Float ox := origin_x curves ; var Float oy := origin_y curves
    for (var Int i) 0 curves:size-1
      var Pointer:Curve c :> curves i
      var Int m := c mode ; MD5Update ctx addressof:m Int:size
      for (var Int j) 0 c:size-1
        var Pointer:CurvePoint p :> c point j
        var Float32 f := p:x-ox ;  MD5Update ctx addressof:f Float32:size
        var Float32 f := p:y-oy ;  MD5Update ctx addressof:f Float32:size
        var Float32 f := p in_x ;  MD5Update ctx addressof:f Float32:size
        var Float32 f := p in_y ;  MD5Update ctx addressof:f Float32:size
        var Float32 f := p out_x ;  MD5Update ctx addressof:f Float32:size
        var Float32 f := p out_y ;  MD5Update ctx addressof:f Float32:size
    MD5Final ctx
    sign := MD5BinarySignature ctx
   
  function same curves1 curves2 -> c
    arg Array:Curve curves1 curves2 ; arg CBool c
    if curves1:size<>curves2:size
      return false
    var Float ox1 := origin_x curves1 ; var Float oy1 := origin_y curves1
    var Float ox2 := origin_x curves2 ; var Float oy2 := origin_y curves2
    for (var Int i) 0 curves1:size-1
      var Pointer:Curve c1 :> curves1 i
      var Pointer:Curve c2 :> curves2 i
      if c1:mode<>c2:mode
        return false
      if c1:size<>c2:size
        return false
      for (var Int j) 0 c1:size-1
        var Pointer:CurvePoint p1 :> c1 point j
        var Pointer:CurvePoint p2 :> c2 point j
        if (cast p1:x-ox1 Float32)<>(cast p2:x-ox2 Float32)
          return false
        if (cast p1:y-oy1 Float32)<>(cast p2:y-oy2 Float32)
          return false
        if (cast p1:in_x Float32)<>(cast p2:in_x Float32)
          return false
        if (cast p1:in_y Float32)<>(cast p2:in_y Float32)
          return false
        if (cast p1:out_x Float32)<>(cast p2:out_x Float32)
          return false
        if (cast p1:out_y Float32)<>(cast p2:out_y Float32)
          return false
    c := true


type DrawDisplayList
  field List list
  field ImagePrototype proto
  field Str dl_options
  field CBool clip_draw_flag <- false
  field List:Str warnings
  if share
    field CBool share
    field Dictionary cache

DrawPrototype maybe DrawDisplayList


type DisplayListClipDrawOpen
  void

type DisplayListClipDrawClose
  void

method d clip_draw_open
  oarg_rw DrawDisplayList d
  if not d:clip_draw_flag
    d:list append (addressof new:DisplayListClipDrawOpen)
    d clip_draw_flag := true

method d clip_draw_close
  oarg_rw DrawDisplayList d
  if d:clip_draw_flag
    d:list append (addressof new:DisplayListClipDrawClose)
    d clip_draw_flag := false


method d setup proto options -> status
  oarg_rw DrawDisplayList d ; arg ImagePrototype proto ; arg Str options ; arg ExtendedStatus status
  d proto := proto
  d:proto options := options
  if share
    d share := not (options option "noshare")


type DisplayListImage
  if clip_image
    field Float x0 y0 x1 y1
  field Link:ImagePrototype img
  field Transform2 t

method d image1 img t
  oarg_rw DrawDisplayList d ; oarg_rw ImagePrototype img ; arg Transform2 t
  var Link:DisplayListImage di :> new DisplayListImage
  if clip_image
    di x0 := undefined ; di y0 := undefined ; di x1 := undefined ; di y1 := undefined
    for (var Int j) 0 3
      var Point2 p := t (point (shunt (j .and. 1)=0 img:x0 img:x1) (shunt (j .and. 2)=0 img:y0 img:y1))
      di x0 := shunt di:x0=undefined or (p:x<>undefined and p:x<di:x0) p:x di:x0
      di y0 := shunt di:y0=undefined or (p:y<>undefined and p:y<di:y0) p:y di:y0
      di x1 := shunt di:x1=undefined or (p:x<>undefined and p:x>di:x1) p:x di:x1
      di y1 := shunt di:y1=undefined or (p:y<>undefined and p:y>di:y1) p:y di:y1
  di img :> img
  di t := t
  if share and d:share
    part scan
      var Str sign := signature img
      var Pointer:Arrow c :> d:cache first sign
      while c<>null
        if entry_type:c<>Array:Curve and (same img (c omap ImagePrototype))
          if trace_share
            console "@"
          di img :> c omap ImagePrototype
          leave scan
        c :> d:cache next sign c
      d:cache insert sign true addressof:img
      if trace_share
        console "+"
  d:list append addressof:di

method d image img t
  oarg_rw DrawDisplayList d ; oarg_rw ImagePrototype img ; arg Transform2 t
  d clip_draw_close
  d image1 img t


type DisplayListRectangle
  field Float x0 y0 x1 y1
  field ColorBuffer color

method d rectangle1 x0 y0 x1 y1 color
  oarg_rw DrawDisplayList d ; arg Float x0 y0 x1 y1 ; arg Address color
  var Link:DisplayListRectangle dr :> new DisplayListRectangle
  dr x0 := x0 ; dr y0 := y0 ; dr x1 := x1 ; dr y1 := y1
  memory_copy color (addressof dr:color) ColorBuffer:size
  d:list append addressof:dr
  
method d rectangle x0 y0 x1 y1 color
  oarg_rw DrawDisplayList d ; arg Float x0 y0 x1 y1 ; arg Address color
  d clip_draw_close
  d rectangle1 x0 y0 x1 y1 color


type DisplayListFill
  if clip_fill
    field Float x0 y0 x1 y1
  if share
    field (Link Array:Curve) curves
  else
    field Array:Curve curves
  field Int mode
  field Transform2 t
  field ColorBuffer color

method d fill1 curves mode t color
  oarg_rw DrawDisplayList d ; arg Array:Curve curves ; arg Int mode ; arg Transform2 t ; arg Address color
  var Link:DisplayListFill df :> new DisplayListFill
  if clip_fill
    df x0 := undefined ; df y0 := undefined ; df x1 := undefined ; df y1 := undefined
    for (var Int i) 0 curves:size-1
      curves:i bbox (var Float x0) (var Float y0) (var Float x1) (var Float y1)
      for (var Int j) 0 3
        var Point2 p := t (point (shunt (j .and. 1)=0 x0 x1) (shunt (j .and. 2)=0 y0 y1))
        df x0 := shunt df:x0=undefined or (p:x<>undefined and p:x<df:x0) p:x df:x0
        df y0 := shunt df:y0=undefined or (p:y<>undefined and p:y<df:y0) p:y df:y0
        df x1 := shunt df:x1=undefined or (p:x<>undefined and p:x>df:x1) p:x df:x1
        df y1 := shunt df:y1=undefined or (p:y<>undefined and p:y>df:y1) p:y df:y1
  if share
    df curves :> new Array:Curve
  df curves := curves
  df mode := mode
  df t := t
  memory_copy color (addressof df:color) ColorBuffer:size
  if share and d:share
    part scan
      var Str sign := signature df:curves
      var Pointer:Arrow c :> d:cache first sign
      while c<>null
        if entry_type:c=Array:Curve and (same df:curves (c omap Array:Curve))
          if trace_share
            console "#"
          df curves :> c map Array:Curve
          df t := compose (transform (origin_x curves)-(origin_x df:curves) (origin_y curves)-(origin_y df:curves) 1 1 0 0) df:t
          leave scan
        c :> d:cache next sign c
      d:cache insert sign true (addressof df:curves)
      if trace_share
        console "."
  d:list append addressof:df

method d fill curves mode t color
  oarg_rw DrawDisplayList d ; arg Array:Curve curves ; arg Int mode ; arg Transform2 t ; arg Address color
  d clip_draw_close
  d fill1 curves mode t color


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

method d text1 txt font kerning length t color
  oarg_rw DrawDisplayList d ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
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
    font bbox txt kerning length (var Float x0) (var Float y0) (var Float x1) (var Float y1)
    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:size
  dt length := length
  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 ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
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 text1 txt font kerning length t color
  d text1 txt font kerning t color


type DrawDisplayListClip
  field Link:DrawDisplayList main

DrawPrototype maybe DrawDisplayListClip

method d image img t
  oarg_rw DrawDisplayListClip d ; oarg_rw ImagePrototype img ; arg Transform2 t
  d:main clip_draw_open
  d:main image1 img t

method d rectangle x0 y0 x1 y1 color
  oarg_rw DrawDisplayListClip d ; arg Float x0 y0 x1 y1 ; arg Address color
  d:main clip_draw_open
  d:main rectangle1 x0 y0 x1 y1 color

method d fill curves mode t color
  oarg_rw DrawDisplayListClip d ; arg Array:Curve curves ; arg Int mode ; arg Transform2 t ; arg Address color
  d:main clip_draw_open
  d:main fill1 curves mode t color

method d text txt font kerning length t color
  oarg_rw DrawDisplayListClip d ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
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 text1 txt font kerning length t color
  d:main text1 txt font kerning t color


type DisplayListClipOpen
  field Float x0 y0 x1 y1

method d clip_open x0 y0 x1 y1 -> dc
  oarg_rw DrawDisplayList d ; arg Float x0 y0 x1 y1 ; arg Link:DrawPrototype dc
  d clip_draw_close
  var Link:DisplayListClipOpen dco :> new DisplayListClipOpen
  dco x0 := x0 ; dco y0 := y0 ; dco x1 := x1 ; dco y1 := y1
  d:list append addressof:dco
  var Link:DrawDisplayListClip dlc :> new DrawDisplayListClip
  dlc main :> d
  dc :> dlc


type DisplayListClipClose
  void

method d clip_close
  oarg_rw DrawDisplayList d
  d clip_draw_close
  var Link:DisplayListClipClose dc :> new DisplayListClipClose
  d:list append addressof:dc


type DisplayListInclude
  field Link:DrawPrototype list
  field Link:Type filter
  field Str options
  field Arrow arrow

method d include list filter options -> arrow
  oarg_rw DrawDisplayList d ; arg DrawPrototype list ; arg Type filter ; arg Str options ; arg_C Arrow arrow
  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 ; arg Str options
  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 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 Float outline_minimum := options option "outline_minimum" Float
  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<proto:x1 and di:y0<proto:y1 and di:x1>proto:x0 and di:y1>proto:y0)
        target image di:img di:t
    eif t=DisplayListRectangle
      var Link:DisplayListRectangle dr :> c map DisplayListRectangle
      if not clip_rectangle or proto:x0=undefined or (dr:x0<proto:x1 and dr:y0<proto:y1 and dr:x1>proto:x0 and dr:y1>proto:y0)
        target rectangle dr:x0 dr:y0 dr:x1 dr:y1 (addressof dr:color)
    eif t=DisplayListFill
      var Link:DisplayListFill df :> c map DisplayListFill
      if not clip_fill or proto:x0=undefined or (df:x0<proto:x1 and df:y0<proto:y1 and df:x1>proto:x0 and df:y1>proto:y0)
        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:y)*(p1:y-p0:y)
            if d2<outline_minimum*outline_minimum
              leave draw_outline
          target fill df:curves df:mode df:t (addressof df:color)
    eif t=DisplayListText
      var Link:DisplayListText dt :> c map DisplayListText
      if not clip_text or proto:x0=undefined or (dt:x0<proto:x1 and dt:y0<proto:y1 and dt:x1>proto:x0 and dt:y1>proto:y0)
        target text dt:txt dt:font dt:kerning:characters dt:length dt:t (addressof dt:color)
        target text dt:txt dt:font dt:kerning:characters dt:t (addressof dt:color)
    eif t=DisplayListClipOpen
      var Link:DisplayListClipOpen dc :> c map DisplayListClipOpen
      if not clip_clip or proto:x0=undefined or dc:x0=undefined or (dc:x0<proto:x1 and dc:y0<proto:y1 and dc:x1>proto:x0 and dc:y1>proto:y0)
        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 DisplayListInclude
      var Link:DrawPrototype filter
      if (exists sub:filter)
        var Link:DrawPrototype filter :> (entry_new sub:filter) map DrawPrototype
        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 warning message
  oarg_rw DrawDisplayList d ; arg Str message
  d warnings += message


method d query command -> answer
  oarg_rw DrawDisplayList d ; arg Str command answer
  if command="memory"
    var Intn mem := 0 ; var (Dictionary Int Void) already
    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 DisplayListImage
        if not exists:(already first (cast (addressof di:img) Int))
          mem += 1n*di:img:size_x*di:img:size_y*di:img:gamut:pixel_size
          already insert (cast (addressof di:img) Int) void
      eif t=DisplayListInclude
        var Link:DisplayListInclude sub :> c map DisplayListInclude
        if not exists:(already first (cast (addressof sub:list) Int))
          if ((sub:list query "memory") parse (var Intn mem2))
            mem += mem2
          already insert (cast (addressof sub:list) Int) void
      c :> d:list next c
    answer := string mem
  else
    answer := ""


method d configure command -> status
  oarg_rw DrawDisplayList d ; arg Str command ; arg ExtendedStatus status
  if command="reset"
    d list := var List empty_list
    d warnings := var List:Str no_warnings
    status := success
  eif command="shrink"
    var Pointer:Arrow c :> d:list first
    while c<>null
      var Pointer:Type t :> entry_type c
      if t=DisplayListInclude
        var Link:DisplayListInclude sub :> c map DisplayListInclude
        sub:list configure "shrink"
      c :> d:list next c
    if share
      d cache := var Dictionary empty_dictionary
    status := success
  else
    status := failure "unknown command"


export DrawDisplayList '. include'
export '. warnings'


#----------------------------------------------------------------------------


type BoundingBox
  field Float x0 <- undefined
  field Float y0 <- undefined
  field Float x1 <- undefined
  field Float y1 <- undefined

method b apply p
  arg_rw BoundingBox b ; arg Point2 p
  if p:x=undefined or p:y=undefined
    void
  eif b:x0=undefined
    b x0 := p x
    b y0 := p y
    b x1 := p x
    b y1 := p y
  else
    b x0 := min b:x0 p:x
    b y0 := min b:y0 p:y
    b x1 := max b:x1 p:x
    b y1 := max b:y1 p:y

method b apply x0 y0 x1 y1
  arg_rw BoundingBox b ; arg Float x0 y0 x1 y1
  b apply (point x0 y0)
  b apply (point x1 y1)

method b apply x0 y0 x1 y1 t
  arg_rw BoundingBox b ; arg Float x0 y0 x1 y1 ; arg Transform2 t
  b apply t:(point x0 y0)
  if t:level>=transform_rotate
    b apply t:(point x1 y0)
    b apply t:(point x1 y1)
  b apply t:(point x0 y1)

method d image_prototype options -> proto
  oarg DrawDisplayList d ; arg Str options ; arg ImagePrototype proto
  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 DisplayListImage
        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:t
      eif t=DisplayListRectangle
        var Link:DisplayListRectangle dr :> c map DisplayListRectangle
        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) (var Float xx1) (var Float yy1)
            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:length (var Float xx0) (var Float yy0) (var Float xx1) (var Float yy1)
          b apply xx0 yy0 xx1 yy1 dt:t
      eif t=DisplayListInclude
        var Link:DisplayListInclude sub :> c map DisplayListInclude
        var ImagePrototype pr := sub:list image_prototype options
        var Transform2 tr
        var Str op := sub options
        if (op option "translate") or (op option "scale") or (op option "rotate")
          if not ((op (op option_position "translate" 0) op:len) parse word:"translate" (var Float tx) (var Float ty) any)
            tx := op option "translate" Float 0
            ty := tx
          if not ((op (op option_position "scale" 0) op:len) parse word:"scale" (var Float sx) (var Float sy) any)
            sx := op option "scale" Float 1
            sy := sx
          if not ((op (op option_position "rotate" 0) op:len) parse word:"rotate" (var Float rx) (var Float ry) any)
            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 ; proto y1 := b y1