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

constant clip_image false
constant clip_fill false
constant clip_image true
constant clip_fill true


type DrawDisplayList
  field List list
  field Link:ColorGamut g
  field Link:ImagePrototype image_prototype
  field Str options
  field CBool clip_draw_flag <- false
  field List:Str warnings

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


type DisplayListSetup
  field ImagePrototype proto
  field Str options

method d setup proto options -> status
  oarg_rw DrawDisplayList d ; arg ImagePrototype proto ; arg Str options ; arg ExtendedStatus status
  var Link:DisplayListSetup ds :> new DisplayListSetup
  ds proto := proto
  ds options := options
  d:list append addressof:ds
  d g :> proto gamut
  d image_prototype :> new ImagePrototype
  d image_prototype := proto
  d options := options


method d gamut -> g
  oarg_rw DrawDisplayList d ; oarg_R ColorGamut g
  g :> d g


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
  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
  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
  df curves := curves
  df mode := mode
  df t := t
  memory_copy color (addressof df:color) ColorBuffer:size
  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
  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
  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
  field Link:ColorGamut g

DrawPrototype maybe DrawDisplayListClip

method d gamut -> g
  oarg_rw DrawDisplayListClip d ; oarg_R ColorGamut g
  g :> d g

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
  dlc g :> color_gamut "grey"
  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


method d replay draw clip_x0 clip_y0 clip_x1 clip_y1
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw ; arg Float clip_x0 clip_y0 clip_x1 clip_y1
  var Array:CBool concerned
type DisplayListInclude
  field Link:DrawDisplayList list
  field Transform2 t

method d include list t
  oarg_rw DrawDisplayList d ; arg DrawDisplayList list ; arg Transform2 t
  var Link:DisplayListInclude di :> new DisplayListInclude
  di list :> list
  di t := t
  d:list append addressof:di


function replay draw list proto clip
  oarg_rw DrawPrototype draw ; arg List list ; arg ImagePrototype proto ; arg CBool clip
  var Link:DrawPrototype clipped
  var Link:DrawPrototype target :> draw
  var Int count := 0
  var Pointer:Arrow c :> d:list first
  var Pointer:Arrow c :> list first
  while c<>null
    count += 1
    c :> d:list next c
  var Pointer:Arrow c :> d:list first ; var Int n := 0
  while c<>null
    # console n "/" count " " memory_current_used\2^20 " MB / " memory_current_consumed\2^20 " MB" eol
    var Pointer:Type t :> entry_type c
    # console t:name eol
    if t=DisplayListSetup
      var Link:DisplayListSetup ds :> c map DisplayListSetup
      draw setup ds:proto ds:options
    eif t=DisplayListImage
    if t=DisplayListImage
      var Link:DisplayListImage di :> c map DisplayListImage
      if not clip_image or (di:x0<clip_x1 and di:y0<clip_y1 and di:x1>clip_x0 and di:y1>clip_y0)
      if not clip_image or not clip 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
      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 (df:x0<clip_x1 and df:y0<clip_y1 and df:x1>clip_x0 and df:y1>clip_y0)
      if not clip_fill or not clip 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)
    eif t=DisplayListText
      var Link:DisplayListText dt :> c map DisplayListText
      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 clip_x0=undefined or dc:x0=undefined or (dc:x0<clip_x1 and dc:y0<clip_y1 and dc:x1>clip_x0 and dc:y1>clip_y0)
      if not clip 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
          c :> 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
    c :> d:list next c ; n += 1
    eif t=DisplayListInclude
      var Link:DisplayListInclude sub :> c map DisplayListInclude
      if sub:t:level=transform_identity
        replay draw sub:list:list proto clip
      else
        var Link:DrawTransform trans :> new DrawTransform
        trans bind draw sub:t
        replay trans sub:list:list proto false
    c :> list next c

method d replay draw
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw
  d replay draw undefined undefined undefined undefined
method d replay draw options
  oarg_rw DrawDisplayList d ; oarg_rw DrawPrototype draw ; arg Str options
  draw setup d:image_prototype options+" "+d:options
  replay draw d:list (image_prototype d:image_prototype options+" "+d:options) not (options option "no_clip")


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


export DrawDisplayList '. replay' '. reset' '. warnings'
export DrawDisplayList '. replay' '. reset' '. include'
export '. image_prototype' '. options' '. 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)
  b apply t:(point x1 y0)
  b apply t:(point x1 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 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
      dt:font bbox dt:txt dt:kerning:characters (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
      sub:list bbox (var Float xx0) (var Float yy0) (var Float xx1) (var Float yy1) 
      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'