Patch title: Release 90 bulk changes
Abstract:
File: /graphic/browser/xml/context.pli
Key:
    Removed line
    Added line
module "/pliant/language/unsafe.pli"
module "/pliant/language/compiler.pli"
module "/pliant/graphic/draw/prototype.pli"
module "tree.pli"


type XmlArea
  field Float x0 y0 x1 y1

type XmlContext
  # attributes forwarding
  field (Dictionary Str Str) values
  field (List List:Str) stack
  #
  # field Link:XmlTree document
  field Link:DrawPrototype draw
  field Float clip_x0 clip_y0 clip_x1 clip_y1
  # space
  field Float x0 y0 x1 y1
  field Float area_x0 area_y0 area_x1 area_y1
  field List:XmlArea areas
  # current line
  field Float line_y0 line_x line_y
  field (List Pointer:XmlTree) line_content
  field CBool line_center
  # event
  field Str url
  field Str key
  field Float x y


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


method c mark
  arg_rw XmlContext c
  c stack += var List:Str empty_list

method c set tag
  arg_rw XmlContext c ; arg Str tag
  c:values insert tag "[0]"
  var (Pointer List:Str) l :> c:stack last
  l += tag

method c reset tag
  arg_rw XmlContext c ; arg Str tag
  c:values insert tag ""
  var (Pointer List:Str) l :> c:stack last
  l += tag

method c query tag -> value
  arg XmlContext c ; arg Str tag ; arg CBool value
  var Pointer:Str p :> c:values first tag
  if exists:p
    value := p:len<>0
  else
    value := false

method c set tag attr value
  arg_rw XmlContext c ; arg Str tag attr value
  c:values insert tag+" "+attr value
  var (Pointer List:Str) l :> c:stack last
  l += attr+" "+value
  l += tag+" "+attr

method c query tag attr -> value
  arg_rw XmlContext c ; arg Str tag attr value
  arg XmlContext c ; arg Str tag attr value
  var Pointer:Str p :> c:values first tag+" "+attr
  if exists:p
    value := p
  else
    value := ""

method c rewind
  arg_rw XmlContext c
  var (Pointer List:Str) l :> c:stack last
  var Pointer:Str p :> l last
  while exists:p
    c:values remove (c:values first p)
    p :> l previous p
  c:stack remove l


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


method c newline
  arg_rw XmlContext c
  c line_y0 := c y0
  c line_x := c x0 ; c line_y := c y0
  if c:line_center
    var Float move_x := 0.5*(c:area_x1-c:line_x)
    each lc c:line_content
      lc x0 += move_x
      lc x1 += move_x
  c line_y0 := c area_y0
  c line_x := c area_x0 ; c line_y := c area_y0
  c line_content := var (List Pointer:XmlTree) empty_list
  c line_center := false

method c addtoline t
  arg_rw XmlContext c ; arg_rw XmlTree t
  # vcenter is not covered yet
  if c:line_x+t:x1-t:x0>c:x1 and c:line_x<>c:x0
    c newline
  var Float move_y := (-t:y0)-(c:line_y-c:line_y0)
  if move_y>0
    each lc c:line_content
      lc y0 += move_y
      lc y1 += move_y
    c line_y += move_y
    c y0 += move_y
  var Float move_y := t:y1-(c:y0-c:line_y)
    c area_y0 += move_y
  var Float move_y := t:y1-(c:area_y0-c:line_y)
  if move_y>0
    c y0 += move_y
    c area_y0 += move_y
    # might need to switch to next area
  t x0 += c line_x ; t y0 += c line_y
  t x1 += c line_x ; t y1 += c line_y
  var Pointer:XmlTree p :> t ; c line_content += p
  c line_x += t:x1-t:x0


method c newarea
  arg_rw XmlContext c
  var Pointer:XmlArea a :> c:areas first
  c x0 := a x0 ; c y0 := a y0 ; c x1 := a x1 ; c y1 := a y1
  c area_x0 := a x0 ; c area_y0 := a y0 ; c area_x1 := a x1 ; c area_y1 := a y1
  c:areas remove a
  c newline


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


method t position_undefined c
  arg_rw XmlTree t ; arg_rw XmlContext c
  each sub t
    sub position c
if false # meta '. attribute' e
  if e:size=3 and (e:0 cast XmlContext) and e:1:is_pure_ident and e:2:is_pure_ident
    var Link:Argument r :> argument local Str
    e suckup e:0
    e add (instruction (the_function '. query' XmlContext Str Str -> Str) e:0:result (argument constant Str e:1:ident) (argument constant Str e:2:ident) r)
    e set_result r access_read

if false
  
  method b position_container c
    oarg_rw D2Box b ; arg_rw D2Context c
    function position_include b c
      oarg_rw D2Box b ; arg_rw D2Box c
      if b:x0=defined
        c x0 := min c:x0 b:x0
        c y0 := min c:y0 b:y0
        c x1 := max c:x1 b:x1
        c y1 := max c:y1 b:y1
      else
        var Pointer:(List Link:D2Box) l :> b list
        if exists:l
          each bb l
            position_include bb c
    b x0 := float_max
    b y0 := float_max
    b x1 := float_min
    b y1 := float_min
    var Pointer:(List Link:D2Box) l :> b list
    if exists:l
      each bb l
        bb position c
        position_include bb b
    if b:x0=float_max
      b x0 := undefined
      b y0 := undefined
      b x1 := undefined
      b y1 := undefined
  
  method b position_zero c
    oarg_rw D2Box b ; arg_rw D2Context c
    var D2Context c2 := c
    c2 x0 := 0
    c2 y0 := 0
    c2 x1 := c:x1-c:x0
    c2 y1 := float_max/2
    c2 newline
    b position_container c2  
  
  method b position_hidden c
    oarg_rw D2Box b ; arg_rw D2Context c
    b x0 := undefined
    b y0 := undefined
    b x1 := undefined
    b y1 := undefined
    var Pointer:(List Link:D2Box) l :> b list
    if exists:l
      each bb l
        bb position_hidden c
  
  
  method b draw_recurse img c
    oarg_rw D2Box b ; oarg_rw ImagePrototype img ; arg_rw D2Context c
    var Pointer:(List Link:D2Box) l :> b list
    if exists:l
      each bb l
        if bb:x0=undefined
          bb draw img c
        eif bb:x0<=img:x1 and bb:y0<=img:y1 or bb:x1>=img:x0 and bb:y1>=img:y0
          bb draw img c
  
  
  method c bind img
    arg_rw D2Context c ; arg ImagePrototype img
    c x0 := img x0
    c y0 := img y0
    c x1 := img x1
    c y1 := img y1
    c areas := var List:D2Area empty_areas_list
    c newline

method c position_setup current_url x0 y0 x1 y1
  arg_rw XmlContext c ; arg Str current_url ; arg Float x0 y0 x1 y1
  c url := current_url
  c area_x0 := x0
  c area_y0 := y0
  c area_x1 := x1
  c area_y1 := y1
  c areas := var List:XmlArea empty_areas_list
  c newline

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

method c draw_setup current_url draw x0 y0 x1 y1
  arg_rw XmlContext c ; arg Str current_url ; oarg_rw DrawPrototype draw ; arg Float x0 y0 x1 y1
  c url := current_url
  c draw :> draw
  c clip_x0 := x0 ; c clip_y0 := y0 ; c clip_x1 := x1 ; c clip_y1 := y1

export XmlContext
method c gamut -> g
  arg_rw XmlContext c ; oarg_R ColorGamut g
  g :> c:draw gamut

method c image img t
  arg_rw XmlContext c ; oarg_rw ImagePrototype img ; arg Transform2 t
  c:draw image img t

method c rectangle x0 y0 x1 y1 color
  arg_rw XmlContext c ; arg Float x0 y0 x1 y1 ; arg Address color
  c:draw rectangle x0 y0 x1 y1 color

method c fill curves mode t color
  arg_rw XmlContext c ; arg Array:Curve curves ; arg Int mode ; arg Transform2 t ; arg Address color
  c:draw fill curves mode t color

method c text txt font kerning length t color
  arg_rw XmlContext c ; arg Str32 txt ; arg Font font ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
  c:draw text txt font kerning length t color

method c event_setup current_url key x y
  arg_rw XmlContext c ; arg Str current_url ; arg Str key ; arg Float x y
  c url := current_url
  c key := key ; c x := x ; c y := y


export XmlContext '. url' '. key' '. x' '. y'
export '. mark' '. set' '. query' '. rewind'
export '. newline' '. addtoline' '. newarea'
export '. area_x0' '. area_y0' '. area_x1' '. area_y1'
export '. line_x' '. line_y' '. newline' '. addtoline' '. line_center' '. newarea'
export '. position_setup'
export '. draw_setup' '. clip_x0' '. clip_y0' '. clip_x1' '. clip_y1'
export '. gamut' '. image' '. rectangle' '. fill' '. text'
export '. event_setup'