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

constant clip_image true

constant clip_image true
constant clip_rectangle true
constant clip_fill 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
type DrawDisplayList
  field List list
  field Link:ImagePrototype image_prototype
  field Str options
  field ImagePrototype proto
  field Str dl_options
  field CBool clip_draw_flag <- false
  field List:Str warnings
  field CBool clip_draw_flag <- false
  field List:Str warnings
  if share
    field CBool share
    field Dictionary cache


method d setup proto options -> status
  oarg_rw DrawDisplayList d ; arg ImagePrototype proto ; arg


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



method d image1 img t
  oarg_rw DrawDisplayList d ; oarg_rw ImagePrototype img ; a
  var Link:DisplayListImage di :> new DisplayListImage
  if clip_image
    di x0 := undefined ; di y0 := undefined ; di x1 := undef
    for (var Int j) 0 3
      var Point2 p := t (point (shunt (j .and. 1)=0 img:x0 i
      di x0 := shunt di:x0=undefined or (p:x<>undefined and 
      di y0 := shunt di:y0=undefined or (p:y<>undefined and 
      di x1 := shunt di:x1=undefined or (p:x<>undefined and 
      di y1 := shunt di:y1=undefined or (p:y<>undefined and 
  di img :> img
  di t := t



method d image1 img t
  oarg_rw DrawDisplayList d ; oarg_rw ImagePrototype img ; a
  var Link:DisplayListImage di :> new DisplayListImage
  if clip_image
    di x0 := undefined ; di y0 := undefined ; di x1 := undef
    for (var Int j) 0 3
      var Point2 p := t (point (shunt (j .and. 1)=0 img:x0 i
      di x0 := shunt di:x0=undefined or (p:x<>undefined and 
      di y0 := shunt di:y0=undefined or (p:y<>undefined and 
      di x1 := shunt di:x1=undefined or (p:x<>undefined and 
      di y1 := shunt di:y1=undefined or (p:y<>undefined and 
  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


type DisplayListFill
  if clip_fill
    field Float x0 y0 x1 y1
  d:list append addressof:di


type DisplayListFill
  if clip_fill
    field Float x0 y0 x1 y1
  field Array:Curve curves
  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 I
  var Link:DisplayListFill df :> new DisplayListFill
  if clip_fill
    df x0 := undefined ; df y0 := undefined ; df x1 := undef
    for (var Int i) 0 curves:size-1
      curves:i bbox (var Float x0) (var Float y0) (var Float
      for (var Int j) 0 3
        var Point2 p := t (point (shunt (j .and. 1)=0 x0 x1)
        df x0 := shunt df:x0=undefined or (p:x<>undefined an
        df y0 := shunt df:y0=undefined or (p:y<>undefined an
        df x1 := shunt df:x1=undefined or (p:x<>undefined an
        df y1 := shunt df:y1=undefined or (p:y<>undefined an
  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 I
  var Link:DisplayListFill df :> new DisplayListFill
  if clip_fill
    df x0 := undefined ; df y0 := undefined ; df x1 := undef
    for (var Int i) 0 curves:size-1
      curves:i bbox (var Float x0) (var Float y0) (var Float
      for (var Int j) 0 3
        var Point2 p := t (point (shunt (j .and. 1)=0 x0 x1)
        df x0 := shunt df:x0=undefined or (p:x<>undefined an
        df y0 := shunt df:y0=undefined or (p:y<>undefined an
        df x1 := shunt df:x1=undefined or (p:x<>undefined an
        df y1 := shunt df:y1=undefined or (p:y<>undefined an
  if share
    df curves :> new Array:Curve
  df curves := curves
  df mode := mode
  df t := t
  memory_copy color (addressof df:color) ColorBuffer:size
  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


type DisplayListText
  d:list append addressof:df


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 
  var Link:DisplayListText dt :> new DisplayListText
  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 
  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)
    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


type DisplayListInclude
  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


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


method d include list t
  oarg_rw DrawDisplayList d ; arg DrawDisplayList list ; arg
method d include list filter options -> arrow
  oarg_rw DrawDisplayList d ; arg DrawPrototype list ; arg Type filter ; arg Str options ; arg_C Arrow arrow
  var Link:DisplayListInclude di :> new DisplayListInclude
  di list :> list
  var Link:DisplayListInclude di :> new DisplayListInclude
  di list :> list
  di t := t
  di filter :> filter
  di options := options
  d:list append addressof:di
  d:list append addressof:di
  arrow :> di arrow




function replay draw list proto clip
  oarg_rw DrawPrototype draw ; arg List list ; arg ImageProt
method d play draw options
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw ; arg Str options
  var ImagePrototype proto := draw image_prototype options
  var Link:DrawPrototype clipped
  var Link:DrawPrototype target :> draw
  var Link:DrawPrototype clipped
  var Link:DrawPrototype target :> draw
  var Pointer:Arrow c :> list first
  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
  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 not clip or (di:x0<proto:x1 and d
      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 DisplayListR
        target image di:img di:t
    eif t=DisplayListRectangle
      var Link:DisplayListRectangle dr :> c map DisplayListR
      target rectangle dr:x0 dr:y0 dr:x1 dr:y1 (addressof dr
      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
    eif t=DisplayListFill
      var Link:DisplayListFill df :> c map DisplayListFill
      if not clip_fill or not clip or (df:x0<proto:x1 and df
      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)
        target fill df:curves df:mode df:t (addressof df:col
    eif t=DisplayListText
      var Link:DisplayListText dt :> c map DisplayListText
        target fill df:curves df:mode df:t (addressof df:col
    eif t=DisplayListText
      var Link:DisplayListText dt :> c map DisplayListText
      target text dt:txt dt:font dt:kerning:characters dt:le
      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)
    eif t=DisplayListClipOpen
      var Link:DisplayListClipOpen dc :> c map DisplayListCl
    eif t=DisplayListClipOpen
      var Link:DisplayListClipOpen dc :> c map DisplayListCl
      if not clip or dc:x0=undefined or (dc:x0<proto:x1 and 
      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
        clipped :> draw clip_open dc:x0 dc:y0 dc:x1 dc:y1
      else
        var Int level := 1
        while level>0
          c :> list next c
          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 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
      if sub:t:level=transform_identity
        replay draw sub:list:list proto clip
      var Link:DrawPrototype filter
      if (exists sub:filter)
        var Link:DrawPrototype filter :> (entry_new sub:filter) map DrawPrototype
        filter bind draw sub:options
      else
      else
        var Link:DrawTransform trans :> new DrawTransform
        trans bind draw sub:t
        replay trans sub:list:list proto false
    c :> list next c
        filter :> draw
      sub:list play filter options
    c :> d:list next c


method d replay draw options
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw ; a
  draw setup d:image_prototype options+" "+d:options
  replay draw d:list (image_prototype d:image_prototype opti



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


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


method d reset
  oarg_rw DrawDisplayList d
  d list := var List empty_list
  d warnings := var List:Str no_warnings
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 := ""




export DrawDisplayList '. replay' '. reset' '. include'
export '. image_prototype' '. options' '. warnings'
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'


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



method b apply x0 y0 x1 y1 t
  arg_rw BoundingBox b ; arg Float x0 y0 x1 y1 ; arg Transfo
  b apply t:(point x0 y0)
#-----------------------------------------------------------



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

  b apply t:(point x0 y1)

method d bbox x0 y0 x1 y1
  oarg_rw DrawDisplayList d ; arg_w Float x0 y0 x1 y1
  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 DisplayListR
      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
      dt:font bbox dt:txt dt:kerning:characters (var Float x
      b apply xx0 yy0 xx1 yy1 dt:t
    eif t=DisplayListInclude
      var Link:DisplayListInclude sub :> c map DisplayListIn
      sub:list bbox (var Float xx0) (var Float yy0) (var Flo
      b apply xx0 yy0 xx1 yy1 sub:t 
    c :> d:list next c
  x0 := b x0 ; y0 := b y0 ; x1 := b x1 ; y1 := b y1

export '. bbox'
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