Patch title: Release 89 bulk changes
Abstract:
File: /graphic/browser/tag/prototype.pli
Key:
    Removed line
    Added line
   
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 

# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 

module "/pliant/language/unsafe.pli"
module "/pliant/admin/file.pli"
module "/pliant/graphic/draw/prototype.pli"
module "/pliant/language/compiler.pli"
submodule "/pliant/graphic/browser/xml/tree.pli"
submodule "/pliant/graphic/browser/xml/context.pli"
submodule "/pliant/graphic/draw/prototype.pli"


public


gvar Dictionary tag_position_dictionary
gvar Dictionary tag_draw_dictionary


type XmlPrototype
  void


method t position c
  oarg_rw XmlPrototype t ; arg_rw XmlContext c
  generic
named_expression tag_position_prototype
  function 'pliant tag position function' tree context
    arg_rw XmlTree tree ; arg_rw XmlContext context
    implicit tree context
      body


method t draw d c
  oarg_rw XmlPrototype t ; oarg_rw DrawPrototype d ; arg_rw 
  generic
meta tag_position e
  if e:size=2 and e:0:is_pure_ident and e:1:ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate tag_position_prototype substitute body e:1 near e
    error_push_record (var ErrorRecord er) error_filter_all
    ee compile
    if er:id<>error_id_noerror
      console er:message eol
      er id := error_id_noerror
      e suckup_error ee
    error_pull_record er
    var Link:Function f :> (pliant_general_dictionary first "pliant tag position function") map Function
    e:module rewind mark
    if exists:f
      tag_position_dictionary insert e:0:ident true addressof:f
      e set_void_result




#-----------------------------------------------------------
named_expression tag_draw_prototype
  function 'pliant tag draw function' tree draw context
    arg_rw XmlTree tree ; oarg_rw DrawPrototype draw ; arg_rw XmlContext context
    implicit tree context
      body


meta tag_draw e
  if e:size=2 and e:0:is_pure_ident and e:1:ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate tag_draw_prototype substitute body e:1 near e
    error_push_record (var ErrorRecord er) error_filter_all
    ee compile
    if er:id<>error_id_noerror
      console er:message eol
      er id := error_id_noerror
      e suckup_error ee
    error_pull_record er
    var Link:Function f :> (pliant_general_dictionary first "pliant tag draw function") map Function
    e:module rewind mark
    if exists:f
      tag_draw_dictionary insert e:0:ident true addressof:f
      e set_void_result


gvar Link:Font default_font :> font "Times"
if false # not exists:default_font
  console "Scanning your /usr/ directory for fonts ..." eol
  font_scan "embedded:/usr/"
  default_font :> font "Times"
  if not exists:default_font
    console "Could not find Times font in your system !" eol
  else
    console "done." eol
export tag_position_dictionary tag_draw_dictionary
export tag_position tag_draw


function build c
  arg_w D2Context c
  c font :> default_font
  c scale := 4
  c color := 0


function tag_position_prototype tree context f
  arg_rw XmlTree tree ; arg_rw XmlContext context ; arg Function f
  indirect


method b translate tx ty
  oarg_rw XmlPrototype b ; arg Float tx ty
  if b:x0=defined
    b x0 += tx
    b y0 += ty
    b x1 += tx
    b y1 += ty
  var Pointer:(List Link:XmlPrototype) l :> b list
  if exists:l
    each bb l
      bb translate tx ty
method tree position context
  arg_rw XmlTree tree ; arg_rw XmlContext context
  tree x0 := undefined ; tree y0 := undefined ; tree x1 := undefined ; tree y1 := undefined
  var Pointer:Arrow c :> tag_position_dictionary first tree:tag
  if exists:c
    tag_position_prototype tree context (c map Function)
  else
    each sub tree
      sub position context




method c newline
  arg_rw D2Context c
  c line_y0 := c y0
  c line_x := c x0 ; c line_y := c y0
  c line_boxes := var (List Link:XmlPrototype) empty_boxes_l
function tag_draw_prototype tree draw context f
  arg_rw XmlTree tree ; oarg_rw DrawPrototype draw ; arg_rw XmlContext context ; arg Function f
  indirect


method c newarea
  arg_rw D2Context c
  var Pointer:D2Area a :> c:areas first
  c x0 := a x0 ; c y0 := a y0 ; c x1 := a x1 ; c y1 := a y1
  c:areas remove a
  c newline

method c addtoline b
  arg_rw D2Context c ; oarg_rw XmlPrototype b
  # vcenter is not covered yet
  if c:line_x+b:x1-b:x0>c:x1 and c:line_x<>c:x0
    c newline
  var Float move_y := (-b:y0)-(c:line_y-c:line_y0)
  if move_y>0
    each lb c:line_boxes
      lb translate 0 move_y
    c line_y += move_y
    c y0 += move_y
  var Float move_y := b:y1-(c:y0-c:line_y)
  if move_y>0
    c y0 += move_y
    # might need to switch to next area
  b translate c:line_x c:line_y
  var Link:XmlPrototype l :> b ; c line_boxes += l
  c line_x += b:x1-b:x0


method b position_undefined c
  oarg_rw XmlPrototype b ; arg_rw D2Context c
  b x0 := undefined
  b y0 := undefined
  b x1 := undefined
  b y1 := undefined
  var Pointer:(List Link:XmlPrototype) l :> b list
  if exists:l
    each bb l
      bb position c

method b position_container c
  oarg_rw XmlPrototype b ; arg_rw D2Context c
  function position_include b c
    oarg_rw XmlPrototype b ; arg_rw XmlPrototype 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:XmlPrototype) 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:XmlPrototype) 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 XmlPrototype 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 XmlPrototype b ; arg_rw D2Context c
  b x0 := undefined
  b y0 := undefined
  b x1 := undefined
  b y1 := undefined
  var Pointer:(List Link:XmlPrototype) l :> b list
  if exists:l
    each bb l
      bb position_hidden c


method b draw_recurse img c
  oarg_rw XmlPrototype b ; oarg_rw ImagePrototype img ; arg_
  var Pointer:(List Link:XmlPrototype) 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 a
        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


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


enumerated D2EventType
  event_mouse
  event_key
  event_extended_key
  event_function_key
  event_other

flagset D2EventStatus
  mouse_button_1
  mouse_button_1_up
  mouse_button_1_pressed
  mouse_button_1_down
  mouse_button_1_released
  mouse_button_2
  mouse_button_2_up
  mouse_button_2_pressed
  mouse_button_2_down
  mouse_button_2_released
  mouse_button_3
  mouse_button_3_up
  mouse_button_3_pressed
  mouse_button_3_down
  mouse_button_3_released
  keyboard_alt
  keyboard_alt_1 
  keyboard_alt_2
  keyboard_shift
  keyboard_shift_1 
  keyboard_shitf_2 
  keyboard_ctrl
  keyboard_ctrl_1
  keyboard_ctrl_2

type D2Event
  field D2EventType type
  field Int key
  field D2EventStatus status
  field Float x y
  field Str options
  #
  field Str potencial_url
  field Link:XmlPrototype form_box
  field Str url form
 
method b event e
  oarg_rw XmlPrototype b ; arg_rw D2Event e
  generic
  var Pointer:(List Link:XmlPrototype) l :> b list
  if exists:l
    each bb l
      bb event e


function url_concat base extra -> url
  arg Str base extra url
  if (extra parse "http://" any)
    url := extra
  eif (extra parse "/" any) and (base parse "http://" any:(v
    url := "http://"+server+extra
method tree draw draw context
  arg_rw XmlTree tree ; oarg_rw DrawPrototype draw ; arg_rw XmlContext context
  tree x0 := undefined ; tree y0 := undefined ; tree x1 := undefined ; tree y1 := undefined
  var Pointer:Arrow c :> tag_position_dictionary first tree:tag
  if exists:c
    tag_draw_prototype tree draw context (c map Function)
  else
  else
    url := (base 0 (base search_last "/" -1)+1)+extra
  while (reverse:url eparse any:(var Str head) "/../" any "/
   url := reverse:tail+"/"+reverse:head
    each sub tree
      sub draw draw context



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


gvar Dictionary html_tags

export '. position' '. draw'