Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/ui/client/instructions.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/util/pml/body.pli"
module "/pliant/graphic/color/color.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/graphic/layout/prototype.pli"
module "/pliant/graphic/layout/sequence.pli"
module "/pliant/graphic/layout/restyle.pli"
module "/pliant/graphic/layout/text.pli"
module "/pliant/graphic/layout/table.pli"
module "/pliant/graphic/layout/form.pli"
module "/pliant/graphic/layout/hook.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/language/type/misc/blob.pli"
module "/pliant/language/stream/blob.pli"
module "/pliant/util/encoding/pack4.pli"
module "/pliant/graphic/layout/image.pli"
module "/pliant/graphic/layout/draw.pli"
module "/pliant/graphic/draw/prototype.pli"
module "/pliant/graphic/console/prototype.pli"
module "/pliant/math/curve.pli"
module "context.pli"
module "connect.pli"
module "window.pli"
module "/pliant/graphic/layout/helper/text.pli"
module "/pliant/graphic/layout/helper/position.pli"
module "/pliant/graphic/layout/helper/event.pli"


method c add p
  arg_rw UIClientContext c ; oarg_rw LayoutPrototype p
  p set_parent c:parent
  c chain :> p
  c chain :>> p next

method c standard_body parent first instruction_name -> status
  arg_rw UIClientContext c ; arg LayoutPrototype parent ; arg_rw Link:LayoutPrototype first ; arg Str instruction_name ; arg Status status
  if not c:connection:ibody_begin
    c ierror "incorrect '"+instruction_name+"' instruction"
    return failure
  var Pointer:LayoutPrototype memo_parent :> c parent
  c parent :> parent
  var (Pointer Link:LayoutPrototype) memo_chain :>> c chain
  c chain :>> first
  while c:connection:ibody_more
    c process_instruction false
  c parent :> memo_parent
  c chain :>> memo_chain
  if not c:connection:ibody_end
    c ierror "incorrect '"+instruction_name+"' instruction"
    return failure
  status := success

method c standard_no_body instruction_name -> status
  arg_rw UIClientContext c ; arg Str instruction_name ; arg Status status
  if not c:connection:ibody_none
    c ierror "incorrect '"+instruction_name+"' instruction"
    return failure
  status := success


ui_client_instruction rejected
  if not (connection itag "rejected")
    ierror "incorrect 'rejected' instruction"
    return
  session rejected := true
  standard_no_body "rejected"

ui_client_instruction unknown
  if not (connection itag "unknown")
    ierror "incorrect 'unknown' instruction"
    return
  session unknown := true
  standard_no_body "unkown"


ui_client_instruction text
  if not (connection itag "text" (var Str txt))
    ierror "incorrect 'text' instruction"
    return
  var Link:LayoutText t :> new LayoutText
  t text := txt
  add t
  standard_no_body "text"


method c para_instruction id flags
  arg_rw UIClientContext c ; arg Str id ; arg Int flags
  implicit c
    if not (connection itag id)
      ierror "incorrect 'para' instruction"
      return
    var Link:LayoutPara para :> new LayoutPara
    para flags := flags
    if (connection iattr "stick")
      para flags := para:flags .and. .not. (cast 3 Int)
    if (connection iattr "cursor")
      para flags += 4
    if (connection iattr "edit")
      para flags += 8
    add para
    standard_body para para:first_son id

ui_client_instruction para
  para_instruction "para" 3

ui_client_instruction header
  para_instruction "header" 13h

ui_client_instruction title
  para_instruction "title" 23h


ui_client_instruction table
  if not (connection itag "table")
    ierror "incorrect 'table' instruction"
    return
  var Link:LayoutTable t :> new LayoutTable
  add t
  standard_body t t:first_son "table"

ui_client_instruction row
  if not (connection itag "row")
    ierror "incorrect 'row' instruction"
    return
  var Link:LayoutRow r :> new LayoutRow
  add r
  standard_body r r:first_son "row"

ui_client_instruction cell
  if not (connection itag "cell")
    ierror "incorrect 'cell' instruction"
    return
  var Link:LayoutCell c :> new LayoutCell
  if (connection iattr "header")
    c header := true
  add c
  standard_body c c:first_son "cell"


ui_client_instruction input
  var Link:LayoutInput i :> new LayoutInput
  if not (connection itag "input" i:id)
    ierror "incorrect 'input' instruction"
    return
  connection iattr "value" i:value
  if (connection iattr "label" (var Str label))
    var Link:LayoutText t :> new LayoutText
    t text := label
    add t
  if (connection iattr "password")
    i flags := i:flags .or. 2
  if (connection iattr "multiline")
    i flags := i:flags .or. 4
  if (connection iattr "help" (var Str help))
    i help := help
  var CBool focus := connection iattr "focus"
  add i
  standard_no_body "input"
  if focus
    var Pointer:LayoutPrototype r :> i
    while (exists r:parent)
      r :> r parent
    each w session:windows
      if addressof:r=(addressof w:root) or addressof:r=(addressof w:overlay)
        var LayoutEC c
        c style :> session:console default_style
        c window :> w
        c set_focus i 0

ui_client_instruction select
  var Link:LayoutSelect s :> new LayoutSelect
  if not (connection itag "select" s:id)
    ierror "incorrect 'select' instruction"
    return
  connection iattr "value" s:value
  if (connection iattr "label" (var Str label))
    var Link:LayoutText t :> new LayoutText
    t text := label
    add t
  if (connection iattr "help" (var Str help))
    s help := help
  var CBool focus := connection iattr "focus"
  add s
  if not connection:ibody_begin
    ierror "incorrect 'select' instruction"
    return
  current :> s
  while connection:ibody_more
    process_instruction false
  current :> null map LayoutPrototype
  if not connection:ibody_end
    ierror "incorrect 'select' instruction"
  if focus
    var Pointer:LayoutPrototype r :> s
    while (exists r:parent)
      r :> r parent
    each w session:windows
      if addressof:r=(addressof w:root) or addressof:r=(addressof w:overlay)
        var LayoutEC c
        c style :> session:console default_style
        c window :> w
        c set_focus s 0

ui_client_instruction option
  var LayoutSelectOption o
  if not (connection itag "option" o:label o:value)
    ierror "incorrect 'select' instruction"
    return
  var Link:LayoutSelect s :> addressof:current map LayoutSelect
  if exists:s and (entry_type addressof:s)=LayoutSelect
    s options += o
  standard_no_body "option"

ui_client_instruction button
  var Link:LayoutButton b :> new LayoutButton
  if not (connection itag "button" b:id)
    ierror "incorrect 'button' instruction"
    return
  connection iattr "label" b:label
  if (connection iattr "key" b:key)
    var (Pointer Link:LayoutPrototype) k :>> session:keys first b:key
    if exists:k
      k :> b
    else
      var Link:LayoutPrototype ptr :> b
      session:keys insert b:key ptr
  if (connection iattr "stretch")
    b flags := b:flags .or. 2
  if (connection iattr "selected")
    b flags := b:flags .or. 4
  if (connection iattr "help" (var Str help))
    b help := help
  add b
  standard_no_body "button"

ui_client_instruction link
  var Link:LayoutButton b :> new LayoutButton
  b flags := b:flags .or. 8
  if not (connection itag "link" b:label b:id)
    ierror "incorrect 'link' instruction"
    return
  add b
  standard_no_body "link"


ui_client_instruction hook
  var Link:LayoutHook h :> new LayoutHook
  if not (connection itag "hook" h:id h:flags)
    ierror "incorrect 'hook' instruction"
    return
  add h
  standard_body h h:first_son "hook"


method l find_focus -> f
  oarg_rw LayoutPrototype l ; arg_C LayoutPrototype f
  var Link:LayoutPrototype p :> l first
  while exists:p
    f :> p find_focus
    if exists:f
      return
    p :> p next
  if l:focusable
    f :> l
  else
    f :> null map LayoutPrototype

ui_client_instruction focus_set
  if not (connection itag "focus_set" (var Str section) (var Int index))
    ierror "incorrect 'focus_set' instruction"
    return
  var Link:LayoutSection s :> (session:namespace first section) map LayoutSection
  if not exists:s or (entry_type addressof:s)<>LayoutSection
    ierror "there is no '"+section+"' section"
    return
  var Link:LayoutPrototype p :> s find_focus
  if not exists:p
    p :> s parent
    while exists:p and not p:focusable
      p :> p parent
  if exists:p
    var Pointer:LayoutPrototype r :> p
    while (exists r:parent)
      r :> r parent
    each w session:windows
      if addressof:r=(addressof w:root) or addressof:r=(addressof w:overlay)
        var LayoutEC c
        c style :> session:console default_style
        c window :> w
        c set_focus p index
  standard_no_body "focus_set"


ui_client_instruction focus_save
  if not (connection itag "focus_save" )
    ierror "incorrect 'focus_save' instruction"
    return
  var UIFocusHistory h
  h window :> session focus_window
  h target :> session focus_target
  h index := session focus_index
  session focus_history += h
  standard_no_body "focus_save"


ui_client_instruction focus_restore
  if not (connection itag "focus_restore" )
    ierror "incorrect 'focus_restore' instruction"
    return
  var Pointer:UIFocusHistory h :> session:focus_history last
  if exists:h
    var LayoutEC c
    c window :> h window
    c set_focus h:target h:index
    session:focus_history remove h
  standard_no_body "focus_restore"


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


ui_client_instruction section
  if not (connection itag "section" (var Str name))
    ierror "incorrect 'section' instruction"
    return
  var Link:LayoutSection s :> new LayoutSection
  s section := name
  if (addressof Link:LayoutPrototype chain)<>null # FIXME
    add s
  standard_body s s:first_son "section"
  session:namespace remove name null
  session:namespace insert name true addressof:s


ui_client_instruction section_overwrite
  if not (connection itag "section_overwrite" (var Str name))
    ierror "incorrect 'section_overwrite' instruction"
    return
  var Link:LayoutSection s :> (session:namespace first name) map LayoutSection
  if not exists:s or (entry_type addressof:s)<>LayoutSection
    ierror "there is no '"+name+"' section"
    return
  # console datetime " section overwrite '" name "'" eol
  var Link:LayoutPrototype p :> s first
  while exists:p
    session discard p
    var Link:LayoutPrototype n :> p next
    p next :> null map LayoutPrototype
    p :> n
  s first_son :> null map LayoutPrototype
  standard_body s s:first_son "section_overwrite"
  session reposition s


ui_client_instruction section_head
  if not (connection itag "section_head" (var Str name))
    ierror "incorrect 'section_head' instruction"
    return
  var Link:LayoutSection s :> (session:namespace first name) map LayoutSection
  if not exists:s or (entry_type addressof:s)<>LayoutSection
    ierror "there is no '"+name+"' section"
    return
  var (Pointer Link:LayoutPrototype) chain :>> s first_son
  var Link:LayoutPrototype memo :> chain ; chain :> null map LayoutPrototype
  standard_body s chain "section_head"
  while exists:chain
    chain :>> chain next
  chain :> memo
  session reposition s


ui_client_instruction section_tail
  if not (connection itag "section_tail" (var Str name))
    ierror "incorrect 'section_tail' instruction"
    return
  var Link:LayoutSection s :> (session:namespace first name) map LayoutSection
  if not exists:s or (entry_type addressof:s)<>LayoutSection
    ierror "there is no '"+name+"' section"
    return
  var (Pointer Link:LayoutPrototype) chain :>> s first_son
  while exists:chain
    chain :>> chain next
  standard_body s chain "section_tail"
  session reposition s


ui_client_instruction section_before
  if not (connection itag "section_before" (var Str name))
    ierror "incorrect 'section_before' instruction"
    return
  var Link:LayoutSection s :> (session:namespace first name) map LayoutSection
  if not exists:s or (entry_type addressof:s)<>LayoutSection
    ierror "there is no '"+name+"' section"
    return
  var Link:LayoutPrototype parent :> s parent
  var (Pointer Link:LayoutPrototype) chain :>> parent first
  while addressof:chain<>addressof:s
    chain :>> chain next
  var Link:LayoutPrototype memo :> chain ; chain :> null map LayoutPrototype
  standard_body s:parent chain "section_before"
  while exists:chain
    chain :>> chain next
  chain :> memo
  session reposition s


ui_client_instruction section_after
  if not (connection itag "section_after" (var Str name))
    ierror "incorrect 'section_after' instruction"
    return
  var Link:LayoutSection s :> (session:namespace first name) map LayoutSection
  if not exists:s or (entry_type addressof:s)<>LayoutSection
    ierror "there is no '"+name+"' section"
    return
  var (Pointer Link:LayoutPrototype) chain :>> s next
  var Link:LayoutPrototype memo :> chain ; chain :> null map LayoutPrototype
  standard_body s:parent chain "section_after"
  while exists:chain
    chain :>> chain next
  chain :> memo
  session reposition s


ui_client_instruction section_delete
  if not (connection itag "section_delete" (var Str name))
    ierror "incorrect 'section_before' instruction"
    return
  var Link:LayoutSection s :> (session:namespace first name) map LayoutSection
  if not exists:s or (entry_type addressof:s)<>LayoutSection
    ierror "there is no '"+name+"' section"
    return
  session reposition s
  var Link:LayoutPrototype parent :> s parent
  var (Pointer Link:LayoutPrototype) chain :>> parent first
  while addressof:chain<>addressof:s
    chain :>> chain next
  chain :> s next
  session discard s
  standard_no_body "section_delete"


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


ui_client_instruction image_define
  if not (connection itag "image_define" (var Str id))
    ierror "incorrect 'image_define' instruction"
    return
  if not (connection iattr "bbox" (var Float x0) (var Float y0) (var Float x1) (var Float y1))
    ierror "incorrect 'image_define' instruction (bbox)"
    return
  if not (connection iattr "size" (var Int size_x) (var Int size_y))
    ierror "incorrect 'image_define' instruction (size)"
    return
  if not (connection iattr "gamut" (var Str gamutname))
    ierror "incorrect 'image_define' instruction (gamut)"
    return
  var Link:ColorGamut gamut :> color_gamut gamutname ""
  if gamut=failure
    ierror "incorrect 'image_define' instruction (invalid gamut name)"
    return
  var Link:ImagePrototype img :> new ImagePacked
  img setup (image_prototype x0 y0 x1 y1 size_x size_y gamut) ""
  img options := "id "+string:id
  session:namespace remove id null
  session:namespace insert id true addressof:img
  standard_no_body "image_define"


ui_client_instruction image_inline
  if not (connection itag "image_inline" (var Str id))
    ierror "incorrect 'image_inline' instruction"
    return
  var Link:ImagePrototype img :> (session:namespace first id) map ImagePrototype
  if not exists:img or (entry_type addressof:img)<>ImagePixmap and (entry_type addressof:img)<>ImagePacked
    ierror "there is no '"+id+"' image"
    return
  var Link:LayoutImage i :> new LayoutImage
  i image :> img
  add i
  standard_no_body "image_inline"
 

ui_client_instruction image_write_raw
  if not (connection itag "image_write_raw" (var Str id) (var Int x0) (var Int y0) (var Int x1) (var Int y1))
    ierror "incorrect 'image_write_raw' instruction"
    return
  var Link:ImagePrototype img :> (session:namespace first id) map ImagePrototype
  if not exists:img or (entry_type addressof:img)<>ImagePixmap and (entry_type addressof:img)<>ImagePacked
    ierror "there is no '"+id+"' image"
    return
  if x0<0 or y0<0 or x1>img:size_x or y1>img:size_y or x1<x0 or y1<y0
    ierror "incorrect 'image_write_raw' instruction (bounds check)"
    return
  if not connection:ibody_begin
    ierror "incorrect 'image_write_raw' instruction (body begin)"
    return
  for (var Int y) y0 y1-1
    if not (connection iraw (var Blob b))
      ierror "incorrect 'image_write_raw' instruction (body)"
      return
    if b:size<>(x1-x0)*img:pixel_size
      ierror "incorrect 'image_write_raw' instruction (pixels)"
      return
    img write x0 y x1-x0 b:content
  if not connection:ibody_end
    ierror "incorrect 'image_write_raw' instruction (body end)"
    return
 

ui_client_instruction image_write_pack4
  if not (connection itag "image_write_pack4" (var Str id) (var Int x0) (var Int y0) (var Int x1) (var Int y1))
    ierror "incorrect 'image_write_pack4' instruction"
    return
  var Link:ImagePrototype img :> (session:namespace first id) map ImagePrototype
  if not exists:img or (entry_type addressof:img)<>ImagePixmap and (entry_type addressof:img)<>ImagePacked
    ierror "there is no '"+id+"' image"
    return
  if x0<0 or y0<0 or x1>img:size_x or y1>img:size_y or x1<x0 or y1<y0
    ierror "incorrect 'image_write_pack4' instruction (bounds check)"
    return
  if not connection:ibody_begin
    ierror "incorrect 'image_write_pack4' instruction (body begin)"
    return
  var Address buffer1 := memory_zallocate (x1-x0)*img:pixel_size null
  var Address buffer2 := memory_allocate (x1-x0)*img:pixel_size null
  for (var Int y) y0 y1-1
    if not (connection iraw (var Blob b))
      ierror "incorrect 'image_write_pack4' instruction (body)"
      return
    if (pack4_decode b:content buffer2 img:pixel_size x1-x0 buffer1)<>b:size
      ierror "incorrect 'image_write' instruction (segment)"
    img write x0 y x1-x0 buffer2
    swap buffer1 buffer2
  memory_free buffer1
  memory_free buffer2
  if not connection:ibody_end
    ierror "incorrect 'image_write_pack4' instruction (body end)"
    return
 

ui_client_instruction image_copy
  if not (connection itag "image_copy" (var Str src_id) (var Int x0) (var Int y0) (var Int x1) (var Int y1) (var Str dest_id) (var Int xx) (var Int yy))
    ierror "incorrect 'image_copy' instruction"
    return
  var Link:ImagePrototype src :> (session:namespace first src_id) map ImagePrototype
  if not exists:src or (entry_type addressof:src)<>ImagePixmap and (entry_type addressof:src)<>ImagePacked
    ierror "there is no '"+src_id+"' image"
    return
  var Link:ImagePrototype dest :> (session:namespace first dest_id) map ImagePrototype
  if not exists:dest or (entry_type addressof:dest)<>ImagePixmap and (entry_type addressof:dest)<>ImagePacked
    ierror "there is no '"+dest_id+"' image"
    return
  if x0<0 or y0<0 or x1>src:size_x or y1>src:size_y or x1<x0 or y1<y0
    ierror "incorrect 'image_copy' instruction (bounds check)"
    return
  if xx<0 or yy<0 or xx+x1-x0>dest:size_x or yy+y1-y0>dest:size_y
    ierror "incorrect 'image_copy' instruction (bounds check)"
    return
  if dest:gamut:pixel_size<>src:gamut:pixel_size
    ierror "incorrect 'image_copy' instruction (gamut)"
    return
  var Address buffer := memory_allocate (x1-x0)*src:gamut:pixel_size null
  if addressof:dest<>addressof:src or yy<=y0
    for (var Int y) y0 y1-1
      src read x0 y x1-x0 buffer
      dest write xx y+yy-y0 x1-x0 buffer
  else
    for (var Int y) y1-1 y0 step -1
      src read x0 y x1-x0 buffer
      dest write xx y+yy-y0 x1-x0 buffer
  memory_free buffer
  standard_no_body "image_copy"
 

function image_redraw_rec p img x0 y0 x1 y1 w
  oarg_rw LayoutPrototype p ; oarg ImagePrototype img ; arg Int x0 y0 x1 y1 ; arg_rw UIWindow w
  if (entry_type addressof:p)=LayoutImage
    var Pointer:LayoutImage i :> addressof:p map LayoutImage
    var Float fx0 := i:tx+img:x0+(img:x1-img:x0)/img:size_x*x0
    var Float fy0 := i:tx+img:y0+(img:y1-img:y0)/img:size_y*y0
    var Float fx1 := i:tx+img:x0+(img:x1-img:x0)/img:size_x*x1
    var Float fy1 := i:tx+img:y0+(img:y1-img:y0)/img:size_y*y1
    w redraw_area fx0 fy0 fx1 fy1
  var Link:LayoutPrototype q :> p first
  while exists:q
    image_redraw_rec q img x0 y0 x1 y1 w
    q :> q next

ui_client_instruction image_redraw
  if not (connection itag "image_redraw" (var Str id) (var Int x0) (var Int y0) (var Int x1) (var Int y1))
    ierror "incorrect 'image_redraw' instruction"
    return
  var Link:ImagePrototype img :> (session:namespace first id) map ImagePrototype
  if not exists:img or (entry_type addressof:img)<>ImagePixmap and (entry_type addressof:img)<>ImagePacked
    ierror "there is no '"+id+"' image"
    return
  if (connection iattr "section" (var Str name))
    var Link:LayoutSection s :> (session:namespace first name) map LayoutSection
    if not exists:s or (entry_type addressof:s)<>LayoutSection
      ierror "there is no '"+name+"' section"
      return
    var Pointer:LayoutPrototype p :> s
    while (exists p:parent)
      p :> p parent
    each w session:windows
      if (addressof w:root)=addressof:p
        image_redraw_rec s img x0 y0 x1 y1 w
  standard_no_body "image_redraw"
 

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


ui_client_instruction draw
  if not (connection itag "draw" (var Float x0) (var Float y0) (var Float x1) (var Float y1))
    ierror "incorrect 'draw' instruction"
    return
  var Link:LayoutDraw d :> new LayoutDraw
  d:bbox x0 := x0
  d:bbox y0 := y0
  d:bbox x1 := x1
  d:bbox y1 := y1
  add d
  standard_body d d:first_son "draw"


ui_client_instruction fill
  if not (connection itag "fill" open (var Ident g) (var Int cr) (var Int cg) (var Int cb) close)
    ierror "incorrect 'fill' instruction"
    return
  if (cast g Str)<>"rgb"
    ierror "incorrect 'fill' instruction (gamut)"
    return
  var Link:LayoutDrawFill f :> new LayoutDrawFill
  if not connection:ibody_begin
    ierror "incorrect 'fill' instruction (body begin)"
    return
  f mode := shunt (connection iattr "nonzero") fill_nonzero fill_evenodd
  f t := transform 0 0 1 1 0 0
  f color := color rgb cr cg cb
  while connection:ibody_more
    if (connection itag "c" (var Int mode))
      (var Curve curve) reset
      connection ibody_begin
      while connection:ibody_more
        if (connection itag "p" (var Float x) (var Float y))
          var CurvePoint p := curve_point x y true
          if (connection iattr "i" (var Int m) p:in_x p:in_y)
            p in_mode := m
          if (connection iattr "o" (var Int m) p:out_x p:out_y)
            p out_mode := m
          connection ibody_none
          curve += p
        eif (connection itag "t" (var Float x) (var Float y))
          connection ibody_none
          curve through x y
        eif (connection itag "a" (var Float x) (var Float y)) # same as 'p'
          connection ibody_none
          curve angle x y
        else
          ierror "incorrect 'fill' instruction (point)"
          return
      connection ibody_end
      curve compute mode
      if curve=success
        f curves += curve
    else
      ierror "incorrect 'fill' instruction (curve)"
      return
  if not connection:ibody_end
    ierror "incorrect 'fill' instruction (body end)"
    return
  add f
 

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


ui_client_instruction window
  if not (connection itag "window" (var Str name))
    ierror "incorrect 'window' instruction"
    return
  var Link:LayoutSequence s :> new LayoutSequence
  s set_parent (null map LayoutPrototype)
  standard_body s s:first_son "window"
  var Pointer:UIWindow w :> session window name
  if exists:w
    if (exists w:root)
      session discard w:root
    if (exists s:first)
      w root :> s
    else
      w root :> null map LayoutPrototype
    w refresh := true


ui_client_instruction group
  if not (connection itag "group")
    ierror "incorrect 'group' instruction"
    return
  standard_body parent chain "group"
  # session:console lazy_display


ui_client_instruction flush
  if not (connection itag "flush")
    ierror "incorrect 'flush' instruction"
    return
  session:console attempt_redraw_now
  if not connection:ibody_none
    ierror "incorrect 'flush' instruction"
    return


ui_client_instruction url_call
  if not (connection itag "url_call" (var Str url))
    ierror "incorrect 'url_call' instruction"
    return
  if (url 0 1)="/"
    if (session:url eparse any:(var Str protocol) "://" any:(var Str server) "/" any) and (protocol search "/" undefined)=undefined
      url := protocol+"://"+server+url
    eif (session:url eparse any:(var Str protocol) ":/" any) and (protocol search "/" undefined)=undefined
      url := protocol+":"+url
  var Pointer:UIConsole c :> session console
  session history_push
  each w session:windows
    w scroll_x := 0 ; w scroll_y := 0
    if (exists w:root)
      session discard w:root
      w root :> null map LayoutPrototype
    if (exists w:overlay)
      session discard w:overlay
      w overlay :> null map LayoutPrototype
    w refresh := true
  session keys := var (Dictionary Str Link:LayoutPrototype) no_keys
  if not connection:ibody_none
    ierror "incorrect 'url_call' instruction"
    return
  session connect_main url (var Dictionary empty_context)
  eos := true


ui_client_instruction url_return
  if not (connection itag "url_return")
    ierror "incorrect 'url_return' instruction"
    return
  session history_pull
  each w session:windows
    if (exists w:root)
      session discard w:root
      w root :> null map LayoutPrototype
    if (exists w:overlay)
      session discard w:overlay
      w overlay :> null map LayoutPrototype
    w refresh := true
  session keys := var (Dictionary Str Link:LayoutPrototype) no_keys
  if not connection:ibody_none
    ierror "incorrect 'url_return' instruction"
    return
  session connect_main session:url session:context
  eos := true


ui_client_instruction thread_create
  if not (connection itag "thread_create" (var Str id))
    ierror "incorrect 'thread_create' instruction"
    return
  if not connection:ibody_none
    ierror "incorrect 'thread_create' instruction"
    return
  var Link:Stream stream :> new Stream
  session extra_connections += stream
  thread
    share session
    session connect_another session:url session:context stream
    stream otag "thread_run" id
    stream flush anytime
    var UIClientContext c2
    c2 connection :> stream
    c2 session :> session
    c2 extra_thread := true
    while stream=success
      c2 process_instruction true
      if stream:stream_read_cur=stream:stream_read_stop # FIXME: don't know why it's required
        sleep 0
    session:console:sem request
    var (Pointer Link:Stream) p :>> session:extra_connections first
    while exists:p and addressof:p<>addressof:stream
      p :>> session:extra_connections next p
    if addressof:p=addressof:stream
      session:extra_connections remove p
    session:console:sem release


ui_client_instruction style_copy
  if not (connection itag "style_copy" (var Str src_id) (var Str dest_id))
    ierror "incorrect 'style_copy' instruction"
    return
  var Pointer:LayoutStyle src :> (session:namespace first "style "+src_id) map LayoutStyle
  if src_id=""
    src :> session:console default_style
  if exists:src and (entry_type addressof:src)=LayoutStyle
    session:namespace remove "style "+dest_id null
    session:namespace insert "style "+dest_id true addressof:(new LayoutStyle src)
  if not connection:ibody_none
    ierror "incorrect 'style_copy' instruction"
    return

method t field name -> f
  arg Type t ; arg Str name ; arg_C TypeField f
  for (var Int i) 0 t:nb_fields-1
    f :> t field i
    if f:name=name
      return
  f :> null map TypeField

function style_rewrite path scale
  arg_rw Str path ; arg_rw Float scale
  if path="table/padding"
    path := "table/header/padding/x0 table/header/padding/y0 table/header/padding/x1 table/header/padding/y1"
    path += " "+(replace path "header" "cell")
  eif path="table/border/size"
    path := "table/box/r2/x0 table/box/r2/y0 table/box/r2/x1 table/box/r2/y1"
    path += " "+(replace path "box" "header")+" "+(replace path "box" "cell")
    path += " table/box/padding/x0 table/box/padding/y0 table/box/padding/x1 table/box/padding/y1"
    scale := 0.5
  eif path="table/border/color"
    path := "table/box/r1/color table/header/r1/color table/cell/r1/color"
  eif path="table/bg_color"
    path := "table/header/r2/color table/cell/r2/color"

ui_client_instruction style_set
  if not (connection iraw open (var Ident instr) (var Str style) (var Str path))
    ierror "incorrect 'style_set' instruction"
    return
  var Float scale := 1
  style_rewrite path scale
  part apply
    var Pointer:LayoutStyle st :> (session:namespace first "style "+style) map LayoutStyle
    if not exists:st and (entry_type addressof:st)<>LayoutStyle
      console "style_set: there is no '" style "' style" eol
      leave apply
    while path<>""
      if not (path eparse any:(var Str all) _ any:(var Str remain1))
        all := path ; remain1 := ""
      var Address a := addressof st ; var Pointer:Type t :> LayoutStyle
      while all<>""
        if not (all eparse any:(var Str name) "/" any:(var Str remain2))
          name := all ; remain2 := ""
        var Pointer:TypeField f :> t field name
        if not exists:f
          console "style_set: there is no '" path "' attribute (" name ")" eol
          leave apply
        a := a translate Byte f:offset ; t :> f type
        all := remain2
      if t=CBool and (connection ipick (var CBool bvalue))
        a map CBool := bvalue
      eif t=Int and (connection ipick (var Int ivalue))
        a map Int := ivalue
      eif t=Float and (connection ipick (var Float fvalue))
        a map Float := scale*fvalue
      eif t=Float and (connection ipick (var Int ivalue)) # FIXME: should not be required
        a map Float := scale*ivalue
      eif t=Str and (connection ipick (var Str svalue))
        a map Str := svalue
      eif t=Float and (connection ipick (var Int ivalue))
        a map Float := ivalue
      eif t=Link:Font and (connection ipick (var Str svalue))
        var Link:Font font :> session font_load svalue
        if exists:font
          a map Link:Font :> font
      eif t=(Array Link:Font) and (connection ipick (var Str svalue))
        var Link:Font font :> session font_load svalue
        if exists:font
          for (var Int i) 0 7
            (a map (Array Link:Font)) 0 :> font # FIXME
      eif t=LayoutColor and (connection ipick open (var Ident id) (var Int r) (var Int g) (var Int b) close) and (cast id Str)="rgb" and r>=0 and r<256 and g>=0 and g<256 and b>=0 and b<256
        a map LayoutColor := color rgb r g b
      else
        console "style_set: unsupported data type for attribute '" path "'" eol
        leave apply
      path := remain1
  connection iskip
  if not (connection iraw close)
    ierror "incorrect 'style_set' instruction"
    return

ui_client_instruction style
  if not (connection iraw open (var Ident instr))
    ierror "incorrect 'style' instruction"
    return
  var Link:LayoutRestyle s :> new LayoutRestyle
  while (connection iraw (var Ident id))
    if id=(cast "use" Ident) and (connection iraw (var Str name))
      var Pointer:LayoutStyle st :> (session:namespace first "style "+name) map LayoutStyle
      if exists:st and (entry_type addressof:st)=LayoutStyle
        s style :> st
    eif id=(cast "set" Ident) and (connection iraw (var Str path))
      var Float scale := 1
      style_rewrite path scale
      part apply
        while path<>""
          if not (path eparse any:(var Str all) _ any:(var Str remain1))
            all := path ; remain1 := ""
          var LayoutAttribute attr ; attr offset := 0 ; var Pointer:Type t :> LayoutStyle
          while all<>""
            if not (all eparse any:(var Str name) "/" any:(var Str remain2))
              name := all ; remain2 := ""
            var Pointer:TypeField f :> t field name
            if not exists:f
              console "style: there is no '" path "' attribute (" name ")" eol
              leave apply
            attr offset += f offset ; t :> f type
            all := remain2
          attr size := t size
          if t=CBool and (connection ipick (var CBool bvalue))
            attr value := addressof (new CBool bvalue)
            s attributes += attr
          eif t=Int and (connection ipick (var Int ivalue))
            attr value := addressof (new Int ivalue)
            s attributes += attr
          eif t=Float and (connection ipick (var Float fvalue))
            attr value := addressof (new Float scale*fvalue)
            s attributes += attr
          eif t=Float and (connection ipick (var Int ivalue)) # FIXME: should not be required
            attr value := addressof (new Float scale*ivalue)
            s attributes += attr
          eif t=Str and (connection ipick (var Str svalue))
            attr value := addressof (new Str svalue)
            s attributes += attr
          eif t=Link:Font and (connection ipick (var Str svalue))
            var Link:Font font :> session font_load svalue
            if exists:font
              attr value := addressof (new Link:Font font)
              s attributes += attr
          eif t=(Array Link:Font) and (connection ipick (var Str svalue))
            var Link:Font font :> session font_load svalue
            if exists:font
              (var (Array Link:Font) fonts) size := 8
              for (var Int i) 0 7
                fonts i :> font
              attr value := addressof (new (Array Link:Font) fonts)
              s attributes += attr
          eif t=LayoutColor and (connection ipick open (var Ident id) (var Int r) (var Int g) (var Int b) close) and (cast id Str)="rgb" and r>=0 and r<256 and g>=0 and g<256 and b>=0 and b<256
            attr value := addressof (new LayoutColor (color rgb r g b))
            s attributes += attr
          else
            console "style: unsupported data type for attribute '" path "'" eol
            leave apply
          path := remain1
      connection iskip
    else
      ierror "incorrect 'style' instruction"
      return
  add s
  standard_body s s:first_son "style"


function clipboard_string c -> text
  arg_rw UIConsole c ; arg Str text
  text := ""
  if (exists c:clipboard_connection)
    c:clipboard_connection otag "clipboard_request"
    c:clipboard_connection flush anytime
    c:clipboard_sem request
    c:clipboard_sem release
  (var Stream s) open c:clipboard_content in
  while (s ipick open)
    if (s iraw open (cast "text" Ident) body text close)
      void
    else
      s iskip

ui_client_instruction clipboard_declare
  if not (connection itag "clipboard_declare")
    ierror "incorrect 'clipboard_declare' instruction"
    return
  var Pointer:UIConsole c :> session console
  c clipboard_connection :> connection
  c:clipboard_sem nowait_request
  c:console clipboard_export (the_function clipboard_string UIConsole -> Str) (addressof session:console)
  if not connection:ibody_none
    ierror "incorrect 'clipboard_declare' instruction"
    return


ui_client_instruction clipboard_write
  if not (connection iraw open (var Ident id) body)
    ierror "incorrect 'clipboard_write' instruction"
    return
  var Pointer:UIConsole c :> session console
  (var Stream s) open c:clipboard_content out
  while (connection ipick open)
    pml_copy connection s
  s close
  if (exists c:clipboard_connection)
    c clipboard_connection :> null map Stream
    c:clipboard_sem release
  c:console clipboard_export (the_function clipboard_string UIConsole -> Str) (addressof session:console)
  if not (connection iraw close)
    ierror "incorrect 'clipboard_write' instruction"
    return


ui_client_instruction clipboard_read
  if not (connection itag "clipboard_read")
    ierror "incorrect 'clipboard_read' instruction"
    return
  if not connection:ibody_none
    ierror "incorrect 'clipboard_read' instruction"
    return
  var Pointer:UIConsole c :> session console
  if (addressof c:clipboard_connection)=addressof:connection
    connection otag "clipboard_self"
  else
    connection oraw open (cast "clipboard_content" Ident) body
    if (session:console:console clipboard_import (var Str txt))=success
      connection oraw open (cast "text" Ident) body txt close
    else
      if (exists c:clipboard_connection)
        c:clipboard_connection otag "clipboard_request"
        c:clipboard_connection flush anytime
        c:sem release
        c:clipboard_sem request
        c:clipboard_sem release
        c:sem request
      var Pointer:Blob blob :> session:console clipboard_content
      connection raw_write blob:content blob:size
    connection oraw close
  connection flush anytime


ui_client_instruction ack
  if not (connection itag "ack")
    ierror "incorrect 'ack' instruction"
    return
  if not connection:ibody_none
    ierror "incorrect 'ack' instruction"
    return
  session:console ack_flag := true