Patch title: Release 93 bulk changes
Abstract:
File: /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"

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
  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: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
  d clip_draw_close
  d text1 txt font kerning length 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
  d:main clip_draw_open
  d:main text1 txt font kerning length 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
  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
  var ImagePrototype proto := draw image_prototype options
  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)
        target fill df:curves df:mode df:t (addressof df:color)
        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)
    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
          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
    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